diff options
| author |  Stephane Glondu <steph@glondu.net> | 2012-01-12 16:02:20 +0100 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2012-01-12 16:02:20 +0100 |
| commit | 97fefe1fcca363a1317e066e7f4b99b9c1e9987b (patch) | |
| tree | 97ec6b7d831cc5fb66328b0c63a11db1cbb2f158 /theories | |
| parent | 300293c119981054c95182a90c829058530a6b6f (diff) | |
Imported Upstream version 8.4~betaupstream/8.4_beta
Diffstat (limited to 'theories')
417 files changed, 28572 insertions, 18681 deletions
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 2e9dc2de..6f3827a3 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Arith.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Arith_base. Require Export ArithRing. diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index e9953e54..4f21dadf 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Arith_base.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Le. Require Export Lt. Require Export Plus. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 65753e31..dd514653 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Between.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Le. Require Import Lt. diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index b3dcd8ec..f384e148 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bool_nat.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Compare_dec. Require Export Peano_dec. Require Import Sumbool. @@ -36,4 +34,4 @@ Definition nat_noteq_bool x y := bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)). Definition zerop_bool x := bool_of_sumbool (zerop x). -Definition notzerop_bool x := bool_of_sumbool (notzerop x).
\ No newline at end of file +Definition notzerop_bool x := bool_of_sumbool (notzerop x). diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v index 2fe5c0d9..c9e6d3cf 100644 --- a/theories/Arith/Compare.v +++ b/theories/Arith/Compare.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Equality is decidable on [nat] *) Open Local Scope nat_scope. @@ -52,4 +50,4 @@ Qed. Require Export Wf_nat. -Require Export Min Max.
\ No newline at end of file +Require Export Min Max. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 99c7415e..360d760a 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Le. Require Import Lt. Require Import Gt. @@ -22,21 +20,21 @@ Proof. destruct n; auto with arith. Defined. -Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}. +Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}. Proof. - induction n; destruct m; auto with arith. + induction n in m |- *; destruct m; auto with arith. destruct (IHn m) as [H|H]; auto with arith. destruct H; auto with arith. Defined. -Definition gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}. +Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}. Proof. intros; apply lt_eq_lt_dec; assumption. Defined. -Definition le_lt_dec : forall n m, {n <= m} + {m < n}. +Definition le_lt_dec n m : {n <= m} + {m < n}. Proof. - induction n. + induction n in m |- *. auto with arith. destruct m. auto with arith. @@ -200,7 +198,8 @@ Proof. apply -> nat_compare_lt; auto. Qed. -Lemma nat_compare_spec : forall x y, CompSpec eq lt x y (nat_compare x y). +Lemma nat_compare_spec : + forall x y, CompareSpec (x=y) (x<y) (y<x) (nat_compare x y). Proof. intros. destruct (nat_compare x y) as [ ]_eqn; constructor. @@ -209,7 +208,6 @@ Proof. apply <- nat_compare_gt; auto. Qed. - (** Some projections of the above equivalences. *) Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n<m. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 89620f5f..24cbc3f9 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Div2.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Lt. Require Import Plus. Require Import Compare_dec. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 60575beb..94986278 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqNat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Equality on natural numbers *) Open Local Scope nat_scope. diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index f32e1ad4..513fd110 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -1,25 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Euclid.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Mult. Require Import Compare_dec. Require Import Wf_nat. -Open Local Scope nat_scope. +Local Open Scope nat_scope. Implicit Types a b n q r : nat. Inductive diveucl a b : Set := divex : forall q r, b > r -> a = q * b + r -> diveucl a b. - Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n. Proof. intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0. @@ -32,7 +29,7 @@ Proof. elim e; auto with arith. intros gtbn. apply divex with 0 n; simpl in |- *; auto with arith. -Qed. +Defined. Lemma quotient : forall n, @@ -50,7 +47,7 @@ Proof. elim H1; auto with arith. intros gtbn. exists 0; exists n; simpl in |- *; auto with arith. -Qed. +Defined. Lemma modulo : forall n, @@ -68,4 +65,4 @@ Proof. elim H1; auto with arith. intros gtbn. exists n; exists 0; simpl in |- *; auto with arith. -Qed. +Defined. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 5bab97c2..cd4dae98 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Even.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. The main results about parity are proved in the module Div2. *) diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 3b434b96..146546dc 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Factorial.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Plus. Require Import Mult. Require Import Lt. @@ -15,13 +13,13 @@ Open Local Scope nat_scope. (** Factorial *) -Boxed Fixpoint fact (n:nat) : nat := +Fixpoint fact (n:nat) : nat := match n with | O => 1 | S n => S n * fact n end. -Arguments Scope fact [nat_scope]. +Arguments fact n%nat. Lemma lt_O_fact : forall n:nat, 0 < fact n. Proof. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index 43df01c0..32f453e5 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Gt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as: << Definition gt (n m:nat) := m < n. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index b73959e7..f0ebf162 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Le.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Order on natural numbers. [le] is defined in [Init/Peano.v] as: << Inductive le (n:nat) : nat -> Prop := @@ -84,8 +82,7 @@ Hint Immediate le_Sn_le: arith v62. Theorem le_S_n : forall n m, S n <= S m -> n <= m. Proof. - intros n m H; change (pred (S n) <= pred (S m)) in |- *. - destruct H; simpl; auto with arith. + exact Peano.le_S_n. Qed. Hint Immediate le_S_n: arith v62. @@ -105,11 +102,9 @@ Hint Resolve le_pred_n: arith v62. Theorem le_pred : forall n m, n <= m -> pred n <= pred m. Proof. - destruct n; simpl; auto with arith. - destruct m; simpl; auto with arith. + exact Peano.le_pred. Qed. - (** * [le] is a order on [nat] *) (** Antisymmetry *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 004274fe..e07bba8d 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as: << Definition lt (n m:nat) := S n <= m. @@ -96,9 +94,9 @@ Proof. Qed. Hint Resolve lt_0_Sn: arith v62. -Theorem lt_n_O : forall n, ~ n < 0. -Proof le_Sn_O. -Hint Resolve lt_n_O: arith v62. +Theorem lt_n_0 : forall n, ~ n < 0. +Proof le_Sn_0. +Hint Resolve lt_n_0: arith v62. (** * Predecessor *) @@ -192,4 +190,5 @@ Hint Immediate lt_0_neq: arith v62. Notation lt_O_Sn := lt_0_Sn (only parsing). Notation neq_O_lt := neq_0_lt (only parsing). Notation lt_O_neq := lt_0_neq (only parsing). +Notation lt_n_O := lt_n_0 (only parsing). (* end hide *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index d1b1b269..77dfa508 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -1,44 +1,48 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Max.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *) -(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) - -Require Export MinMax. +Require Import NPeano. Local Open Scope nat_scope. Implicit Types m n p : nat. -Notation max := MinMax.max (only parsing). - -Definition max_0_l := max_0_l. -Definition max_0_r := max_0_r. -Definition succ_max_distr := succ_max_distr. -Definition plus_max_distr_l := plus_max_distr_l. -Definition plus_max_distr_r := plus_max_distr_r. -Definition max_case_strong := max_case_strong. -Definition max_spec := max_spec. -Definition max_dec := max_dec. -Definition max_case := max_case. -Definition max_idempotent := max_id. -Definition max_assoc := max_assoc. -Definition max_comm := max_comm. -Definition max_l := max_l. -Definition max_r := max_r. -Definition le_max_l := le_max_l. -Definition le_max_r := le_max_r. -Definition max_lub_l := max_lub_l. -Definition max_lub_r := max_lub_r. -Definition max_lub := max_lub. +Notation max := Peano.max (only parsing). + +Definition max_0_l := Nat.max_0_l. +Definition max_0_r := Nat.max_0_r. +Definition succ_max_distr := Nat.succ_max_distr. +Definition plus_max_distr_l := Nat.add_max_distr_l. +Definition plus_max_distr_r := Nat.add_max_distr_r. +Definition max_case_strong := Nat.max_case_strong. +Definition max_spec := Nat.max_spec. +Definition max_dec := Nat.max_dec. +Definition max_case := Nat.max_case. +Definition max_idempotent := Nat.max_id. +Definition max_assoc := Nat.max_assoc. +Definition max_comm := Nat.max_comm. +Definition max_l := Nat.max_l. +Definition max_r := Nat.max_r. +Definition le_max_l := Nat.le_max_l. +Definition le_max_r := Nat.le_max_r. +Definition max_lub_l := Nat.max_lub_l. +Definition max_lub_r := Nat.max_lub_r. +Definition max_lub := Nat.max_lub. (* begin hide *) (* Compatibility *) Notation max_case2 := max_case (only parsing). -Notation max_SS := succ_max_distr (only parsing). +Notation max_SS := Nat.succ_max_distr (only parsing). (* end hide *) + +Hint Resolve + Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith v62. + +Hint Resolve + Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith v62. diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index 0c8b5669..bcfbe0ef 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -1,44 +1,42 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Min.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *) -(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *) - -Require Export MinMax. +Require Import NPeano. Open Local Scope nat_scope. Implicit Types m n p : nat. -Notation min := MinMax.min (only parsing). +Notation min := Peano.min (only parsing). -Definition min_0_l := min_0_l. -Definition min_0_r := min_0_r. -Definition succ_min_distr := succ_min_distr. -Definition plus_min_distr_l := plus_min_distr_l. -Definition plus_min_distr_r := plus_min_distr_r. -Definition min_case_strong := min_case_strong. -Definition min_spec := min_spec. -Definition min_dec := min_dec. -Definition min_case := min_case. -Definition min_idempotent := min_id. -Definition min_assoc := min_assoc. -Definition min_comm := min_comm. -Definition min_l := min_l. -Definition min_r := min_r. -Definition le_min_l := le_min_l. -Definition le_min_r := le_min_r. -Definition min_glb_l := min_glb_l. -Definition min_glb_r := min_glb_r. -Definition min_glb := min_glb. +Definition min_0_l := Nat.min_0_l. +Definition min_0_r := Nat.min_0_r. +Definition succ_min_distr := Nat.succ_min_distr. +Definition plus_min_distr_l := Nat.add_min_distr_l. +Definition plus_min_distr_r := Nat.add_min_distr_r. +Definition min_case_strong := Nat.min_case_strong. +Definition min_spec := Nat.min_spec. +Definition min_dec := Nat.min_dec. +Definition min_case := Nat.min_case. +Definition min_idempotent := Nat.min_id. +Definition min_assoc := Nat.min_assoc. +Definition min_comm := Nat.min_comm. +Definition min_l := Nat.min_l. +Definition min_r := Nat.min_r. +Definition le_min_l := Nat.le_min_l. +Definition le_min_r := Nat.le_min_r. +Definition min_glb_l := Nat.min_glb_l. +Definition min_glb_r := Nat.min_glb_r. +Definition min_glb := Nat.min_glb. (* begin hide *) (* Compatibility *) Notation min_case2 := min_case (only parsing). -Notation min_SS := succ_min_distr (only parsing). -(* end hide *)
\ No newline at end of file +Notation min_SS := Nat.succ_min_distr (only parsing). +(* end hide *) diff --git a/theories/Arith/MinMax.v b/theories/Arith/MinMax.v deleted file mode 100644 index 8a23c8f6..00000000 --- a/theories/Arith/MinMax.v +++ /dev/null @@ -1,113 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Orders NatOrderedType GenericMinMax. - -(** * Maximum and Minimum of two natural numbers *) - -Fixpoint max n m : nat := - match n, m with - | O, _ => m - | S n', O => n - | S n', S m' => S (max n' m') - end. - -Fixpoint min n m : nat := - match n, m with - | O, _ => 0 - | S n', O => 0 - | S n', S m' => S (min n' m') - end. - -(** These functions implement indeed a maximum and a minimum *) - -Lemma max_l : forall x y, y<=x -> max x y = x. -Proof. - induction x; destruct y; simpl; auto with arith. -Qed. - -Lemma max_r : forall x y, x<=y -> max x y = y. -Proof. - induction x; destruct y; simpl; auto with arith. -Qed. - -Lemma min_l : forall x y, x<=y -> min x y = x. -Proof. - induction x; destruct y; simpl; auto with arith. -Qed. - -Lemma min_r : forall x y, y<=x -> min x y = y. -Proof. - induction x; destruct y; simpl; auto with arith. -Qed. - - -Module NatHasMinMax <: HasMinMax Nat_as_OT. - Definition max := max. - Definition min := min. - Definition max_l := max_l. - Definition max_r := max_r. - Definition min_l := min_l. - Definition min_r := min_r. -End NatHasMinMax. - -(** We obtain hence all the generic properties of [max] and [min], - see file [GenericMinMax] or use SearchAbout. *) - -Module Export MMP := UsualMinMaxProperties Nat_as_OT NatHasMinMax. - - -(** * Properties specific to the [nat] domain *) - -(** Simplifications *) - -Lemma max_0_l : forall n, max 0 n = n. -Proof. reflexivity. Qed. - -Lemma max_0_r : forall n, max n 0 = n. -Proof. destruct n; auto. Qed. - -Lemma min_0_l : forall n, min 0 n = 0. -Proof. reflexivity. Qed. - -Lemma min_0_r : forall n, min n 0 = 0. -Proof. destruct n; auto. Qed. - -(** Compatibilities (consequences of monotonicity) *) - -Lemma succ_max_distr : forall n m, S (max n m) = max (S n) (S m). -Proof. auto. Qed. - -Lemma succ_min_distr : forall n m, S (min n m) = min (S n) (S m). -Proof. auto. Qed. - -Lemma plus_max_distr_l : forall n m p, max (p + n) (p + m) = p + max n m. -Proof. -intros. apply max_monotone. repeat red; auto with arith. -Qed. - -Lemma plus_max_distr_r : forall n m p, max (n + p) (m + p) = max n m + p. -Proof. -intros. apply max_monotone with (f:=fun x => x + p). -repeat red; auto with arith. -Qed. - -Lemma plus_min_distr_l : forall n m p, min (p + n) (p + m) = p + min n m. -Proof. -intros. apply min_monotone. repeat red; auto with arith. -Qed. - -Lemma plus_min_distr_r : forall n m p, min (n + p) (m + p) = min n m + p. -Proof. -intros. apply min_monotone with (f:=fun x => x + p). -repeat red; auto with arith. -Qed. - -Hint Resolve - max_l max_r le_max_l le_max_r - min_l min_r le_min_l le_min_r : arith v62. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 1b36f236..ed215f54 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Minus.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as: << Fixpoint minus (n m:nat) : nat := diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 5dd61d67..479138a9 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mult.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Plus. Require Export Minus. Require Export Lt. @@ -177,19 +175,22 @@ Qed. Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p. Proof. induction n; intros; simpl in *. - rewrite <- 2! plus_n_O; assumption. + rewrite <- 2 plus_n_O; assumption. auto using plus_lt_compat. Qed. Hint Resolve mult_S_lt_compat_l: arith. +Lemma mult_lt_compat_l : forall n m p, n < m -> 0 < p -> p * n < p * m. +Proof. + intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp). + now apply mult_S_lt_compat_l. +Qed. + Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p. Proof. - intros m n p H H0. - induction p. - elim (lt_irrefl _ H0). - rewrite mult_comm. - replace (n * S p) with (S p * n); auto with arith. + intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp). + rewrite (mult_comm m), (mult_comm n). now apply mult_S_lt_compat_l. Qed. Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p. diff --git a/theories/Arith/NatOrderedType.v b/theories/Arith/NatOrderedType.v deleted file mode 100644 index fb4bf233..00000000 --- a/theories/Arith/NatOrderedType.v +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Lt Peano_dec Compare_dec EqNat - Equalities Orders OrdersTac. - - -(** * DecidableType structure for Peano numbers *) - -Module Nat_as_UBE <: UsualBoolEq. - Definition t := nat. - Definition eq := @eq nat. - Definition eqb := beq_nat. - Definition eqb_eq := beq_nat_true_iff. -End Nat_as_UBE. - -Module Nat_as_DT <: UsualDecidableTypeFull := Make_UDTF Nat_as_UBE. - -(** Note that the last module fulfills by subtyping many other - interfaces, such as [DecidableType] or [EqualityType]. *) - - - -(** * OrderedType structure for Peano numbers *) - -Module Nat_as_OT <: OrderedTypeFull. - Include Nat_as_DT. - Definition lt := lt. - Definition le := le. - Definition compare := nat_compare. - - Instance lt_strorder : StrictOrder lt. - Proof. split; [ exact lt_irrefl | exact lt_trans ]. Qed. - - Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) lt. - Proof. repeat red; intros; subst; auto. Qed. - - Definition le_lteq := le_lt_or_eq_iff. - Definition compare_spec := nat_compare_spec. - -End Nat_as_OT. - -(** Note that [Nat_as_OT] can also be seen as a [UsualOrderedType] - and a [OrderedType] (and also as a [DecidableType]). *) - - - -(** * An [order] tactic for Peano numbers *) - -Module NatOrder := OTF_to_OrderTac Nat_as_OT. -Ltac nat_order := NatOrder.order. - -(** Note that [nat_order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) - -Section Test. -Let test : forall x y : nat, x<=y -> y<=x -> x=y. -Proof. nat_order. Qed. -End Test. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 5cceab8b..6eb667c1 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -1,15 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Decidable. - +Require Eqdep_dec. +Require Import Le Lt. Open Local Scope nat_scope. Implicit Types m n x y : nat. @@ -32,3 +31,22 @@ Hint Resolve O_or_S eq_nat_dec: arith. Theorem dec_eq_nat : forall n m, decidable (n = m). intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith. Defined. + +Definition UIP_nat:= Eqdep_dec.UIP_dec eq_nat_dec. + +Lemma le_unique: forall m n (h1 h2: m <= n), h1 = h2. +Proof. +fix 3. +refine (fun m _ h1 => match h1 as h' in _ <= k return forall hh: m <= k, h' = hh + with le_n => _ |le_S i H => _ end). +refine (fun hh => match hh as h' in _ <= k return forall eq: m = k, + le_n m = match eq in _ = p return m <= p -> m <= m with |eq_refl => fun bli => bli end h' with + |le_n => fun eq => _ |le_S j H' => fun eq => _ end eq_refl). +rewrite (UIP_nat _ _ eq eq_refl). reflexivity. +subst m. destruct (Lt.lt_irrefl j H'). +refine (fun hh => match hh as h' in _ <= k return match k as k' return m <= k' -> Prop + with |0 => fun _ => True |S i' => fun h'' => forall H':m <= i', le_S m i' H' = h'' end h' + with |le_n => _ |le_S j H2 => fun H' => _ end H). +destruct m. exact I. intros; destruct (Lt.lt_irrefl m H'). +f_equal. apply le_unique. +Qed. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 12f12300..02975d8f 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -1,13 +1,11 @@ -(************************************************************************) + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Plus.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Properties of addition. [add] is defined in [Init/Peano.v] as: << Fixpoint plus (n m:nat) : nat := @@ -26,17 +24,10 @@ Open Local Scope nat_scope. Implicit Types m n p q : nat. -(** * Zero is neutral *) - -Lemma plus_0_l : forall n, 0 + n = n. -Proof. - reflexivity. -Qed. - -Lemma plus_0_r : forall n, n + 0 = n. -Proof. - intro; symmetry in |- *; apply plus_n_O. -Qed. +(** * Zero is neutral +Deprecated : Already in Init/Peano.v *) +Notation plus_0_l := plus_O_n (only parsing). +Definition plus_0_r n := eq_sym (plus_n_O n). (** * Commutativity *) @@ -49,14 +40,8 @@ Hint Immediate plus_comm: arith v62. (** * Associativity *) -Lemma plus_Snm_nSm : forall n m, S n + m = n + S m. -Proof. - intros. - simpl in |- *. - rewrite (plus_comm n m). - rewrite (plus_comm n (S m)). - trivial with arith. -Qed. +Definition plus_Snm_nSm : forall n m, S n + m = n + S m:= + plus_n_Sm. Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p. Proof. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 23419531..b4468dd1 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf_nat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Well-founded relations and natural numbers *) Require Import Lt. @@ -260,19 +258,6 @@ Qed. Unset Implicit Arguments. -(** [n]th iteration of the function [f] *) - -Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) : A := - match n with - | O => x - | S n' => f (iter_nat n' A f x) - end. - -Theorem iter_nat_plus : - forall (n m:nat) (A:Type) (f:A -> A) (x:A), - iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x). -Proof. - simple induction n; - [ simpl in |- *; auto with arith - | intros; simpl in |- *; apply f_equal with (f := f); apply H ]. -Qed. +Notation iter_nat := @nat_iter (only parsing). +Notation iter_nat_plus := @nat_iter_plus (only parsing). +Notation iter_nat_invariant := @nat_iter_invariant (only parsing). diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget index c3f29d21..0b6564e1 100644 --- a/theories/Arith/vo.itarget +++ b/theories/Arith/vo.itarget @@ -19,5 +19,3 @@ Mult.vo Peano_dec.vo Plus.vo Wf_nat.vo -NatOrderedType.vo -MinMax.vo diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 9509d9fd..d5d11cea 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bool.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** The type [bool] is defined in the prelude as [Inductive bool : Set := true : bool | false : bool] *) @@ -259,6 +257,11 @@ Proof. intros. apply orb_false_iff; trivial. Qed. +Lemma orb_diag : forall b, b || b = b. +Proof. + destr_bool. +Qed. + (** [true] is a zero for [orb] *) Lemma orb_true_r : forall b:bool, b || true = true. @@ -364,6 +367,11 @@ Qed. Notation andb_b_false := andb_false_r (only parsing). Notation andb_false_b := andb_false_l (only parsing). +Lemma andb_diag : forall b, b && b = b. +Proof. + destr_bool. +Qed. + (** [true] is neutral for [andb] *) Lemma andb_true_r : forall b:bool, b && true = b. @@ -547,6 +555,21 @@ Proof. destr_bool. Qed. +Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'. +Proof. + destruct b,b'; trivial. +Qed. + +Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b'). +Proof. + destruct b,b'; trivial. +Qed. + +Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'. +Proof. + destruct b,b'; trivial. +Qed. + (** Lemmas about the [b = true] embedding of [bool] to [Prop] *) Lemma eq_iff_eq_true : forall b1 b2, b1 = b2 <-> (b1 = true <-> b2 = true). @@ -768,7 +791,7 @@ Qed. Lemma iff_reflect : forall P b, (P<->b=true) -> reflect P b. Proof. destr_bool; intuition. -Qed. +Defined. (** It would be nice to join [reflect_iff] and [iff_reflect] in a unique [iff] statement, but this isn't allowed since @@ -779,7 +802,7 @@ Qed. Lemma reflect_dec : forall P b, reflect P b -> {P}+{~P}. Proof. destruct 1; auto. -Qed. +Defined. (** Reciprocally, from a decidability, we could state a [reflect] as soon as we have a [bool_of_sumbool]. *) diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index ee82caf1..d40e56bf 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BoolEq.v 14641 2011-11-06 11:59:10Z herbelin $ i*) (* Cuihtlauac Alvarado - octobre 2000 *) (** Properties of a boolean equality *) diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index daf3a9fb..0c218163 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -1,18 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bvector.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) -Require Export Bool. -Require Export Sumbool. -Require Import Arith. +Require Export Bool Sumbool. +Require Vector. +Export Vector.VectorNotations. +Require Import Minus. Open Local Scope nat_scope. @@ -30,161 +29,6 @@ as definition, since the type inference mechanism for pattern-matching is sometimes weaker that the one implemented for elimination tactiques. *) -Section VECTORS. - -(** -A vector is a list of size n whose elements belongs to a set A. -If the size is non-zero, we can extract the first component and the -rest of the vector, as well as the last component, or adding or -removing a component (carry) or repeating the last component at the -end of the vector. -We can also truncate the vector and remove its p last components or -reciprocally extend the vector by concatenation. -A unary function over A generates a function on vectors of size n by -applying f pointwise. -A binary function over A generates a function on pairs of vectors of -size n by applying f pointwise. -*) - -Variable A : Type. - -Inductive vector : nat -> Type := - | Vnil : vector 0 - | Vcons : forall (a:A) (n:nat), vector n -> vector (S n). - -Definition Vhead (n:nat) (v:vector (S n)) := - match v with - | Vcons a _ _ => a - end. - -Definition Vtail (n:nat) (v:vector (S n)) := - match v with - | Vcons _ _ v => v - end. - -Definition Vlast : forall n:nat, vector (S n) -> A. -Proof. - induction n as [| n f]; intro v. - inversion v. - exact a. - - inversion v as [| n0 a H0 H1]. - exact (f H0). -Defined. - -Fixpoint Vconst (a:A) (n:nat) := - match n return vector n with - | O => Vnil - | S n => Vcons a _ (Vconst a n) - end. - -(** Shifting and truncating *) - -Lemma Vshiftout : forall n:nat, vector (S n) -> vector n. -Proof. - induction n as [| n f]; intro v. - exact Vnil. - - inversion v as [| a n0 H0 H1]. - exact (Vcons a n (f H0)). -Defined. - -Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n). -Proof. - induction n as [| n f]; intros a v. - exact (Vcons a 0 v). - - inversion v as [| a0 n0 H0 H1 ]. - exact (Vcons a (S n) (f a H0)). -Defined. - -Lemma Vshiftrepeat : forall n:nat, vector (S n) -> vector (S (S n)). -Proof. - induction n as [| n f]; intro v. - inversion v. - exact (Vcons a 1 v). - - inversion v as [| a n0 H0 H1 ]. - exact (Vcons a (S (S n)) (f H0)). -Defined. - -Lemma Vtrunc : forall n p:nat, n > p -> vector n -> vector (n - p). -Proof. - induction p as [| p f]; intros H v. - rewrite <- minus_n_O. - exact v. - - apply (Vshiftout (n - S p)). - - rewrite minus_Sn_m. - apply f. - auto with *. - exact v. - auto with *. -Defined. - -(** Concatenation of two vectors *) - -Fixpoint Vextend n p (v:vector n) (w:vector p) : vector (n+p) := - match v with - | Vnil => w - | Vcons a n' v' => Vcons a (n'+p) (Vextend n' p v' w) - end. - -(** Uniform application on the arguments of the vector *) - -Variable f : A -> A. - -Fixpoint Vunary n (v:vector n) : vector n := - match v with - | Vnil => Vnil - | Vcons a n' v' => Vcons (f a) n' (Vunary n' v') - end. - -Variable g : A -> A -> A. - -Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n. -Proof. - induction n as [| n h]; intros v v0. - exact Vnil. - - inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3]. - exact (Vcons (g a a0) n (h H0 H2)). -Defined. - -(** Eta-expansion of a vector *) - -Definition Vid n : vector n -> vector n := - match n with - | O => fun _ => Vnil - | _ => fun v => Vcons (Vhead _ v) _ (Vtail _ v) - end. - -Lemma Vid_eq : forall (n:nat) (v:vector n), v = Vid n v. -Proof. - destruct v; auto. -Qed. - -Lemma VSn_eq : - forall (n : nat) (v : vector (S n)), v = Vcons (Vhead _ v) _ (Vtail _ v). -Proof. - intros. - exact (Vid_eq _ v). -Qed. - -Lemma V0_eq : forall (v : vector 0), v = Vnil. -Proof. - intros. - exact (Vid_eq _ v). -Qed. - -End VECTORS. - -(* suppressed: incompatible with Coq-Art book -Implicit Arguments Vnil [A]. -Implicit Arguments Vcons [A n]. -*) - Section BOOLEAN_VECTORS. (** @@ -200,38 +44,38 @@ NOTA BENE: all shift operations expect predecessor of size as parameter (they only work on non-empty vectors). *) -Definition Bvector := vector bool. +Definition Bvector := Vector.t bool. -Definition Bnil := @Vnil bool. +Definition Bnil := @Vector.nil bool. -Definition Bcons := @Vcons bool. +Definition Bcons := @Vector.cons bool. -Definition Bvect_true := Vconst bool true. +Definition Bvect_true := Vector.const true. -Definition Bvect_false := Vconst bool false. +Definition Bvect_false := Vector.const false. -Definition Blow := Vhead bool. +Definition Blow := @Vector.hd bool. -Definition Bhigh := Vtail bool. +Definition Bhigh := @Vector.tl bool. -Definition Bsign := Vlast bool. +Definition Bsign := @Vector.last bool. -Definition Bneg := Vunary bool negb. +Definition Bneg n (v : Bvector n) := Vector.map negb v. -Definition BVand := Vbinary bool andb. +Definition BVand n (v : Bvector n) := Vector.map2 andb v. -Definition BVor := Vbinary bool orb. +Definition BVor n (v : Bvector n) := Vector.map2 orb v. -Definition BVxor := Vbinary bool xorb. +Definition BVxor n (v : Bvector n) := Vector.map2 xorb v. Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) := - Bcons carry n (Vshiftout bool n bv). + Bcons carry n (Vector.shiftout bv). Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) := - Bhigh (S n) (Vshiftin bool (S n) carry bv). + Bhigh (S n) (Vector.shiftin carry bv). Definition BshiftRa (n:nat) (bv:Bvector (S n)) := - Bhigh (S n) (Vshiftrepeat bool n bv). + Bhigh (S n) (Vector.shiftrepeat bv). Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := match p with @@ -252,3 +96,4 @@ Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) := end. End BOOLEAN_VECTORS. + diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index e49d1f97..3f03d2c1 100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DecBool.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C := diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 9cca05d4..6872eaea 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: IfProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Bool. Inductive IfProp (A B:Prop) : bool -> Prop := @@ -47,4 +45,4 @@ Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}. destruct b; intro H. left; inversion H; auto with bool. right; inversion H; auto with bool. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 5b1822be..24b6a776 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sumbool.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Here are collected some results about the type sumbool (see INIT/Specif.v) [sumbool A B], which is written [{A}+{B}], is the informative disjunction "A or B", where A and B are logical propositions. @@ -68,4 +66,4 @@ Definition bool_of_sumbool : intros A B H. elim H; intro; [exists true | exists false]; assumption. Defined. -Implicit Arguments bool_of_sumbool.
\ No newline at end of file +Arguments bool_of_sumbool : default implicits. diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index e67ba677..bac4c0d6 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zerob.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Arith. Require Import Bool. @@ -39,4 +37,4 @@ Hint Resolve zerob_false_intro: bool. Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0. Proof. destruct n; [ inversion 1 | auto with bool ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index ea1543e3..719a9a84 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: EquivDec.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Export notations. *) Require Export Coq.Classes.Equivalence. diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index e562328d..d9e9fe25 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: Equivalence.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index eea16129..a001f2e9 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,8 +13,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: Init.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Hints for the proof search: these combinators should be considered rigid. *) Require Import Coq.Program.Basics. @@ -36,4 +34,4 @@ Ltac unconvertible := | |- _ => exact tt end. -Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances.
\ No newline at end of file +Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index ea869a66..8e491b1b 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,8 +13,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: Morphisms.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. @@ -23,12 +21,6 @@ Require Export Coq.Classes.RelationClasses. Generalizable All Variables. Local Obligation Tactic := simpl_relation. -Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) - (at level 200, x binder, y binder, right associativity). - -Local Notation "'Π' x .. y , P" := (forall x, .. (forall y, P) ..) - (at level 200, x binder, y binder, right associativity) : type_scope. - (** * Morphisms. We now turn to the definition of [Proper] and declare standard instances. @@ -63,8 +55,8 @@ Definition respectful {A B : Type} Delimit Scope signature_scope with signature. -Arguments Scope Proper [type_scope signature_scope]. -Arguments Scope respectful [type_scope type_scope signature_scope signature_scope]. +Arguments Proper {A}%type R%signature m. +Arguments respectful {A B}%type (R R')%signature _ _. Module ProperNotations. @@ -83,17 +75,58 @@ Export ProperNotations. Open Local Scope signature_scope. +(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f] + by repeated introductions and setoid rewrites. It should work + fine when [f] is a combination of already known morphisms and + quantifiers. *) + +Ltac solve_respectful t := + match goal with + | |- respectful _ _ _ _ => + let H := fresh "H" in + intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t) + | _ => t; reflexivity + end. + +Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac). + +(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences. + For example, if we know that [f] is a morphism for [E1==>E2==>E], + then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv] + into the subgoals [E1 x x'] and [E2 y y']. +*) + +Ltac f_equiv := + match goal with + | |- ?R (?f ?x) (?f' _) => + let T := type of x in + let Rx := fresh "R" in + evar (Rx : relation T); + let H := fresh in + assert (H : (Rx==>R)%signature f f'); + unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ] + | |- ?R ?f ?f' => + try reflexivity; + change (Proper R f); eauto with typeclass_instances; fail + | _ => idtac + end. + +(** [forall_def] reifies the dependent product as a definition. *) + +Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x. + (** Dependent pointwise lifting of a relation on the range. *) -Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) := - λ f g, Π a : A, sig a (f a) (g a). +Definition forall_relation {A : Type} {B : A -> Type} + (sig : forall a, relation (B a)) : relation (forall x, B x) := + fun f g => forall a, sig a (f a) (g a). -Arguments Scope forall_relation [type_scope type_scope signature_scope]. +Arguments forall_relation {A B}%type sig%signature _ _. (** Non-dependent pointwise lifting *) Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := - Eval compute in forall_relation (B:=λ _, B) (λ _, R). + Eval compute in forall_relation (B:=fun _ => B) (fun _ => R). Lemma pointwise_pointwise A B (R : relation B) : relation_equivalence (pointwise_relation A R) (@eq A ==> R). @@ -192,28 +225,34 @@ Hint Extern 4 (subrelation (inverse _) _) => (** The complement of a relation conserves its proper elements. *) -Program Instance complement_proper +Program Definition complement_proper `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R). + Proper (RA ==> RA ==> iff) (complement R) := _. - Next Obligation. + Next Obligation. Proof. unfold complement. pose (mR x y H x0 y0 H0). intuition. Qed. + +Hint Extern 1 (Proper _ (complement _)) => + apply @complement_proper : typeclass_instances. (** The [inverse] too, actually the [flip] instance is a bit more general. *) -Program Instance flip_proper +Program Definition flip_proper `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : - Proper (RB ==> RA ==> RC) (flip f). + Proper (RB ==> RA ==> RC) (flip f) := _. Next Obligation. Proof. apply mor ; auto. Qed. +Hint Extern 1 (Proper _ (flip _)) => + apply @flip_proper : typeclass_instances. + (** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) @@ -369,41 +408,45 @@ Class PartialApplication. CoInductive normalization_done : Prop := did_normalization. Ltac partial_application_tactic := - let rec do_partial_apps H m := + let rec do_partial_apps H m cont := match m with - | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H] - | _ => idtac + | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; + [(do_partial_apps H m' ltac:idtac)|clear H] + | _ => cont end in - let rec do_partial H ar m := + let rec do_partial H ar m := match ar with - | 0 => do_partial_apps H m + | 0%nat => do_partial_apps H m ltac:(fail 1) | S ?n' => match m with ?m' ?x => do_partial H n' m' end end in - let on_morphism m := - let m' := fresh in head_of_constr m' m ; - let n := fresh in evar (n:nat) ; - let v := eval compute in n in clear n ; - let H := fresh in - assert(H:Params m' v) by typeclasses eauto ; - let v' := eval compute in v in subst m'; - do_partial H v' m - in + let params m sk fk := + (let m' := fresh in head_of_constr m' m ; + let n := fresh in evar (n:nat) ; + let v := eval compute in n in clear n ; + let H := fresh in + assert(H:Params m' v) by typeclasses eauto ; + let v' := eval compute in v in subst m'; + (sk H v' || fail 1)) + || fk + in + let on_morphism m cont := + params m ltac:(fun H n => do_partial H n m) + ltac:(cont) + in match goal with | [ _ : normalization_done |- _ ] => fail 1 | [ _ : @Params _ _ _ |- _ ] => fail 1 | [ |- @Proper ?T _ (?m ?x) ] => match goal with - | [ _ : PartialApplication |- _ ] => - class_apply @Reflexive_partial_app_morphism - | _ => - on_morphism (m x) || - (class_apply @Reflexive_partial_app_morphism ; - [ pose Build_PartialApplication | idtac ]) + | [ H : PartialApplication |- _ ] => + class_apply @Reflexive_partial_app_morphism; [|clear H] + | _ => on_morphism (m x) + ltac:(class_apply @Reflexive_partial_app_morphism) end end. @@ -432,7 +475,7 @@ Qed. Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). -Proof. unfold Normalizes in *. intros. +Proof. unfold Normalizes in *. intros. rewrite NA, NB. firstorder. Qed. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 5a2482d4..256bcc37 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -107,3 +107,33 @@ Program Instance all_inverse_impl_morphism {A : Type} : unfold pointwise_relation, all in *. intuition ; specialize (H x0) ; intuition. Qed. + +(** Equivalent points are simultaneously accessible or not *) + +Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) + `(Equivalence _ E) `(Proper _ (E==>E==>iff) R) : + Proper (E==>iff) (Acc R). +Proof. + apply proper_sym_impl_iff; auto with *. + intros x y EQ WF. apply Acc_intro; intros z Hz. + rewrite <- EQ in Hz. now apply Acc_inv with x. +Qed. + +(** Equivalent relations have the same accessible points *) + +Instance Acc_rel_morphism {A:Type} : + Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A). +Proof. + apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry. + intros R R' EQ a a' Ha WF. subst a'. + induction WF as [x _ WF']. constructor. + intros y Ryx. now apply WF', EQ. +Qed. + +(** Equivalent relations are simultaneously well-founded or not *) + +Instance well_founded_morphism {A : Type} : + Proper (@relation_equivalence A ==> iff) (@well_founded A). +Proof. + unfold well_founded. solve_proper. +Qed. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index a8009f9e..7ac49eeb 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -32,11 +32,11 @@ Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> Require Import List. -Lemma predicate_equivalence_pointwise (l : list Type) : +Lemma predicate_equivalence_pointwise (l : Tlist) : Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id. Proof. do 2 red. unfold predicate_equivalence. auto. Qed. -Lemma predicate_implication_pointwise (l : list Type) : +Lemma predicate_implication_pointwise (l : Tlist) : Proper (@predicate_implication l ==> pointwise_lifting impl l) id. Proof. do 2 red. unfold predicate_implication. auto. Qed. @@ -45,11 +45,11 @@ Proof. do 2 red. unfold predicate_implication. auto. Qed. Instance relation_equivalence_pointwise : Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. -Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed. +Proof. intro. apply (predicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed. Instance subrelation_pointwise : Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. -Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. +Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. Lemma inverse_pointwise_relation A (R : relation A) : diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 94c51bf1..cf05d9d4 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,13 +1,13 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** * Typeclass-based relations, tactics and standard instances +(** * Typeclass-based relations, tactics and standard instances This is the basic theory needed to formalize morphisms and setoids. @@ -15,8 +15,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: RelationClasses.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Coq.Classes.Init. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. @@ -143,9 +141,9 @@ Program Instance impl_Transitive : Transitive impl. (** Logical equivalence. *) -Program Instance iff_Reflexive : Reflexive iff. -Program Instance iff_Symmetric : Symmetric iff. -Program Instance iff_Transitive : Transitive iff. +Instance iff_Reflexive : Reflexive iff := iff_refl. +Instance iff_Symmetric : Symmetric iff := iff_sym. +Instance iff_Transitive : Transitive iff := iff_trans. (** Leibniz equality. *) @@ -158,14 +156,14 @@ Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A. (** A [PreOrder] is both Reflexive and Transitive. *) Class PreOrder {A} (R : relation A) : Prop := { - PreOrder_Reflexive :> Reflexive R ; - PreOrder_Transitive :> Transitive R }. + PreOrder_Reflexive :> Reflexive R | 2 ; + PreOrder_Transitive :> Transitive R | 2 }. (** A partial equivalence relation is Symmetric and Transitive. *) Class PER {A} (R : relation A) : Prop := { - PER_Symmetric :> Symmetric R ; - PER_Transitive :> Transitive R }. + PER_Symmetric :> Symmetric R | 3 ; + PER_Transitive :> Transitive R | 3 }. (** Equivalence relations. *) @@ -210,17 +208,21 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) -Fixpoint arrows (l : list Type) (r : Type) : Type := +(* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) +Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. +Local Infix "::" := Tcons. + +Fixpoint arrows (l : Tlist) (r : Type) : Type := match l with - | nil => r + | Tnil => r | A :: l' => A -> arrows l' r end. (** We can define abbreviations for operation and relation types based on [arrows]. *) -Definition unary_operation A := arrows (A::nil) A. -Definition binary_operation A := arrows (A::A::nil) A. -Definition ternary_operation A := arrows (A::A::A::nil) A. +Definition unary_operation A := arrows (A::Tnil) A. +Definition binary_operation A := arrows (A::A::Tnil) A. +Definition ternary_operation A := arrows (A::A::A::Tnil) A. (** We define n-ary [predicate]s as functions into [Prop]. *) @@ -228,23 +230,23 @@ Notation predicate l := (arrows l Prop). (** Unary predicates, or sets. *) -Definition unary_predicate A := predicate (A::nil). +Definition unary_predicate A := predicate (A::Tnil). (** Homogeneous binary relations, equivalent to [relation A]. *) -Definition binary_relation A := predicate (A::A::nil). +Definition binary_relation A := predicate (A::A::Tnil). (** We can close a predicate by universal or existential quantification. *) -Fixpoint predicate_all (l : list Type) : predicate l -> Prop := +Fixpoint predicate_all (l : Tlist) : predicate l -> Prop := match l with - | nil => fun f => f + | Tnil => fun f => f | A :: tl => fun f => forall x : A, predicate_all tl (f x) end. -Fixpoint predicate_exists (l : list Type) : predicate l -> Prop := +Fixpoint predicate_exists (l : Tlist) : predicate l -> Prop := match l with - | nil => fun f => f + | Tnil => fun f => f | A :: tl => fun f => exists x : A, predicate_exists tl (f x) end. @@ -253,30 +255,30 @@ Fixpoint predicate_exists (l : list Type) : predicate l -> Prop := For an operator on [Prop] this lifts the operator to a binary operation. *) Fixpoint pointwise_extension {T : Type} (op : binary_operation T) - (l : list Type) : binary_operation (arrows l T) := + (l : Tlist) : binary_operation (arrows l T) := match l with - | nil => fun R R' => op R R' + | Tnil => fun R R' => op R R' | A :: tl => fun R R' => fun x => pointwise_extension op tl (R x) (R' x) end. (** Pointwise lifting, equivalent to doing [pointwise_extension] and closing using [predicate_all]. *) -Fixpoint pointwise_lifting (op : binary_relation Prop) (l : list Type) : binary_relation (predicate l) := +Fixpoint pointwise_lifting (op : binary_relation Prop) (l : Tlist) : binary_relation (predicate l) := match l with - | nil => fun R R' => op R R' + | Tnil => fun R R' => op R R' | A :: tl => fun R R' => forall x, pointwise_lifting op tl (R x) (R' x) end. (** The n-ary equivalence relation, defined by lifting the 0-ary [iff] relation. *) -Definition predicate_equivalence {l : list Type} : binary_relation (predicate l) := +Definition predicate_equivalence {l : Tlist} : binary_relation (predicate l) := pointwise_lifting iff l. (** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *) -Definition predicate_implication {l : list Type} := +Definition predicate_implication {l : Tlist} := pointwise_lifting impl l. (** Notations for pointwise equivalence and implication of predicates. *) @@ -297,15 +299,15 @@ Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_ (** The always [True] and always [False] predicates. *) -Fixpoint true_predicate {l : list Type} : predicate l := +Fixpoint true_predicate {l : Tlist} : predicate l := match l with - | nil => True + | Tnil => True | A :: tl => fun _ => @true_predicate tl end. -Fixpoint false_predicate {l : list Type} : predicate l := +Fixpoint false_predicate {l : Tlist} : predicate l := match l with - | nil => False + | Tnil => False | A :: tl => fun _ => @false_predicate tl end. @@ -315,6 +317,7 @@ Notation "∙⊥∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). + Next Obligation. induction l ; firstorder. Qed. @@ -343,18 +346,18 @@ Program Instance predicate_implication_preorder : from the general ones. *) Definition relation_equivalence {A : Type} : relation (relation A) := - @predicate_equivalence (_::_::nil). + @predicate_equivalence (_::_::Tnil). Class subrelation {A:Type} (R R' : relation A) : Prop := - is_subrelation : @predicate_implication (A::A::nil) R R'. + is_subrelation : @predicate_implication (A::A::Tnil) R R'. -Implicit Arguments subrelation [[A]]. +Arguments subrelation {A} R R'. Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_intersection (A::A::nil) R R'. + @predicate_intersection (A::A::Tnil) R R'. Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := - @predicate_union (A::A::nil) R R'. + @predicate_union (A::A::Tnil) R R'. (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) @@ -362,10 +365,10 @@ Set Automatic Introduction. Instance relation_equivalence_equivalence (A : Type) : Equivalence (@relation_equivalence A). -Proof. exact (@predicate_equivalence_equivalence (A::A::nil)). Qed. +Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. Instance relation_implication_preorder A : PreOrder (@subrelation A). -Proof. exact (@predicate_implication_preorder (A::A::nil)). Qed. +Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed. (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. @@ -393,7 +396,7 @@ Program Instance subrelation_partial_order : Next Obligation. Proof. - unfold relation_equivalence in *. firstorder. + unfold relation_equivalence in *. compute; firstorder. Qed. Typeclasses Opaque arrows predicate_implication predicate_equivalence @@ -420,7 +423,7 @@ Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA (** Strict Order *) -Class StrictOrder {A : Type} (R : relation A) := { +Class StrictOrder {A : Type} (R : relation A) : Prop := { StrictOrder_Irreflexive :> Irreflexive R ; StrictOrder_Transitive :> Transitive R }. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 7972c96c..2b010206 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -15,27 +15,25 @@ Require Import Relations Morphisms. fix the simpl tactic, since "simpl fst" would be refused for the moment. -Implicit Arguments fst [[A] [B]]. -Implicit Arguments snd [[A] [B]]. -Implicit Arguments pair [[A] [B]]. +Arguments fst {A B}. +Arguments snd {A B}. +Arguments pair {A B}. /NB *) Local Notation Fst := (@fst _ _). Local Notation Snd := (@snd _ _). -Arguments Scope relation_conjunction - [type_scope signature_scope signature_scope]. -Arguments Scope relation_equivalence - [type_scope signature_scope signature_scope]. -Arguments Scope subrelation [type_scope signature_scope signature_scope]. -Arguments Scope Reflexive [type_scope signature_scope]. -Arguments Scope Irreflexive [type_scope signature_scope]. -Arguments Scope Symmetric [type_scope signature_scope]. -Arguments Scope Transitive [type_scope signature_scope]. -Arguments Scope PER [type_scope signature_scope]. -Arguments Scope Equivalence [type_scope signature_scope]. -Arguments Scope StrictOrder [type_scope signature_scope]. +Arguments relation_conjunction A%type (R R')%signature _ _. +Arguments relation_equivalence A%type (_ _)%signature. +Arguments subrelation A%type (R R')%signature. +Arguments Reflexive A%type R%signature. +Arguments Irreflexive A%type R%signature. +Arguments Symmetric A%type R%signature. +Arguments Transitive A%type R%signature. +Arguments PER A%type R%signature. +Arguments Equivalence A%type R%signature. +Arguments StrictOrder A%type R%signature. Generalizable Variables A B RA RB Ri Ro f. @@ -88,10 +86,10 @@ Section RelCompFun_Instances. `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f). Proof. firstorder. Qed. - Global Instance RelCompFun_Equivalence + Global Program Instance RelCompFun_Equivalence `(Measure A B f, Equivalence _ R) : Equivalence (R@@f). - Global Instance RelCompFun_StrictOrder + Global Program Instance RelCompFun_StrictOrder `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f). End RelCompFun_Instances. @@ -108,7 +106,7 @@ Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B) `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB). Proof. firstorder. Qed. -Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) +Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B) `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB). Lemma FstRel_ProdRel {A B}(RA:relation A) : diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index e9da6874..591671d9 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: SetoidClass.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Set Implicit Arguments. Unset Strict Implicit. @@ -71,7 +69,7 @@ Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : (** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) Ltac clsubst H := - match type of H with + lazymatch type of H with ?x == ?y => substitute H ; clear H x end. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 4f70b244..6708220e 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,16 +13,11 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: SetoidDec.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Set Implicit Arguments. Unset Strict Implicit. Generalizable Variables A B . -Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) - (at level 200, x binder, y binder, right associativity). - (** Export notations. *) Require Export Coq.Classes.SetoidClass. @@ -95,7 +90,7 @@ Program Instance bool_eqdec : EqDec (eq_setoid bool) := bool_dec. Program Instance unit_eqdec : EqDec (eq_setoid unit) := - λ x y, in_left. + fun x y => in_left. Next Obligation. Proof. @@ -103,8 +98,9 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := reflexivity. Qed. -Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := - λ x y, +Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) + : EqDec (eq_setoid (prod A B)) := + fun x y => let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then @@ -117,8 +113,9 @@ Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : Eq (** Objects of function spaces with countable domains like bool have decidable equality. *) -Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) := - λ f g, +Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) + : EqDec (eq_setoid (bool -> A)) := + fun f g => if f true == g true then if f false == g false then in_left else in_right diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index a1a0c969..31a4f5f2 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,6 @@ Institution: LRI, CNRS UMR 8623 - University Paris Sud *) -(* $Id: SetoidTactics.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop. Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions. Require Import Coq.Classes.Equivalence Coq.Program.Basics. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 49f595d7..c761e2a7 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -8,8 +8,6 @@ (* Finite map library. *) -(* $Id: FMapAVL.v 13768 2011-01-06 13:55:35Z glondu $ *) - (** * FMapAVL *) (** This module implements maps using AVL trees. @@ -39,6 +37,7 @@ Open Local Scope lazy_bool_scope. Open Local Scope Int_scope. Definition key := X.t. +Hint Transparent key. (** * Trees *) @@ -542,12 +541,12 @@ Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). Ltac join_tac := intros l; induction l as [| ll _ lx ld lr Hlr lh]; [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); + [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE]; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] end - | destruct (gt_le_dec rh (lh+2)); + | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; [ match goal with |- context [ bal ?u ?v ?w ?z ] => replace (bal u v w z) with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] @@ -823,7 +822,7 @@ Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. + (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. @@ -1113,7 +1112,7 @@ Lemma join_bst : forall l x d r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x d r). Proof. join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; - clear Hrl Hlr z; intro; intros; rewrite join_in in *. + clear Hrl Hlr; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. @@ -1333,7 +1332,7 @@ Proof. inversion_clear H. destruct H7; simpl in *. order. - destruct (elements_aux_mapsto r acc x e0); intuition eauto. + destruct (elements_aux_mapsto r acc x e0); intuition eauto. Qed. Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 8944f7ce..0c1448c9 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 12459 2009-11-02 18:51:43Z letouzey $ *) - (** * Finite maps library *) (** This functor derives additional facts from [FMapInterface.S]. These @@ -259,7 +257,7 @@ Qed. Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), MapsTo x b (mapi f m) -> - exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a 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. @@ -654,7 +652,7 @@ Add Relation key E.eq transitivity proved by E.eq_trans as KeySetoid. -Implicit Arguments Equal [[elt]]. +Arguments Equal {elt} m m'. Add Parametric Relation (elt : Type) : (t elt) Equal reflexivity proved by (@Equal_refl elt) @@ -740,7 +738,7 @@ End WFacts_fun. (** * Same facts for self-contained weak sets and for full maps *) -Module WFacts (M:S) := WFacts_fun M.E M. +Module WFacts (M:WS) := WFacts_fun M.E M. Module Facts := WFacts. (** * Additional Properties for weak maps @@ -761,8 +759,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Notation eqk := (@eq_key elt). Instance eqk_equiv : Equivalence eqk. - Proof. split; repeat red; eauto. Qed. - + Proof. unfold eq_key; split; eauto. Qed. + Instance eqke_equiv : Equivalence eqke. Proof. unfold eq_key_elt; split; repeat red; firstorder. @@ -834,8 +832,11 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** * 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 (l : list (key*elt)) := - List.fold_right (fun p => add (fst p) (snd p)) (empty _) l. + List.fold_right (uncurry (@add _)) (empty _) l. Definition to_list := elements. @@ -845,6 +846,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). 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. @@ -861,6 +863,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). 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. @@ -883,6 +886,14 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** * 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 @@ -897,8 +908,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). P m (fold f m i). Proof. intros A P f i m Hempty Hstep. - rewrite fold_1, <- fold_left_rev_right. - set (F:=fun (y : key * elt) (x : A) => f (fst y) (snd y) x). + 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)). @@ -983,8 +994,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). R (fold f m i) (fold g m j). Proof. intros A B R f g i j m Rempty Rstep. - do 2 rewrite fold_1, <- fold_left_rev_right. - set (l:=rev (elements m)). + 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; auto with *). @@ -1099,14 +1109,15 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. - intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. + intros. + rewrite 2 fold_spec_right. assert (NoDupA eqk (rev (elements m1))) by (auto with *). assert (NoDupA eqk (rev (elements m2))) by (auto with *). apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke); auto with *. 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; simpl; auto. + 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; @@ -1116,8 +1127,9 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). 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; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - set (f':=fun y x0 => f (fst y) (snd y) x0) in *. + 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 *). @@ -1126,7 +1138,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *. 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; simpl; auto. + unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto. rewrite <- NoDupA_altdef; auto. rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder. intros (a,b). @@ -2130,8 +2142,7 @@ Module OrdProperties (M:S). eqA (fold f m1 i) (fold f m2 i). Proof. intros m1 m2 A eqA st f i Hf Heq. - do 2 rewrite fold_1. - do 2 rewrite <- fold_left_rev_right. + 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. @@ -2142,8 +2153,7 @@ Module OrdProperties (M:S). Above x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (f x e (fold f m1 i)). Proof. - intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - set (f':=fun y x0 => f (fst y) (snd y) x0) in *. + 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. @@ -2158,8 +2168,7 @@ Module OrdProperties (M:S). Below x m1 -> Add x e m1 m2 -> eqA (fold f m2 i) (fold f m1 (f x e i)). Proof. - intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - set (f':=fun y x0 => f (fst y) (snd y) x0) in *. + 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. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 2b9e7077..774bcd9b 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -8,8 +8,6 @@ (* Finite map library. *) -(* $Id: FMapFullAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *) - (** * FMapFullAVL This file contains some complements to [FMapAVL]. diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index bbfecfb1..4d89b562 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *) - (** * Finite map library *) (** This file proposes interfaces for finite maps *) @@ -58,6 +56,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. Module Type WSfun (E : DecidableType). Definition key := E.t. + Hint Transparent key. Parameter t : Type -> Type. (** the abstract type of maps *) diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 4b7f183c..f15ab222 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 12458 2009-11-02 18:50:33Z letouzey $ *) - (** * Finite map library *) (** This file proposes an implementation of the non-dependant interface diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 30bce2db..2e2eb166 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapPositive.v 13297 2010-07-19 23:32:42Z letouzey $ *) - (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. @@ -86,7 +84,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section A. Variable A:Type. - Implicit Arguments Leaf [A]. + Arguments Leaf [A]. Definition empty : t A := Leaf. @@ -496,9 +494,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition lt_key (p p':positive*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. + Global Program Instance eqk_equiv : Equivalence eq_key. + Global Program Instance eqke_equiv : Equivalence eq_key_elt. + Global Program Instance ltk_strorder : StrictOrder lt_key. Lemma mem_find : forall m x, mem x m = match find x m with None => false | _ => true end. @@ -816,7 +814,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Variable A B C : Type. Variable f : option A -> option B -> option C. - Implicit Arguments Leaf [A]. + Arguments Leaf [A]. Fixpoint xmap2_l (m : t A) : t C := match m with diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index db479ea8..6c1e8ca8 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapWeakList.v 12458 2009-11-02 18:50:33Z letouzey $ *) - (** * Finite map library *) (** This file proposes an implementation of the non-dependant interface diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v index 75904202..19b25d95 100644 --- a/theories/FSets/FMaps.v +++ b/theories/FSets/FMaps.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *) - Require Export OrderedType OrderedTypeEx OrderedTypeAlt. Require Export DecidableType DecidableTypeEx. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index 2cbba723..df627a14 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -7,8 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetAVL.v 12641 2010-01-07 15:32:52Z letouzey $ *) - (** * FSetAVL : Implementation of FSetInterface via AVL trees *) (** This module implements finite sets using AVL trees. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index c2d921be..25ce5577 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 13253 2010-07-07 08:39:30Z letouzey $ *) - (** * Finite sets library *) (** This module implements bridges (as functors) from dependent diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v index c3d614ee..6b3d86d3 100644 --- a/theories/FSets/FSetCompat.v +++ b/theories/FSets/FSetCompat.v @@ -264,7 +264,7 @@ Module Update_WSets 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. - Instance eq_equiv : Equivalence eq. + Instance eq_equiv : Equivalence eq := _. Section Spec. Variable s s': t. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 7c321779..f64df9fe 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetDecide.v 14527 2011-10-07 14:33:38Z letouzey $ *) - (**************************************************************) (* FSetDecide.v *) (* *) diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index ac55aef5..755bc7dd 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *) - (** * Finite sets library *) (** This module proves many properties of finite sets that diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index 45b43d83..f473b334 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 12461 2009-11-03 08:24:06Z letouzey $ *) - (** * Finite sets library *) (** This functor derives additional facts from [FSetInterface.S]. These diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index f366ed3e..a0361119 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *) - (** * Finite set library *) (** Set interfaces, inspired by the one of Ocaml. When compared with @@ -253,6 +251,7 @@ Module Type WSfun (E : DecidableType). End Spec. + Hint Transparent elt. 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 diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index 9408ba05..1f36306c 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 12641 2010-01-07 15:32:52Z letouzey $ *) - (** * Finite sets library *) (** This file proposes an implementation of the non-dependant diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 59e19cd3..1bad8061 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *) - (** * Finite sets library *) (** This functor derives additional properties from [FSetInterface.S]. @@ -337,6 +335,14 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Section Fold. + (** 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. + Notation NoDup := (NoDupA E.eq). Notation InA := (InA E.eq). @@ -353,8 +359,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). P s (fold f s i). Proof. intros A P f i s Pempty Pstep. - rewrite fold_1, <- fold_left_rev_right. - set (l:=rev (elements s)). + 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. @@ -426,8 +431,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). R (fold f s i) (fold g s j). Proof. intros A B R f g i j s Rempty Rstep. - do 2 rewrite fold_1, <- fold_left_rev_right. - set (l:=rev (elements s)). + 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. @@ -485,8 +489,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. - rewrite fold_left_rev_right. - apply fold_1. + apply fold_spec_right. Qed. (** An alternate (and previous) specification for [fold] was based on @@ -1088,8 +1091,7 @@ Module OrdProperties (M:S). Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. intros. - do 2 rewrite M.fold_1. - do 2 rewrite <- fold_left_rev_right. + 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. @@ -1105,11 +1107,11 @@ Module OrdProperties (M:S). Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. intros. - do 2 rewrite M.fold_1. + 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. - do 2 rewrite <- fold_left_rev_right. + 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. @@ -1126,8 +1128,7 @@ Module OrdProperties (M:S). Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. - intros; do 2 rewrite M.fold_1. - do 2 rewrite <- fold_left_rev_right. + 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. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 2aa1b433..3ac5d9e4 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetToFiniteSet.v 12363 2009-09-28 15:04:07Z letouzey $ *) - (** * Finite sets library : conversion to old [Finite_sets] *) Require Import Ensembles Finite_sets. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index b55db37a..2ea32e97 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 12641 2010-01-07 15:32:52Z letouzey $ *) - (** * Finite sets library *) (** This file proposes an implementation of the non-dependant diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index a725c1eb..572f2865 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSets.v 13297 2010-07-19 23:32:42Z letouzey $ *) - Require Export OrderedType. Require Export OrderedTypeEx. Require Export OrderedTypeAlt. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index deadec43..41f6b70b 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -1,25 +1,33 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import Notations. Require Import Logic. Declare ML Module "nat_syntax_plugin". +(********************************************************************) +(** * Datatypes with zero and one element *) + +(** [Empty_set] is a datatype with no inhabitant *) + +Inductive Empty_set : Set :=. (** [unit] is a singleton datatype with sole inhabitant [tt] *) Inductive unit : Set := tt : unit. + +(********************************************************************) +(** * The boolean datatype *) + (** [bool] is the datatype of the boolean values [true] and [false] *) Inductive bool : Set := @@ -53,9 +61,7 @@ Definition negb (b:bool) := if b then false else true. Infix "||" := orb : bool_scope. Infix "&&" := andb : bool_scope. -(*******************************) -(** * Properties of [andb] *) -(*******************************) +(** Basic properties of [andb] *) Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. Proof. @@ -104,6 +110,22 @@ Proof. intros P b H H0; destruct H0 in H; assumption. Defined. +(** The [BoolSpec] inductive will be used to relate a [boolean] value + and two propositions corresponding respectively to the [true] + case and the [false] case. + Interest: [BoolSpec] behave nicely with [case] and [destruct]. + See also [Bool.reflect] when [Q = ~P]. +*) + +Inductive BoolSpec (P Q : Prop) : bool -> Prop := + | BoolSpecT : P -> BoolSpec P Q true + | BoolSpecF : Q -> BoolSpec P Q false. +Hint Constructors BoolSpec. + + +(********************************************************************) +(** * Peano natural numbers *) + (** [nat] is the datatype of natural numbers built from [O] and successor [S]; note that the constructor name is the letter O. Numbers in [nat] can be denoted using a decimal notation; @@ -115,23 +137,11 @@ Inductive nat : Set := Delimit Scope nat_scope with nat. Bind Scope nat_scope with nat. -Arguments Scope S [nat_scope]. +Arguments S _%nat. -(** [Empty_set] has no inhabitant *) -Inductive Empty_set : Set :=. - -(** [identity A a] is the family of datatypes on [A] whose sole non-empty - member is the singleton datatype [identity A a a] whose - sole inhabitant is denoted [refl_identity A a] *) - -Inductive identity (A:Type) (a:A) : A -> Type := - identity_refl : identity a a. -Hint Resolve identity_refl: core. - -Implicit Arguments identity_ind [A]. -Implicit Arguments identity_rec [A]. -Implicit Arguments identity_rect [A]. +(********************************************************************) +(** * Container datatypes *) (** [option A] is the extension of [A] with an extra element [None] *) @@ -139,7 +149,7 @@ Inductive option (A:Type) : Type := | Some : A -> option A | None : option A. -Implicit Arguments None [A]. +Arguments None [A]. Definition option_map (A B:Type) (f:A->B) o := match o with @@ -155,6 +165,9 @@ Inductive sum (A B:Type) : Type := Notation "x + y" := (sum x y) : type_scope. +Arguments inl {A B} _ , [A] B _. +Arguments inr {A B} _ , A [B] _. + (** [prod A B], written [A * B], is the product of [A] and [B]; the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *) @@ -166,6 +179,8 @@ Add Printing Let prod. Notation "x * y" := (prod x y) : type_scope. Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. +Arguments pair {A B} _ _. + Section projections. Variables A B : Type. Definition fst (p:A * B) := match p with @@ -200,7 +215,40 @@ Definition prod_curry (A B C:Type) (f:A -> B -> C) | pair x y => f x y end. -(** Comparison *) +(** Polymorphic lists and some operations *) + +Inductive list (A : Type) : Type := + | nil : list A + | cons : A -> list A -> list A. + +Arguments nil [A]. +Infix "::" := cons (at level 60, right associativity) : list_scope. +Delimit Scope list_scope with list. +Bind Scope list_scope with list. + +Local Open Scope list_scope. + +Definition length (A : Type) : list A -> nat := + fix length l := + match l with + | nil => O + | _ :: l' => S (length l') + end. + +(** Concatenation of two lists *) + +Definition app (A : Type) : list A -> list A -> list A := + fix app l m := + match l with + | nil => m + | a :: l1 => a :: app l1 m + end. + +Infix "++" := app (right associativity, at level 60) : list_scope. + + +(********************************************************************) +(** * The comparison datatype *) Inductive comparison : Set := | Eq : comparison @@ -229,68 +277,68 @@ Proof. split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto. Qed. -(** The [CompSpec] inductive will be used to relate a [compare] function - (returning a comparison answer) and some equality and order predicates. - Interest: [CompSpec] behave nicely with [case] and [destruct]. *) +(** The [CompareSpec] inductive relates a [comparison] value with three + propositions, one for each possible case. Typically, it can be used to + specify a comparison function via some equality and order predicates. + Interest: [CompareSpec] behave nicely with [case] and [destruct]. *) -Inductive CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := - | CompEq : eq x y -> CompSpec eq lt x y Eq - | CompLt : lt x y -> CompSpec eq lt x y Lt - | CompGt : lt y x -> CompSpec eq lt x y Gt. -Hint Constructors CompSpec. +Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := + | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq + | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt + | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. +Hint Constructors CompareSpec. -(** For having clean interfaces after extraction, [CompSpec] is declared +(** For having clean interfaces after extraction, [CompareSpec] is declared in Prop. For some situations, it is nonetheless useful to have a - version in Type. Interestingly, these two versions are equivalent. -*) + version in Type. Interestingly, these two versions are equivalent. *) -Inductive CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := - | CompEqT : eq x y -> CompSpecT eq lt x y Eq - | CompLtT : lt x y -> CompSpecT eq lt x y Lt - | CompGtT : lt y x -> CompSpecT eq lt x y Gt. -Hint Constructors CompSpecT. +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. +Hint Constructors CompareSpecT. -Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, - CompSpec eq lt x y c -> CompSpecT eq lt x y c. +Lemma CompareSpec2Type : forall Peq Plt Pgt c, + CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. Proof. destruct c; intros H; constructor; inversion_clear H; auto. Defined. -(** Identity *) +(** As an alternate formulation, one may also directly refer to predicates + [eq] and [lt] for specifying a comparison, rather that fully-applied + propositions. This [CompSpec] is now a particular case of [CompareSpec]. *) -Definition ID := forall A:Type, A -> A. -Definition id : ID := fun A x => x. +Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := + CompareSpec (eq x y) (lt x y) (lt y x). +Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := + CompareSpecT (eq x y) (lt x y) (lt y x). +Hint Unfold CompSpec CompSpecT. -(** Polymorphic lists and some operations *) +Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, + CompSpec eq lt x y c -> CompSpecT eq lt x y c. +Proof. intros. apply CompareSpec2Type; assumption. Defined. -Inductive list (A : Type) : Type := - | nil : list A - | cons : A -> list A -> list A. -Implicit Arguments nil [A]. -Infix "::" := cons (at level 60, right associativity) : list_scope. -Delimit Scope list_scope with list. -Bind Scope list_scope with list. +(******************************************************************) +(** * Misc Other Datatypes *) -Local Open Scope list_scope. +(** [identity A a] is the family of datatypes on [A] whose sole non-empty + member is the singleton datatype [identity A a a] whose + sole inhabitant is denoted [refl_identity A a] *) -Definition length (A : Type) : list A -> nat := - fix length l := - match l with - | nil => O - | _ :: l' => S (length l') - end. +Inductive identity (A:Type) (a:A) : A -> Type := + identity_refl : identity a a. +Hint Resolve identity_refl: core. -(** Concatenation of two lists *) +Arguments identity_ind [A] a P f y i. +Arguments identity_rec [A] a P f y i. +Arguments identity_rect [A] a P f y i. -Definition app (A : Type) : list A -> list A -> list A := - fix app l m := - match l with - | nil => m - | a :: l1 => a :: app l1 m - end. +(** Identity type *) + +Definition ID := forall A:Type, A -> A. +Definition id : ID := fun A x => x. -Infix "++" := app (right associativity, at level 60) : list_scope. (* begin hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index b95d78a4..d1eabcab 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import Notations. @@ -64,6 +62,9 @@ Inductive or (A B:Prop) : Prop := where "A \/ B" := (or A B) : type_scope. +Arguments or_introl [A B] _, [A] B _. +Arguments or_intror [A B] _, A [B] _. + (** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *) Definition iff (A B:Prop) := (A -> B) /\ (B -> A). @@ -95,53 +96,53 @@ Hint Unfold iff: extcore. Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False). Proof. -intro A; unfold not; split. -intro H; split; [exact H | intro H1; elim H1]. -intros [H _]; exact H. + intro A; unfold not; split. + - intro H; split; [exact H | intro H1; elim H1]. + - intros [H _]; exact H. Qed. Theorem and_cancel_l : forall A B C : Prop, (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)). Proof. -intros; tauto. + intros; tauto. Qed. Theorem and_cancel_r : forall A B C : Prop, (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)). Proof. -intros; tauto. + intros; tauto. Qed. Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A. Proof. -intros; tauto. + intros; tauto. Qed. Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C. Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_cancel_l : forall A B C : Prop, (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)). Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_cancel_r : forall A B C : Prop, (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)). Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A). Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C. Proof. -intros; tauto. + intros; tauto. Qed. (** Backward direction of the equivalences above does not need assumptions *) @@ -149,35 +150,35 @@ Qed. Theorem and_iff_compat_l : forall A B C : Prop, (B <-> C) -> (A /\ B <-> A /\ C). Proof. -intros; tauto. + intros; tauto. Qed. Theorem and_iff_compat_r : forall A B C : Prop, (B <-> C) -> (B /\ A <-> C /\ A). Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_iff_compat_l : forall A B C : Prop, (B <-> C) -> (A \/ B <-> A \/ C). Proof. -intros; tauto. + intros; tauto. Qed. Theorem or_iff_compat_r : forall A B C : Prop, (B <-> C) -> (B \/ A <-> C \/ A). Proof. -intros; tauto. + intros; tauto. Qed. Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A). Proof. -intros A B []; split; trivial. + intros A B []; split; trivial. Qed. Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A). Proof. -intros; tauto. + intros; tauto. Qed. (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes @@ -218,11 +219,9 @@ Definition all (A:Type) (P:A -> Prop) := forall x:A, P x. (* Rule order is important to give printing priority to fully typed exists *) -Notation "'exists' x , p" := (ex (fun x => p)) - (at level 200, x ident, right associativity) : type_scope. -Notation "'exists' x : t , p" := (ex (fun x:t => p)) - (at level 200, x ident, right associativity, - format "'[' 'exists' '/ ' x : t , '/ ' p ']'") +Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) + (at level 200, x binder, right associativity, + format "'[' 'exists' '/ ' x .. y , '/ ' p ']'") : type_scope. Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) @@ -271,11 +270,12 @@ Notation "x = y" := (x = y :>_) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. Notation "x <> y" := (x <> y :>_) : type_scope. -Implicit Arguments eq [ [A] ]. +Arguments eq {A} x _. +Arguments eq_refl {A x} , [A] x. -Implicit Arguments eq_ind [A]. -Implicit Arguments eq_rec [A]. -Implicit Arguments eq_rect [A]. +Arguments eq_ind [A] x P _ y _. +Arguments eq_rec [A] x P _ y _. +Arguments eq_rect [A] x P _ y _. Hint Resolve I conj or_introl or_intror eq_refl: core. Hint Resolve ex_intro ex_intro2: core. @@ -334,6 +334,15 @@ Section Logic_lemmas. Defined. End Logic_lemmas. +Module EqNotations. + Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H) + (at level 10, H' at level 10). + Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H) + (at level 10, H' at level 10). + Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H) + (at level 10, H' at level 10, only parsing). +End EqNotations. + Theorem f_equal2 : forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2. @@ -392,26 +401,47 @@ Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y. (** Unique existence *) -Notation "'exists' ! x , P" := (ex (unique (fun x => P))) - (at level 200, x ident, right associativity, - format "'[' 'exists' ! '/ ' x , '/ ' P ']'") : type_scope. -Notation "'exists' ! x : A , P" := - (ex (unique (fun x:A => P))) - (at level 200, x ident, right associativity, - format "'[' 'exists' ! '/ ' x : A , '/ ' P ']'") : type_scope. +Notation "'exists' ! x .. y , p" := + (ex (unique (fun x => .. (ex (unique (fun y => p))) ..))) + (at level 200, x binder, right associativity, + format "'[' 'exists' ! '/ ' x .. y , '/ ' p ']'") + : type_scope. Lemma unique_existence : forall (A:Type) (P:A->Prop), ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x). Proof. intros A P; split. - intros ((x,Hx),Huni); exists x; red; auto. - intros (x,(Hx,Huni)); split. - exists x; assumption. - intros x' x'' Hx' Hx''; transitivity x. - symmetry; auto. - auto. + - intros ((x,Hx),Huni); exists x; red; auto. + - intros (x,(Hx,Huni)); split. + + exists x; assumption. + + intros x' x'' Hx' Hx''; transitivity x. + symmetry; auto. + auto. Qed. +Lemma forall_exists_unique_domain_coincide : + forall A (P:A->Prop), (exists! x, P x) -> + forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x). +Proof. + intros A P (x & Hp & Huniq); split. + - intro; exists x; auto. + - intros (x0 & HPx0 & HQx0) x1 HPx1. + replace x1 with x0 by (transitivity x; [symmetry|]; auto). + assumption. +Qed. + +Lemma forall_exists_coincide_unique_domain : + forall A (P:A->Prop), + (forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x)) + -> (exists! x, P x). +Proof. + intros A P H. + destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|]. + exists x. split; [trivial|]. + destruct H with (Q:=fun x'=>x=x') as (_,Huniq). + apply Huniq. exists x; auto. +Qed. + (** * Being inhabited *) (** The predicate [inhabited] can be used in different contexts. If [A] is @@ -436,7 +466,7 @@ Qed. Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y. Proof. -intros A x y z H1 H2. rewrite <- H2; exact H1. + intros A x y z H1 H2. rewrite <- H2; exact H1. Qed. Declare Left Step eq_stepl. @@ -444,7 +474,7 @@ Declare Right Step eq_trans. Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B). Proof. -intros; tauto. + intros; tauto. Qed. Declare Left Step iff_stepl. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index bf4031d5..2a833576 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This module defines type constructors for types in [Type] ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *) diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 3619d827..490cbf57 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Notations.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** These are the notations whose level and associativity are imposed by Coq *) (** Notations for propositional connectives *) diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index abf843bf..c3716eaa 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) @@ -28,7 +26,6 @@ Require Import Notations. Require Import Datatypes. Require Import Logic. -Unset Boxed Definitions. Open Scope nat_scope. @@ -52,13 +49,7 @@ Qed. (** Injectivity of successor *) -Theorem eq_add_S : forall n m:nat, S n = S m -> n = m. -Proof. - intros n m Sn_eq_Sm. - replace (n=m) with (pred (S n) = pred (S m)) by auto using pred_Sn. - rewrite Sn_eq_Sm; trivial. -Qed. - +Definition eq_add_S n m (H: S n = S m): n = m := f_equal pred H. Hint Immediate eq_add_S: core. Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m. @@ -201,6 +192,16 @@ Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope. Notation "x < y < z" := (x < y /\ y < z) : nat_scope. Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope. +Theorem le_pred : forall n m, n <= m -> pred n <= pred m. +Proof. +induction 1; auto. destruct m; simpl; auto. +Qed. + +Theorem le_S_n : forall n m, S n <= S m -> n <= m. +Proof. +intros n m. exact (le_pred (S n) (S m)). +Qed. + (** Case analysis *) Theorem nat_case : @@ -220,3 +221,76 @@ Proof. induction n; auto. destruct m as [| n0]; auto. Qed. + +(** Maximum and minimum : definitions and specifications *) + +Fixpoint max n m : nat := + match n, m with + | O, _ => m + | S n', O => n + | S n', S m' => S (max n' m') + end. + +Fixpoint min n m : nat := + match n, m with + | O, _ => 0 + | S n', O => 0 + | S n', S m' => S (min n' m') + end. + +Theorem max_l : forall n m : nat, m <= n -> max n m = n. +Proof. +induction n; destruct m; simpl; auto. inversion 1. +intros. apply f_equal. apply IHn. apply le_S_n. trivial. +Qed. + +Theorem max_r : forall n m : nat, n <= m -> max n m = m. +Proof. +induction n; destruct m; simpl; auto. inversion 1. +intros. apply f_equal. apply IHn. apply le_S_n. trivial. +Qed. + +Theorem min_l : forall n m : nat, n <= m -> min n m = n. +Proof. +induction n; destruct m; simpl; auto. inversion 1. +intros. apply f_equal. apply IHn. apply le_S_n. trivial. +Qed. + +Theorem min_r : forall n m : nat, m <= n -> min n m = m. +Proof. +induction n; destruct m; simpl; auto. inversion 1. +intros. apply f_equal. apply IHn. apply le_S_n. trivial. +Qed. + +(** [n]th iteration of the function [f] *) + +Fixpoint nat_iter (n:nat) {A} (f:A->A) (x:A) : A := + match n with + | O => x + | S n' => f (nat_iter n' f x) + end. + +Lemma nat_iter_succ_r n {A} (f:A->A) (x:A) : + nat_iter (S n) f x = nat_iter n f (f x). +Proof. + induction n; intros; simpl; rewrite <- ?IHn; trivial. +Qed. + +Theorem nat_iter_plus : + forall (n m:nat) {A} (f:A -> A) (x:A), + nat_iter (n + m) f x = nat_iter n f (nat_iter m f x). +Proof. + induction n; intros; simpl; rewrite ?IHn; trivial. +Qed. + +(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], + then the iterates of [f] also preserve it. *) + +Theorem nat_iter_invariant : + forall (n:nat) {A} (f:A -> A) (P : A -> Prop), + (forall x, P x -> P (f x)) -> + forall x, P x -> P (nat_iter n f x). +Proof. + induction n; simpl; trivial. + intros A f P Hf x Hx. apply Hf, IHn; trivial. +Qed. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 5fcb2671..e929c561 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Prelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Notations. Require Export Logic. Require Export Datatypes. @@ -18,9 +16,12 @@ Require Export Coq.Init.Tactics. (* Initially available plugins (+ nat_syntax_plugin loaded in Datatypes) *) Declare ML Module "extraction_plugin". +Declare ML Module "decl_mode_plugin". Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". Declare ML Module "dp_plugin". Declare ML Module "recdef_plugin". Declare ML Module "subtac_plugin". Declare ML Module "xml_plugin". +(* Default substrings not considered by queries like SearchAbout *) +Add Search Blacklist "_admitted" "_subproof" "Private_". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 5a951d14..637994b2 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Specif.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Basic specifications : sets that may contain logical information *) Set Implicit Arguments. @@ -40,10 +38,10 @@ Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := (* Notations *) -Arguments Scope sig [type_scope type_scope]. -Arguments Scope sig2 [type_scope type_scope type_scope]. -Arguments Scope sigT [type_scope type_scope]. -Arguments Scope sigT2 [type_scope type_scope type_scope]. +Arguments sig (A P)%type. +Arguments sig2 (A P Q)%type. +Arguments sigT (A P)%type. +Arguments sigT2 (A P Q)%type. Notation "{ x | P }" := (sig (fun x => P)) : type_scope. Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. @@ -128,6 +126,9 @@ Inductive sumbool (A B:Prop) : Set := Add Printing If sumbool. +Arguments left {A B} _, [A] B _. +Arguments right {A B} _ , A [B] _. + (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) @@ -138,6 +139,9 @@ Inductive sumor (A:Type) (B:Prop) : Type := Add Printing If sumor. +Arguments inleft {A B} _ , [A] B _. +Arguments inright {A B} _ , A [B] _. + (** Various forms of the axiom of choice for specifications *) Section Choice_lemmas. @@ -152,16 +156,16 @@ Section Choice_lemmas. Proof. intro H. exists (fun z => proj1_sig (H z)). - intro z; destruct (H z); trivial. - Qed. + intro z; destruct (H z); assumption. + Defined. Lemma Choice2 : (forall x:S, {y:S' & R' x y}) -> {f:S -> S' & forall z:S, R' z (f z)}. Proof. intro H. exists (fun z => projT1 (H z)). - intro z; destruct (H z); trivial. - Qed. + intro z; destruct (H z); assumption. + Defined. Lemma bool_choice : (forall x:S, {R1 x} + {R2 x}) -> @@ -170,7 +174,7 @@ Section Choice_lemmas. intro H. exists (fun z:S => if H z then true else false). intro z; destruct (H z); auto. - Qed. + Defined. End Choice_lemmas. @@ -188,7 +192,7 @@ Section Dependent_choice_lemmas. exists f. split. reflexivity. induction n; simpl; apply proj2_sig. - Qed. + Defined. End Dependent_choice_lemmas. @@ -204,18 +208,18 @@ Definition Exc := option. Definition value := Some. Definition error := @None. -Implicit Arguments error [A]. +Arguments error [A]. Definition except := False_rec. (* for compatibility with previous versions *) -Implicit Arguments except [P]. +Arguments except [P] _. Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C. Proof. intros A C h1 h2. apply False_rec. apply (h2 h1). -Qed. +Defined. Hint Resolve left right inleft inright: core v62. Hint Resolve exist exist2 existT existT2: core. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 1fa4a77f..4d64b823 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Notations. Require Import Logic. Require Import Specif. @@ -79,6 +77,10 @@ Ltac false_hyp H G := Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. +(* use either discriminate or injection on a hypothesis *) + +Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)). + (* Similar variants of destruct *) Tactic Notation "destruct_with_eqn" constr(x) := @@ -187,6 +189,10 @@ Ltac easy := Tactic Notation "now" tactic(t) := t; easy. +(** Slightly more than [easy]*) + +Ltac easy' := repeat split; simpl; easy || now destruct 1. + (** A tactic to document or check what is proved at some point of a script *) Ltac now_show c := change c. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 5a5f672b..2bb7eae9 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** * This module proves the validity of - well-founded recursion (also known as course of values) - well-founded induction diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 4c14008c..ecadddbc 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: List.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import Le Gt Minus Min Bool. +Require Import Le Gt Minus Bool. Set Implicit Arguments. @@ -55,9 +53,16 @@ Section Lists. End Lists. -(* Keep these notations local to prevent conflicting notations *) -Local Notation "[ ]" := nil : list_scope. -Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope. + +(** Standard notations for lists. +In a special module to avoid conflict. *) +Module ListNotations. +Notation " [ ] " := nil : list_scope. +Notation " [ x ] " := (cons x nil) : list_scope. +Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. +End ListNotations. + +Import ListNotations. (** ** Facts about lists *) @@ -119,7 +124,7 @@ Section Facts. unfold not; intros a H; inversion_clear H. Qed. - Theorem in_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2. + Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. Proof. induction l; simpl; destruct 1. subst a; auto. @@ -254,7 +259,7 @@ Section Facts. Qed. - (** Compatibility wtih other operations *) + (** Compatibility with other operations *) Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'. Proof. @@ -1643,7 +1648,7 @@ Proof. exact Forall2_nil. Qed. Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l', Forall2 R (l1 ++ l2) l' -> - exists l1', exists l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'. + exists l1' l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'. Proof. induction l1; intros. exists [], l'; auto. @@ -1654,7 +1659,7 @@ Qed. Theorem Forall2_app_inv_r : forall A B (R:A->B->Prop) l1' l2' l, Forall2 R l (l1' ++ l2') -> - exists l1, exists l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2. + exists l1 l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2. Proof. induction l1'; intros. exists [], l; auto. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 56df3f9c..d67baf57 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListSet.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** A Library for finite sets, implemented as lists *) (** List is loaded, but not exported. diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index 08669499..3343aa6f 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListTactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import BinPos. Require Import List. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index ec31f37d..97915055 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: SetoidList.v 12919 2010-04-10 16:30:44Z herbelin $ *) - Require Export List. Require Export Sorting. Require Export Setoid Basics Morphisms. @@ -82,6 +80,10 @@ Qed. 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. intro. intros. inversion H. Qed. +Hint Resolve incl_nil : list. + (** lists with same elements modulo [eqA] at the same place *) Inductive eqlistA : list A -> list A -> Prop := @@ -159,8 +161,7 @@ Qed. Hint Resolve In_InA. Lemma InA_split : forall l x, InA x l -> - exists l1, exists y, exists l2, - eqA x y /\ l = l1++y::l2. + exists l1 y l2, eqA x y /\ l = l1++y::l2. Proof. induction l; intros; inv. exists (@nil A); exists a; exists l; auto. @@ -747,7 +748,7 @@ rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. -Implicit Arguments eq [ [A] ]. +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. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 1ab4fa9d..45490c62 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 02d17211..7a6f38fc 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Streams.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. (** Streams *) diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v deleted file mode 100644 index 498a9dca..00000000 --- a/theories/Lists/TheoryList.v +++ /dev/null @@ -1,423 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: TheoryList.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(** Some programs and results about lists following CAML Manual *) - -Require Export List. -Set Implicit Arguments. - -Local Notation "[ ]" := nil (at level 0). -Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0). - -Section Lists. - -Variable A : Type. - -(**********************) -(** The null function *) -(**********************) - -Definition Isnil (l:list A) : Prop := nil = l. - -Lemma Isnil_nil : Isnil nil. -Proof. -red in |- *; auto. -Qed. -Hint Resolve Isnil_nil. - -Lemma not_Isnil_cons : forall (a:A) (l:list A), ~ Isnil (a :: l). -Proof. -unfold Isnil in |- *. -intros; discriminate. -Qed. - -Hint Resolve Isnil_nil not_Isnil_cons. - -Lemma Isnil_dec : forall l:list A, {Isnil l} + {~ Isnil l}. -Proof. -intro l; case l; auto. -(* -Realizer (fun l => match l with - | nil => true - | _ => false - end). -*) -Qed. - -(************************) -(** The Uncons function *) -(************************) - -Lemma Uncons : - forall l:list A, {a : A & {m : list A | a :: m = l}} + {Isnil l}. -Proof. -intro l; case l. -auto. -intros a m; intros; left; exists a; exists m; reflexivity. -(* -Realizer (fun l => match l with - | nil => error - | (cons a m) => value (a,m) - end). -*) -Qed. - -(********************************) -(** The head function *) -(********************************) - -Lemma Hd : - forall l:list A, {a : A | exists m : list A, a :: m = l} + {Isnil l}. -Proof. -intro l; case l. -auto. -intros a m; intros; left; exists a; exists m; reflexivity. -(* -Realizer (fun l => match l with - | nil => error - | (cons a m) => value a - end). -*) -Qed. - -Lemma Tl : - forall l:list A, - {m : list A | (exists a : A, a :: m = l) \/ Isnil l /\ Isnil m}. -Proof. -intro l; case l. -exists (nil (A:=A)); auto. -intros a m; intros; exists m; left; exists a; reflexivity. -(* -Realizer (fun l => match l with - | nil => nil - | (cons a m) => m - end). -*) -Qed. - -(****************************************) -(** Length of lists *) -(****************************************) - -(* length is defined in List *) -Fixpoint Length_l (l:list A) (n:nat) : nat := - match l with - | nil => n - | _ :: m => Length_l m (S n) - end. - -(* A tail recursive version *) -Lemma Length_l_pf : forall (l:list A) (n:nat), {m : nat | n + length l = m}. -Proof. -induction l as [| a m lrec]. -intro n; exists n; simpl in |- *; auto. -intro n; elim (lrec (S n)); simpl in |- *; intros. -exists x; transitivity (S (n + length m)); auto. -(* -Realizer Length_l. -*) -Qed. - -Lemma Length : forall l:list A, {m : nat | length l = m}. -Proof. -intro l. apply (Length_l_pf l 0). -(* -Realizer (fun l -> Length_l_pf l O). -*) -Qed. - -(*******************************) -(** Members of lists *) -(*******************************) -Inductive In_spec (a:A) : list A -> Prop := - | in_hd : forall l:list A, In_spec a (a :: l) - | in_tl : forall (l:list A) (b:A), In a l -> In_spec a (b :: l). -Hint Resolve in_hd in_tl. -Hint Unfold In. -Hint Resolve in_cons. - -Theorem In_In_spec : forall (a:A) (l:list A), In a l <-> In_spec a l. -split. -elim l; - [ intros; contradiction - | intros; elim H0; [ intros; rewrite H1; auto | auto ] ]. -intros; elim H; auto. -Qed. - -Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}. - -Fixpoint mem (a:A) (l:list A) : bool := - match l with - | nil => false - | b :: m => if eqA_dec a b then true else mem a m - end. - -Hint Unfold In. -Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}. -Proof. -induction l. -auto. -elim (eqA_dec a a0). -auto. -simpl in |- *. elim IHl; auto. -(* -Realizer mem. -*) -Qed. - -(*********************************) -(** Index of elements *) -(*********************************) - -Require Import Le. -Require Import Lt. - -Inductive nth_spec : list A -> nat -> A -> Prop := - | nth_spec_O : forall (a:A) (l:list A), nth_spec (a :: l) 1 a - | nth_spec_S : - forall (n:nat) (a b:A) (l:list A), - nth_spec l n a -> nth_spec (b :: l) (S n) a. -Hint Resolve nth_spec_O nth_spec_S. - -Inductive fst_nth_spec : list A -> nat -> A -> Prop := - | fst_nth_O : forall (a:A) (l:list A), fst_nth_spec (a :: l) 1 a - | fst_nth_S : - forall (n:nat) (a b:A) (l:list A), - a <> b -> fst_nth_spec l n a -> fst_nth_spec (b :: l) (S n) a. -Hint Resolve fst_nth_O fst_nth_S. - -Lemma fst_nth_nth : - forall (l:list A) (n:nat) (a:A), fst_nth_spec l n a -> nth_spec l n a. -Proof. -induction 1; auto. -Qed. -Hint Immediate fst_nth_nth. - -Lemma nth_lt_O : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> 0 < n. -Proof. -induction 1; auto. -Qed. - -Lemma nth_le_length : - forall (l:list A) (n:nat) (a:A), nth_spec l n a -> n <= length l. -Proof. -induction 1; simpl in |- *; auto with arith. -Qed. - -Fixpoint Nth_func (l:list A) (n:nat) : Exc A := - match l, n with - | a :: _, S O => value a - | _ :: l', S (S p) => Nth_func l' (S p) - | _, _ => error - end. - -Lemma Nth : - forall (l:list A) (n:nat), - {a : A | nth_spec l n a} + {n = 0 \/ length l < n}. -Proof. -induction l as [| a l IHl]. -intro n; case n; simpl in |- *; auto with arith. -intro n; destruct n as [| [| n1]]; simpl in |- *; auto. -left; exists a; auto. -destruct (IHl (S n1)) as [[b]| o]. -left; exists b; auto. -right; destruct o. -absurd (S n1 = 0); auto. -auto with arith. -(* -Realizer Nth_func. -*) -Qed. - -Lemma Item : - forall (l:list A) (n:nat), {a : A | nth_spec l (S n) a} + {length l <= n}. -Proof. -intros l n; case (Nth l (S n)); intro. -case s; intro a; left; exists a; auto. -right; case o; intro. -absurd (S n = 0); auto. -auto with arith. -Qed. - -Require Import Minus. -Require Import DecBool. - -Fixpoint index_p (a:A) (l:list A) : nat -> Exc nat := - match l with - | nil => fun p => error - | b :: m => fun p => ifdec (eqA_dec a b) (value p) (index_p a m (S p)) - end. - -Lemma Index_p : - forall (a:A) (l:list A) (p:nat), - {n : nat | fst_nth_spec l (S n - p) a} + {AllS (fun b:A => a <> b) l}. -Proof. -induction l as [| b m irec]. -auto. -intro p. -destruct (eqA_dec a b) as [e| e]. -left; exists p. -destruct e; elim minus_Sn_m; trivial; elim minus_n_n; auto with arith. -destruct (irec (S p)) as [[n H]| ]. -left; exists n; auto with arith. -elim minus_Sn_m; auto with arith. -apply lt_le_weak; apply lt_O_minus_lt; apply nth_lt_O with m a; - auto with arith. -auto. -Qed. - -Lemma Index : - forall (a:A) (l:list A), - {n : nat | fst_nth_spec l n a} + {AllS (fun b:A => a <> b) l}. - -Proof. -intros a l; case (Index_p a l 1); auto. -intros [n P]; left; exists n; auto. -rewrite (minus_n_O n); trivial. -(* -Realizer (fun a l -> Index_p a l (S O)). -*) -Qed. - -Section Find_sec. -Variables R P : A -> Prop. - -Inductive InR : list A -> Prop := - | inR_hd : forall (a:A) (l:list A), R a -> InR (a :: l) - | inR_tl : forall (a:A) (l:list A), InR l -> InR (a :: l). -Hint Resolve inR_hd inR_tl. - -Definition InR_inv (l:list A) := - match l with - | nil => False - | b :: m => R b \/ InR m - end. - -Lemma InR_INV : forall l:list A, InR l -> InR_inv l. -Proof. -induction 1; simpl in |- *; auto. -Qed. - -Lemma InR_cons_inv : forall (a:A) (l:list A), InR (a :: l) -> R a \/ InR l. -Proof. -intros a l H; exact (InR_INV H). -Qed. - -Lemma InR_or_app : forall l m:list A, InR l \/ InR m -> InR (l ++ m). -Proof. -intros l m [| ]. -induction 1; simpl in |- *; auto. -intro. induction l; simpl in |- *; auto. -Qed. - -Lemma InR_app_or : forall l m:list A, InR (l ++ m) -> InR l \/ InR m. -Proof. -intros l m; elim l; simpl in |- *; auto. -intros b l' Hrec IAc; elim (InR_cons_inv IAc); auto. -intros; elim Hrec; auto. -Qed. - -Hypothesis RS_dec : forall a:A, {R a} + {P a}. - -Fixpoint find (l:list A) : Exc A := - match l with - | nil => error - | a :: m => ifdec (RS_dec a) (value a) (find m) - end. - -Lemma Find : forall l:list A, {a : A | In a l & R a} + {AllS P l}. -Proof. -induction l as [| a m [[b H1 H2]| H]]; auto. -left; exists b; auto. -destruct (RS_dec a). -left; exists a; auto. -auto. -(* -Realizer find. -*) -Qed. - -Variable B : Type. -Variable T : A -> B -> Prop. - -Variable TS_dec : forall a:A, {c : B | T a c} + {P a}. - -Fixpoint try_find (l:list A) : Exc B := - match l with - | nil => error - | a :: l1 => - match TS_dec a with - | inleft (exist c _) => value c - | inright _ => try_find l1 - end - end. - -Lemma Try_find : - forall l:list A, {c : B | exists2 a : A, In a l & T a c} + {AllS P l}. -Proof. -induction l as [| a m [[b H1]| H]]. -auto. -left; exists b; destruct H1 as [a' H2 H3]; exists a'; auto. -destruct (TS_dec a) as [[c H1]| ]. -left; exists c. -exists a; auto. -auto. -(* -Realizer try_find. -*) -Qed. - -End Find_sec. - -Section Assoc_sec. - -Variable B : Type. -Fixpoint assoc (a:A) (l:list (A * B)) : - Exc B := - match l with - | nil => error - | (a', b) :: m => ifdec (eqA_dec a a') (value b) (assoc a m) - end. - -Inductive AllS_assoc (P:A -> Prop) : list (A * B) -> Prop := - | allS_assoc_nil : AllS_assoc P nil - | allS_assoc_cons : - forall (a:A) (b:B) (l:list (A * B)), - P a -> AllS_assoc P l -> AllS_assoc P ((a, b) :: l). - -Hint Resolve allS_assoc_nil allS_assoc_cons. - -(* The specification seems too weak: it is enough to return b if the - list has at least an element (a,b); probably the intention is to have - the specification - - (a:A)(l:(list A*B)){b:B|(In_spec (a,b) l)}+{(AllS_assoc [a':A]~(a=a') l)}. -*) - -Lemma Assoc : - forall (a:A) (l:list (A * B)), B + {AllS_assoc (fun a':A => a <> a') l}. -Proof. -induction l as [| [a' b] m assrec]. auto. -destruct (eqA_dec a a'). -left; exact b. -destruct assrec as [b'| ]. -left; exact b'. -right; auto. -(* -Realizer assoc. -*) -Qed. - -End Assoc_sec. - -End Lists. - -Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons : datatypes. -Hint Immediate fst_nth_nth: datatypes. diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex index 0051e2c2..e849967c 100755 --- a/theories/Lists/intro.tex +++ b/theories/Lists/intro.tex @@ -13,10 +13,6 @@ This library includes the following files: \item {\tt ListSet.v} contains definitions and properties of finite sets, implemented as lists. -\item {\tt TheoryList.v} contains complementary results on lists. Here - a more theoretic point of view is assumed : one extracts functions - from propositions, rather than defining functions and then prove them. - \item {\tt Streams.v} defines the type of infinite lists (streams). It is a coinductive type. Basic facts are stated and proved. The streams are also polymorphic. diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget index d2a31367..adcfba49 100644 --- a/theories/Lists/vo.itarget +++ b/theories/Lists/vo.itarget @@ -4,4 +4,3 @@ List.vo SetoidList.vo StreamMemo.vo Streams.vo -TheoryList.vo diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index d954f40c..2b388687 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Berardi.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file formalizes Berardi's paradox which says that in the calculus of constructions, excluded middle (EM) and axiom of choice (AC) imply proof irrelevance (PI). diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 60dbf3ea..8d82bc8e 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ChoiceFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Some facts and definitions concerning choice and description in intuitionistic logic. diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 3f36ff38..9362a11f 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* File created for Coq V5.10.14b, Oct 1995 *) (** Classical Logic *) diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index 17b08a2f..6bc0be1d 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides classical logic and functional choice; this especially provides both indefinite descriptions and choice functions but this is weaker than providing epsilon operator and classical logic diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index ad454a4d..d35ed138 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalDescription.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides classical logic and definite description, which is equivalent to providing classical logic and Church's iota operator *) @@ -18,14 +16,12 @@ Set Implicit Arguments. -Require Export Classical. +Require Export Classical. (* Axiomatize classical reasoning *) +Require Export Description. (* Axiomatize constructive form of Church's iota *) Require Import ChoiceFacts. Notation Local inhabited A := A (only parsing). -Axiom constructive_definite_description : - forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }. - (** The idea for the following proof comes from [ChicliPottierSimpson02] *) Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 52ecadaf..ae32b127 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides classical logic and indefinite description under the form of Hilbert's epsilon operator *) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 5f4516dd..bcec657a 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Some facts and definitions about classical logic Table of contents: diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index fafa0b94..ebb73b19 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalUniqueChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides classical logic and unique choice; this is weaker than providing iota operator and classical logic as the definite descriptions provided by the axiom of unique choice can diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v index 06502d63..7d8bde71 100644 --- a/theories/Logic/Classical_Pred_Set.v +++ b/theories/Logic/Classical_Pred_Set.v @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Set.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* File created for Coq V5.10.14b, Oct 1995, by duplication of + Classical_Pred_Type.v *) (** This file is obsolete, use Classical_Pred_Type.v via Classical.v instead *) diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index bcd529f0..9d57fe88 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* This file is a renaming for V5.10.14b, Oct 1995, of file Classical.v + introduced in Coq V5.8.3, June 1993 *) (** Classical Predicate Logic on Type *) diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index c51050d5..d2b35da2 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -1,12 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Prop.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* File created for Coq V5.10.14b, Oct 1995 *) +(* Classical tactics for proving disjunctions by Julien Narboux, Jul 2005 *) +(* Inferred proof-irrelevance and eq_rect_eq added by Hugo Herbelin, Mar 2006 *) (** Classical Propositional Logic *) diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v index 94e623bd..9b28a6ab 100644 --- a/theories/Logic/Classical_Type.v +++ b/theories/Logic/Classical_Type.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Type.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file is obsolete, use Classical.v instead *) (** Classical Logic for Type *) diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 004fdef3..33550389 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -1,26 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(*i $Id: ConstructiveEpsilon.v 14628 2011-11-03 23:22:45Z herbelin $ i*) -(*i $Id: ConstructiveEpsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(** This module proves the constructive description schema, which -infers the sigma-existence (i.e., [Set]-existence) of a witness to a -predicate from the regular existence (i.e., [Prop]-existence). One -requires that the underlying set is countable and that the predicate -is decidable. *) +(** This provides with a proof of the constructive form of definite +and indefinite descriptions for Sigma^0_1-formulas (hereafter called +"small" formulas), which infers the sigma-existence (i.e., +[Type]-existence) of a witness to a decidable predicate over a +countable domain from the regular existence (i.e., +[Prop]-existence). *) (** Coq does not allow case analysis on sort [Prop] when the goal is in -[Set]. Therefore, one cannot eliminate [exists n, P n] in order to +not in [Prop]. Therefore, one cannot eliminate [exists n, P n] in order to show [{n : nat | P n}]. However, one can perform a recursion on an inductive predicate in sort [Prop] so that the returning type of the -recursion is in [Set]. This trick is described in Coq'Art book, Sect. +recursion is in [Type]. This trick is described in Coq'Art book, Sect. 14.2.3 and 15.4. In particular, this trick is used in the proof of [Fix_F] in the module Coq.Init.Wf. There, recursion is done on an inductive predicate [Acc] and the resulting type is in [Type]. @@ -41,7 +40,7 @@ For the first one we provide explicit and short proof terms. *) (* Direct version *) -Section ConstructiveIndefiniteDescription_Direct. +Section ConstructiveIndefiniteGroundDescription_Direct. Variable P : nat -> Prop. @@ -79,11 +78,11 @@ Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} := | right no => linear_search (S m) (inv_before_witness m b no) end. -Definition constructive_indefinite_description_nat : +Definition constructive_indefinite_ground_description_nat : (exists n, P n) -> {n:nat | P n} := fun e => linear_search O (let (n, p) := e in O_witness n (stop n p)). -End ConstructiveIndefiniteDescription_Direct. +End ConstructiveIndefiniteGroundDescription_Direct. (************************************************************************) @@ -91,7 +90,7 @@ End ConstructiveIndefiniteDescription_Direct. Require Import Arith. -Section ConstructiveIndefiniteDescription_Acc. +Section ConstructiveIndefiniteGroundDescription_Acc. Variable P : nat -> Prop. @@ -151,40 +150,40 @@ destruct (IH y Ryx) as [n Hn]. exists n; assumption. Defined. -Theorem constructive_indefinite_description_nat_Acc : +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 ConstructiveIndefiniteDescription_Acc. +End ConstructiveIndefiniteGroundDescription_Acc. (************************************************************************) -Section ConstructiveEpsilon_nat. +Section ConstructiveGroundEpsilon_nat. Variable P : nat -> Prop. Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}. -Definition constructive_epsilon_nat (E : exists n : nat, P n) : nat - := proj1_sig (constructive_indefinite_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_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_epsilon_nat E) - := proj2_sig (constructive_indefinite_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 ConstructiveEpsilon_nat. +End ConstructiveGroundEpsilon_nat. (************************************************************************) -Section ConstructiveEpsilon. +Section ConstructiveGroundEpsilon. (** 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 : Set. +Variable A : Type. Variable f : A -> nat. Variable g : nat -> A. @@ -201,24 +200,43 @@ Proof. intro n; unfold P'; destruct (P_decidable (g n)); auto. Defined. -Lemma constructive_indefinite_description : (exists x : A, P x) -> {x : A | P x}. +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_description_nat P' P'_decidable) in H1. +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_description : (exists! x : A, P x) -> {x : A | P x}. +Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}. Proof. - intros; apply constructive_indefinite_description; firstorder. + intros; apply constructive_indefinite_ground_description; firstorder. Defined. -Definition constructive_epsilon (E : exists x : A, P x) : A - := proj1_sig (constructive_indefinite_description E). - -Definition constructive_epsilon_spec (E : (exists x, P x)) : P (constructive_epsilon E) - := proj2_sig (constructive_indefinite_description E). - -End ConstructiveEpsilon. - +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). + +End ConstructiveGroundEpsilon. + +(* begin hide *) +(* Compatibility: the qualificative "ground" was absent from the initial +names of the results in this file but this had introduced confusion +with the similarly named statement in Description.v *) +Notation constructive_indefinite_description_nat := + constructive_indefinite_ground_description_nat (only parsing). +Notation constructive_epsilon_spec_nat := + constructive_ground_epsilon_spec_nat (only parsing). +Notation constructive_epsilon_nat := + constructive_ground_epsilon_nat (only parsing). +Notation constructive_indefinite_description := + constructive_indefinite_ground_description (only parsing). +Notation constructive_definite_description := + constructive_definite_ground_description (only parsing). +Notation constructive_epsilon_spec := + constructive_ground_epsilon_spec (only parsing). +Notation constructive_epsilon := + constructive_ground_epsilon (only parsing). +(* end hide *) diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index ace50884..fec7904e 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Decidable.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Properties of decidable propositions *) Definition decidable (P:Prop) := P \/ ~ P. diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index c59d8460..b74ebcc8 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Description.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides a constructive form of definite description; it allows to build functions from the proof of their existence in any context; this is weaker than Church's iota operator *) diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 257245cc..8569e55e 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Diaconescu.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show that the axiom of choice in equivalence classes entails @@ -158,8 +156,8 @@ End PredExt_RelChoice_imp_EM. (**********************************************************************) (** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *) -(** This is an adaptation of Diaconescu's paradox exploiting that - proof-irrelevance is some form of extensionality *) +(** This is an adaptation of Diaconescu's theorem, exploiting the + form of extensionality provided by proof-irrelevance *) Section ProofIrrel_RelChoice_imp_EqEM. diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index 9134b3aa..cb8f8a73 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Epsilon.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides indefinite description under the form of Hilbert's epsilon operator; it does not assume classical logic. *) diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index 7918061c..b8e99036 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -1,13 +1,15 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *) +(* Abstraction with respect to the eq_rect_eq axiom and creation of + EqdepFacts.v by Hugo Herbelin, Mar 2006 *) (** This file axiomatizes the invariance by substitution of reflexive equality proofs [[Streicher93]] and exports its consequences, such diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 2d5f1537..d84cd824 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -1,13 +1,17 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqdepFacts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *) +(* Further documentation and variants of eq_rect_eq by Hugo Herbelin, + Apr 2003 *) +(* Abstraction with respect to the eq_rect_eq axiom and renaming to + EqdepFacts.v by Hugo Herbelin, Mar 2006 *) (** This file defines dependent equality and shows its equivalence with equality on dependent pairs (inhabiting sigma-types). It derives @@ -33,7 +37,8 @@ Table of contents: -1. Definition of dependent equality and equivalence with equality +1. Definition of dependent equality and equivalence with equality of + dependent pairs and with dependent pair of equalities 2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K @@ -45,6 +50,8 @@ Table of contents: (************************************************************************) (** * Definition of dependent equality and equivalence with equality of dependent pairs *) +Import EqNotations. + Section Dependent_Equality. Variable U : Type. @@ -75,11 +82,11 @@ Section Dependent_Equality. Scheme eq_indd := Induction for eq Sort Prop. - (** Equivalent definition of dependent equality expressed as a non - dependent inductive type *) + (** Equivalent definition of dependent equality as a dependent pair of + equalities *) Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop := - eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y. + eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y. Lemma eq_dep1_dep : forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y. @@ -95,13 +102,13 @@ Section Dependent_Equality. Proof. destruct 1. apply eq_dep1_intro with (refl_equal p). - simpl in |- *; trivial. + simpl; trivial. Qed. End Dependent_Equality. -Implicit Arguments eq_dep [U P]. -Implicit Arguments eq_dep1 [U P]. +Arguments eq_dep [U P] p x q _. +Arguments eq_dep1 [U P] p x q y. (** Dependent equality is equivalent to equality on dependent pairs *) @@ -116,24 +123,103 @@ Qed. Notation eq_sigS_eq_dep := eq_sigT_eq_dep (only parsing). (* Compatibility *) -Lemma equiv_eqex_eqdep : +Lemma eq_dep_eq_sigT : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - existT P p x = existT P q y <-> eq_dep p x q y. + eq_dep p x q y -> existT P p x = existT P q y. Proof. - split. - (* -> *) - apply eq_sigT_eq_dep. - (* <- *) destruct 1; reflexivity. Qed. -Lemma eq_dep_eq_sigT : +Lemma eq_sigT_iff_eq_dep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - eq_dep p x q y -> existT P p x = existT P q y. + existT P p x = existT P q y <-> eq_dep p x q y. +Proof. + split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT. +Qed. + +Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *) + +Lemma eq_sig_eq_dep : + forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q), + exist P p x = exist P q y -> eq_dep p x q y. +Proof. + intros. + dependent rewrite H. + apply eq_dep_intro. +Qed. + +Lemma eq_dep_eq_sig : + forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q), + eq_dep p x q y -> exist P p x = exist P q y. Proof. destruct 1; reflexivity. Qed. +Lemma eq_sig_iff_eq_dep : + forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q), + exist P p x = exist P q y <-> eq_dep p x q y. +Proof. + split; auto using eq_sig_eq_dep, eq_dep_eq_sig. +Qed. + +(** Dependent equality is equivalent to a dependent pair of equalities *) + +Set Implicit Arguments. + +Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. +Proof. + intros; split; intro H. + - change x2 with (projT1 (existT P x2 H2)). + change H2 with (projT2 (existT P x2 H2)) at 5. + destruct H. simpl. + exists eq_refl. + reflexivity. + - destruct H as (->,<-). + reflexivity. +Defined. + +Lemma eq_sigT_fst : + forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2. +Proof. + intros. + change x2 with (projT1 (existT P x2 H2)). + destruct H. + reflexivity. +Defined. + +Lemma eq_sigT_snd : + forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2. +Proof. + intros. + unfold eq_sigT_fst. + change x2 with (projT1 (existT P x2 H2)). + change H2 with (projT2 (existT P x2 H2)) at 3. + destruct H. + reflexivity. +Defined. + +Lemma eq_sig_fst : + forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2. +Proof. + intros. + change x2 with (proj1_sig (exist P x2 H2)). + destruct H. + reflexivity. +Defined. + +Lemma eq_sig_snd : + forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2. +Proof. + intros. + unfold eq_sig_fst, eq_ind. + change x2 with (proj1_sig (exist P x2 H2)). + change H2 with (proj2_sig (exist P x2 H2)) at 3. + destruct H. + reflexivity. +Defined. + +Unset Implicit Arguments. + (** Exported hints *) Hint Resolve eq_dep_intro: core. @@ -326,5 +412,5 @@ Notation inj_pairT2 := inj_pair2. End EqdepTheory. -Implicit Arguments eq_dep []. -Implicit Arguments eq_dep1 []. +Arguments eq_dep U P p x q _ : clear implicits. +Arguments eq_dep1 U P p x q y : clear implicits. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 77908b08..59088aa7 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(* Created by Bruno Barras, Jan 1998 *) +(* Made a module instance for EqdepFacts by Hugo Herbelin, Mar 2006 *) (** We prove that there is only one proof of [x=x], i.e [refl_equal x]. This holds if the equality upon the set of [x] is decidable. diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v new file mode 100644 index 00000000..f5e71ef4 --- /dev/null +++ b/theories/Logic/ExtensionalityFacts.v @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Some facts and definitions about extensionality + +We investigate the relations between the following extensionality principles + +- Functional extensionality +- Equality of projections from diagonal +- Unicity of inverse bijections +- Bijectivity of bijective composition + +Table of contents + +1. Definitions + +2. Functional extensionality <-> Equality of projections from diagonal + +3. Functional extensionality <-> Unicity of inverse bijections + +4. Functional extensionality <-> Bijectivity of bijective composition + +*) + +Set Implicit Arguments. + +(**********************************************************************) +(** * Definitions *) + +(** Being an inverse *) + +Definition is_inverse A B f g := (forall a:A, g (f a) = a) /\ (forall b:B, f (g b) = b). + +(** The diagonal over A and the one-one correspondence with A *) + +Record Delta A := { pi1:A; pi2:A; eq:pi1=pi2 }. + +Definition delta {A} (a:A) := {|pi1 := a; pi2 := a; eq := eq_refl a |}. + +Arguments pi1 {A} _. +Arguments pi2 {A} _. + +Lemma diagonal_projs_same_behavior : forall A (x:Delta A), pi1 x = pi2 x. +Proof. + destruct x as (a1,a2,Heq); assumption. +Qed. + +Lemma diagonal_inverse1 : forall A, is_inverse (A:=A) delta pi1. +Proof. + split; [trivial|]; destruct b as (a1,a2,[]); reflexivity. +Qed. + +Lemma diagonal_inverse2 : forall A, is_inverse (A:=A) delta pi2. +Proof. + split; [trivial|]; destruct b as (a1,a2,[]); reflexivity. +Qed. + +(** Functional extensionality *) + +Local Notation FunctionalExtensionality := + (forall A B (f g : A -> B), (forall x, f x = g x) -> f = g). + +(** Equality of projections from diagonal *) + +Local Notation EqDeltaProjs := (forall A, pi1 = pi2 :> (Delta A -> A)). + +(** Unicity of bijection inverse *) + +Local Notation UniqueInverse := (forall A B (f:A->B) g1 g2, is_inverse f g1 -> is_inverse f g2 -> g1 = g2). + +(** Bijectivity of bijective composition *) + +Definition action A B C (f:A->B) := (fun h:B->C => fun x => h (f x)). + +Local Notation BijectivityBijectiveComp := (forall A B C (f:A->B) g, + is_inverse f g -> is_inverse (A:=B->C) (action f) (action g)). + +(**********************************************************************) +(** * Functional extensionality <-> Equality of projections from diagonal *) + +Theorem FunctExt_iff_EqDeltaProjs : FunctionalExtensionality <-> EqDeltaProjs. +Proof. + split. + - intros FunExt *; apply FunExt, diagonal_projs_same_behavior. + - intros EqProjs **; change f with (fun x => pi1 {|pi1:=f x; pi2:=g x; eq:=H x|}). + rewrite EqProjs; reflexivity. +Qed. + +(**********************************************************************) +(** * Functional extensionality <-> Unicity of bijection inverse *) + +Lemma FunctExt_UniqInverse : FunctionalExtensionality -> UniqueInverse. +Proof. + intros FunExt * (Hg1f,Hfg1) (Hg2f,Hfg2). + apply FunExt. intros; congruence. +Qed. + +Lemma UniqInverse_EqDeltaProjs : UniqueInverse -> EqDeltaProjs. +Proof. + intros UniqInv *. + apply UniqInv with delta; [apply diagonal_inverse1 | apply diagonal_inverse2]. +Qed. + +Theorem FunctExt_iff_UniqInverse : FunctionalExtensionality <-> UniqueInverse. +Proof. + split. + - apply FunctExt_UniqInverse. + - intro; apply FunctExt_iff_EqDeltaProjs, UniqInverse_EqDeltaProjs; trivial. +Qed. + +(**********************************************************************) +(** * Functional extensionality <-> Bijectivity of bijective composition *) + +Lemma FunctExt_BijComp : FunctionalExtensionality -> BijectivityBijectiveComp. +Proof. + intros FunExt * (Hgf,Hfg). split; unfold action. + - intros h; apply FunExt; intro b; rewrite Hfg; reflexivity. + - intros h; apply FunExt; intro a; rewrite Hgf; reflexivity. +Qed. + +Lemma BijComp_FunctExt : BijectivityBijectiveComp -> FunctionalExtensionality. +Proof. + intros BijComp. + apply FunctExt_iff_UniqInverse. intros * H1 H2. + destruct BijComp with (C:=A) (1:=H2) as (Hg2f,_). + destruct BijComp with (C:=A) (1:=H1) as (_,Hfg1). + rewrite <- (Hg2f g1). + change g1 with (action g1 (fun x => x)). + rewrite -> (Hfg1 (fun x => x)). + reflexivity. +Qed. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index a696b6c8..35db160f 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: FunctionalExtensionality.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion. It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *) diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index afaeb51a..bb03c666 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index afca2ee1..8badc07c 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: IndefiniteDescription.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file provides a constructive form of indefinite description that allows to build choice functions; this is weaker than Hilbert's epsilon operator (which implies weakly classical properties) but diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 95640d67..753009e6 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: JMeq.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** John Major's Equality as proposed by Conor McBride Reference: @@ -26,6 +24,8 @@ Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop := Set Elimination Schemes. +Arguments JMeq_refl {A x} , [A] x. + Hint Resolve JMeq_refl. Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. @@ -113,8 +113,7 @@ apply JMeq_refl. Qed. Lemma eq_dep_strictly_stronger_JMeq : - exists U, exists P, exists p, exists q, exists x, exists y, - JMeq x y /\ ~ eq_dep U P p x q y. + 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. diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v index 2a55f0bb..36508969 100644 --- a/theories/Logic/ProofIrrelevance.v +++ b/theories/Logic/ProofIrrelevance.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index 160ac2d5..6accc480 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 25d07fc9..d0d58e37 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RelationalChoice.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file axiomatizes the relational form of the axiom of choice *) Axiom relational_choice : diff --git a/theories/Logic/SetIsType.v b/theories/Logic/SetIsType.v index df64822d..f0876fbc 100644 --- a/theories/Logic/SetIsType.v +++ b/theories/Logic/SetIsType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,4 +14,4 @@ Set: simply insert some Require Export of this file at starting points of the development and try to recompile... *) -Notation "'Set'" := Type (only parsing).
\ No newline at end of file +Notation "'Set'" := Type (only parsing). diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index 96580749..bdada486 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -7,8 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * MSetAVL : Implementation of MSetInterface via AVL trees *) (** This module implements finite sets using AVL trees. @@ -48,6 +46,7 @@ Local Open Scope Int_scope. Local Open Scope lazy_bool_scope. Definition elt := X.t. +Hint Transparent elt. (** ** Trees @@ -376,7 +375,7 @@ Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A := | Leaf => a | Node l x r _ => fold f r (f x (fold f l a)) end. -Implicit Arguments fold [A]. +Arguments fold [A] f s _. (** ** Subset *) @@ -877,12 +876,12 @@ Open Scope Int_scope. Ltac join_tac := intro l; induction l as [| ll _ lx lr Hlr lh]; [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); + [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE]; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] end - | destruct (gt_le_dec rh (lh+2)); + | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] @@ -905,7 +904,7 @@ Instance join_ok : forall l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (join l x r). Proof. join_tac; auto with *; inv; apply bal_ok; auto; - clear Hrl Hlr z; intro; intros; rewrite join_spec in *. + clear Hrl Hlr; intro; intros; rewrite join_spec in *. intuition; [ setoid_replace y with x | ]; eauto. intuition; [ setoid_replace y with x | ]; eauto. Qed. @@ -1691,7 +1690,7 @@ Proof. Qed. Definition lt (s1 s2 : t) : Prop := - exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' + exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' /\ L.lt (elements s1') (elements s2'). Instance lt_strorder : StrictOrder lt. @@ -1768,7 +1767,7 @@ Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, 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; auto. + simpl; intros; elim_compare x1 x2; simpl; red; auto. Qed. Lemma compare_cont_Cmp : forall s1 cont e2 l, diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index 4ec050bd..eefd2951 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (**************************************************************) (* MSetDecide.v *) (* *) diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index fe6c3c79..2e7da404 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library *) (** This module proves many properties of finite sets that diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v index 6d38b696..4e17618f 100644 --- a/theories/MSets/MSetFacts.v +++ b/theories/MSets/MSetFacts.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library *) (** This functor derives additional facts from [MSetInterface.S]. These diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 194cb904..f2b908af 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite set library *) (** Set interfaces, inspired by the one of Ocaml. When compared with @@ -439,7 +437,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. - Implicit Arguments Mkt [ [is_ok] ]. + Arguments Mkt this {is_ok}. Hint Resolve is_ok : typeclass_instances. Definition In (x : elt)(s : t) := M.In x s.(this). @@ -653,7 +651,218 @@ Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O. End Raw2Sets. -(** We provide an ordering for sets-as-sorted-lists *) +(** It is in fact possible to provide an ordering on sets with + very little information on them (more or less only the [In] + predicate). This generic build of ordering is in fact not + used for the moment, we rather use a simplier version + dedicated to sets-as-sorted-lists, see [MakeListOrdering]. +*) + +Module Type IN (O:OrderedType). + Parameter Inline t : Type. + Parameter Inline In : O.t -> t -> Prop. + 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. + + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + 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')). + + 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. + + 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. + + 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. + + 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. + + 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. + + 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<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<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. @@ -663,7 +872,7 @@ Module MakeListOrdering (O:OrderedType). Definition eq s s' := forall x, In x s <-> In x s'. - Instance eq_equiv : Equivalence eq. + Instance eq_equiv : Equivalence eq := _. Inductive lt_list : t -> t -> Prop := | lt_nil : forall x s, lt_list nil (x :: s) diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index 48af7e6a..bcf68f1d 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library *) (** This file proposes an implementation of the non-dependant @@ -788,8 +786,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Definition eq := L.eq. Definition eq_equiv := L.eq_equiv. Definition lt l1 l2 := - exists l1', exists l2', Ok l1' /\ Ok l2' /\ - eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. + exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. Instance lt_strorder : StrictOrder lt. Proof. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index c0038a4f..0f24d76a 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library *) (** This functor derives additional properties from [MSetInterface.S]. @@ -339,6 +337,14 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). 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 @@ -352,8 +358,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). P s (fold f s i). Proof. intros A P f i s Pempty Pstep. - rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right. - set (l:=rev (elements s)). + 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. @@ -425,8 +430,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). R (fold f s i) (fold g s j). Proof. intros A B R f g i j s Rempty Rstep. - do 2 (rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right). - set (l:=rev (elements s)). + 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. @@ -484,8 +488,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. - rewrite fold_left_rev_right. - apply fold_1. + apply fold_spec_right. Qed. (** An alternate (and previous) specification for [fold] was based on @@ -1095,8 +1098,7 @@ Module OrdProperties (M:Sets). Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. intros. - rewrite !FM.fold_1. - unfold flip; rewrite <-!fold_left_rev_right. + 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 *. @@ -1112,7 +1114,7 @@ Module OrdProperties (M:Sets). Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. intros. - rewrite !FM.fold_1. + 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. @@ -1133,8 +1135,7 @@ Module OrdProperties (M:Sets). forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros. - rewrite !FM.fold_1. - unfold flip; rewrite <- !fold_left_rev_right. + 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. diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v index f0b964cf..e8087bc5 100644 --- a/theories/MSets/MSetToFiniteSet.v +++ b/theories/MSets/MSetToFiniteSet.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library : conversion to old [Finite_sets] *) Require Import Ensembles Finite_sets. diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 945cb2dd..76f09c76 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - (** * Finite sets library *) (** This file proposes an implementation of the non-dependant @@ -517,7 +515,7 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Definition In := InA X.eq. Definition eq := Equal. - Instance eq_equiv : Equivalence eq. + Instance eq_equiv : Equivalence eq := _. End MakeRaw. diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v index 958e9861..f179bcd1 100644 --- a/theories/MSets/MSets.v +++ b/theories/MSets/MSets.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) - Require Export Orders. Require Export OrdersEx. Require Export OrdersAlt. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 8695acca..30e35f50 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -1,500 +1,1123 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinNat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import BinPos. -Unset Boxed Definitions. +Require Export BinNums. +Require Import BinPos RelationClasses Morphisms Setoid + Equalities OrdersFacts GenericMinMax Bool NAxioms NProperties. +Require BinNatDef. (**********************************************************************) -(** Binary natural numbers *) +(** * Binary natural numbers, operations and properties *) +(**********************************************************************) -Inductive N : Set := - | N0 : N - | Npos : positive -> N. +(** The type [N] and its constructors [N0] and [Npos] are now + defined in [BinNums.v] *) -(** Declare binding key for scope positive_scope *) +(** Every definitions and properties about binary natural numbers + are placed in a module [N] for qualification purpose. *) -Delimit Scope N_scope with N. +Local Open Scope N_scope. -(** Automatically open scope positive_scope for the constructors of N *) +(** Every definitions and early properties about positive numbers + are placed in a module [N] for qualification purpose. *) -Bind Scope N_scope with N. -Arguments Scope Npos [positive_scope]. +Module N + <: NAxiomsSig + <: UsualOrderedTypeFull + <: UsualDecidableTypeFull + <: TotalOrder. -Open Local Scope N_scope. +(** Definitions of operations, now in a separate file *) -Definition Ndiscr : forall n:N, { p:positive | n = Npos p } + { n = N0 }. -Proof. - destruct n; auto. - left; exists p; auto. -Defined. +Include BinNatDef.N. -(** Operation x -> 2*x+1 *) +(** When including property functors, only inline t eq zero one two *) -Definition Ndouble_plus_one x := - match x with - | N0 => Npos 1 - | Npos p => Npos (xI p) - end. +Set Inline Level 30. -(** Operation x -> 2*x *) +(** Logical predicates *) -Definition Ndouble n := - match n with - | N0 => N0 - | Npos p => Npos (xO p) - end. +Definition eq := @Logic.eq N. +Definition eq_equiv := @eq_equivalence N. -(** Successor *) +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 Nsucc n := - match n with - | N0 => Npos 1 - | Npos p => Npos (Psucc p) - end. +Infix "<=" := le : N_scope. +Infix "<" := lt : N_scope. +Infix ">=" := ge : N_scope. +Infix ">" := gt : N_scope. -(** Predecessor *) +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 Npred (n : N) := match n with -| N0 => N0 -| Npos p => match p with - | xH => N0 - | _ => Npos (Ppred p) - end -end. +Definition divide p q := exists r, q = r*p. +Notation "( p | q )" := (divide p q) (at level 0) : N_scope. -(** Addition *) +Definition Even n := exists m, n = 2*m. +Definition Odd n := exists m, n = 2*m+1. -Definition Nplus n m := - match n, m with - | N0, _ => m - | _, N0 => n - | Npos p, Npos q => Npos (p + q) - end. +(** Decidability of equality. *) -Infix "+" := Nplus : N_scope. +Definition eq_dec : forall n m : N, { n = m } + { n <> m }. +Proof. + decide equality. + apply Pos.eq_dec. +Defined. -(** Subtraction *) +(** Discrimination principle *) -Definition Nminus (n m : N) := -match n, m with -| N0, _ => N0 -| n, N0 => n -| Npos n', Npos m' => - match Pminus_mask n' m' with - | IsPos p => Npos p - | _ => N0 - end -end. +Definition discr n : { p:positive | n = Npos p } + { n = N0 }. +Proof. + destruct n; auto. + left; exists p; auto. +Defined. -Infix "-" := Nminus : N_scope. +(** 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 (Npos p) in + let f2' p := f2 (Npos p) in + let fS2' p := fS2 (Npos p) in + match n with + | 0 => f0 + | Npos p => positive_rect P' fS2' f2' (fS2 0 f0) p + end. -(** Multiplication *) +Definition binary_rec (P:N -> Set) := binary_rect P. +Definition binary_ind (P:N -> Prop) := binary_rect P. -Definition Nmult n m := - match n, m with - | N0, _ => N0 - | _, N0 => N0 - | Npos p, Npos q => Npos (p * q) - end. +(** Peano induction on binary natural numbers *) -Infix "*" := Nmult : N_scope. +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 (Npos p) in +let f' p := f (Npos p) in +match n with +| 0 => f0 +| Npos p => Pos.peano_rect P' (f 0 f0) f' p +end. -(** Boolean Equality *) +Theorem peano_rect_base P a f : peano_rect P a f 0 = a. +Proof. +reflexivity. +Qed. -Definition Neqb n m := - match n, m with - | N0, N0 => true - | Npos n, Npos m => Peqb n m - | _,_ => false - end. +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. -(** Order *) +Definition peano_ind (P : N -> Prop) := peano_rect P. -Definition Ncompare n m := - match n, m with - | N0, N0 => Eq - | N0, Npos m' => Lt - | Npos n', N0 => Gt - | Npos n', Npos m' => (n' ?= m')%positive Eq - end. +Definition peano_rec (P : N -> Set) := peano_rect P. -Infix "?=" := Ncompare (at level 70, no associativity) : N_scope. +Theorem peano_rec_base P a f : peano_rec P a f 0 = a. +Proof. +apply peano_rect_base. +Qed. -Definition Nlt (x y:N) := (x ?= y) = Lt. -Definition Ngt (x y:N) := (x ?= y) = Gt. -Definition Nle (x y:N) := (x ?= y) <> Gt. -Definition Nge (x y:N) := (x ?= y) <> Lt. +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. -Infix "<=" := Nle : N_scope. -Infix "<" := Nlt : N_scope. -Infix ">=" := Nge : N_scope. -Infix ">" := Ngt : N_scope. +(** Properties of mixed successor and predecessor. *) -(** Min and max *) +Lemma pos_pred_spec p : Pos.pred_N p = pred (Npos p). +Proof. + now destruct p. +Qed. -Definition Nmin (n n' : N) := match Ncompare n n' with - | Lt | Eq => n - | Gt => n' - end. +Lemma succ_pos_spec n : Npos (succ_pos n) = succ n. +Proof. + now destruct n. +Qed. -Definition Nmax (n n' : N) := match Ncompare n n' with - | Lt | Eq => n' - | Gt => n - end. +Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n. +Proof. + destruct n. trivial. apply Pos.pred_N_succ. +Qed. -(** Decidability of equality. *) +Lemma succ_pos_pred p : succ (Pos.pred_N p) = Npos p. +Proof. + destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double. +Qed. + +(** Properties of successor and predecessor *) -Definition N_eq_dec : forall n m : N, { n = m } + { n <> m }. +Theorem pred_succ n : pred (succ n) = n. Proof. - decide equality. - apply positive_eq_dec. -Defined. +destruct n; trivial. simpl. apply Pos.pred_N_succ. +Qed. -(** convenient induction principles *) +Theorem pred_sub n : pred n = sub n 1. +Proof. + now destruct n as [|[p|p|]]. +Qed. -Lemma N_ind_double : - forall (a:N) (P:N -> Prop), - P N0 -> - (forall a, P a -> P (Ndouble a)) -> - (forall a, P a -> P (Ndouble_plus_one a)) -> P a. +Theorem succ_0_discr n : succ n <> 0. Proof. - intros; elim a. trivial. - simple induction p. intros. - apply (H1 (Npos p0)); trivial. - intros; apply (H0 (Npos p0)); trivial. - intros; apply (H1 N0); assumption. +now destruct n. Qed. -Lemma N_rec_double : - forall (a:N) (P:N -> Set), - P N0 -> - (forall a, P a -> P (Ndouble a)) -> - (forall a, P a -> P (Ndouble_plus_one a)) -> P a. +(** Specification of addition *) + +Theorem add_0_l n : 0 + n = n. Proof. - intros; elim a. trivial. - simple induction p. intros. - apply (H1 (Npos p0)); trivial. - intros; apply (H0 (Npos p0)); trivial. - intros; apply (H1 N0); assumption. +reflexivity. Qed. -(** Peano induction on binary natural numbers *) +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. -Definition Nrect - (P : N -> Type) (a : P N0) - (f : forall n : N, P n -> P (Nsucc n)) (n : N) : P n := -let f' (p : positive) (x : P (Npos p)) := f (Npos p) x in -let P' (p : positive) := P (Npos p) in -match n return (P n) with -| N0 => a -| Npos p => Prect P' (f N0 a) f' p -end. +(** Specification of subtraction. *) -Theorem Nrect_base : forall P a f, Nrect P a f N0 = a. +Theorem sub_0_r n : n - 0 = n. Proof. -intros P a f; simpl; reflexivity. +now destruct n. Qed. -Theorem Nrect_step : forall P a f n, Nrect P a f (Nsucc n) = f n (Nrect P a f n). +Theorem sub_succ_r n m : n - succ m = pred (n - m). Proof. -intros P a f; destruct n as [| p]; simpl; -[rewrite Prect_base | rewrite Prect_succ]; reflexivity. +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. -Definition Nind (P : N -> Prop) := Nrect P. +(** Specification of multiplication *) -Definition Nrec (P : N -> Set) := Nrect P. +Theorem mul_0_l n : 0 * n = 0. +Proof. +reflexivity. +Qed. -Theorem Nrec_base : forall P a f, Nrec P a f N0 = a. +Theorem mul_succ_l n m : (succ n) * m = n * m + m. Proof. -intros P a f; unfold Nrec; apply Nrect_base. +destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm. +apply Pos.mul_succ_l. Qed. -Theorem Nrec_step : forall P a f n, Nrec P a f (Nsucc n) = f n (Nrec P a f n). +(** Specification of boolean comparisons. *) + +Lemma eqb_eq n m : eqb n m = true <-> n=m. Proof. -intros P a f; unfold Nrec; apply Nrect_step. +destruct n as [|n], m as [|m]; simpl; try easy'. +rewrite Pos.eqb_eq. split; intro H. now subst. now destr_eq H. Qed. -(** Properties of successor and predecessor *) +Lemma ltb_lt n m : (n <? m) = true <-> n < m. +Proof. + unfold ltb, lt. destruct compare; easy'. +Qed. -Theorem Npred_succ : forall n : N, Npred (Nsucc n) = n. +Lemma leb_le n m : (n <=? m) = true <-> n <= m. Proof. -destruct n as [| p]; simpl. reflexivity. -case_eq (Psucc p); try (intros q H; rewrite <- H; now rewrite Ppred_succ). -intro H; false_hyp H Psucc_not_one. + unfold leb, le. destruct compare; easy'. Qed. -(** Properties of addition *) +(** 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 Nplus_0_l : forall n:N, N0 + n = n. +Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m. Proof. reflexivity. Qed. -Theorem Nplus_0_r : forall n:N, n + N0 = n. +Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. Proof. -destruct n; reflexivity. +reflexivity. Qed. -Theorem Nplus_comm : forall n m:N, n + m = m + n. +Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m). Proof. -intros. -destruct n; destruct m; simpl in |- *; try reflexivity. -rewrite Pplus_comm; reflexivity. +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. + +(** We regroup here some results used for proving the correctness + of more advanced functions. These results will also be provided + by the generic functor of properties about natural numbers + instantiated at the end of the file. *) + +Module Import Private_BootStrap. + +Theorem add_0_r n : n + 0 = n. +Proof. +now destruct n. Qed. -Theorem Nplus_assoc : forall n m p:N, n + (m + p) = n + m + p. +Theorem add_comm n m : n + m = m + n. +Proof. +destruct n, m; simpl; try reflexivity. simpl. f_equal. apply Pos.add_comm. +Qed. + +Theorem add_assoc n m p : n + (m + p) = n + m + p. Proof. -intros. destruct n; try reflexivity. destruct m; try reflexivity. destruct p; try reflexivity. -simpl in |- *; rewrite Pplus_assoc; reflexivity. +simpl. f_equal. apply Pos.add_assoc. +Qed. + +Lemma sub_add n m : n <= m -> m - n + n = m. +Proof. + destruct n as [|p], m as [|q]; simpl; try easy'. intros H. + case Pos.sub_mask_spec; intros; simpl; subst; trivial. + now rewrite Pos.add_comm. + apply Pos.le_nlt in H. elim H. apply Pos.lt_add_r. +Qed. + +Theorem mul_comm n m : n * m = m * n. +Proof. +destruct n, m; simpl; trivial. f_equal. apply Pos.mul_comm. +Qed. + +Lemma le_0_l n : 0<=n. +Proof. +now destruct n. +Qed. + +Lemma leb_spec n m : BoolSpec (n<=m) (m<n) (n <=? m). +Proof. + unfold le, lt, leb. rewrite (compare_antisym n m). + case compare; now constructor. +Qed. + +Lemma add_lt_cancel_l n m p : p+n < p+m -> n<m. +Proof. + intro H. destruct p. simpl; auto. + destruct n; destruct m. + elim (Pos.lt_irrefl _ H). + red; auto. + rewrite add_0_r in H. simpl in H. + red in H. simpl in H. + elim (Pos.lt_not_add_l _ _ H). + now apply (Pos.add_lt_mono_l p). +Qed. + +End Private_BootStrap. + +(** 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. -Theorem Nplus_succ : forall n m:N, Nsucc n + m = Nsucc (n + m). +(** Properties of [double] and [succ_double] *) + +Lemma double_spec n : double n = 2 * n. Proof. -destruct n; destruct m. - simpl in |- *; reflexivity. - unfold Nsucc, Nplus in |- *; rewrite <- Pplus_one_succ_l; reflexivity. - simpl in |- *; reflexivity. - simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity. + reflexivity. Qed. -Theorem Nsucc_0 : forall n : N, Nsucc n <> N0. +Lemma succ_double_spec n : succ_double n = 2 * n + 1. Proof. -intro n; elim n; simpl Nsucc; intros; discriminate. + now destruct n. Qed. -Theorem Nsucc_inj : forall n m:N, Nsucc n = Nsucc m -> n = m. +Lemma double_add n m : double (n+m) = double n + double m. Proof. -destruct n; destruct m; simpl in |- *; intro H; reflexivity || injection H; - clear H; intro H. - symmetry in H; contradiction Psucc_not_one with p. - contradiction Psucc_not_one with p. - rewrite Psucc_inj with (1 := H); reflexivity. + now destruct n, m. Qed. -Theorem Nplus_reg_l : forall n m p:N, n + m = n + p -> m = p. +Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m. Proof. -intro n; pattern n in |- *; apply Nind; clear n; simpl in |- *. - trivial. - intros n IHn m p H0; do 2 rewrite Nplus_succ in H0. - apply IHn; apply Nsucc_inj; assumption. + now destruct n, m. Qed. -(** Properties of subtraction. *) +Lemma double_mul n m : double (n*m) = double n * m. +Proof. + now destruct n, m. +Qed. -Lemma Nminus_N0_Nle : forall n n' : N, n - n' = N0 <-> n <= n'. +Lemma succ_double_mul n m : + succ_double n * m = double n * m + m. Proof. -destruct n as [| p]; destruct n' as [| q]; unfold Nle; simpl; -split; intro H; try discriminate; try reflexivity. -now elim H. -intro H1; apply Pminus_mask_Gt in H1. destruct H1 as [h [H1 _]]. -rewrite H1 in H; discriminate. -case_eq (Pcompare p q Eq); intro H1; rewrite H1 in H; try now elim H. -assert (H2 : p = q); [now apply Pcompare_Eq_eq |]. now rewrite H2, Pminus_mask_diag. -now rewrite Pminus_mask_Lt. + destruct n; simpl; destruct m; trivial. + now rewrite Pos.add_comm. Qed. -Theorem Nminus_0_r : forall n : N, n - N0 = n. +Lemma div2_double n : div2 (double n) = n. Proof. now destruct n. Qed. -Theorem Nminus_succ_r : forall n m : N, n - (Nsucc m) = Npred (n - m). +Lemma div2_succ_double n : div2 (succ_double n) = n. Proof. -destruct n as [| p]; destruct m as [| q]; try reflexivity. -now destruct p. -simpl. rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec. -now destruct (Pminus_mask p q) as [| r |]; [| destruct r |]. +now destruct n. Qed. -(** Properties of multiplication *) +Lemma double_inj n m : double n = double m -> n = m. +Proof. +intro H. rewrite <- (div2_double n), H. apply div2_double. +Qed. -Theorem Nmult_0_l : forall n:N, N0 * n = N0. +Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m. Proof. -reflexivity. +intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double. Qed. -Theorem Nmult_1_l : forall n:N, Npos 1 * n = n. +Lemma succ_double_lt n m : n<m -> succ_double n < double m. Proof. -destruct n; reflexivity. + destruct n as [|n], m as [|m]; intros H; try easy. + unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H. Qed. -Theorem Nmult_Sn_m : forall n m : N, (Nsucc n) * m = m + n * m. + +(** Specification of minimum and maximum *) + +Theorem min_l n m : n <= m -> min n m = n. Proof. -destruct n as [| n]; destruct m as [| m]; simpl; auto. -rewrite Pmult_Sn_m; reflexivity. +unfold min, le. case compare; trivial. now destruct 1. Qed. -Theorem Nmult_1_r : forall n:N, n * Npos 1%positive = n. +Theorem min_r n m : m <= n -> min n m = m. Proof. -destruct n; simpl in |- *; try reflexivity. -rewrite Pmult_1_r; reflexivity. +unfold min, le. rewrite compare_antisym. +case compare_spec; trivial. now destruct 2. Qed. -Theorem Nmult_comm : forall n m:N, n * m = m * n. +Theorem max_l n m : m <= n -> max n m = n. Proof. -intros. -destruct n; destruct m; simpl in |- *; try reflexivity. -rewrite Pmult_comm; reflexivity. +unfold max, le. rewrite compare_antisym. +case compare_spec; auto. now destruct 2. Qed. -Theorem Nmult_assoc : forall n m p:N, n * (m * p) = n * m * p. +Theorem max_r n m : n <= m -> max n m = m. Proof. -intros. -destruct n; try reflexivity. -destruct m; try reflexivity. -destruct p; try reflexivity. -simpl in |- *; rewrite Pmult_assoc; reflexivity. +unfold max, le. case compare; trivial. now destruct 1. Qed. -Theorem Nmult_plus_distr_r : forall n m p:N, (n + m) * p = n * p + m * p. +(** 0 is the least natural number *) + +Theorem compare_0_r n : (n ?= 0) <> Lt. Proof. -intros. -destruct n; try reflexivity. -destruct m; destruct p; try reflexivity. -simpl in |- *; rewrite Pmult_plus_distr_r; reflexivity. +now destruct n. Qed. -Theorem Nmult_reg_r : forall n m p:N, p <> N0 -> n * p = m * p -> n = m. +(** 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. -destruct p; intros Hp H. -contradiction Hp; reflexivity. -destruct n; destruct m; reflexivity || (try discriminate H). -injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity. + now destruct p. Qed. -(** Properties of boolean order. *) +(** Specification of square *) -Lemma Neqb_eq : forall n m, Neqb n m = true <-> n=m. +Lemma square_spec n : square n = n * n. Proof. -destruct n as [|n], m as [|m]; simpl; split; auto; try discriminate. -intros; f_equal. apply (Peqb_eq n m); auto. -intros. apply (Peqb_eq n m). congruence. + destruct n; trivial. simpl. f_equal. apply Pos.square_spec. Qed. -(** Properties of comparison *) +(** Specification of Base-2 logarithm *) -Lemma Ncompare_refl : forall n, (n ?= n) = Eq. +Lemma size_log2 n : n<>0 -> size n = succ (log2 n). Proof. -destruct n; simpl; auto. -apply Pcompare_refl. + destruct n as [|[n|n| ]]; trivial. now destruct 1. Qed. -Theorem Ncompare_Eq_eq : forall n m:N, (n ?= m) = Eq -> n = m. +Lemma size_gt n : n < 2^(size n). Proof. -destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H; - reflexivity || (try discriminate H). - rewrite (Pcompare_Eq_eq n m H); reflexivity. + destruct n. reflexivity. simpl. apply Pos.size_gt. Qed. -Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m. +Lemma size_le n : 2^(size n) <= succ_double n. Proof. -split; intros; - [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ]. + destruct n. 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 Ncompare_antisym : forall n m, CompOpp (n ?= m) = (m ?= n). +Lemma log2_spec n : 0 < n -> + 2^(log2 n) <= n < 2^(succ (log2 n)). Proof. -destruct n; destruct m; simpl; auto. -exact (Pcompare_antisym p p0 Eq). + destruct n as [|[p|p|]]; discriminate || intros _; simpl; split. + apply (size_le (Npos p)). + apply Pos.size_gt. + apply Pos.size_le. + apply Pos.size_gt. + discriminate. + reflexivity. Qed. -Lemma Ngt_Nlt : forall n m, n > m -> m < n. +Lemma log2_nonpos n : n<=0 -> log2 n = 0. Proof. -unfold Ngt, Nlt; intros n m GT. -rewrite <- Ncompare_antisym, GT; reflexivity. + destruct n; intros Hn. reflexivity. now destruct Hn. Qed. -Theorem Nlt_irrefl : forall n : N, ~ n < n. +(** Specification of parity functions *) + +Lemma even_spec n : even n = true <-> Even n. Proof. -intro n; unfold Nlt; now rewrite Ncompare_refl. + destruct n. + split. now exists 0. + trivial. + destruct p; simpl; split; try easy. + intros (m,H). now destruct m. + now exists (Npos p). + intros (m,H). now destruct m. Qed. -Theorem Nlt_trans : forall n m q, n < m -> m < q -> n < q. +Lemma odd_spec n : odd n = true <-> Odd n. Proof. -destruct n; - destruct m; try discriminate; - destruct q; try discriminate; auto. -eapply Plt_trans; eauto. + destruct n. + split. discriminate. + intros (m,H). now destruct m. + destruct p; simpl; split; try easy. + now exists (Npos p). + intros (m,H). now destruct m. + now exists 0. Qed. -Theorem Nlt_not_eq : forall n m, n < m -> ~ n = m. +(** Specification of the euclidean division *) + +Theorem pos_div_eucl_spec (a:positive)(b:N) : + let (q,r) := pos_div_eucl a b in Npos a = q * b + r. Proof. - intros n m LT EQ. subst m. elim (Nlt_irrefl n); auto. + induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + (* a~1 *) + destruct pos_div_eucl as (q,r). + change (Npos a~1) with (succ_double (Npos 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 (Npos a~0) with (double (Npos 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 Ncompare_n_Sm : - forall n m : N, Ncompare n (Nsucc m) = Lt <-> Ncompare n m = Lt \/ n = m. +Theorem div_eucl_spec a b : + let (q,r) := div_eucl a b in a = b * q + r. Proof. -intros n m; split; destruct n as [| p]; destruct m as [| q]; simpl; auto. -destruct p; simpl; intros; discriminate. -pose proof (Pcompare_p_Sq p q) as (?,_). -assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. -intros H; destruct H; discriminate. -pose proof (Pcompare_p_Sq p q) as (_,?); -assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. + destruct a as [|a], b as [|b]; unfold div_eucl; trivial. + generalize (pos_div_eucl_spec a (Npos b)). + destruct pos_div_eucl. now rewrite mul_comm. Qed. -Lemma Nle_lteq : forall x y, x <= y <-> x < y \/ x=y. +Theorem div_mod' a b : a = b * (a/b) + (a mod b). Proof. -unfold Nle, Nlt; intros. -generalize (Ncompare_eq_correct x y). -destruct (x ?= y); intuition; discriminate. + generalize (div_eucl_spec a b). + unfold div, modulo. now destruct div_eucl. Qed. -Lemma Ncompare_spec : forall x y, CompSpec eq Nlt x y (Ncompare x y). +Definition div_mod a b : b<>0 -> a = b * (a/b) + (a mod b). Proof. -intros. -destruct (Ncompare x y) as [ ]_eqn; constructor; auto. -apply Ncompare_Eq_eq; auto. -apply Ngt_Nlt; auto. + intros _. apply div_mod'. Qed. -(** 0 is the least natural number *) +Theorem pos_div_eucl_remainder (a:positive) (b:N) : + b<>0 -> snd (pos_div_eucl a b) < b. +Proof. + intros Hb. + induction a; 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_cancel_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_cancel_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<b -> 0 <= a mod b < b. +Proof. + intros _ H. split. apply le_0_l. apply mod_lt. now destruct b. +Qed. -Theorem Ncompare_0 : forall n : N, Ncompare n N0 <> Lt. +(** Specification of square root *) + +Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. +Proof. + destruct n. 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. 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. 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. -destruct n; discriminate. + 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. -(** Dividing by 2 *) +(** We now prove directly that gcd is the greatest amongst common divisors *) -Definition Ndiv2 (n:N) := - match n with - | N0 => N0 - | Npos 1 => N0 - | Npos (xO p) => Npos p - | Npos (xI p) => Npos p - end. +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 (Npos 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 Ndouble_div2 : forall n:N, Ndiv2 (Ndouble n) = n. +Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. Proof. - destruct n; trivial. + now destruct a. Qed. -Lemma Ndouble_plus_one_div2 : - forall n:N, Ndiv2 (Ndouble_plus_one n) = n. +Lemma testbit_succ_r_div2 a n : 0<=n -> + testbit a (succ n) = testbit (div2 a) n. Proof. - destruct n; trivial. + intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial; + f_equal; apply Pos.pred_N_succ. Qed. -Lemma Ndouble_inj : forall n m, Ndouble n = Ndouble m -> n = m. +Lemma testbit_odd_succ a n : 0<=n -> + testbit (2*a+1) (succ n) = testbit a n. Proof. - intros. rewrite <- (Ndouble_div2 n). rewrite H. apply Ndouble_div2. + intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a. Qed. -Lemma Ndouble_plus_one_inj : - forall n m, Ndouble_plus_one n = Ndouble_plus_one m -> n = m. +Lemma testbit_even_succ a n : 0<=n -> + testbit (2*a) (succ n) = testbit a n. Proof. - intros. rewrite <- (Ndouble_plus_one_div2 n). rewrite H. apply Ndouble_plus_one_div2. + 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 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<n -> + testbit (shiftl a n) m = false. +Proof. + revert a m. + induction n using peano_ind; intros a m H. + elim (le_0_l m). now rewrite compare_antisym, H. + rewrite shiftl_succ_r. + destruct m. 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_cancel_l with 1. rewrite 2 (add_succ_l 0). simpl. + now rewrite succ_pos_pred. +Qed. + +Definition 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. + 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. + +(** Specification of constants *) + +Lemma one_succ : 1 = succ 0. +Proof. reflexivity. Qed. + +Lemma two_succ : 2 = succ 1. +Proof. reflexivity. Qed. + +Definition pred_0 : pred 0 = 0. +Proof. reflexivity. Qed. + +(** 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 := _. + +(** Generic induction / recursion *) + +Theorem bi_induction : + forall A : N -> Prop, Proper (Logic.eq==>iff) A -> + A N0 -> (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). + +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. + +(** Instantiation of generic properties of natural numbers *) + +Include NProp + <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + +(** Otherwise N stays associated with abstract_scope : (TODO FIX) *) +Bind Scope N_scope with N. + +(** 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, + used in BinInt *) + +Lemma pos_pred_shiftl_low : forall p n m, m<n -> + testbit (Pos.pred_N (Pos.shiftl p n)) m = true. +Proof. + induction n using peano_ind. + now 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 n xO p) 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. + induction n 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 n xO p). + 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. + +End N. + +(** Exportation of notations *) + +Infix "+" := N.add : N_scope. +Infix "-" := N.sub : N_scope. +Infix "*" := N.mul : N_scope. +Infix "^" := N.pow : N_scope. + +Infix "?=" := N.compare (at level 70, no associativity) : N_scope. + +Infix "<=" := N.le : N_scope. +Infix "<" := N.lt : N_scope. +Infix ">=" := N.ge : N_scope. +Infix ">" := N.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. + +Infix "=?" := N.eqb (at level 70, no associativity) : N_scope. +Infix "<=?" := N.leb (at level 70, no associativity) : N_scope. +Infix "<?" := N.ltb (at level 70, no associativity) : N_scope. + +Infix "/" := N.div : N_scope. +Infix "mod" := N.modulo (at level 40, no associativity) : N_scope. + +Notation "( p | q )" := (N.divide p q) (at level 0) : N_scope. + +(** Compatibility notations *) + +(*Notation N := N (only parsing).*) (*hidden by module N above *) +Notation N_rect := N_rect (only parsing). +Notation N_rec := N_rec (only parsing). +Notation N_ind := N_ind (only parsing). +Notation N0 := N0 (only parsing). +Notation Npos := Npos (only parsing). + +Notation Ndiscr := N.discr (only parsing). +Notation Ndouble_plus_one := N.succ_double. +Notation Ndouble := N.double (only parsing). +Notation Nsucc := N.succ (only parsing). +Notation Npred := N.pred (only parsing). +Notation Nsucc_pos := N.succ_pos (only parsing). +Notation Ppred_N := Pos.pred_N (only parsing). +Notation Nplus := N.add (only parsing). +Notation Nminus := N.sub (only parsing). +Notation Nmult := N.mul (only parsing). +Notation Neqb := N.eqb (only parsing). +Notation Ncompare := N.compare (only parsing). +Notation Nlt := N.lt (only parsing). +Notation Ngt := N.gt (only parsing). +Notation Nle := N.le (only parsing). +Notation Nge := N.ge (only parsing). +Notation Nmin := N.min (only parsing). +Notation Nmax := N.max (only parsing). +Notation Ndiv2 := N.div2 (only parsing). +Notation Neven := N.even (only parsing). +Notation Nodd := N.odd (only parsing). +Notation Npow := N.pow (only parsing). +Notation Nlog2 := N.log2 (only parsing). + +Notation nat_of_N := N.to_nat (only parsing). +Notation N_of_nat := N.of_nat (only parsing). +Notation N_eq_dec := N.eq_dec (only parsing). +Notation Nrect := N.peano_rect (only parsing). +Notation Nrect_base := N.peano_rect_base (only parsing). +Notation Nrect_step := N.peano_rect_succ (only parsing). +Notation Nind := N.peano_ind (only parsing). +Notation Nrec := N.peano_rec (only parsing). +Notation Nrec_base := N.peano_rec_base (only parsing). +Notation Nrec_succ := N.peano_rec_succ (only parsing). + +Notation Npred_succ := N.pred_succ (only parsing). +Notation Npred_minus := N.pred_sub (only parsing). +Notation Nsucc_pred := N.succ_pred (only parsing). +Notation Ppred_N_spec := N.pos_pred_spec (only parsing). +Notation Nsucc_pos_spec := N.succ_pos_spec (only parsing). +Notation Ppred_Nsucc := N.pos_pred_succ (only parsing). +Notation Nplus_0_l := N.add_0_l (only parsing). +Notation Nplus_0_r := N.add_0_r (only parsing). +Notation Nplus_comm := N.add_comm (only parsing). +Notation Nplus_assoc := N.add_assoc (only parsing). +Notation Nplus_succ := N.add_succ_l (only parsing). +Notation Nsucc_0 := N.succ_0_discr (only parsing). +Notation Nsucc_inj := N.succ_inj (only parsing). +Notation Nminus_N0_Nle := N.sub_0_le (only parsing). +Notation Nminus_0_r := N.sub_0_r (only parsing). +Notation Nminus_succ_r:= N.sub_succ_r (only parsing). +Notation Nmult_0_l := N.mul_0_l (only parsing). +Notation Nmult_1_l := N.mul_1_l (only parsing). +Notation Nmult_1_r := N.mul_1_r (only parsing). +Notation Nmult_comm := N.mul_comm (only parsing). +Notation Nmult_assoc := N.mul_assoc (only parsing). +Notation Nmult_plus_distr_r := N.mul_add_distr_r (only parsing). +Notation Neqb_eq := N.eqb_eq (only parsing). +Notation Nle_0 := N.le_0_l (only parsing). +Notation Ncompare_refl := N.compare_refl (only parsing). +Notation Ncompare_Eq_eq := N.compare_eq (only parsing). +Notation Ncompare_eq_correct := N.compare_eq_iff (only parsing). +Notation Nlt_irrefl := N.lt_irrefl (only parsing). +Notation Nlt_trans := N.lt_trans (only parsing). +Notation Nle_lteq := N.lt_eq_cases (only parsing). +Notation Nlt_succ_r := N.lt_succ_r (only parsing). +Notation Nle_trans := N.le_trans (only parsing). +Notation Nle_succ_l := N.le_succ_l (only parsing). +Notation Ncompare_spec := N.compare_spec (only parsing). +Notation Ncompare_0 := N.compare_0_r (only parsing). +Notation Ndouble_div2 := N.div2_double (only parsing). +Notation Ndouble_plus_one_div2 := N.div2_succ_double (only parsing). +Notation Ndouble_inj := N.double_inj (only parsing). +Notation Ndouble_plus_one_inj := N.succ_double_inj (only parsing). +Notation Npow_0_r := N.pow_0_r (only parsing). +Notation Npow_succ_r := N.pow_succ_r (only parsing). +Notation Nlog2_spec := N.log2_spec (only parsing). +Notation Nlog2_nonpos := N.log2_nonpos (only parsing). +Notation Neven_spec := N.even_spec (only parsing). +Notation Nodd_spec := N.odd_spec (only parsing). +Notation Nlt_not_eq := N.lt_neq (only parsing). +Notation Ngt_Nlt := N.gt_lt (only parsing). + +(** More complex compatibility facts, expressed as lemmas + (to preserve scopes for instance) *) + +Lemma Nplus_reg_l n m p : n + m = n + p -> m = p. +Proof (proj1 (N.add_cancel_l m p n)). +Lemma Nmult_Sn_m n m : N.succ n * m = m + n * m. +Proof (eq_trans (N.mul_succ_l n m) (N.add_comm _ _)). +Lemma Nmult_plus_distr_l n m p : p * (n + m) = p * n + p * m. +Proof (N.mul_add_distr_l p n m). +Lemma Nmult_reg_r n m p : p <> 0 -> n * p = m * p -> n = m. +Proof (fun H => proj1 (N.mul_cancel_r n m p H)). +Lemma Ncompare_antisym n m : CompOpp (n ?= m) = (m ?= n). +Proof (eq_sym (N.compare_antisym n m)). + +Definition N_ind_double a P f0 f2 fS2 := N.binary_ind P f0 f2 fS2 a. +Definition N_rec_double a P f0 f2 fS2 := N.binary_rec P f0 f2 fS2 a. + +(** Not kept : Ncompare_n_Sm Nplus_lt_cancel_l *) diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v new file mode 100644 index 00000000..d7660422 --- /dev/null +++ b/theories/NArith/BinNatDef.v @@ -0,0 +1,381 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export BinNums. +Require Import BinPos. + +Local Open Scope N_scope. + +(**********************************************************************) +(** * Binary natural numbers, definitions of operations *) +(**********************************************************************) + +Module N. + +Definition t := N. + +(** ** Constants *) + +Definition zero := 0. +Definition one := 1. +Definition two := 2. + +(** ** Operation [x -> 2*x+1] *) + +Definition succ_double x := + match x with + | 0 => 1 + | Npos p => Npos p~1 + end. + +(** ** Operation [x -> 2*x] *) + +Definition double n := + match n with + | 0 => 0 + | Npos p => Npos p~0 + end. + +(** ** Successor *) + +Definition succ n := + match n with + | 0 => 1 + | Npos p => Npos (Pos.succ p) + end. + +(** ** Predecessor *) + +Definition pred n := + match n with + | 0 => 0 + | Npos p => Pos.pred_N p + end. + +(** ** The successor of a [N] can be seen as a [positive] *) + +Definition succ_pos (n : N) : positive := + match n with + | N0 => 1%positive + | Npos p => Pos.succ p + end. + +(** ** Addition *) + +Definition add n m := + match n, m with + | 0, _ => m + | _, 0 => n + | Npos p, Npos q => Npos (p + q) + end. + +Infix "+" := add : N_scope. + +(** Subtraction *) + +Definition sub n m := +match n, m with +| 0, _ => 0 +| n, 0 => n +| Npos n', Npos m' => + match Pos.sub_mask n' m' with + | IsPos p => Npos p + | _ => 0 + end +end. + +Infix "-" := sub : N_scope. + +(** Multiplication *) + +Definition mul n m := + match n, m with + | 0, _ => 0 + | _, 0 => 0 + | Npos p, Npos q => Npos (p * q) + end. + +Infix "*" := mul : N_scope. + +(** Order *) + +Definition compare n m := + match n, m with + | 0, 0 => Eq + | 0, Npos m' => Lt + | Npos n', 0 => Gt + | Npos n', Npos m' => (n' ?= m')%positive + end. + +Infix "?=" := compare (at level 70, no associativity) : N_scope. + +(** Boolean equality and comparison *) + +(** Nota: this [eqb] is not convertible with the generated [N_beq], + since the underlying [Pos.eqb] differs from [positive_beq] + (cf BinIntDef). *) + +Fixpoint eqb n m := + match n, m with + | 0, 0 => true + | Npos p, Npos q => Pos.eqb p q + | _, _ => false + end. + +Definition leb x y := + match x ?= y with Gt => false | _ => true 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 "<?" := ltb (at level 70, no associativity) : N_scope. + +(** Min and max *) + +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. + +(** Dividing by 2 *) + +Definition div2 n := + match n with + | 0 => 0 + | 1 => 0 + | Npos (p~0) => Npos p + | Npos (p~1) => Npos p + end. + +(** Parity *) + +Definition even n := + match n with + | 0 => true + | Npos (xO _) => true + | _ => false + end. + +Definition odd n := negb (even n). + +(** Power *) + +Definition pow n p := + match p, n with + | 0, _ => 1 + | _, 0 => 0 + | Npos p, Npos q => Npos (q^p) + end. + +Infix "^" := pow : N_scope. + +(** Square *) + +Definition square n := + match n with + | 0 => 0 + | Npos p => Npos (Pos.square p) + end. + +(** Base-2 logarithm *) + +Definition log2 n := + match n with + | 0 => 0 + | 1 => 0 + | Npos (p~0) => Npos (Pos.size p) + | Npos (p~1) => Npos (Pos.size p) + end. + +(** How many digits in a number ? + Number 0 is said to have no digits at all. +*) + +Definition size n := + match n with + | 0 => 0 + | Npos p => Npos (Pos.size p) + end. + +Definition size_nat n := + match n with + | 0 => O + | Npos p => Pos.size_nat p + end. + +(** Euclidean division *) + +Fixpoint pos_div_eucl (a:positive)(b:N) : N * N := + match a with + | xH => + match b with 1 => (1,0) | _ => (0,1) end + | xO a' => + let (q, r) := pos_div_eucl a' b in + let r' := double r in + if b <=? r' then (succ_double q, r' - b) + else (double q, r') + | xI a' => + let (q, r) := pos_div_eucl a' b in + let r' := succ_double r in + if b <=? r' then (succ_double q, r' - b) + else (double q, r') + end. + +Definition div_eucl (a b:N) : N * N := + match a, b with + | 0, _ => (0, 0) + | _, 0 => (0, a) + | Npos 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). + +Infix "/" := div : N_scope. +Infix "mod" := modulo (at level 40, no associativity) : N_scope. + +(** Greatest common divisor *) + +Definition gcd a b := + match a, b with + | 0, _ => b + | _, 0 => a + | Npos p, Npos q => Npos (Pos.gcd p q) + end. + +(** 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)) + | Npos p, Npos q => + let '(g,(aa,bb)) := Pos.ggcd p q in + (Npos g, (Npos aa, Npos bb)) + end. + +(** Square root *) + +Definition sqrtrem n := + match n with + | 0 => (0, 0) + | Npos p => + match Pos.sqrtrem p with + | (s, IsPos r) => (Npos s, Npos r) + | (s, _) => (Npos s, 0) + end + end. + +Definition sqrt n := + match n with + | 0 => 0 + | Npos p => Npos (Pos.sqrt p) + end. + +(** Operation over bits of a [N] number. *) + +(** Logical [or] *) + +Definition lor n m := + match n, m with + | 0, _ => m + | _, 0 => n + | Npos p, Npos q => Npos (Pos.lor p q) + end. + +(** Logical [and] *) + +Definition land n m := + match n, m with + | 0, _ => 0 + | _, 0 => 0 + | Npos p, Npos q => Pos.land p q + end. + +(** Logical [diff] *) + +Fixpoint ldiff n m := + match n, m with + | 0, _ => 0 + | _, 0 => n + | Npos p, Npos q => Pos.ldiff p q + end. + +(** [xor] *) + +Definition lxor n m := + match n, m with + | 0, _ => m + | _, 0 => n + | Npos p, Npos q => Pos.lxor p q + end. + +(** Shifts *) + +Definition shiftl_nat (a:N)(n:nat) := nat_iter n double a. +Definition shiftr_nat (a:N)(n:nat) := nat_iter n div2 a. + +Definition shiftl a n := + match a with + | 0 => 0 + | Npos a => Npos (Pos.shiftl a n) + end. + +Definition shiftr a n := + match n with + | 0 => a + | Npos p => Pos.iter p div2 a + end. + +(** Checking whether a particular bit is set or not *) + +Definition testbit_nat (a:N) := + match a with + | 0 => fun _ => false + | Npos p => Pos.testbit_nat p + end. + +(** Same, but with index in N *) + +Definition testbit a n := + match a with + | 0 => false + | Npos p => Pos.testbit p n + end. + +(** Translation from [N] to [nat] and back. *) + +Definition to_nat (a:N) := + match a with + | 0 => O + | Npos p => Pos.to_nat p + end. + +Definition of_nat (n:nat) := + match n with + | O => 0 + | S n' => Npos (Pos.of_succ_nat n') + end. + +(** Iteration of a function *) + +Definition iter (n:N) {A} (f:A->A) (x:A) : A := + match n with + | 0 => x + | Npos p => Pos.iter p f x + end. + +End N.
\ No newline at end of file diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v deleted file mode 100644 index 62bd57c0..00000000 --- a/theories/NArith/BinPos.v +++ /dev/null @@ -1,1172 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: BinPos.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Unset Boxed Definitions. - -Declare ML Module "z_syntax_plugin". - -(**********************************************************************) -(** Binary positive numbers *) - -(** Original development by Pierre Crégut, CNET, Lannion, France *) - -Inductive positive : Set := -| xI : positive -> positive -| xO : positive -> positive -| xH : positive. - -(** Declare binding key for scope positive_scope *) - -Delimit Scope positive_scope with positive. - -(** Automatically open scope positive_scope for type positive, xO and xI *) - -Bind Scope positive_scope with positive. -Arguments Scope xO [positive_scope]. -Arguments Scope xI [positive_scope]. - -(** Postfix notation for positive numbers, allowing to mimic - the position of bits in a big-endian representation. - For instance, we can write 1~1~0 instead of (xO (xI xH)) - for the number 6 (which is 110 in binary notation). -*) - -Notation "p ~ 1" := (xI p) - (at level 7, left associativity, format "p '~' '1'") : positive_scope. -Notation "p ~ 0" := (xO p) - (at level 7, left associativity, format "p '~' '0'") : positive_scope. - -Open Local Scope positive_scope. - -(* In the current file, [xH] cannot yet be written as [1], since the - interpretation of positive numerical constants is not available - yet. We fix this here with an ad-hoc temporary notation. *) - -Notation Local "1" := xH (at level 7). - -(** Successor *) - -Fixpoint Psucc (x:positive) : positive := - match x with - | p~1 => (Psucc p)~0 - | p~0 => p~1 - | 1 => 1~0 - end. - -(** Addition *) - -Set Boxed Definitions. - -Fixpoint Pplus (x y:positive) : positive := - match x, y with - | p~1, q~1 => (Pplus_carry p q)~0 - | p~1, q~0 => (Pplus p q)~1 - | p~1, 1 => (Psucc p)~0 - | p~0, q~1 => (Pplus p q)~1 - | p~0, q~0 => (Pplus p q)~0 - | p~0, 1 => p~1 - | 1, q~1 => (Psucc q)~0 - | 1, q~0 => q~1 - | 1, 1 => 1~0 - end - -with Pplus_carry (x y:positive) : positive := - match x, y with - | p~1, q~1 => (Pplus_carry p q)~1 - | p~1, q~0 => (Pplus_carry p q)~0 - | p~1, 1 => (Psucc p)~1 - | p~0, q~1 => (Pplus_carry p q)~0 - | p~0, q~0 => (Pplus p q)~1 - | p~0, 1 => (Psucc p)~0 - | 1, q~1 => (Psucc q)~1 - | 1, q~0 => (Psucc q)~0 - | 1, 1 => 1~1 - end. - -Unset Boxed Definitions. - -Infix "+" := Pplus : positive_scope. - -(** From binary positive numbers to Peano natural numbers *) - -Fixpoint Pmult_nat (x:positive) (pow2:nat) : nat := - match x with - | p~1 => (pow2 + Pmult_nat p (pow2 + pow2))%nat - | p~0 => Pmult_nat p (pow2 + pow2)%nat - | 1 => pow2 - end. - -Definition nat_of_P (x:positive) := Pmult_nat x (S O). - -(** From Peano natural numbers to binary positive numbers *) - -Fixpoint P_of_succ_nat (n:nat) : positive := - match n with - | O => 1 - | S x => Psucc (P_of_succ_nat x) - end. - -(** Operation x -> 2*x-1 *) - -Fixpoint Pdouble_minus_one (x:positive) : positive := - match x with - | p~1 => p~0~1 - | p~0 => (Pdouble_minus_one p)~1 - | 1 => 1 - end. - -(** Predecessor *) - -Definition Ppred (x:positive) := - match x with - | p~1 => p~0 - | p~0 => Pdouble_minus_one p - | 1 => 1 - end. - -(** An auxiliary type for subtraction *) - -Inductive positive_mask : Set := -| IsNul : positive_mask -| IsPos : positive -> positive_mask -| IsNeg : positive_mask. - -(** Operation x -> 2*x+1 *) - -Definition Pdouble_plus_one_mask (x:positive_mask) := - match x with - | IsNul => IsPos 1 - | IsNeg => IsNeg - | IsPos p => IsPos p~1 - end. - -(** Operation x -> 2*x *) - -Definition Pdouble_mask (x:positive_mask) := - match x with - | IsNul => IsNul - | IsNeg => IsNeg - | IsPos p => IsPos p~0 - end. - -(** Operation x -> 2*x-2 *) - -Definition Pdouble_minus_two (x:positive) := - match x with - | p~1 => IsPos p~0~0 - | p~0 => IsPos (Pdouble_minus_one p)~0 - | 1 => IsNul - end. - -(** Subtraction of binary positive numbers into a positive numbers mask *) - -Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask := - match x, y with - | p~1, q~1 => Pdouble_mask (Pminus_mask p q) - | p~1, q~0 => Pdouble_plus_one_mask (Pminus_mask p q) - | p~1, 1 => IsPos p~0 - | p~0, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q) - | p~0, q~0 => Pdouble_mask (Pminus_mask p q) - | p~0, 1 => IsPos (Pdouble_minus_one p) - | 1, 1 => IsNul - | 1, _ => IsNeg - end - -with Pminus_mask_carry (x y:positive) {struct y} : positive_mask := - match x, y with - | p~1, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q) - | p~1, q~0 => Pdouble_mask (Pminus_mask p q) - | p~1, 1 => IsPos (Pdouble_minus_one p) - | p~0, q~1 => Pdouble_mask (Pminus_mask_carry p q) - | p~0, q~0 => Pdouble_plus_one_mask (Pminus_mask_carry p q) - | p~0, 1 => Pdouble_minus_two p - | 1, _ => IsNeg - end. - -(** Subtraction of binary positive numbers x and y, returns 1 if x<=y *) - -Definition Pminus (x y:positive) := - match Pminus_mask x y with - | IsPos z => z - | _ => 1 - end. - -Infix "-" := Pminus : positive_scope. - -(** Multiplication on binary positive numbers *) - -Fixpoint Pmult (x y:positive) : positive := - match x with - | p~1 => y + (Pmult p y)~0 - | p~0 => (Pmult p y)~0 - | 1 => y - end. - -Infix "*" := Pmult : positive_scope. - -(** Division by 2 rounded below but for 1 *) - -Definition Pdiv2 (z:positive) := - match z with - | 1 => 1 - | p~0 => p - | p~1 => p - end. - -Infix "/" := Pdiv2 : positive_scope. - -(** Comparison on binary positive numbers *) - -Fixpoint Pcompare (x y:positive) (r:comparison) {struct y} : comparison := - match x, y with - | p~1, q~1 => Pcompare p q r - | p~1, q~0 => Pcompare p q Gt - | p~1, 1 => Gt - | p~0, q~1 => Pcompare p q Lt - | p~0, q~0 => Pcompare p q r - | p~0, 1 => Gt - | 1, q~1 => Lt - | 1, q~0 => Lt - | 1, 1 => r - end. - -Infix "?=" := Pcompare (at level 70, no associativity) : positive_scope. - -Definition Plt (x y:positive) := (Pcompare x y Eq) = Lt. -Definition Pgt (x y:positive) := (Pcompare x y Eq) = Gt. -Definition Ple (x y:positive) := (Pcompare x y Eq) <> Gt. -Definition Pge (x y:positive) := (Pcompare x y Eq) <> Lt. - -Infix "<=" := Ple : positive_scope. -Infix "<" := Plt : positive_scope. -Infix ">=" := Pge : positive_scope. -Infix ">" := Pgt : 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. - - -Definition Pmin (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p - | Gt => p' - end. - -Definition Pmax (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p' - | Gt => p - end. - -(********************************************************************) -(** Boolean equality *) - -Fixpoint Peqb (x y : positive) {struct y} : bool := - match x, y with - | 1, 1 => true - | p~1, q~1 => Peqb p q - | p~0, q~0 => Peqb p q - | _, _ => false - end. - -(**********************************************************************) -(** Decidability of equality on binary positive numbers *) - -Lemma positive_eq_dec : forall x y: positive, {x = y} + {x <> y}. -Proof. - decide equality. -Defined. - -(* begin hide *) -Corollary ZL11 : forall p:positive, p = 1 \/ p <> 1. -Proof. - intro; edestruct positive_eq_dec; eauto. -Qed. -(* end hide *) - -(**********************************************************************) -(** Properties of successor on binary positive numbers *) - -(** Specification of [xI] in term of [Psucc] and [xO] *) - -Lemma xI_succ_xO : forall p:positive, p~1 = Psucc p~0. -Proof. - reflexivity. -Qed. - -Lemma Psucc_discr : forall p:positive, p <> Psucc p. -Proof. - destruct p; discriminate. -Qed. - -(** Successor and double *) - -Lemma Psucc_o_double_minus_one_eq_xO : - forall p:positive, Psucc (Pdouble_minus_one p) = p~0. -Proof. - induction p; simpl; f_equal; auto. -Qed. - -Lemma Pdouble_minus_one_o_succ_eq_xI : - forall p:positive, Pdouble_minus_one (Psucc p) = p~1. -Proof. - induction p; simpl; f_equal; auto. -Qed. - -Lemma xO_succ_permute : - forall p:positive, (Psucc p)~0 = Psucc (Psucc p~0). -Proof. - induction p; simpl; auto. -Qed. - -Lemma double_moins_un_xO_discr : - forall p:positive, Pdouble_minus_one p <> p~0. -Proof. - destruct p; discriminate. -Qed. - -(** Successor and predecessor *) - -Lemma Psucc_not_one : forall p:positive, Psucc p <> 1. -Proof. - destruct p; discriminate. -Qed. - -Lemma Ppred_succ : forall p:positive, Ppred (Psucc p) = p. -Proof. - intros [[p|p| ]|[p|p| ]| ]; simpl; auto. - f_equal; apply Pdouble_minus_one_o_succ_eq_xI. -Qed. - -Lemma Psucc_pred : forall p:positive, p = 1 \/ Psucc (Ppred p) = p. -Proof. - induction p; simpl; auto. - right; apply Psucc_o_double_minus_one_eq_xO. -Qed. - -Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)). - -(** Injectivity of successor *) - -Lemma Psucc_inj : forall p q:positive, Psucc p = Psucc q -> p = q. -Proof. - induction p; intros [q|q| ] H; simpl in *; destr_eq H; f_equal; auto. - elim (Psucc_not_one p); auto. - elim (Psucc_not_one q); auto. -Qed. - -(**********************************************************************) -(** Properties of addition on binary positive numbers *) - -(** Specification of [Psucc] in term of [Pplus] *) - -Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + 1. -Proof. - destruct p; reflexivity. -Qed. - -Lemma Pplus_one_succ_l : forall p:positive, Psucc p = 1 + p. -Proof. - destruct p; reflexivity. -Qed. - -(** Specification of [Pplus_carry] *) - -Theorem Pplus_carry_spec : - forall p q:positive, Pplus_carry p q = Psucc (p + q). -Proof. - induction p; destruct q; simpl; f_equal; auto. -Qed. - -(** Commutativity *) - -Theorem Pplus_comm : forall p q:positive, p + q = q + p. -Proof. - induction p; destruct q; simpl; f_equal; auto. - rewrite 2 Pplus_carry_spec; f_equal; auto. -Qed. - -(** Permutation of [Pplus] and [Psucc] *) - -Theorem Pplus_succ_permute_r : - forall p q:positive, p + Psucc q = Psucc (p + q). -Proof. - induction p; destruct q; simpl; f_equal; - auto using Pplus_one_succ_r; rewrite Pplus_carry_spec; auto. -Qed. - -Theorem Pplus_succ_permute_l : - forall p q:positive, Psucc p + q = Psucc (p + q). -Proof. - intros p q; rewrite Pplus_comm, (Pplus_comm p); - apply Pplus_succ_permute_r. -Qed. - -Theorem Pplus_carry_pred_eq_plus : - forall p q:positive, q <> 1 -> Pplus_carry p (Ppred q) = p + q. -Proof. - intros p q H; rewrite Pplus_carry_spec, <- Pplus_succ_permute_r; f_equal. - destruct (Psucc_pred q); [ elim H; assumption | assumption ]. -Qed. - -(** No neutral for addition on strictly positive numbers *) - -Lemma Pplus_no_neutral : forall p q:positive, q + p <> p. -Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; - destr_eq H; apply (IHp q H). -Qed. - -Lemma Pplus_carry_no_neutral : - forall p q:positive, Pplus_carry q p <> Psucc p. -Proof. - intros p q H; elim (Pplus_no_neutral p q). - apply Psucc_inj; rewrite <- Pplus_carry_spec; assumption. -Qed. - -(** Simplification *) - -Lemma Pplus_carry_plus : - forall p q r s:positive, Pplus_carry p r = Pplus_carry q s -> p + r = q + s. -Proof. - intros p q r s H; apply Psucc_inj; do 2 rewrite <- Pplus_carry_spec; - assumption. -Qed. - -Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q. -Proof. - intros p q r; revert p q; induction r. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; - f_equal; auto using Pplus_carry_plus; - contradict H; auto using Pplus_carry_no_neutral. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; - contradict H; auto using Pplus_no_neutral. - intros p q H; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption. -Qed. - -Lemma Pplus_reg_l : forall p q r:positive, p + q = p + r -> q = r. -Proof. - intros p q r H; apply Pplus_reg_r with (r:=p). - rewrite (Pplus_comm r), (Pplus_comm q); assumption. -Qed. - -Lemma Pplus_carry_reg_r : - forall p q r:positive, Pplus_carry p r = Pplus_carry q r -> p = q. -Proof. - intros p q r H; apply Pplus_reg_r with (r:=r); apply Pplus_carry_plus; - assumption. -Qed. - -Lemma Pplus_carry_reg_l : - forall p q r:positive, Pplus_carry p q = Pplus_carry p r -> q = r. -Proof. - intros p q r H; apply Pplus_reg_r with (r:=p); - rewrite (Pplus_comm r), (Pplus_comm q); apply Pplus_carry_plus; assumption. -Qed. - -(** Addition on positive is associative *) - -Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r. -Proof. - induction p. - intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, - ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. - intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, - ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. - intros p r; rewrite <- 2 Pplus_one_succ_l, Pplus_succ_permute_l; auto. -Qed. - -(** Commutation of addition with the double of a positive number *) - -Lemma Pplus_xO : forall m n : positive, (m + n)~0 = m~0 + n~0. -Proof. - destruct n; destruct m; simpl; auto. -Qed. - -Lemma Pplus_xI_double_minus_one : - forall p q:positive, (p + q)~0 = p~1 + Pdouble_minus_one q. -Proof. - intros; change (p~1) with (p~0 + 1). - rewrite <- Pplus_assoc, <- Pplus_one_succ_l, Psucc_o_double_minus_one_eq_xO. - reflexivity. -Qed. - -Lemma Pplus_xO_double_minus_one : - forall p q:positive, Pdouble_minus_one (p + q) = p~0 + Pdouble_minus_one q. -Proof. - induction p as [p IHp| p IHp| ]; destruct q; simpl; - rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, - ?Pplus_xI_double_minus_one; try reflexivity. - rewrite IHp; auto. - rewrite <- Psucc_o_double_minus_one_eq_xO, Pplus_one_succ_l; reflexivity. -Qed. - -(** Misc *) - -Lemma Pplus_diag : forall p:positive, p + p = p~0. -Proof. - induction p as [p IHp| p IHp| ]; simpl; - try rewrite ?Pplus_carry_spec, ?IHp; reflexivity. -Qed. - -(**********************************************************************) -(** Peano induction and recursion on binary positive positive numbers *) -(** (a nice proof from Conor McBride, see "The view from the left") *) - -Inductive PeanoView : positive -> Type := -| PeanoOne : PeanoView 1 -| PeanoSucc : forall p, PeanoView p -> PeanoView (Psucc 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 (Psucc 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). - -Require Import Eqdep_dec EqdepFacts. - -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. - induction q as [ | p q IHq ]. - apply eq_dep_eq_positive. - cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial. - destruct p0; intros; discriminate. - trivial. - apply eq_dep_eq_positive. - cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. - intro. destruct p; discriminate. - intro. unfold p0 in H. apply Psucc_inj in H. - generalize q'. rewrite H. intro. - rewrite (IHq q'0). - trivial. - trivial. -Qed. - -Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) - (p:positive) := - PeanoView_iter P a f p (peanoView p). - -Theorem Prect_succ : forall (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (Psucc p)) (p:positive), - Prect P a f (Psucc p) = f _ (Prect P a f p). -Proof. - intros. - unfold Prect. - rewrite (PeanoViewUnique _ (peanoView (Psucc p)) (PeanoSucc _ (peanoView p))). - trivial. -Qed. - -Theorem Prect_base : forall (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (Psucc p)), Prect P a f 1 = a. -Proof. - trivial. -Qed. - -Definition Prec (P:positive->Set) := Prect P. - -(** Peano induction *) - -Definition Pind (P:positive->Prop) := Prect P. - -(** Peano case analysis *) - -Theorem Pcase : - forall P:positive -> Prop, - P 1 -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p. -Proof. - intros; apply Pind; auto. -Qed. - -(**********************************************************************) -(** Properties of multiplication on binary positive numbers *) - -(** One is right neutral for multiplication *) - -Lemma Pmult_1_r : forall p:positive, p * 1 = p. -Proof. - induction p; simpl; f_equal; auto. -Qed. - -(** Successor and multiplication *) - -Lemma Pmult_Sn_m : forall n m : positive, (Psucc n) * m = m + n * m. -Proof. - induction n as [n IHn | n IHn | ]; simpl; intro m. - rewrite IHn, Pplus_assoc, Pplus_diag, <-Pplus_xO; reflexivity. - reflexivity. - symmetry; apply Pplus_diag. -Qed. - -(** Right reduction properties for multiplication *) - -Lemma Pmult_xO_permute_r : forall p q:positive, p * q~0 = (p * q)~0. -Proof. - intros p q; induction p; simpl; do 2 (f_equal; auto). -Qed. - -Lemma Pmult_xI_permute_r : forall p q:positive, p * q~1 = p + (p * q)~0. -Proof. - intros p q; induction p as [p IHp|p IHp| ]; simpl; f_equal; auto. - rewrite IHp, 2 Pplus_assoc, (Pplus_comm p); reflexivity. -Qed. - -(** Commutativity of multiplication *) - -Theorem Pmult_comm : forall p q:positive, p * q = q * p. -Proof. - intros p q; induction q as [q IHq|q IHq| ]; simpl; try rewrite <- IHq; - auto using Pmult_xI_permute_r, Pmult_xO_permute_r, Pmult_1_r. -Qed. - -(** Distributivity of multiplication over addition *) - -Theorem Pmult_plus_distr_l : - forall p q r:positive, p * (q + r) = p * q + p * r. -Proof. - intros p q r; 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 Pplus_assoc; f_equal. - rewrite <- 2 Pplus_assoc; f_equal. - apply Pplus_comm. - f_equal; auto. - reflexivity. -Qed. - -Theorem Pmult_plus_distr_r : - forall p q r:positive, (p + q) * r = p * r + q * r. -Proof. - intros p q r; do 3 rewrite Pmult_comm with (q:=r); apply Pmult_plus_distr_l. -Qed. - -(** Associativity of multiplication *) - -Theorem Pmult_assoc : forall p q r:positive, p * (q * r) = p * q * r. -Proof. - induction p as [p IHp| p IHp | ]; simpl; intros q r. - rewrite IHp; rewrite Pmult_plus_distr_r; reflexivity. - rewrite IHp; reflexivity. - reflexivity. -Qed. - -(** Parity properties of multiplication *) - -Lemma Pmult_xI_mult_xO_discr : forall p q r:positive, p~1 * r <> q~0 * r. -Proof. - intros p q r; induction r; try discriminate. - rewrite 2 Pmult_xO_permute_r; intro H; destr_eq H; auto. -Qed. - -Lemma Pmult_xO_discr : forall p q:positive, p~0 * q <> q. -Proof. - intros p q; induction q; try discriminate. - rewrite Pmult_xO_permute_r; injection; assumption. -Qed. - -(** Simplification properties of multiplication *) - -Theorem Pmult_reg_r : forall p q r:positive, p * r = q * r -> p = q. -Proof. - induction p as [p IHp| p IHp| ]; intros [q|q| ] r H; - reflexivity || apply (f_equal (A:=positive)) || apply False_ind. - apply IHp with (r~0); simpl in *; - rewrite 2 Pmult_xO_permute_r; apply Pplus_reg_l with (1:=H). - apply Pmult_xI_mult_xO_discr with (1:=H). - simpl in H; rewrite Pplus_comm in H; apply Pplus_no_neutral with (1:=H). - symmetry in H; apply Pmult_xI_mult_xO_discr with (1:=H). - apply IHp with (r~0); simpl; rewrite 2 Pmult_xO_permute_r; assumption. - apply Pmult_xO_discr with (1:= H). - simpl in H; symmetry in H; rewrite Pplus_comm in H; - apply Pplus_no_neutral with (1:=H). - symmetry in H; apply Pmult_xO_discr with (1:=H). -Qed. - -Theorem Pmult_reg_l : forall p q r:positive, r * p = r * q -> p = q. -Proof. - intros p q r H; apply Pmult_reg_r with (r:=r). - rewrite (Pmult_comm p), (Pmult_comm q); assumption. -Qed. - -(** Inversion of multiplication *) - -Lemma Pmult_1_inversion_l : forall p q:positive, p * q = 1 -> p = 1. -Proof. - intros [p|p| ] [q|q| ] H; destr_eq H; auto. -Qed. - -(*********************************************************************) -(** Properties of boolean equality *) - -Theorem Peqb_refl : forall x:positive, Peqb x x = true. -Proof. - induction x; auto. -Qed. - -Theorem Peqb_true_eq : forall x y:positive, Peqb x y = true -> x=y. -Proof. - induction x; destruct y; simpl; intros; try discriminate. - f_equal; auto. - f_equal; auto. - reflexivity. -Qed. - -Theorem Peqb_eq : forall x y : positive, Peqb x y = true <-> x=y. -Proof. - split. apply Peqb_true_eq. - intros; subst; apply Peqb_refl. -Qed. - - -(**********************************************************************) -(** Properties of comparison on binary positive numbers *) - -Theorem Pcompare_refl : forall p:positive, (p ?= p) Eq = Eq. - induction p; auto. -Qed. - -(* A generalization of Pcompare_refl *) - -Theorem Pcompare_refl_id : forall (p : positive) (r : comparison), (p ?= p) r = r. - induction p; auto. -Qed. - -Theorem Pcompare_not_Eq : - forall p q:positive, (p ?= q) Gt <> Eq /\ (p ?= q) Lt <> Eq. -Proof. - induction p as [p IHp| p IHp| ]; intros [q| q| ]; split; simpl; auto; - discriminate || (elim (IHp q); auto). -Qed. - -Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q. -Proof. - induction p; intros [q| q| ] H; simpl in *; auto; - try discriminate H; try (f_equal; auto; fail). - destruct (Pcompare_not_Eq p q) as (H',_); elim H'; auto. - destruct (Pcompare_not_Eq p q) as (_,H'); elim H'; auto. -Qed. - -Lemma Pcompare_eq_iff : forall p q:positive, (p ?= q) Eq = Eq <-> p = q. -Proof. - split. - apply Pcompare_Eq_eq. - intros; subst; apply Pcompare_refl. -Qed. - -Lemma Pcompare_Gt_Lt : - forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt. -Proof. - induction p; intros [q|q| ] H; simpl; auto; discriminate. -Qed. - -Lemma Pcompare_eq_Lt : - forall p q : positive, (p ?= q) Eq = Lt <-> (p ?= q) Gt = Lt. -Proof. - intros p q; split; [| apply Pcompare_Gt_Lt]. - revert q; induction p; intros [q|q| ] H; simpl; auto; discriminate. -Qed. - -Lemma Pcompare_Lt_Gt : - forall p q:positive, (p ?= q) Lt = Gt -> (p ?= q) Eq = Gt. -Proof. - induction p; intros [q|q| ] H; simpl; auto; discriminate. -Qed. - -Lemma Pcompare_eq_Gt : - forall p q : positive, (p ?= q) Eq = Gt <-> (p ?= q) Lt = Gt. -Proof. - intros p q; split; [| apply Pcompare_Lt_Gt]. - revert q; induction p; intros [q|q| ] H; simpl; auto; discriminate. -Qed. - -Lemma Pcompare_Lt_Lt : - forall p q:positive, (p ?= q) Lt = Lt -> (p ?= q) Eq = Lt \/ p = q. -Proof. - induction p as [p IHp| p IHp| ]; intros [q|q| ] H; simpl in *; auto; - destruct (IHp q H); subst; auto. -Qed. - -Lemma Pcompare_Lt_eq_Lt : - forall p q:positive, (p ?= q) Lt = Lt <-> (p ?= q) Eq = Lt \/ p = q. -Proof. - intros p q; split; [apply Pcompare_Lt_Lt |]. - intros [H|H]; [|subst; apply Pcompare_refl_id]. - revert q H; induction p; intros [q|q| ] H; simpl in *; - auto; discriminate. -Qed. - -Lemma Pcompare_Gt_Gt : - forall p q:positive, (p ?= q) Gt = Gt -> (p ?= q) Eq = Gt \/ p = q. -Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; - destruct (IHp q H); subst; auto. -Qed. - -Lemma Pcompare_Gt_eq_Gt : - forall p q:positive, (p ?= q) Gt = Gt <-> (p ?= q) Eq = Gt \/ p = q. -Proof. - intros p q; split; [apply Pcompare_Gt_Gt |]. - intros [H|H]; [|subst; apply Pcompare_refl_id]. - revert q H; induction p; intros [q|q| ] H; simpl in *; - auto; discriminate. -Qed. - -Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. -Proof. - destruct r; auto. -Qed. - -Ltac ElimPcompare c1 c2 := - elim (Dcompare ((c1 ?= c2) Eq)); - [ idtac | let x := fresh "H" in (intro x; case x; clear x) ]. - -Lemma Pcompare_antisym : - forall (p q:positive) (r:comparison), - CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r). -Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; - rewrite IHp; auto. -Qed. - -Lemma ZC1 : forall p q:positive, (p ?= q) Eq = Gt -> (q ?= p) Eq = Lt. -Proof. - intros p q H; change Eq with (CompOpp Eq). - rewrite <- Pcompare_antisym, H; reflexivity. -Qed. - -Lemma ZC2 : forall p q:positive, (p ?= q) Eq = Lt -> (q ?= p) Eq = Gt. -Proof. - intros p q H; change Eq with (CompOpp Eq). - rewrite <- Pcompare_antisym, H; reflexivity. -Qed. - -Lemma ZC3 : forall p q:positive, (p ?= q) Eq = Eq -> (q ?= p) Eq = Eq. -Proof. - intros p q H; change Eq with (CompOpp Eq). - rewrite <- Pcompare_antisym, H; reflexivity. -Qed. - -Lemma ZC4 : forall p q:positive, (p ?= q) Eq = CompOpp ((q ?= p) Eq). -Proof. - intros; change Eq at 1 with (CompOpp Eq). - symmetry; apply Pcompare_antisym. -Qed. - -Lemma Pcompare_spec : forall p q, CompSpec eq Plt p q ((p ?= q) Eq). -Proof. - intros. destruct ((p ?= q) Eq) as [ ]_eqn; constructor. - apply Pcompare_Eq_eq; auto. - auto. - apply ZC1; auto. -Qed. - - -(** Comparison and the successor *) - -Lemma Pcompare_p_Sp : forall p : positive, (p ?= Psucc p) Eq = Lt. -Proof. - induction p; simpl in *; - [ elim (Pcompare_eq_Lt p (Psucc p)); auto | - apply Pcompare_refl_id | reflexivity]. -Qed. - -Theorem Pcompare_p_Sq : forall p q : positive, - (p ?= Psucc q) Eq = Lt <-> (p ?= q) Eq = Lt \/ p = q. -Proof. - intros p q; split. - (* -> *) - revert p q; induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; - try (left; reflexivity); try (right; reflexivity). - destruct (IHp q (Pcompare_Gt_Lt _ _ H)); subst; auto. - destruct (Pcompare_eq_Lt p q); auto. - destruct p; discriminate. - left; destruct (IHp q H); - [ elim (Pcompare_Lt_eq_Lt p q); auto | subst; apply Pcompare_refl_id]. - destruct (Pcompare_Lt_Lt p q H); subst; auto. - destruct p; discriminate. - (* <- *) - intros [H|H]; [|subst; apply Pcompare_p_Sp]. - revert q H; induction p; intros [q|q| ] H; simpl in *; - auto; try discriminate. - destruct (Pcompare_eq_Lt p (Psucc q)); auto. - apply Pcompare_Gt_Lt; auto. - destruct (Pcompare_Lt_Lt p q H); subst; auto using Pcompare_p_Sp. - destruct (Pcompare_Lt_eq_Lt p q); auto. -Qed. - -(** 1 is the least positive number *) - -Lemma Pcompare_1 : forall p, ~ (p ?= 1) Eq = Lt. -Proof. - destruct p; discriminate. -Qed. - -(** Properties of the strict order on positive numbers *) - -Lemma Plt_1 : forall p, ~ p < 1. -Proof. - exact Pcompare_1. -Qed. - -Lemma Plt_lt_succ : forall n m : positive, n < m -> n < Psucc m. -Proof. - unfold Plt; intros n m H; apply <- Pcompare_p_Sq; auto. -Qed. - -Lemma Plt_irrefl : forall p : positive, ~ p < p. -Proof. - unfold Plt; intro p; rewrite Pcompare_refl; discriminate. -Qed. - -Lemma Plt_trans : forall n m p : positive, n < m -> m < p -> n < p. -Proof. - intros n m p; induction p using Pind; intros H H0. - elim (Plt_1 _ H0). - apply Plt_lt_succ. - destruct (Pcompare_p_Sq m p) as (H',_); destruct (H' H0); subst; auto. -Qed. - -Theorem Plt_ind : forall (A : positive -> Prop) (n : positive), - A (Psucc n) -> - (forall m : positive, n < m -> A m -> A (Psucc m)) -> - forall m : positive, n < m -> A m. -Proof. - intros A n AB AS m. induction m using Pind; intros H. - elim (Plt_1 _ H). - destruct (Pcompare_p_Sq n m) as (H',_); destruct (H' H); subst; auto. -Qed. - -Lemma Ple_lteq : forall p q, p <= q <-> p < q \/ p = q. -Proof. - unfold Ple, Plt. intros. - generalize (Pcompare_eq_iff p q). - destruct ((p ?= q) Eq); intuition; discriminate. -Qed. - - -(**********************************************************************) -(** Properties of subtraction on binary positive numbers *) - -Lemma Ppred_minus : forall p, Ppred p = Pminus p 1. -Proof. - destruct p; auto. -Qed. - -Definition Ppred_mask (p : positive_mask) := -match p with -| IsPos 1 => IsNul -| IsPos q => IsPos (Ppred q) -| IsNul => IsNeg -| IsNeg => IsNeg -end. - -Lemma Pminus_mask_succ_r : - forall p q : positive, Pminus_mask p (Psucc q) = Pminus_mask_carry p q. -Proof. - induction p ; destruct q; simpl; f_equal; auto; destruct p; auto. -Qed. - -Theorem Pminus_mask_carry_spec : - forall p q : positive, Pminus_mask_carry p q = Ppred_mask (Pminus_mask p q). -Proof. - induction p as [p IHp|p IHp| ]; destruct q; simpl; - try reflexivity; try rewrite IHp; - destruct (Pminus_mask p q) as [|[r|r| ]|] || destruct p; auto. -Qed. - -Theorem Pminus_succ_r : forall p q : positive, p - (Psucc q) = Ppred (p - q). -Proof. - intros p q; unfold Pminus; - rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec. - destruct (Pminus_mask p q) as [|[r|r| ]|]; auto. -Qed. - -Lemma double_eq_zero_inversion : - forall p:positive_mask, Pdouble_mask p = IsNul -> p = IsNul. -Proof. - destruct p; simpl; intros; trivial; discriminate. -Qed. - -Lemma double_plus_one_zero_discr : - forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul. -Proof. - destruct p; discriminate. -Qed. - -Lemma double_plus_one_eq_one_inversion : - forall p:positive_mask, Pdouble_plus_one_mask p = IsPos 1 -> p = IsNul. -Proof. - destruct p; simpl; intros; trivial; discriminate. -Qed. - -Lemma double_eq_one_discr : - forall p:positive_mask, Pdouble_mask p <> IsPos 1. -Proof. - destruct p; discriminate. -Qed. - -Theorem Pminus_mask_diag : forall p:positive, Pminus_mask p p = IsNul. -Proof. - induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto. -Qed. - -Lemma Pminus_mask_carry_diag : forall p, Pminus_mask_carry p p = IsNeg. -Proof. - induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto. -Qed. - -Lemma Pminus_mask_IsNeg : forall p q:positive, - Pminus_mask p q = IsNeg -> Pminus_mask_carry p q = IsNeg. -Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; - try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; - specialize IHp with q. - destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto. - destruct (Pminus_mask p q); simpl; auto; try discriminate. - destruct (Pminus_mask_carry p q); simpl; auto; try discriminate. - destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto. -Qed. - -Lemma ZL10 : - forall p q:positive, - Pminus_mask p q = IsPos 1 -> Pminus_mask_carry p q = IsNul. -Proof. - induction p; intros [q|q| ] H; simpl in *; try discriminate. - elim (double_eq_one_discr _ H). - rewrite (double_plus_one_eq_one_inversion _ H); auto. - rewrite (double_plus_one_eq_one_inversion _ H); auto. - elim (double_eq_one_discr _ H). - destruct p; simpl; auto; discriminate. -Qed. - -(** Properties of subtraction valid only for x>y *) - -Lemma Pminus_mask_Gt : - forall p q:positive, - (p ?= q) Eq = Gt -> - exists h : positive, - Pminus_mask p q = IsPos h /\ - q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred h)). -Proof. - induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; - try discriminate H. - (* p~1, q~1 *) - destruct (IHp q H) as (r & U & V & W); exists (r~0); rewrite ?U, ?V; auto. - repeat split; auto; right. - destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]]. - rewrite ZL10; subst; auto. - rewrite W; simpl; destruct r; auto; elim NE; auto. - (* p~1, q~0 *) - destruct (Pcompare_Gt_Gt _ _ H) as [H'|H']; clear H; rename H' into H. - destruct (IHp q H) as (r & U & V & W); exists (r~1); rewrite ?U, ?V; auto. - exists 1; subst; rewrite Pminus_mask_diag; auto. - (* p~1, 1 *) - exists (p~0); auto. - (* p~0, q~1 *) - destruct (IHp q (Pcompare_Lt_Gt _ _ H)) as (r & U & V & W). - destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]]. - exists 1; subst; rewrite ZL10, Pplus_one_succ_r; auto. - exists ((Ppred r)~1); rewrite W, Pplus_carry_pred_eq_plus, V; auto. - (* p~0, q~0 *) - destruct (IHp q H) as (r & U & V & W); exists (r~0); rewrite ?U, ?V; auto. - repeat split; auto; right. - destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]]. - rewrite ZL10; subst; auto. - rewrite W; simpl; destruct r; auto; elim NE; auto. - (* p~0, 1 *) - exists (Pdouble_minus_one p); repeat split; destruct p; simpl; auto. - rewrite Psucc_o_double_minus_one_eq_xO; auto. -Qed. - -Theorem Pplus_minus : - forall p q:positive, (p ?= q) Eq = Gt -> q + (p - q) = p. -Proof. - intros p q H; destruct (Pminus_mask_Gt p q H) as (r & U & V & _). - unfold Pminus; rewrite U; simpl; auto. -Qed. - -(** When x<y, the substraction of x by y returns 1 *) - -Lemma Pminus_mask_Lt : forall p q:positive, p<q -> Pminus_mask p q = IsNeg. -Proof. - unfold Plt; induction p as [p IHp|p IHp| ]; destruct q; simpl; intros; - try discriminate; try rewrite IHp; auto. - apply Pcompare_Gt_Lt; auto. - destruct (Pcompare_Lt_Lt _ _ H). - rewrite Pminus_mask_IsNeg; simpl; auto. - subst; rewrite Pminus_mask_carry_diag; auto. -Qed. - -Lemma Pminus_Lt : forall p q:positive, p<q -> p-q = 1. -Proof. - intros; unfold Plt, Pminus; rewrite Pminus_mask_Lt; auto. -Qed. - -(** The substraction of x by x returns 1 *) - -Lemma Pminus_Eq : forall p:positive, p-p = 1. -Proof. - intros; unfold Pminus; rewrite Pminus_mask_diag; auto. -Qed. - -(** Number of digits in a number *) - -Fixpoint Psize (p:positive) : nat := - match p with - | 1 => S O - | p~1 => S (Psize p) - | p~0 => S (Psize p) - end. - -Lemma Psize_monotone : forall p q, (p?=q) Eq = Lt -> (Psize p <= Psize q)%nat. -Proof. - assert (le0 : forall n, (0<=n)%nat) by (induction n; auto). - assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). - induction p; destruct q; simpl; auto; intros; try discriminate. - intros; generalize (Pcompare_Gt_Lt _ _ H); auto. - intros; destruct (Pcompare_Lt_Lt _ _ H); auto; subst; auto. -Qed. - - - - - diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index 48f78c50..4a5f4ee1 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -1,18 +1,33 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArith.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Library for binary natural numbers *) +Require Export BinNums. Require Export BinPos. Require Export BinNat. Require Export Nnat. +Require Export Ndiv_def. +Require Export Nsqrt_def. +Require Export Ngcd_def. Require Export Ndigits. - Require Export NArithRing. + +(** [N] contains an [order] tactic for natural numbers *) + +(** Note that [N.order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + +Local Open Scope N_scope. + +Section TestOrder. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + N.order. + Qed. +End TestOrder. diff --git a/theories/NArith/NOrderedType.v b/theories/NArith/NOrderedType.v deleted file mode 100644 index f1ab4b23..00000000 --- a/theories/NArith/NOrderedType.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import BinNat Equalities Orders OrdersTac. - -Local Open Scope N_scope. - -(** * DecidableType structure for [N] binary natural numbers *) - -Module N_as_UBE <: UsualBoolEq. - Definition t := N. - Definition eq := @eq N. - Definition eqb := Neqb. - Definition eqb_eq := Neqb_eq. -End N_as_UBE. - -Module N_as_DT <: UsualDecidableTypeFull := Make_UDTF N_as_UBE. - -(** Note that the last module fulfills by subtyping many other - interfaces, such as [DecidableType] or [EqualityType]. *) - - - -(** * OrderedType structure for [N] numbers *) - -Module N_as_OT <: OrderedTypeFull. - Include N_as_DT. - Definition lt := Nlt. - Definition le := Nle. - Definition compare := Ncompare. - - Instance lt_strorder : StrictOrder Nlt. - Proof. split; [ exact Nlt_irrefl | exact Nlt_trans ]. Qed. - - Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Nlt. - Proof. repeat red; intros; subst; auto. Qed. - - Definition le_lteq := Nle_lteq. - Definition compare_spec := Ncompare_spec. - -End N_as_OT. - -(** Note that [N_as_OT] can also be seen as a [UsualOrderedType] - and a [OrderedType] (and also as a [DecidableType]). *) - - - -(** * An [order] tactic for [N] numbers *) - -Module NOrder := OTF_to_OrderTac N_as_OT. -Ltac n_order := NOrder.order. - -(** Note that [n_order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) - diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index 0e1c3de0..f2ee29cc 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Bool. Require Import Sumbool. Require Import Arith. @@ -29,14 +27,14 @@ Proof. intros. now apply (Peqb_eq p p'). Qed. -Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq. +Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pos.compare p p' = Eq. Proof. - intros. now rewrite Pcompare_eq_iff, <- Peqb_eq. + intros. now rewrite Pos.compare_eq_iff, <- Peqb_eq. Qed. -Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true. +Lemma Pcompare_Peqb : forall p p', Pos.compare p p' = Eq -> Peqb p p' = true. Proof. - intros; now rewrite Peqb_eq, <- Pcompare_eq_iff. + intros; now rewrite Peqb_eq, <- Pos.compare_eq_iff. Qed. Lemma Neqb_correct : forall n, Neqb n n = true. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index 6b490dfc..b0c33595 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -1,320 +1,253 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndigits.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Import Bool Morphisms Setoid Bvector BinPos BinNat Wf_nat + Pnat Nnat Compare_dec Lt Minus. -Require Import Bool. -Require Import Bvector. -Require Import BinPos. -Require Import BinNat. +Local Open Scope N_scope. -(** Operation over bits of a [N] number. *) +(** This file is mostly obsolete, see directly [BinNat] now. *) -(** [xor] *) +(** Compatibility names for some bitwise operations *) -Fixpoint Pxor (p1 p2:positive) : N := - match p1, p2 with - | xH, xH => N0 - | xH, xO p2 => Npos (xI p2) - | xH, xI p2 => Npos (xO p2) - | xO p1, xH => Npos (xI p1) - | xO p1, xO p2 => Ndouble (Pxor p1 p2) - | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2) - | xI p1, xH => Npos (xO p1) - | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2) - | xI p1, xI p2 => Ndouble (Pxor p1 p2) - end. +Notation Pxor := Pos.lxor (only parsing). +Notation Nxor := N.lxor (only parsing). +Notation Pbit := Pos.testbit_nat (only parsing). +Notation Nbit := N.testbit_nat (only parsing). -Definition Nxor (n n':N) := - match n, n' with - | N0, _ => n' - | _, N0 => n - | Npos p, Npos p' => Pxor p p' - end. +Notation Nxor_eq := N.lxor_eq (only parsing). +Notation Nxor_comm := N.lxor_comm (only parsing). +Notation Nxor_assoc := N.lxor_assoc (only parsing). +Notation Nxor_neutral_left := N.lxor_0_l (only parsing). +Notation Nxor_neutral_right := N.lxor_0_r (only parsing). +Notation Nxor_nilpotent := N.lxor_nilpotent (only parsing). -Lemma Nxor_neutral_left : forall n:N, Nxor N0 n = n. +(** Equivalence of bit-testing functions, + either with index in [N] or in [nat]. *) + +Lemma Ptestbit_Pbit : + forall p n, Pos.testbit p (N.of_nat n) = Pbit p n. Proof. - trivial. + induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial; + rewrite <- IH; f_equal; rewrite (pred_Sn n) at 2; now rewrite N_of_pred. Qed. -Lemma Nxor_neutral_right : forall n:N, Nxor n N0 = n. +Lemma Ntestbit_Nbit : forall a n, N.testbit a (N.of_nat n) = Nbit a n. Proof. - destruct n; trivial. + destruct a. trivial. apply Ptestbit_Pbit. Qed. -Lemma Nxor_comm : forall n n':N, Nxor n n' = Nxor n' n. +Lemma Pbit_Ptestbit : + forall p n, Pbit p (N.to_nat n) = Pos.testbit p n. Proof. - destruct n; destruct n'; simpl; auto. - generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl; - auto. - destruct p0; trivial; rewrite Hrecp; trivial. - destruct p0; trivial; rewrite Hrecp; trivial. - destruct p0 as [p| p| ]; simpl; auto. + intros; now rewrite <- Ptestbit_Pbit, N2Nat.id. Qed. -Lemma Nxor_nilpotent : forall n:N, Nxor n n = N0. +Lemma Nbit_Ntestbit : + forall a n, Nbit a (N.to_nat n) = N.testbit a n. Proof. - destruct n; trivial. - simpl. induction p as [p IHp| p IHp| ]; trivial. - simpl. rewrite IHp; reflexivity. - simpl. rewrite IHp; reflexivity. + destruct a. trivial. apply Pbit_Ptestbit. Qed. -(** Checking whether a particular bit is set on not *) - -Fixpoint Pbit (p:positive) : nat -> bool := - match p with - | xH => fun n:nat => match n with - | O => true - | S _ => false - end - | xO p => - fun n:nat => match n with - | O => false - | S n' => Pbit p n' - end - | xI p => fun n:nat => match n with - | O => true - | S n' => Pbit p n' - end - end. +(** Equivalence of shifts, index in [N] or [nat] *) -Definition Nbit (a:N) := - match a with - | N0 => fun _ => false - | Npos p => Pbit p - end. +Lemma Nshiftr_nat_S : forall a n, + N.shiftr_nat a (S n) = N.div2 (N.shiftr_nat a n). +Proof. + reflexivity. +Qed. -(** Auxiliary results about streams of bits *) +Lemma Nshiftl_nat_S : forall a n, + N.shiftl_nat a (S n) = N.double (N.shiftl_nat a n). +Proof. + reflexivity. +Qed. -Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n. +Lemma Nshiftr_nat_equiv : + forall a n, N.shiftr_nat a (N.to_nat n) = N.shiftr a n. +Proof. + intros a [|n]; simpl. unfold N.shiftr_nat. + trivial. + symmetry. apply iter_nat_of_P. +Qed. -Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f. +Lemma Nshiftr_equiv_nat : + forall a n, N.shiftr a (N.of_nat n) = N.shiftr_nat a n. Proof. - unfold eqf. intros. rewrite H. reflexivity. + intros. now rewrite <- Nshiftr_nat_equiv, Nat2N.id. Qed. -Lemma eqf_refl : forall f:nat -> bool, eqf f f. +Lemma Nshiftl_nat_equiv : + forall a n, N.shiftl_nat a (N.to_nat n) = N.shiftl a n. Proof. - unfold eqf. trivial. + intros [|a] [|n]; simpl; unfold N.shiftl_nat; trivial. + apply nat_iter_invariant; intros; now subst. + rewrite <- Pos2Nat.inj_iter. symmetry. now apply Pos.iter_swap_gen. Qed. -Lemma eqf_trans : - forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''. +Lemma Nshiftl_equiv_nat : + forall a n, N.shiftl a (N.of_nat n) = N.shiftl_nat a n. Proof. - unfold eqf. intros. rewrite H. exact (H0 n). + intros. now rewrite <- Nshiftl_nat_equiv, Nat2N.id. Qed. -Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n). +(** Correctness proofs for shifts, nat version *) -Lemma xorf_eq : - forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'. +Lemma Nshiftr_nat_spec : forall a n m, + Nbit (N.shiftr_nat a n) m = Nbit a (m+n). Proof. - unfold eqf, xorf. intros. apply xorb_eq, H. + induction n; intros m. + now rewrite <- plus_n_O. + simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn, Nshiftr_nat_S. + destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial. Qed. -Lemma xorf_assoc : - forall f f' f'', - eqf (xorf (xorf f f') f'') (xorf f (xorf f' f'')). +Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat -> + Nbit (N.shiftl_nat a n) m = Nbit a (m-n). Proof. - unfold eqf, xorf. intros. apply xorb_assoc. + induction n; intros m H. + now rewrite <- minus_n_O. + destruct m. inversion H. apply le_S_n in H. + simpl. rewrite <- IHn, Nshiftl_nat_S; trivial. + destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial. Qed. -Lemma eqf_xorf : - forall f f' f'' f''', - eqf f f' -> eqf f'' f''' -> eqf (xorf f f'') (xorf f' f'''). +Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat -> + Nbit (N.shiftl_nat a n) m = false. Proof. - unfold eqf, xorf. intros. rewrite H. rewrite H0. reflexivity. + induction n; intros m H. inversion H. + rewrite Nshiftl_nat_S. + destruct m. + destruct (N.shiftl_nat a n); trivial. + specialize (IHn m (lt_S_n _ _ H)). + destruct (N.shiftl_nat a n); trivial. Qed. -(** End of auxilliary results *) +(** A left shift for positive numbers (used in BigN) *) + +Lemma Pshiftl_nat_0 : forall p, Pos.shiftl_nat p 0 = p. +Proof. reflexivity. Qed. -(** This part is aimed at proving that if two numbers produce - the same stream of bits, then they are equal. *) +Lemma Pshiftl_nat_S : + forall p n, Pos.shiftl_nat p (S n) = xO (Pos.shiftl_nat p n). +Proof. reflexivity. Qed. -Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a. +Lemma Pshiftl_nat_N : + forall p n, Npos (Pos.shiftl_nat p n) = N.shiftl_nat (Npos p) n. Proof. - destruct a. trivial. - induction p as [p IHp| p IHp| ]; intro H. - absurd (N0 = Npos p). discriminate. - exact (IHp (fun n => H (S n))). - absurd (N0 = Npos p). discriminate. - exact (IHp (fun n => H (S n))). - absurd (false = true). discriminate. - exact (H 0). + unfold Pos.shiftl_nat, N.shiftl_nat. + induction n; simpl; auto. now rewrite <- IHn. Qed. -Lemma Nbit_faithful_2 : - forall a:N, eqf (Nbit (Npos 1)) (Nbit a) -> Npos 1 = a. +Lemma Pshiftl_nat_plus : forall n m p, + Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m. Proof. - destruct a. intros. absurd (true = false). discriminate. - exact (H 0). - destruct p. intro H. absurd (N0 = Npos p). discriminate. - exact (Nbit_faithful_1 (Npos p) (fun n:nat => H (S n))). - intros. absurd (true = false). discriminate. - exact (H 0). - trivial. + induction m; simpl; intros. reflexivity. + rewrite 2 Pshiftl_nat_S. now f_equal. +Qed. + +(** Semantics of bitwise operations with respect to [Nbit] *) + +Lemma Pxor_semantics p p' n : + Nbit (Pos.lxor p p') n = xorb (Pbit p n) (Pbit p' n). +Proof. + rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_lxor_spec. Qed. -Lemma Nbit_faithful_3 : - forall (a:N) (p:positive), - (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> - eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a. +Lemma Nxor_semantics a a' n : + Nbit (N.lxor a a') n = xorb (Nbit a n) (Nbit a' n). Proof. - destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))). - intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity. - unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity. - destruct p. discriminate (H0 O). - rewrite (H p (fun n => H0 (S n))). reflexivity. - discriminate (H0 0). + rewrite <- !Ntestbit_Nbit. apply N.lxor_spec. Qed. -Lemma Nbit_faithful_4 : - forall (a:N) (p:positive), - (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> - eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a. +Lemma Por_semantics p p' n : + Pbit (Pos.lor p p') n = (Pbit p n) || (Pbit p' n). Proof. - destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))). - intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity. - intro. rewrite H0. reflexivity. - destruct p. rewrite (H p (fun n:nat => H0 (S n))). reflexivity. - discriminate (H0 0). - cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))). - intro. discriminate (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))). - intro. rewrite H0. reflexivity. + rewrite <- !Ptestbit_Pbit. apply N.pos_lor_spec. Qed. -Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'. +Lemma Nor_semantics a a' n : + Nbit (N.lor a a') n = (Nbit a n) || (Nbit a' n). Proof. - destruct a. exact Nbit_faithful_1. - induction p. intros a' H. apply Nbit_faithful_4. intros. - assert (Npos p = Npos p') by exact (IHp (Npos p') H0). - inversion H1. reflexivity. - assumption. - intros. apply Nbit_faithful_3. intros. - assert (Npos p = Npos p') by exact (IHp (Npos p') H0). - inversion H1. reflexivity. - assumption. - exact Nbit_faithful_2. + rewrite <- !Ntestbit_Nbit. apply N.lor_spec. Qed. -(** We now describe the semantics of [Nxor] in terms of bit streams. *) +Lemma Pand_semantics p p' n : + Nbit (Pos.land p p') n = (Pbit p n) && (Pbit p' n). +Proof. + rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_land_spec. +Qed. -Lemma Nxor_sem_1 : forall a':N, Nbit (Nxor N0 a') 0 = Nbit a' 0. +Lemma Nand_semantics a a' n : + Nbit (N.land a a') n = (Nbit a n) && (Nbit a' n). Proof. - trivial. + rewrite <- !Ntestbit_Nbit. apply N.land_spec. Qed. -Lemma Nxor_sem_2 : - forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0). +Lemma Pdiff_semantics p p' n : + Nbit (Pos.ldiff p p') n = (Pbit p n) && negb (Pbit p' n). Proof. - intro. destruct a'. trivial. - destruct p; trivial. + rewrite <- Ntestbit_Nbit, <- !Ptestbit_Pbit. apply N.pos_ldiff_spec. +Qed. + +Lemma Ndiff_semantics a a' n : + Nbit (N.ldiff a a') n = (Nbit a n) && negb (Nbit a' n). +Proof. + rewrite <- !Ntestbit_Nbit. apply N.ldiff_spec. Qed. -Lemma Nxor_sem_3 : - forall (p:positive) (a':N), - Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0. +(** Equality over functional streams of bits *) + +Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n. + +Program Instance eqf_equiv : Equivalence eqf. + +Local Infix "==" := eqf (at level 70, no associativity). + +(** If two numbers produce the same stream of bits, they are equal. *) + +Local Notation Step H := (fun n => H (S n)). + +Lemma Pbit_faithful_0 : forall p, ~(Pbit p == (fun _ => false)). Proof. - intros. destruct a'. trivial. - simpl. destruct p0; trivial. - destruct (Pxor p p0); trivial. - destruct (Pxor p p0); trivial. + induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O). + apply (IHp (Step H)). Qed. -Lemma Nxor_sem_4 : - forall (p:positive) (a':N), - Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0). +Lemma Pbit_faithful : forall p p', Pbit p == Pbit p' -> p = p'. Proof. - intros. destruct a'. trivial. - simpl. destruct p0; trivial. - destruct (Pxor p p0); trivial. - destruct (Pxor p p0); trivial. + induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial; + try discriminate (H O). + f_equal. apply (IHp _ (Step H)). + destruct (Pbit_faithful_0 _ (Step H)). + f_equal. apply (IHp _ (Step H)). + symmetry in H. destruct (Pbit_faithful_0 _ (Step H)). Qed. -Lemma Nxor_sem_5 : - forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0. +Lemma Nbit_faithful : forall n n', Nbit n == Nbit n' -> n = n'. Proof. - destruct a; intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial. - destruct p. apply Nxor_sem_4. - change (Nbit (Nxor (Npos (xO p)) a') 0 = xorb false (Nbit a' 0)). - rewrite false_xorb. apply Nxor_sem_3. apply Nxor_sem_2. + intros [|p] [|p'] H; trivial. + symmetry in H. destruct (Pbit_faithful_0 _ H). + destruct (Pbit_faithful_0 _ H). + f_equal. apply Pbit_faithful, H. Qed. -Lemma Nxor_sem_6 : - forall n:nat, - (forall a a':N, Nbit (Nxor a a') n = xorf (Nbit a) (Nbit a') n) -> - forall a a':N, - Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n). +Lemma Nbit_faithful_iff : forall n n', Nbit n == Nbit n' <-> n = n'. Proof. - intros. -(* pose proof (fun p1 p2 => H (Npos p1) (Npos p2)) as H'. clear H. rename H' into H.*) - generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H. - unfold xorf in *. - destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity. - destruct a' as [|p0]. - simpl Nbit; rewrite xorb_false. reflexivity. - destruct p. destruct p0; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p p0); trivial. - rewrite <- H; simpl; case (Pxor p p0); trivial. - rewrite xorb_false. reflexivity. - destruct p0; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p p0); trivial. - rewrite <- H; simpl; case (Pxor p p0); trivial. - rewrite xorb_false. reflexivity. - simpl Nbit. rewrite false_xorb. destruct p0; trivial. -Qed. - -Lemma Nxor_semantics : - forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')). -Proof. - unfold eqf. intros; generalize a, a'. induction n. - apply Nxor_sem_5. apply Nxor_sem_6; assumption. -Qed. - -(** Consequences: - - only equal numbers lead to a null xor - - xor is associative -*) - -Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'. -Proof. - intros. apply Nbit_faithful, xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')). - apply eqf_sym, Nxor_semantics. - rewrite H. unfold eqf. trivial. -Qed. - -Lemma Nxor_assoc : - forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a''). -Proof. - intros. apply Nbit_faithful. - apply eqf_trans with (xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')). - apply eqf_trans with (xorf (Nbit (Nxor a a')) (Nbit a'')). - apply Nxor_semantics. - apply eqf_xorf. apply Nxor_semantics. - apply eqf_refl. - apply eqf_trans with (xorf (Nbit a) (xorf (Nbit a') (Nbit a''))). - apply xorf_assoc. - apply eqf_trans with (xorf (Nbit a) (Nbit (Nxor a' a''))). - apply eqf_xorf. apply eqf_refl. - apply eqf_sym, Nxor_semantics. - apply eqf_sym, Nxor_semantics. + split. apply Nbit_faithful. intros; now subst. Qed. +Local Close Scope N_scope. + (** Checking whether a number is odd, i.e. if its lower bit is set. *) -Definition Nbit0 (n:N) := - match n with - | N0 => false - | Npos (xO _) => false - | _ => true - end. +Notation Nbit0 := N.odd (only parsing). Definition Nodd (n:N) := Nbit0 n = true. Definition Neven (n:N) := Nbit0 n = false. @@ -363,8 +296,8 @@ Qed. Lemma Nxor_bit0 : forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a'). Proof. - intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' 0). - unfold xorf. rewrite Nbit0_correct, Nbit0_correct. reflexivity. + intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' O). + rewrite Nbit0_correct, Nbit0_correct. reflexivity. Qed. Lemma Nxor_div2 : @@ -372,7 +305,7 @@ Lemma Nxor_div2 : Proof. intros. apply Nbit_faithful. unfold eqf. intro. rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)). - unfold xorf. rewrite 2! Ndiv2_correct. + rewrite 2! Ndiv2_correct. reflexivity. Qed. @@ -381,7 +314,8 @@ Lemma Nneg_bit0 : Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a'). Proof. intros. - rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. + rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, + xorb_nilpotent, xorb_false. reflexivity. Qed. @@ -404,7 +338,8 @@ Lemma Nsame_bit0 : Proof. intros. rewrite <- (xorb_false (Nbit0 a)). assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity. - rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. + rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. + reflexivity. Qed. (** a lexicographic order on bits, starting from the lowest bit *) @@ -511,8 +446,8 @@ Lemma Nless_trans : Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true. Proof. induction a as [|a IHa|a IHa] using N_ind_double; intros a' a'' H H0. - destruct (Nless N0 a'') as []_eqn:Heqb. trivial. - rewrite (N0_less_2 a'' Heqb), (Nless_z a') in H0. discriminate H0. + case_eq (Nless N0 a'') ; intros Heqn. trivial. + rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0. induction a' as [|a' _|a' _] using N_ind_double. rewrite (Nless_z (Ndouble a)) in H. discriminate H. rewrite (Nless_def_1 a a') in H. @@ -539,10 +474,10 @@ Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. induction a using N_rec_double; intro a'. - destruct (Nless N0 a') as []_eqn:Heqb. left. left. auto. + case_eq (Nless N0 a') ; intros Heqb. left. left. auto. right. rewrite (N0_less_2 a' Heqb). reflexivity. induction a' as [|a' _|a' _] using N_rec_double. - destruct (Nless N0 (Ndouble a)) as []_eqn:Heqb. left. right. auto. + case_eq (Nless N0 (Ndouble a)) ; intros Heqb. left. right. auto. right. exact (N0_less_2 _ Heqb). rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->]. left. assumption. @@ -558,11 +493,7 @@ Qed. (** Number of digits in a number *) -Definition Nsize (n:N) : nat := match n with - | N0 => 0%nat - | Npos p => Psize p - end. - +Notation Nsize := N.size_nat (only parsing). (** conversions between N and bit vectors. *) @@ -581,9 +512,9 @@ Definition N2Bv (n:N) : Bvector (Nsize n) := Fixpoint Bv2N (n:nat)(bv:Bvector n) : N := match bv with - | Vnil => N0 - | Vcons false n bv => Ndouble (Bv2N n bv) - | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) + | Vector.nil => N0 + | Vector.cons false n bv => Ndouble (Bv2N n bv) + | Vector.cons true n bv => Ndouble_plus_one (Bv2N n bv) end. Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. @@ -599,13 +530,12 @@ Qed. Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n. Proof. -induction n; intros. -rewrite (V0_eq _ bv); simpl; auto. -rewrite (VSn_eq _ _ bv); simpl. -specialize IHn with (Vtail _ _ bv). -destruct (Vhead _ _ bv); - destruct (Bv2N n (Vtail bool n bv)); - simpl; auto with arith. +induction bv; intros. +auto. +simpl. +destruct h; + destruct (Bv2N n bv); + simpl ; auto with arith. Qed. (** In the previous lemma, we can only replace the inequality by @@ -615,15 +545,10 @@ Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), Bsign _ bv = true <-> Nsize (Bv2N _ bv) = (S n). Proof. -induction n; intro. -rewrite (VSn_eq _ _ bv); simpl. -rewrite (V0_eq _ (Vtail _ _ bv)); simpl. -destruct (Vhead _ _ bv); simpl; intuition; try discriminate. -rewrite (VSn_eq _ _ bv); simpl. -generalize (IHn (Vtail _ _ bv)); clear IHn. -destruct (Vhead _ _ bv); - destruct (Bv2N (S n) (Vtail bool (S n) bv)); - simpl; intuition; try discriminate. +apply Vector.rectS ; intros ; simpl. +destruct a ; compute ; split ; intros x ; now inversion x. + destruct a, (Bv2N (S n) v) ; + simpl ;intuition ; try discriminate. Qed. (** To state nonetheless a second result about composition of @@ -653,7 +578,7 @@ Qed. [a] plus some zeros. *) Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), - N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k). + N2Bv_gen (Nsize a + k) a = Vector.append (N2Bv a) (Bvect_false k). Proof. destruct a; simpl. destruct k; simpl; auto. @@ -665,13 +590,13 @@ Qed. Lemma N2Bv_Bv2N : forall n (bv:Bvector n), N2Bv_gen n (Bv2N n bv) = bv. Proof. -induction n; intros. -rewrite (V0_eq _ bv); simpl; auto. -rewrite (VSn_eq _ _ bv); simpl. -generalize (IHn (Vtail _ _ bv)); clear IHn. +induction bv; intros. +auto. +simpl. +generalize IHbv; clear IHbv. unfold Bcons. -destruct (Bv2N _ (Vtail _ _ bv)); - destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; +destruct (Bv2N _ bv); + destruct h; intro H; rewrite <- H; simpl; trivial; induction n; simpl; auto. Qed. @@ -680,31 +605,25 @@ Qed. Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), Nbit0 (Bv2N _ bv) = Blow _ bv. Proof. +apply Vector.caseS. intros. unfold Blow. -rewrite (VSn_eq _ _ bv) at 1. simpl. -destruct (Bv2N n (Vtail bool n bv)); simpl; - destruct (Vhead bool n bv); auto. +destruct (Bv2N n t); simpl; + destruct h; auto. Qed. -Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p<n -> bool. -Proof. - induction bv in p |- *. - intros. - exfalso; inversion H. - intros. - destruct p. - exact a. - apply (IHbv p); auto with arith. -Defined. +Notation Bnth := (@Vector.nth_order bool). Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n), - Bnth _ bv p H = Nbit (Bv2N _ bv) p. + Bnth bv H = Nbit (Bv2N _ bv) p. Proof. induction bv; intros. inversion H. -destruct p; simpl; destruct (Bv2N n bv); destruct a; simpl in *; auto. +destruct p ; simpl. + destruct (Bv2N n bv); destruct h; simpl in *; auto. + specialize IHbv with p (lt_S_n _ _ H). + simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto. Qed. Lemma Nbit_Nsize : forall n p, Nsize n <= p -> Nbit n p = false. @@ -716,26 +635,30 @@ inversion H. inversion H. Qed. -Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth _ (N2Bv n) p H. +Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth (N2Bv n) H. Proof. destruct n as [|n]. inversion H. -induction n; simpl in *; intros; destruct p; auto with arith. -inversion H; inversion H1. +induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto. +intros H ; destruct (lt_n_O _ (lt_S_n _ _ H)). Qed. -(** Xor is the same in the two worlds. *) +(** Binary bitwise operations are the same in the two worlds. *) Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv'). Proof. -induction n. -intros. -rewrite (V0_eq _ bv), (V0_eq _ bv'); simpl; auto. -intros. -rewrite (VSn_eq _ _ bv), (VSn_eq _ _ bv'); simpl; auto. -rewrite IHn. -destruct (Vhead bool n bv); destruct (Vhead bool n bv'); - destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto. +apply Vector.rect2 ; intros. +now simpl. +simpl. +destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl in *; rewrite H ; now simpl. Qed. +Lemma Nand_BVand : forall n (bv bv' : Bvector n), + Bv2N _ (BVand _ bv bv') = N.land (Bv2N _ bv) (Bv2N _ bv'). +Proof. +refine (@Vector.rect2 _ _ _ _ _); simpl; intros; auto. +rewrite H. +destruct a, b, (Bv2N n v1), (Bv2N n v2); + simpl; auto. +Qed. diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v index 586c1114..22adc505 100644 --- a/theories/NArith/Ndist.v +++ b/theories/NArith/Ndist.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndist.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Arith. Require Import Min. Require Import BinPos. @@ -303,7 +301,7 @@ Proof. cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit a'' k = false). intros. apply H1. reflexivity. intro a''. case a''. intro. reflexivity. - intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). unfold xorf in |- *. + intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). rewrite (Nplength_zeros (Npos p) (Pplength p) (refl_equal (Nplength (Npos p))) k H0). @@ -335,4 +333,4 @@ Proof. intro. rewrite <- H. apply Nplength_ultra. rewrite Nxor_assoc. rewrite <- (Nxor_assoc a'' a'' a'). rewrite Nxor_nilpotent. rewrite Nxor_neutral_left. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v new file mode 100644 index 00000000..559f01f1 --- /dev/null +++ b/theories/NArith/Ndiv_def.v @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinNat. +Local Open Scope N_scope. + +(** Obsolete file, see [BinNat] now, + only compatibility notations remain here. *) + +Definition Pdiv_eucl a b := N.pos_div_eucl a (Npos b). + +Definition Pdiv_eucl_correct a b : + let (q,r) := Pdiv_eucl a b in Npos a = q * Npos b + r + := N.pos_div_eucl_spec a (Npos b). + +Lemma Pdiv_eucl_remainder a b : + snd (Pdiv_eucl a b) < Npos b. +Proof. now apply (N.pos_div_eucl_remainder a (Npos b)). Qed. + +Notation Ndiv_eucl := N.div_eucl (only parsing). +Notation Ndiv := N.div (only parsing). +Notation Nmod := N.modulo (only parsing). + +Notation Ndiv_eucl_correct := N.div_eucl_spec (only parsing). +Notation Ndiv_mod_eq := N.div_mod' (only parsing). +Notation Nmod_lt := N.mod_lt (only parsing). diff --git a/theories/NArith/Ngcd_def.v b/theories/NArith/Ngcd_def.v new file mode 100644 index 00000000..13211f46 --- /dev/null +++ b/theories/NArith/Ngcd_def.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinPos BinNat. +Local Open Scope N_scope. + +(** Obsolete file, see [BinNat] now, + only compatibility notations remain here. *) + +Notation Ndivide := N.divide (only parsing). +Notation Ngcd := N.gcd (only parsing). +Notation Nggcd := N.ggcd (only parsing). +Notation Nggcd_gcd := N.ggcd_gcd (only parsing). +Notation Nggcd_correct_divisors := N.ggcd_correct_divisors (only parsing). +Notation Ngcd_divide_l := N.gcd_divide_l (only parsing). +Notation Ngcd_divide_r := N.gcd_divide_r (only parsing). +Notation Ngcd_greatest := N.gcd_greatest (only parsing). diff --git a/theories/NArith/Nminmax.v b/theories/NArith/Nminmax.v deleted file mode 100644 index 58184a4f..00000000 --- a/theories/NArith/Nminmax.v +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Orders BinNat Nnat NOrderedType GenericMinMax. - -(** * Maximum and Minimum of two [N] numbers *) - -Local Open Scope N_scope. - -(** The functions [Nmax] and [Nmin] implement indeed - a maximum and a minimum *) - -Lemma Nmax_l : forall x y, y<=x -> Nmax x y = x. -Proof. - unfold Nle, Nmax. intros x y. - generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y). - destruct (x ?= y); intuition. -Qed. - -Lemma Nmax_r : forall x y, x<=y -> Nmax x y = y. -Proof. - unfold Nle, Nmax. intros x y. destruct (x ?= y); intuition. -Qed. - -Lemma Nmin_l : forall x y, x<=y -> Nmin x y = x. -Proof. - unfold Nle, Nmin. intros x y. destruct (x ?= y); intuition. -Qed. - -Lemma Nmin_r : forall x y, y<=x -> Nmin x y = y. -Proof. - unfold Nle, Nmin. intros x y. - generalize (Ncompare_eq_correct x y). rewrite <- (Ncompare_antisym x y). - destruct (x ?= y); intuition. -Qed. - -Module NHasMinMax <: HasMinMax N_as_OT. - Definition max := Nmax. - Definition min := Nmin. - Definition max_l := Nmax_l. - Definition max_r := Nmax_r. - Definition min_l := Nmin_l. - Definition min_r := Nmin_r. -End NHasMinMax. - -Module N. - -(** We obtain hence all the generic properties of max and min. *) - -Include UsualMinMaxProperties N_as_OT NHasMinMax. - -(** * Properties specific to the [positive] domain *) - -(** Simplifications *) - -Lemma max_0_l : forall n, Nmax 0 n = n. -Proof. - intros. unfold Nmax. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n). - destruct (n ?= 0); intuition. -Qed. - -Lemma max_0_r : forall n, Nmax n 0 = n. -Proof. intros. rewrite N.max_comm. apply max_0_l. Qed. - -Lemma min_0_l : forall n, Nmin 0 n = 0. -Proof. - intros. unfold Nmin. rewrite <- Ncompare_antisym. generalize (Ncompare_0 n). - destruct (n ?= 0); intuition. -Qed. - -Lemma min_0_r : forall n, Nmin n 0 = 0. -Proof. intros. rewrite N.min_comm. apply min_0_l. Qed. - -(** Compatibilities (consequences of monotonicity) *) - -Lemma succ_max_distr : - forall n m, Nsucc (Nmax n m) = Nmax (Nsucc n) (Nsucc m). -Proof. - intros. symmetry. apply max_monotone. - intros x x'. unfold Nle. - rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc. - simpl; auto. -Qed. - -Lemma succ_min_distr : forall n m, Nsucc (Nmin n m) = Nmin (Nsucc n) (Nsucc m). -Proof. - intros. symmetry. apply min_monotone. - intros x x'. unfold Nle. - rewrite 2 nat_of_Ncompare, 2 nat_of_Nsucc. - simpl; auto. -Qed. - -Lemma plus_max_distr_l : forall n m p, Nmax (p + n) (p + m) = p + Nmax n m. -Proof. - intros. apply max_monotone. - intros x x'. unfold Nle. - rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus. - rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. -Qed. - -Lemma plus_max_distr_r : forall n m p, Nmax (n + p) (m + p) = Nmax n m + p. -Proof. - intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p). - apply plus_max_distr_l. -Qed. - -Lemma plus_min_distr_l : forall n m p, Nmin (p + n) (p + m) = p + Nmin n m. -Proof. - intros. apply min_monotone. - intros x x'. unfold Nle. - rewrite 2 nat_of_Ncompare, 2 nat_of_Nplus. - rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. -Qed. - -Lemma plus_min_distr_r : forall n m p, Nmin (n + p) (m + p) = Nmin n m + p. -Proof. - intros. rewrite (Nplus_comm n p), (Nplus_comm m p), (Nplus_comm _ p). - apply plus_min_distr_l. -Qed. - -End N.
\ No newline at end of file diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index f57fab0f..133d4c23 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -1,370 +1,232 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Nnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import Arith_base. -Require Import Compare_dec. -Require Import Sumbool. -Require Import Div2. -Require Import Min. -Require Import Max. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Import Pnat. -Require Import Zmax. -Require Import Zmin. -Require Import Znat. - -(** Translation from [N] to [nat] and back. *) - -Definition nat_of_N (a:N) := - match a with - | N0 => 0%nat - | Npos p => nat_of_P p - end. - -Definition N_of_nat (n:nat) := - match n with - | O => N0 - | S n' => Npos (P_of_succ_nat n') - end. - -Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a. -Proof. - destruct a as [| p]. reflexivity. - simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. - rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. - rewrite nat_of_P_inj with (1 := H). reflexivity. -Qed. - -Lemma nat_of_N_of_nat : forall n:nat, nat_of_N (N_of_nat n) = n. -Proof. - induction n. trivial. - intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ. -Qed. - -(** Interaction of this translation and usual operations. *) - -Lemma nat_of_Ndouble : forall a, nat_of_N (Ndouble a) = 2*(nat_of_N a). -Proof. - destruct a; simpl nat_of_N; auto. - apply nat_of_P_xO. -Qed. - -Lemma N_of_double : forall n, N_of_nat (2*n) = Ndouble (N_of_nat n). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - rewrite <- nat_of_Ndouble. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Ndouble_plus_one : - forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)). -Proof. - destruct a; simpl nat_of_N; auto. - apply nat_of_P_xI. -Qed. - -Lemma N_of_double_plus_one : - forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - rewrite <- nat_of_Ndouble_plus_one. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Nsucc : forall a, nat_of_N (Nsucc a) = S (nat_of_N a). -Proof. - destruct a; simpl. - apply nat_of_P_xH. - apply nat_of_P_succ_morphism. -Qed. - -Lemma N_of_S : forall n, N_of_nat (S n) = Nsucc (N_of_nat n). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - rewrite <- nat_of_Nsucc. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Nplus : - forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a'). -Proof. - destruct a; destruct a'; simpl; auto. - apply nat_of_P_plus_morphism. -Qed. - -Lemma N_of_plus : - forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n'). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - rewrite <- nat_of_Nplus. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Nminus : - forall a a', nat_of_N (Nminus a a') = ((nat_of_N a)-(nat_of_N a'))%nat. -Proof. - destruct a; destruct a'; simpl; auto with arith. - case_eq (Pcompare p p0 Eq); simpl; intros. - rewrite (Pcompare_Eq_eq _ _ H); auto with arith. - rewrite Pminus_mask_diag. simpl. apply minus_n_n. - rewrite Pminus_mask_Lt. pose proof (nat_of_P_lt_Lt_compare_morphism _ _ H). simpl. - symmetry; apply not_le_minus_0. auto with arith. assumption. - pose proof (Pminus_mask_Gt p p0 H) as H1. destruct H1 as [q [H1 _]]. rewrite H1; simpl. - replace q with (Pminus p p0) by (unfold Pminus; now rewrite H1). - apply nat_of_P_minus_morphism; auto. -Qed. - -Lemma N_of_minus : - forall n n', N_of_nat (n-n') = Nminus (N_of_nat n) (N_of_nat n'). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - rewrite <- nat_of_Nminus. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Nmult : - forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a'). -Proof. - destruct a; destruct a'; simpl; auto. - apply nat_of_P_mult_morphism. -Qed. +Require Import Arith_base Compare_dec Sumbool Div2 Min Max. +Require Import BinPos BinNat Pnat. -Lemma N_of_mult : - forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n'). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - rewrite <- nat_of_Nmult. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Ndiv2 : - forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a). -Proof. - destruct a; simpl in *; auto. - destruct p; auto. - rewrite nat_of_P_xI. - rewrite div2_double_plus_one; auto. - rewrite nat_of_P_xO. - rewrite div2_double; auto. -Qed. - -Lemma N_of_div2 : - forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - rewrite <- nat_of_Ndiv2. - apply N_of_nat_of_N. -Qed. - -Lemma nat_of_Ncompare : - forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a'). -Proof. - destruct a; destruct a'; simpl. - reflexivity. - assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P. - destruct nat_of_P; [inversion NZ|auto]. - assert (NZ : 0 < nat_of_P p) by auto using lt_O_nat_of_P. - destruct nat_of_P; [inversion NZ|auto]. - apply nat_of_P_compare_morphism. -Qed. +(** * Conversions from [N] to [nat] *) -Lemma N_of_nat_compare : - forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n'). -Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - symmetry; apply nat_of_Ncompare. -Qed. +Module N2Nat. -Lemma nat_of_Nmin : - forall a a', nat_of_N (Nmin a a') = min (nat_of_N a) (nat_of_N a'). -Proof. - intros; unfold Nmin; rewrite nat_of_Ncompare. - rewrite nat_compare_equiv; unfold nat_compare_alt. - destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; - simpl; intros; symmetry; auto with arith. - apply min_l; rewrite e; auto with arith. -Qed. +(** [N.to_nat] is a bijection between [N] and [nat], + with [Pos.of_nat] as reciprocal. + See [Nat2N.id] below for the dual equation. *) -Lemma N_of_min : - forall n n', N_of_nat (min n n') = Nmin (N_of_nat n) (N_of_nat n'). +Lemma id a : N.of_nat (N.to_nat a) = a. Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - rewrite <- nat_of_Nmin. - apply N_of_nat_of_N. + 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. -Lemma nat_of_Nmax : - forall a a', nat_of_N (Nmax a a') = max (nat_of_N a) (nat_of_N a'). -Proof. - intros; unfold Nmax; rewrite nat_of_Ncompare. - rewrite nat_compare_equiv; unfold nat_compare_alt. - destruct (lt_eq_lt_dec (nat_of_N a) (nat_of_N a')) as [[|]|]; - simpl; intros; symmetry; auto with arith. - apply max_r; rewrite e; auto with arith. -Qed. +(** [N.to_nat] is hence injective *) -Lemma N_of_max : - forall n n', N_of_nat (max n n') = Nmax (N_of_nat n) (N_of_nat n'). +Lemma inj a a' : N.to_nat a = N.to_nat a' -> a = a'. Proof. - intros. - pattern n at 1; rewrite <- (nat_of_N_of_nat n). - pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). - rewrite <- nat_of_Nmax. - apply N_of_nat_of_N. + intro H. rewrite <- (id a), <- (id a'). now f_equal. Qed. -(** Properties concerning [Z_of_N] *) - -Lemma Z_of_nat_of_N : forall n:N, Z_of_nat (nat_of_N n) = Z_of_N n. +Lemma inj_iff a a' : N.to_nat a = N.to_nat a' <-> a = a'. Proof. - destruct n; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P. + split. apply inj. intros; now subst. Qed. -Lemma Z_of_N_eq : forall n m, n = m -> Z_of_N n = Z_of_N m. -Proof. - intros; f_equal; assumption. -Qed. +(** Interaction of this translation and usual operations. *) -Lemma Z_of_N_eq_rev : forall n m, Z_of_N n = Z_of_N m -> n = m. +Lemma inj_double a : N.to_nat (N.double a) = 2*(N.to_nat a). Proof. - intros [|n] [|m]; simpl; intros; try discriminate; congruence. + destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xO. Qed. -Lemma Z_of_N_eq_iff : forall n m, n = m <-> Z_of_N n = Z_of_N m. +Lemma inj_succ_double a : N.to_nat (N.succ_double a) = S (2*(N.to_nat a)). Proof. - split; [apply Z_of_N_eq | apply Z_of_N_eq_rev]. + destruct a; simpl N.to_nat; trivial. apply Pos2Nat.inj_xI. Qed. -Lemma Z_of_N_le : forall n m, (n<=m)%N -> (Z_of_N n <= Z_of_N m)%Z. +Lemma inj_succ a : N.to_nat (N.succ a) = S (N.to_nat a). Proof. - intros [|n] [|m]; simpl; auto. + destruct a; simpl; trivial. apply Pos2Nat.inj_succ. Qed. -Lemma Z_of_N_le_rev : forall n m, (Z_of_N n <= Z_of_N m)%Z -> (n<=m)%N. +Lemma inj_add a a' : + N.to_nat (a + a') = N.to_nat a + N.to_nat a'. Proof. - intros [|n] [|m]; simpl; auto. + destruct a, a'; simpl; trivial. apply Pos2Nat.inj_add. Qed. -Lemma Z_of_N_le_iff : forall n m, (n<=m)%N <-> (Z_of_N n <= Z_of_N m)%Z. +Lemma inj_mul a a' : + N.to_nat (a * a') = N.to_nat a * N.to_nat a'. Proof. - split; [apply Z_of_N_le | apply Z_of_N_le_rev]. + destruct a, a'; simpl; trivial. apply Pos2Nat.inj_mul. Qed. -Lemma Z_of_N_lt : forall n m, (n<m)%N -> (Z_of_N n < Z_of_N m)%Z. +Lemma inj_sub a a' : + N.to_nat (a - a') = N.to_nat a - N.to_nat a'. Proof. - intros [|n] [|m]; simpl; auto. + destruct a as [|a], a' as [|a']; simpl; auto with arith. + destruct (Pos.compare_spec a a'). + subst. now rewrite Pos.sub_mask_diag, <- minus_n_n. + rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. + simpl; symmetry; apply not_le_minus_0; auto with arith. + destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq). + simpl. apply plus_minus. now rewrite <- Hq, Pos2Nat.inj_add. Qed. -Lemma Z_of_N_lt_rev : forall n m, (Z_of_N n < Z_of_N m)%Z -> (n<m)%N. +Lemma inj_pred a : N.to_nat (N.pred a) = pred (N.to_nat a). Proof. - intros [|n] [|m]; simpl; auto. + intros. rewrite pred_of_minus, N.pred_sub. apply inj_sub. Qed. -Lemma Z_of_N_lt_iff : forall n m, (n<m)%N <-> (Z_of_N n < Z_of_N m)%Z. +Lemma inj_div2 a : N.to_nat (N.div2 a) = div2 (N.to_nat a). Proof. - split; [apply Z_of_N_lt | apply Z_of_N_lt_rev]. + destruct a as [|[p|p| ]]; trivial. + simpl N.to_nat. now rewrite Pos2Nat.inj_xI, div2_double_plus_one. + simpl N.to_nat. now rewrite Pos2Nat.inj_xO, div2_double. Qed. -Lemma Z_of_N_ge : forall n m, (n>=m)%N -> (Z_of_N n >= Z_of_N m)%Z. +Lemma inj_compare a a' : + (a ?= a')%N = nat_compare (N.to_nat a) (N.to_nat a'). Proof. - intros [|n] [|m]; simpl; auto. + destruct a, a'; simpl; trivial. + now destruct (Pos2Nat.is_succ p) as (n,->). + now destruct (Pos2Nat.is_succ p) as (n,->). + apply Pos2Nat.inj_compare. Qed. -Lemma Z_of_N_ge_rev : forall n m, (Z_of_N n >= Z_of_N m)%Z -> (n>=m)%N. +Lemma inj_max a a' : + N.to_nat (N.max a a') = max (N.to_nat a) (N.to_nat a'). Proof. - intros [|n] [|m]; simpl; auto. + unfold N.max. rewrite inj_compare; symmetry. + case nat_compare_spec; intros H; try rewrite H; auto with arith. Qed. -Lemma Z_of_N_ge_iff : forall n m, (n>=m)%N <-> (Z_of_N n >= Z_of_N m)%Z. +Lemma inj_min a a' : + N.to_nat (N.min a a') = min (N.to_nat a) (N.to_nat a'). Proof. - split; [apply Z_of_N_ge | apply Z_of_N_ge_rev]. + unfold N.min; rewrite inj_compare. symmetry. + case nat_compare_spec; intros H; try rewrite H; auto with arith. Qed. -Lemma Z_of_N_gt : forall n m, (n>m)%N -> (Z_of_N n > Z_of_N m)%Z. +Lemma inj_iter a {A} (f:A->A) (x:A) : + N.iter a f x = nat_iter (N.to_nat a) f x. Proof. - intros [|n] [|m]; simpl; auto. + destruct a as [|a]. trivial. apply Pos2Nat.inj_iter. Qed. -Lemma Z_of_N_gt_rev : forall n m, (Z_of_N n > Z_of_N m)%Z -> (n>m)%N. -Proof. - intros [|n] [|m]; simpl; auto. -Qed. +End N2Nat. -Lemma Z_of_N_gt_iff : forall n m, (n>m)%N <-> (Z_of_N n > Z_of_N m)%Z. -Proof. - split; [apply Z_of_N_gt | apply Z_of_N_gt_rev]. -Qed. +Hint Rewrite N2Nat.inj_double N2Nat.inj_succ_double + N2Nat.inj_succ N2Nat.inj_add N2Nat.inj_mul N2Nat.inj_sub + N2Nat.inj_pred N2Nat.inj_div2 N2Nat.inj_max N2Nat.inj_min + N2Nat.id + : Nnat. -Lemma Z_of_N_of_nat : forall n:nat, Z_of_N (N_of_nat n) = Z_of_nat n. -Proof. - destruct n; simpl; auto. -Qed. -Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p. -Proof. - destruct p; simpl; auto. -Qed. +(** * Conversions from [nat] to [N] *) -Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z. -Proof. - destruct z; simpl; auto. -Qed. +Module Nat2N. -Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z. -Proof. - destruct n; intro; discriminate. -Qed. +(** [N.of_nat] is an bijection between [nat] and [N], + with [Pos.to_nat] as reciprocal. + See [N2Nat.id] above for the dual equation. *) -Lemma Z_of_N_plus : forall n m:N, Z_of_N (n+m) = (Z_of_N n + Z_of_N m)%Z. +Lemma id n : N.to_nat (N.of_nat n) = n. Proof. - destruct n; destruct m; auto. + induction n; simpl; trivial. apply SuccNat2Pos.id_succ. Qed. -Lemma Z_of_N_mult : forall n m:N, Z_of_N (n*m) = (Z_of_N n * Z_of_N m)%Z. -Proof. - destruct n; destruct m; auto. -Qed. +Hint Rewrite id : Nnat. +Ltac nat2N := apply N2Nat.inj; now autorewrite with Nnat. -Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). -Proof. - intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nminus; apply inj_minus. -Qed. +(** [N.of_nat] is hence injective *) -Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). +Lemma inj n n' : N.of_nat n = N.of_nat n' -> n = n'. Proof. - intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S. + intros H. rewrite <- (id n), <- (id n'). now f_equal. Qed. -Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). +Lemma inj_iff n n' : N.of_nat n = N.of_nat n' <-> n = n'. Proof. - intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min. + split. apply inj. intros; now subst. Qed. -Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). -Proof. - intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max. -Qed. +(** 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_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_pred n : N.of_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_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_div2 n : N.of_nat (div2 n) = N.div2 (N.of_nat n). +Proof. nat2N. Qed. + +Lemma inj_compare n n' : + nat_compare n n' = (N.of_nat n ?= N.of_nat n')%N. +Proof. now rewrite N2Nat.inj_compare, !id. Qed. + +Lemma inj_min n n' : + N.of_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 (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. + +End Nat2N. + +Hint Rewrite Nat2N.id : Nnat. + +(** Compatibility notations *) + +Notation nat_of_N_inj := N2Nat.inj (only parsing). +Notation N_of_nat_of_N := N2Nat.id (only parsing). +Notation nat_of_Ndouble := N2Nat.inj_double (only parsing). +Notation nat_of_Ndouble_plus_one := N2Nat.inj_succ_double (only parsing). +Notation nat_of_Nsucc := N2Nat.inj_succ (only parsing). +Notation nat_of_Nplus := N2Nat.inj_add (only parsing). +Notation nat_of_Nmult := N2Nat.inj_mul (only parsing). +Notation nat_of_Nminus := N2Nat.inj_sub (only parsing). +Notation nat_of_Npred := N2Nat.inj_pred (only parsing). +Notation nat_of_Ndiv2 := N2Nat.inj_div2 (only parsing). +Notation nat_of_Ncompare := N2Nat.inj_compare (only parsing). +Notation nat_of_Nmax := N2Nat.inj_max (only parsing). +Notation nat_of_Nmin := N2Nat.inj_min (only parsing). + +Notation nat_of_N_of_nat := Nat2N.id (only parsing). +Notation N_of_nat_inj := Nat2N.inj (only parsing). +Notation N_of_double := Nat2N.inj_double (only parsing). +Notation N_of_double_plus_one := Nat2N.inj_succ_double (only parsing). +Notation N_of_S := Nat2N.inj_succ (only parsing). +Notation N_of_pred := Nat2N.inj_pred (only parsing). +Notation N_of_plus := Nat2N.inj_add (only parsing). +Notation N_of_minus := Nat2N.inj_sub (only parsing). +Notation N_of_mult := Nat2N.inj_mul (only parsing). +Notation N_of_div2 := Nat2N.inj_div2 (only parsing). +Notation N_of_nat_compare := Nat2N.inj_compare (only parsing). +Notation N_of_min := Nat2N.inj_min (only parsing). +Notation N_of_max := Nat2N.inj_max (only parsing). diff --git a/theories/NArith/Nsqrt_def.v b/theories/NArith/Nsqrt_def.v new file mode 100644 index 00000000..edb6b289 --- /dev/null +++ b/theories/NArith/Nsqrt_def.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinNat. + +(** Obsolete file, see [BinNat] now, + only compatibility notations remain here. *) + +Notation Nsqrtrem := N.sqrtrem (only parsing). +Notation Nsqrt := N.sqrt (only parsing). +Notation Nsqrtrem_spec := N.sqrtrem_spec (only parsing). +Notation Nsqrt_spec := (fun n => N.sqrt_spec n (N.le_0_l n)) (only parsing). +Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (only parsing). diff --git a/theories/NArith/Pminmax.v b/theories/NArith/Pminmax.v deleted file mode 100644 index 6bac033c..00000000 --- a/theories/NArith/Pminmax.v +++ /dev/null @@ -1,126 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Orders BinPos Pnat POrderedType GenericMinMax. - -(** * Maximum and Minimum of two positive numbers *) - -Local Open Scope positive_scope. - -(** The functions [Pmax] and [Pmin] implement indeed - a maximum and a minimum *) - -Lemma Pmax_l : forall x y, y<=x -> Pmax x y = x. -Proof. - unfold Ple, Pmax. intros x y. - rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y). - destruct ((x ?= y) Eq); intuition. -Qed. - -Lemma Pmax_r : forall x y, x<=y -> Pmax x y = y. -Proof. - unfold Ple, Pmax. intros x y. destruct ((x ?= y) Eq); intuition. -Qed. - -Lemma Pmin_l : forall x y, x<=y -> Pmin x y = x. -Proof. - unfold Ple, Pmin. intros x y. destruct ((x ?= y) Eq); intuition. -Qed. - -Lemma Pmin_r : forall x y, y<=x -> Pmin x y = y. -Proof. - unfold Ple, Pmin. intros x y. - rewrite (ZC4 y x). generalize (Pcompare_eq_iff x y). - destruct ((x ?= y) Eq); intuition. -Qed. - -Module PositiveHasMinMax <: HasMinMax Positive_as_OT. - Definition max := Pmax. - Definition min := Pmin. - Definition max_l := Pmax_l. - Definition max_r := Pmax_r. - Definition min_l := Pmin_l. - Definition min_r := Pmin_r. -End PositiveHasMinMax. - - -Module P. -(** We obtain hence all the generic properties of max and min. *) - -Include UsualMinMaxProperties Positive_as_OT PositiveHasMinMax. - -(** * Properties specific to the [positive] domain *) - -(** Simplifications *) - -Lemma max_1_l : forall n, Pmax 1 n = n. -Proof. - intros. unfold Pmax. rewrite ZC4. generalize (Pcompare_1 n). - destruct (n ?= 1); intuition. -Qed. - -Lemma max_1_r : forall n, Pmax n 1 = n. -Proof. intros. rewrite P.max_comm. apply max_1_l. Qed. - -Lemma min_1_l : forall n, Pmin 1 n = 1. -Proof. - intros. unfold Pmin. rewrite ZC4. generalize (Pcompare_1 n). - destruct (n ?= 1); intuition. -Qed. - -Lemma min_1_r : forall n, Pmin n 1 = 1. -Proof. intros. rewrite P.min_comm. apply min_1_l. Qed. - -(** Compatibilities (consequences of monotonicity) *) - -Lemma succ_max_distr : - forall n m, Psucc (Pmax n m) = Pmax (Psucc n) (Psucc m). -Proof. - intros. symmetry. apply max_monotone. - intros x x'. unfold Ple. - rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism. - simpl; auto. -Qed. - -Lemma succ_min_distr : forall n m, Psucc (Pmin n m) = Pmin (Psucc n) (Psucc m). -Proof. - intros. symmetry. apply min_monotone. - intros x x'. unfold Ple. - rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_succ_morphism. - simpl; auto. -Qed. - -Lemma plus_max_distr_l : forall n m p, Pmax (p + n) (p + m) = p + Pmax n m. -Proof. - intros. apply max_monotone. - intros x x'. unfold Ple. - rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism. - rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. -Qed. - -Lemma plus_max_distr_r : forall n m p, Pmax (n + p) (m + p) = Pmax n m + p. -Proof. - intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p). - apply plus_max_distr_l. -Qed. - -Lemma plus_min_distr_l : forall n m p, Pmin (p + n) (p + m) = p + Pmin n m. -Proof. - intros. apply min_monotone. - intros x x'. unfold Ple. - rewrite 2 nat_of_P_compare_morphism, 2 nat_of_P_plus_morphism. - rewrite <- 2 Compare_dec.nat_compare_le. auto with arith. -Qed. - -Lemma plus_min_distr_r : forall n m p, Pmin (n + p) (m + p) = Pmin n m + p. -Proof. - intros. rewrite (Pplus_comm n p), (Pplus_comm m p), (Pplus_comm _ p). - apply plus_min_distr_l. -Qed. - -End P.
\ No newline at end of file diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v deleted file mode 100644 index 29641dbe..00000000 --- a/theories/NArith/Pnat.v +++ /dev/null @@ -1,462 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: Pnat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import BinPos. - -(**********************************************************************) -(** Properties of the injection from binary positive numbers to Peano - natural numbers *) - -(** Original development by Pierre Crégut, CNET, Lannion, France *) - -Require Import Le. -Require Import Lt. -Require Import Gt. -Require Import Plus. -Require Import Mult. -Require Import Minus. -Require Import Compare_dec. - -Local Open Scope positive_scope. -Local Open Scope nat_scope. - -(** [nat_of_P] is a morphism for addition *) - -Lemma Pmult_nat_succ_morphism : - forall (p:positive) (n:nat), Pmult_nat (Psucc p) n = n + Pmult_nat p n. -Proof. -intro x; induction x as [p IHp| p IHp| ]; simpl in |- *; auto; intro m; - rewrite IHp; rewrite plus_assoc; trivial. -Qed. - -Lemma nat_of_P_succ_morphism : - forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p). -Proof. - intro; change (S (nat_of_P p)) with (1 + nat_of_P p) in |- *; - unfold nat_of_P in |- *; apply Pmult_nat_succ_morphism. -Qed. - -Theorem Pmult_nat_plus_carry_morphism : - forall (p q:positive) (n:nat), - Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n. -Proof. -intro x; induction x as [p IHp| p IHp| ]; intro y; - [ destruct y as [p0| p0| ] - | destruct y as [p0| p0| ] - | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; - intro m; - [ rewrite IHp; rewrite plus_assoc; trivial with arith - | rewrite IHp; rewrite plus_assoc; trivial with arith - | rewrite Pmult_nat_succ_morphism; rewrite plus_assoc; trivial with arith - | rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ]. -Qed. - -Theorem nat_of_P_plus_carry_morphism : - forall p q:positive, nat_of_P (Pplus_carry p q) = S (nat_of_P (p + q)). -Proof. -intros; unfold nat_of_P in |- *; rewrite Pmult_nat_plus_carry_morphism; - simpl in |- *; trivial with arith. -Qed. - -Theorem Pmult_nat_l_plus_morphism : - forall (p q:positive) (n:nat), - Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n. -Proof. -intro x; induction x as [p IHp| p IHp| ]; intro y; - [ destruct y as [p0| p0| ] - | destruct y as [p0| p0| ] - | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; - [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp; - rewrite plus_assoc_reverse; rewrite plus_assoc_reverse; - rewrite (plus_permute m (Pmult_nat p (m + m))); - trivial with arith - | intros m; rewrite IHp; apply plus_assoc - | intros m; rewrite Pmult_nat_succ_morphism; - rewrite (plus_comm (m + Pmult_nat p (m + m))); - apply plus_assoc_reverse - | intros m; rewrite IHp; apply plus_permute - | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ]. -Qed. - -Theorem nat_of_P_plus_morphism : - forall p q:positive, nat_of_P (p + q) = nat_of_P p + nat_of_P q. -Proof. -intros x y; exact (Pmult_nat_l_plus_morphism x y 1). -Qed. - -(** [Pmult_nat] is a morphism for addition *) - -Lemma Pmult_nat_r_plus_morphism : - forall (p:positive) (n:nat), - Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n. -Proof. -intro y; induction y as [p H| p H| ]; intro m; - [ simpl in |- *; rewrite H; rewrite plus_assoc_reverse; - rewrite (plus_permute m (Pmult_nat p (m + m))); - rewrite plus_assoc_reverse; auto with arith - | simpl in |- *; rewrite H; auto with arith - | simpl in |- *; trivial with arith ]. -Qed. - -Lemma ZL6 : forall p:positive, Pmult_nat p 2 = nat_of_P p + nat_of_P p. -Proof. -intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism; - trivial. -Qed. - -(** [nat_of_P] is a morphism for multiplication *) - -Theorem nat_of_P_mult_morphism : - forall p q:positive, nat_of_P (p * q) = nat_of_P p * nat_of_P q. -Proof. -intros x y; induction x as [x' H| x' H| ]; - [ change (xI x' * y)%positive with (y + xO (x' * y))%positive in |- *; - rewrite nat_of_P_plus_morphism; unfold nat_of_P at 2 3 in |- *; - simpl in |- *; do 2 rewrite ZL6; rewrite H; rewrite mult_plus_distr_r; - reflexivity - | unfold nat_of_P at 1 2 in |- *; simpl in |- *; do 2 rewrite ZL6; rewrite H; - rewrite mult_plus_distr_r; reflexivity - | simpl in |- *; rewrite <- plus_n_O; reflexivity ]. -Qed. - -(** [nat_of_P] maps to the strictly positive subset of [nat] *) - -Lemma ZL4 : forall p:positive, exists h : nat, nat_of_P p = S h. -Proof. -intro y; induction y as [p H| p H| ]; - [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *; - simpl in |- *; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; - rewrite H1; auto with arith - | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *; - simpl in |- *; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; - rewrite H2; auto with arith - | exists 0; auto with arith ]. -Qed. - -(** Extra lemmas on [lt] on Peano natural numbers *) - -Lemma ZL7 : forall n m:nat, n < m -> n + n < m + m. -Proof. -intros m n H; apply lt_trans with (m := m + n); - [ apply plus_lt_compat_l with (1 := H) - | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ]. -Qed. - -Lemma ZL8 : forall n m:nat, n < m -> S (n + n) < m + m. -Proof. -intros m n H; apply le_lt_trans with (m := m + n); - [ change (m + m < m + n) in |- *; apply plus_lt_compat_l with (1 := H) - | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ]. -Qed. - -(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed - from [compare] on [positive]) - - Part 1: [lt] on [positive] is finer than [lt] on [nat] -*) - -Lemma nat_of_P_lt_Lt_compare_morphism : - forall p q:positive, (p ?= q) Eq = Lt -> nat_of_P p < nat_of_P q. -Proof. -intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ]; - intro H2; - [ unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; do 2 rewrite ZL6; - apply ZL7; apply H; simpl in H2; assumption - | unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; apply ZL8; - apply H; simpl in H2; apply Pcompare_Gt_Lt; assumption - | simpl in |- *; discriminate H2 - | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - elim (Pcompare_Lt_Lt p q H2); - [ intros H3; apply lt_S; apply ZL7; apply H; apply H3 - | intros E; rewrite E; apply lt_n_Sn ] - | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; - apply ZL7; apply H; assumption - | simpl in |- *; discriminate H2 - | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6; - elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; - apply lt_O_Sn - | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q); - intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm; - apply lt_n_S; apply lt_O_Sn - | simpl in |- *; discriminate H2 ]. -Qed. - -(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed - from [compare] on [positive]) - - Part 1: [gt] on [positive] is finer than [gt] on [nat] -*) - -Lemma nat_of_P_gt_Gt_compare_morphism : - forall p q:positive, (p ?= q) Eq = Gt -> nat_of_P p > nat_of_P q. -Proof. -intros p q GT. unfold gt. -apply nat_of_P_lt_Lt_compare_morphism. -change ((q ?= p) (CompOpp Eq) = CompOpp Gt). -rewrite <- Pcompare_antisym, GT; auto. -Qed. - -(** [nat_of_P] is a morphism for [Pcompare] and [nat_compare] *) - -Lemma nat_of_P_compare_morphism : forall p q, - (p ?= q) Eq = nat_compare (nat_of_P p) (nat_of_P q). -Proof. - intros p q; symmetry. - destruct ((p ?= q) Eq) as [ | | ]_eqn. - rewrite (Pcompare_Eq_eq p q); auto. - apply <- nat_compare_eq_iff; auto. - apply -> nat_compare_lt. apply nat_of_P_lt_Lt_compare_morphism; auto. - apply -> nat_compare_gt. apply nat_of_P_gt_Gt_compare_morphism; auto. -Qed. - -(** [nat_of_P] is hence injective. *) - -Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q. -Proof. -intros. -apply Pcompare_Eq_eq. -rewrite nat_of_P_compare_morphism. -apply <- nat_compare_eq_iff; auto. -Qed. - -(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed - from [compare] on [positive]) - - Part 2: [lt] on [nat] is finer than [lt] on [positive] -*) - -Lemma nat_of_P_lt_Lt_compare_complement_morphism : - forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q) Eq = Lt. -Proof. - intros. rewrite nat_of_P_compare_morphism. - apply -> nat_compare_lt; auto. -Qed. - -(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed - from [compare] on [positive]) - - Part 2: [gt] on [nat] is finer than [gt] on [positive] -*) - -Lemma nat_of_P_gt_Gt_compare_complement_morphism : - forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q) Eq = Gt. -Proof. - intros. rewrite nat_of_P_compare_morphism. - apply -> nat_compare_gt; auto. -Qed. - - -(** [nat_of_P] is strictly positive *) - -Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n. -induction p; simpl in |- *; auto with arith. -intro m; apply le_trans with (m + m); auto with arith. -Qed. - -Lemma lt_O_nat_of_P : forall p:positive, 0 < nat_of_P p. -intro; unfold nat_of_P in |- *; apply lt_le_trans with 1; auto with arith. -apply le_Pmult_nat. -Qed. - -(** Pmult_nat permutes with multiplication *) - -Lemma Pmult_nat_mult_permute : - forall (p:positive) (n m:nat), Pmult_nat p (m * n) = m * Pmult_nat p n. -Proof. - simple induction p. intros. simpl in |- *. rewrite mult_plus_distr_l. rewrite <- (mult_plus_distr_l m n n). - rewrite (H (n + n) m). reflexivity. - intros. simpl in |- *. rewrite <- (mult_plus_distr_l m n n). apply H. - trivial. -Qed. - -Lemma Pmult_nat_2_mult_2_permute : - forall p:positive, Pmult_nat p 2 = 2 * Pmult_nat p 1. -Proof. - intros. rewrite <- Pmult_nat_mult_permute. reflexivity. -Qed. - -Lemma Pmult_nat_4_mult_2_permute : - forall p:positive, Pmult_nat p 4 = 2 * Pmult_nat p 2. -Proof. - intros. rewrite <- Pmult_nat_mult_permute. reflexivity. -Qed. - -(** Mapping of xH, xO and xI through [nat_of_P] *) - -Lemma nat_of_P_xH : nat_of_P 1 = 1. -Proof. - reflexivity. -Qed. - -Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p. -Proof. - intros. - change 2 with (nat_of_P 2). - rewrite <- nat_of_P_mult_morphism. - f_equal. -Qed. - -Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p). -Proof. - intros. - change 2 with (nat_of_P 2). - rewrite <- nat_of_P_mult_morphism, <- nat_of_P_succ_morphism. - f_equal. -Qed. - -(**********************************************************************) -(** Properties of the shifted injection from Peano natural numbers to - binary positive numbers *) - -(** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *) - -Theorem nat_of_P_o_P_of_succ_nat_eq_succ : - forall n:nat, nat_of_P (P_of_succ_nat n) = S n. -Proof. -induction n as [|n H]. -reflexivity. -simpl; rewrite nat_of_P_succ_morphism, H; auto. -Qed. - -(** Miscellaneous lemmas on [P_of_succ_nat] *) - -Lemma ZL3 : - forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n). -Proof. -induction n as [| n H]; simpl; - [ auto with arith - | rewrite plus_comm; simpl; rewrite H; - rewrite xO_succ_permute; auto with arith ]. -Qed. - -Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n). -Proof. -induction n as [| n H]; simpl; - [ auto with arith - | rewrite <- plus_n_Sm; simpl; simpl in H; rewrite H; - auto with arith ]. -Qed. - -(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *) - -Theorem P_of_succ_nat_o_nat_of_P_eq_succ : - forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p. -Proof. -intros. -apply nat_of_P_inj. -rewrite nat_of_P_o_P_of_succ_nat_eq_succ, nat_of_P_succ_morphism; auto. -Qed. - -(** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity - on [positive] *) - -Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id : - forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p. -Proof. -intros; rewrite P_of_succ_nat_o_nat_of_P_eq_succ, Ppred_succ; auto. -Qed. - -(**********************************************************************) -(** Extra properties of the injection from binary positive numbers to Peano - natural numbers *) - -(** [nat_of_P] is a morphism for subtraction on positive numbers *) - -Theorem nat_of_P_minus_morphism : - forall p q:positive, - (p ?= q) Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q. -Proof. -intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r; - [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith - | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ]. -Qed. - - -Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p. -Proof. -intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1; - rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; - apply le_minus. -Qed. - -Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q). -Proof. -intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q); - intros k H; rewrite H; rewrite plus_comm; simpl in |- *; - apply le_n_S; apply le_plus_r. -Qed. - -(** Comparison and subtraction *) - -Lemma Pcompare_minus_r : - forall p q r:positive, - (q ?= p) Eq = Lt -> - (r ?= p) Eq = Gt -> - (r ?= q) Eq = Gt -> (r - p ?= r - q) Eq = Lt. -Proof. -intros; apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ apply plus_lt_reg_l with (p := nat_of_P q); rewrite le_plus_minus_r; - [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); - rewrite plus_assoc; rewrite le_plus_minus_r; - [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; - assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; - assumption ] - | assumption ] - | assumption ]. -Qed. - -Lemma Pcompare_minus_l : - forall p q r:positive, - (q ?= p) Eq = Lt -> - (p ?= r) Eq = Gt -> - (q ?= r) Eq = Gt -> (q - r ?= p - r) Eq = Lt. -Proof. -intros p q z; intros; apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z); - rewrite le_plus_minus_r; - [ rewrite le_plus_minus_r; - [ apply nat_of_P_lt_Lt_compare_morphism; assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; - assumption ] - | assumption ] - | assumption ]. -Qed. - -(** Distributivity of multiplication over subtraction *) - -Theorem Pmult_minus_distr_l : - forall p q r:positive, - (q ?= r) Eq = Gt -> - (p * (q - r) = p * q - p * r)%positive. -Proof. -intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ do 2 rewrite nat_of_P_mult_morphism; - do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r - | apply nat_of_P_gt_Gt_compare_complement_morphism; - do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; - elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l; - exact (nat_of_P_gt_Gt_compare_morphism y z H) ] - | assumption ]. -Qed. diff --git a/theories/NArith/intro.tex b/theories/NArith/intro.tex index 83eed970..bf39bc36 100644 --- a/theories/NArith/intro.tex +++ b/theories/NArith/intro.tex @@ -1,4 +1,4 @@ -\section{Binary positive and non negative integers : NArith}\label{NArith} +\section{Binary natural numbers : NArith}\label{NArith} Here are defined various arithmetical notions and their properties, similar to those of {\tt Arith}. diff --git a/theories/NArith/vo.itarget b/theories/NArith/vo.itarget index 32f94f01..e76033f7 100644 --- a/theories/NArith/vo.itarget +++ b/theories/NArith/vo.itarget @@ -1,12 +1,10 @@ +BinNatDef.vo BinNat.vo -BinPos.vo NArith.vo Ndec.vo Ndigits.vo Ndist.vo Nnat.vo -Pnat.vo -POrderedType.vo -Pminmax.vo -NOrderedType.vo -Nminmax.vo +Ndiv_def.vo +Nsqrt_def.vo +Ngcd_def.vo
\ No newline at end of file diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index 510b6888..26850688 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigNumPrelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** * BigNumPrelude *) (** Auxillary functions & theorems used for arbitrary precision efficient @@ -102,7 +100,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. apply Zle_trans with ((b-1)*(b-1)). apply Zmult_le_compat;auto with zarith. - apply Zeq_le;ring. + apply Zeq_le; ring. Qed. Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, @@ -315,7 +313,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. apply Zdiv_le_lower_bound;auto with zarith. replace (2^p) with 0. destruct x;compute;intro;discriminate. - destruct p;trivial;discriminate z. + destruct p;trivial;discriminate. Qed. Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. @@ -327,7 +325,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. assert (0 < 2^p);auto with zarith. replace (2^p) with 0. destruct x;change (0<y);auto with zarith. - destruct p;trivial;discriminate z. + destruct p;trivial;discriminate. Qed. Theorem Zgcd_div_pos a b: diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v new file mode 100644 index 00000000..dfb2c502 --- /dev/null +++ b/theories/Numbers/BinNums.v @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * Binary Numerical Datatypes *) + +Set Implicit Arguments. +(* For compatibility, we will not use generic equality functions *) +Local Unset Boolean Equality Schemes. + +Declare ML Module "z_syntax_plugin". + +(** [positive] is a datatype representing the strictly positive integers + in a binary way. Starting from 1 (represented by [xH]), one can + add a new least significant digit via [xO] (digit 0) or [xI] (digit 1). + Numbers in [positive] can also be denoted using a decimal notation; + e.g. [6%positive] abbreviates [xO (xI xH)] *) + +Inductive positive : Set := + | xI : positive -> positive + | xO : positive -> positive + | xH : positive. + +Delimit Scope positive_scope with positive. +Bind Scope positive_scope with positive. +Arguments xO _%positive. +Arguments xI _%positive. + +(** [N] is a datatype representing natural numbers in a binary way, + by extending the [positive] datatype with a zero. + Numbers in [N] can also be denoted using a decimal notation; + e.g. [6%N] abbreviates [Npos (xO (xI xH))] *) + +Inductive N : Set := + | N0 : N + | Npos : positive -> N. + +Delimit Scope N_scope with N. +Bind Scope N_scope with N. +Arguments Npos _%positive. + +(** [Z] is a datatype representing the integers in a binary way. + An integer is either zero or a strictly positive number + (coded as a [positive]) or a strictly negative number + (whose opposite is stored as a [positive] value). + Numbers in [Z] can also be denoted using a decimal notation; + e.g. [(-6)%Z] abbreviates [Zneg (xO (xI xH))] *) + +Inductive Z : Set := + | Z0 : Z + | Zpos : positive -> Z + | Zneg : positive -> Z. + +Delimit Scope Z_scope with Z. +Bind Scope Z_scope with Z. +Arguments Zpos _%positive. +Arguments Zneg _%positive. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index fa097802..59656eed 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(* $Id: CyclicAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** * Signature and specification of a bounded integer structure *) (** This file specifies how to represent [Z/nZ] when [n=2^d], @@ -26,352 +24,300 @@ Local Open Scope Z_scope. (** First, a description via an operator record and a spec record. *) -Section Z_nZ_Op. - - Variable znz : Type. +Module ZnZ. - Record znz_op := mk_znz_op { + Class Ops (t:Type) := MkOps { (* Conversion functions with Z *) - znz_digits : positive; - znz_zdigits: znz; - znz_to_Z : znz -> Z; - znz_of_pos : positive -> N * znz; (* Euclidean division by [2^digits] *) - znz_head0 : znz -> znz; (* number of digits 0 in front of the number *) - znz_tail0 : znz -> znz; (* number of digits 0 at the bottom of the number *) + 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 *) - znz_0 : znz; - znz_1 : znz; - znz_Bm1 : znz; (* [2^digits-1], which is equivalent to [-1] *) + zero : t; + one : t; + minus_one : t; (* [2^digits-1], which is equivalent to [-1] *) (* Comparison *) - znz_compare : znz -> znz -> comparison; - znz_eq0 : znz -> bool; + compare : t -> t -> comparison; + eq0 : t -> bool; (* Basic arithmetic operations *) - znz_opp_c : znz -> carry znz; - znz_opp : znz -> znz; - znz_opp_carry : znz -> znz; (* the carry is known to be -1 *) - - znz_succ_c : znz -> carry znz; - znz_add_c : znz -> znz -> carry znz; - znz_add_carry_c : znz -> znz -> carry znz; - znz_succ : znz -> znz; - znz_add : znz -> znz -> znz; - znz_add_carry : znz -> znz -> znz; - - znz_pred_c : znz -> carry znz; - znz_sub_c : znz -> znz -> carry znz; - znz_sub_carry_c : znz -> znz -> carry znz; - znz_pred : znz -> znz; - znz_sub : znz -> znz -> znz; - znz_sub_carry : znz -> znz -> znz; - - znz_mul_c : znz -> znz -> zn2z znz; - znz_mul : znz -> znz -> znz; - znz_square_c : znz -> zn2z znz; + 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 *) - znz_div21 : znz -> znz -> znz -> znz*znz; - znz_div_gt : znz -> znz -> znz * znz; (* specialized version of [znz_div] *) - znz_div : znz -> znz -> znz * znz; + div21 : t -> t -> t -> t*t; + div_gt : t -> t -> t * t; (* specialized version of [div] *) + div : t -> t -> t * t; - znz_mod_gt : znz -> znz -> znz; (* specialized version of [znz_mod] *) - znz_mod : znz -> znz -> znz; + modulo_gt : t -> t -> t; (* specialized version of [mod] *) + modulo : t -> t -> t; - znz_gcd_gt : znz -> znz -> znz; (* specialized version of [znz_gcd] *) - znz_gcd : znz -> znz -> znz; - (* [znz_add_mul_div p i j] is a combination of the [(digits-p)] + 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]: - [znz_add_mul_div p i j = i*2^p+j/2^(digits-p)] *) - znz_add_mul_div : znz -> znz -> znz -> znz; - (* [znz_pos_mod p i] is [i mod 2^p] *) - znz_pos_mod : znz -> znz -> znz; + [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; - znz_is_even : znz -> bool; + is_even : t -> bool; (* square root *) - znz_sqrt2 : znz -> znz -> znz * carry znz; - znz_sqrt : znz -> znz }. - -End Z_nZ_Op. - -Section Z_nZ_Spec. - Variable w : Type. - Variable w_op : znz_op w. - - Let w_digits := w_op.(znz_digits). - Let w_zdigits := w_op.(znz_zdigits). - Let w_to_Z := w_op.(znz_to_Z). - Let w_of_pos := w_op.(znz_of_pos). - Let w_head0 := w_op.(znz_head0). - Let w_tail0 := w_op.(znz_tail0). - - Let w0 := w_op.(znz_0). - Let w1 := w_op.(znz_1). - Let wBm1 := w_op.(znz_Bm1). - - Let w_compare := w_op.(znz_compare). - Let w_eq0 := w_op.(znz_eq0). - - Let w_opp_c := w_op.(znz_opp_c). - Let w_opp := w_op.(znz_opp). - Let w_opp_carry := w_op.(znz_opp_carry). - - Let w_succ_c := w_op.(znz_succ_c). - Let w_add_c := w_op.(znz_add_c). - Let w_add_carry_c := w_op.(znz_add_carry_c). - Let w_succ := w_op.(znz_succ). - Let w_add := w_op.(znz_add). - Let w_add_carry := w_op.(znz_add_carry). + sqrt2 : t -> t -> t * carry t; + sqrt : t -> t }. - Let w_pred_c := w_op.(znz_pred_c). - Let w_sub_c := w_op.(znz_sub_c). - Let w_sub_carry_c := w_op.(znz_sub_carry_c). - Let w_pred := w_op.(znz_pred). - Let w_sub := w_op.(znz_sub). - Let w_sub_carry := w_op.(znz_sub_carry). + Section Specs. + Context {t : Type}{ops : Ops t}. - Let w_mul_c := w_op.(znz_mul_c). - Let w_mul := w_op.(znz_mul). - Let w_square_c := w_op.(znz_square_c). + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - Let w_div21 := w_op.(znz_div21). - Let w_div_gt := w_op.(znz_div_gt). - Let w_div := w_op.(znz_div). - - Let w_mod_gt := w_op.(znz_mod_gt). - Let w_mod := w_op.(znz_mod). - - Let w_gcd_gt := w_op.(znz_gcd_gt). - Let w_gcd := w_op.(znz_gcd). - - Let w_add_mul_div := w_op.(znz_add_mul_div). - - Let w_pos_mod := w_op.(znz_pos_mod). - - Let w_is_even := w_op.(znz_is_even). - Let w_sqrt2 := w_op.(znz_sqrt2). - Let w_sqrt := w_op.(znz_sqrt). - - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - - Let wB := base w_digits. + Let wB := base digits. Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + (interp_carry 1 wB to_Z c) (at level 0, x at level 99). Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + (interp_carry (-1) wB to_Z c) (at level 0, x at level 99). Notation "[|| x ||]" := - (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). - Record znz_spec := mk_znz_spec { + 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 (w_of_pos p)))*wB + [|(snd (w_of_pos p))|]; - spec_zdigits : [| w_zdigits |] = Zpos w_digits; - spec_more_than_1_digit: 1 < Zpos w_digits; + 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 : [|w0|] = 0; - spec_1 : [|w1|] = 1; - spec_Bm1 : [|wBm1|] = wB - 1; + spec_0 : [|zero|] = 0; + spec_1 : [|one|] = 1; + spec_m1 : [|minus_one|] = wB - 1; (* Comparison *) - spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end; - spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0; + 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, [-|w_opp_c x|] = -[|x|]; - spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB; - spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1; - - spec_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1; - spec_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]; - spec_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1; - spec_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB; - spec_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB; + 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, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; + forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; - spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1; - spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]; - spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1; - spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB; - spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) 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, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; + forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; - spec_mul_c : forall x y, [|| w_mul_c x y ||] = [|x|] * [|y|]; - spec_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB; - spec_square_c : forall x, [|| w_square_c x||] = [|x|] * [|x|]; + 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) := w_div21 a1 a2 b in + 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) := w_div_gt a b in + 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) := w_div a b in + let (q,r) := div a b in [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]; - spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|w_mod_gt a b|] = [|a|] mod [|b|]; - spec_mod : forall a b, 0 < [|b|] -> - [|w_mod a b|] = [|a|] mod [|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|] [|w_gcd_gt a b|]; - spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd 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 -> [|w_head0 x|] = Zpos w_digits; + spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits; spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; - spec_tail00: forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits; + 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 ^ [|w_tail0 x|]) ; + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]) ; spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = + [|p|] <= Zpos digits -> + [| add_mul_div p x y |] = ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB; + [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB; spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]); + [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]); (* sqrt *) spec_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; + 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) := w_sqrt2 x y in + let (s,r) := sqrt2 x y in [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ [+|r|] <= 2 * [|s|]; spec_sqrt : forall x, - [|w_sqrt x|] ^ 2 <= [|x|] < ([|w_sqrt x|] + 1) ^ 2 + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2 }. -End Z_nZ_Spec. + End Specs. + + Arguments Specs {t} ops. + + (** Generic construction of double words *) -(** Generic construction of double words *) + Section WW. -Section WW. + Context {t : Type}{ops : Ops t}{specs : Specs ops}. - Variable w : Type. - Variable w_op : znz_op w. - Variable op_spec : znz_spec w_op. + Let wB := base digits. - Let wB := base w_op.(znz_digits). - Let w_to_Z := w_op.(znz_to_Z). - Let w_eq0 := w_op.(znz_eq0). - Let w_0 := w_op.(znz_0). + Definition WO' (eq0:t->bool) zero h := + if eq0 h then W0 else WW h zero. - Definition znz_W0 h := - if w_eq0 h then W0 else WW h w_0. + Definition WO := Eval lazy beta delta [WO'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + WO' eq0 zero. - Definition znz_0W l := - if w_eq0 l then W0 else WW w_0 l. + Definition OW' (eq0:t->bool) zero l := + if eq0 l then W0 else WW zero l. - Definition znz_WW h l := - if w_eq0 h then znz_0W l else WW h l. + Definition OW := Eval lazy beta delta [OW'] in + let eq0 := ZnZ.eq0 in + let zero := ZnZ.zero in + OW' eq0 zero. - Lemma spec_W0 : forall h, - zn2z_to_Z wB w_to_Z (znz_W0 h) = (w_to_Z h)*wB. + 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, znz_W0, w_to_Z; simpl; intros. - case_eq (w_eq0 h); intros. - rewrite (op_spec.(spec_eq0) _ H); auto. - unfold w_0; rewrite op_spec.(spec_0); auto with zarith. + 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_0W : forall l, - zn2z_to_Z wB w_to_Z (znz_0W l) = w_to_Z l. + Lemma spec_OW : forall l, + zn2z_to_Z wB to_Z (OW l) = to_Z l. Proof. - unfold zn2z_to_Z, znz_0W, w_to_Z; simpl; intros. - case_eq (w_eq0 l); intros. - rewrite (op_spec.(spec_eq0) _ H); auto. - unfold w_0; rewrite op_spec.(spec_0); auto with zarith. + 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 w_to_Z (znz_WW h l) = (w_to_Z h)*wB + w_to_Z l. + zn2z_to_Z wB to_Z (WW h l) = (to_Z h)*wB + to_Z l. Proof. - unfold znz_WW, w_to_Z; simpl; intros. - case_eq (w_eq0 h); intros. - rewrite (op_spec.(spec_eq0) _ H); auto. - rewrite spec_0W; auto. + 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 *) + End WW. -Section znz_of_pos. + (** Injecting [Z] numbers into a cyclic structure *) - Variable w : Type. - Variable w_op : znz_op w. - Variable op_spec : znz_spec w_op. + Section Of_Z. - Notation "[| x |]" := (znz_to_Z w_op x) (at level 0, x at level 99). + Context {t : Type}{ops : Ops t}{specs : Specs ops}. - Definition znz_of_Z (w:Type) (op:znz_op w) z := - match z with - | Zpos p => snd (op.(znz_of_pos) p) - | _ => op.(znz_0) - end. + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - Theorem znz_of_pos_correct: - forall p, Zpos p < base (znz_digits w_op) -> [|(snd (znz_of_pos w_op p))|] = Zpos p. + Theorem of_pos_correct: + forall p, Zpos p < base digits -> [|(snd (of_pos p))|] = Zpos p. + Proof. intros p Hp. - generalize (spec_of_pos op_spec p). - case (znz_of_pos w_op p); intros n w1; simpl. + generalize (spec_of_pos p). + case (of_pos p); intros n w1; simpl. case n; simpl Npos; auto with zarith. intros p1 Hp1; contradict Hp; apply Zle_not_lt. - rewrite Hp1; auto with zarith. - match goal with |- _ <= ?X + ?Y => - apply Zle_trans with X; auto with zarith - end. - match goal with |- ?X <= _ => - pattern X at 1; rewrite <- (Zmult_1_l); - apply Zmult_le_compat_r; auto with zarith - end. + replace (base digits) with (1 * base digits + 0) by ring. + rewrite Hp1. + apply Zplus_le_compat. + apply Zmult_le_compat; auto with zarith. case p1; simpl; intros; red; simpl; intros; discriminate. unfold base; auto with zarith. - case (spec_to_Z op_spec w1); auto with zarith. + case (spec_to_Z w1); auto with zarith. Qed. - Theorem znz_of_Z_correct: - forall p, 0 <= p < base (znz_digits w_op) -> [|znz_of_Z w_op p|] = p. + 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 znz_of_pos_correct; auto with zarith. + intros; rewrite of_pos_correct; auto with zarith. intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto. Qed. -End znz_of_pos. + End Of_Z. + +End ZnZ. (** A modular specification grouping the earlier records. *) Module Type CyclicType. - Parameter w : Type. - Parameter w_op : znz_op w. - Parameter w_spec : znz_spec w_op. + Parameter t : Type. + Declare Instance ops : ZnZ.Ops t. + Declare Instance specs : ZnZ.Specs ops. End CyclicType. @@ -379,38 +325,29 @@ End CyclicType. Module CyclicRing (Import Cyclic : CyclicType). -Definition t := w. - -Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). +Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). Definition eq (n m : t) := [| n |] = [| m |]. -Definition zero : t := w_op.(znz_0). -Definition one := w_op.(znz_1). -Definition add := w_op.(znz_add). -Definition sub := w_op.(znz_sub). -Definition mul := w_op.(znz_mul). -Definition opp := w_op.(znz_opp). Local Infix "==" := eq (at level 70). -Local Notation "0" := zero. -Local Notation "1" := one. -Local Infix "+" := add. -Local Infix "-" := sub. -Local Infix "*" := mul. -Local Notation "!!" := (base (znz_digits w_op)). - -Hint Rewrite - w_spec.(spec_0) w_spec.(spec_1) - w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_opp) w_spec.(spec_sub) +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). + +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, zero, one, add, sub, mul, opp in *; autorewrite with cyclic. +Ltac zify := unfold eq in *; autorewrite with cyclic. Lemma add_0_l : forall x, 0 + x == x. Proof. intros. zify. rewrite Zplus_0_l. -apply Zmod_small. apply w_spec.(spec_to_Z). +apply Zmod_small. apply ZnZ.spec_to_Z. Qed. Lemma add_comm : forall x y, x + y == y + x. @@ -426,7 +363,7 @@ Qed. Lemma mul_1_l : forall x, 1 * x == x. Proof. intros. zify. rewrite Zmult_1_l. -apply Zmod_small. apply w_spec.(spec_to_Z). +apply Zmod_small. apply ZnZ.spec_to_Z. Qed. Lemma mul_comm : forall x y, x * y == y * x. @@ -444,22 +381,22 @@ Proof. intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Zmult_plus_distr_l. Qed. -Lemma add_opp_r : forall x y, x + opp y == x-y. +Lemma add_opp_r : forall x y, x + - y == x-y. Proof. intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Zminus. -destruct (Z_eq_dec ([|y|] mod !!) 0) as [EQ|NEQ]. +destruct (Z_eq_dec ([|y|] mod wB) 0) as [EQ|NEQ]. rewrite Z_mod_zero_opp_full, EQ, 2 Zplus_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 + opp x == 0. +Lemma add_opp_diag_r : forall x, x + - x == 0. Proof. intros. red. rewrite add_opp_r. zify. now rewrite Zminus_diag, Zmod_0_l. Qed. -Lemma CyclicRing : ring_theory 0 1 add mul sub opp eq. +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. @@ -470,15 +407,26 @@ exact add_opp_diag_r. Qed. Definition eqb x y := - match w_op.(znz_compare) x y with Eq => true | _ => false end. + 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 Zcompare_spec; intuition; try discriminate. +Qed. +(* POUR HUGO: Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. Proof. - intros. unfold eqb, eq. generalize (w_spec.(spec_compare) x y). - destruct (w_op.(znz_compare) x y); intuition; try discriminate. + intros. unfold eqb, eq. generalize (ZnZ.spec_compare x y). + case (ZnZ.compare x y); intuition; try discriminate. + (* BUG ?! using destruct instead of case won't work: + it gives 3 subcases, but ZnZ.compare x y is still there in them! *) Qed. +*) Lemma eqb_correct : forall x y, eqb x y = true -> x==y. Proof. now apply eqb_eq. Qed. -End CyclicRing.
\ No newline at end of file +End CyclicRing. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 92215ba9..c52cbe10 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NZAxioms. Require Import BigNumPrelude. Require Import DoubleType. @@ -27,21 +25,19 @@ Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig. Local Open Scope Z_scope. -Definition t := w. - -Definition NZ_to_Z : t -> Z := znz_to_Z w_op. -Definition Z_to_NZ : Z -> t := znz_of_Z w_op. -Local Notation wB := (base w_op.(znz_digits)). +Local Notation wB := (base ZnZ.digits). -Local Notation "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). +Local Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). Definition eq (n m : t) := [| n |] = [| m |]. -Definition zero := w_op.(znz_0). -Definition succ := w_op.(znz_succ). -Definition pred := w_op.(znz_pred). -Definition add := w_op.(znz_add). -Definition sub := w_op.(znz_sub). -Definition mul := w_op.(znz_mul). +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. @@ -51,41 +47,25 @@ Local Infix "+" := add. Local Infix "-" := sub. Local Infix "*" := mul. -Hint Rewrite w_spec.(spec_0) w_spec.(spec_succ) w_spec.(spec_pred) - w_spec.(spec_add) w_spec.(spec_mul) w_spec.(spec_sub) : w. -Ltac wsimpl := - unfold eq, zero, succ, pred, add, sub, mul; autorewrite with w. -Ltac wcongruence := repeat red; intros; wsimpl; congruence. +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. Instance eq_equiv : Equivalence eq. Proof. unfold eq. firstorder. Qed. -Instance succ_wd : Proper (eq ==> eq) succ. -Proof. -wcongruence. -Qed. - -Instance pred_wd : Proper (eq ==> eq) pred. -Proof. -wcongruence. -Qed. - -Instance add_wd : Proper (eq ==> eq ==> eq) add. -Proof. -wcongruence. -Qed. - -Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -Proof. -wcongruence. -Qed. +Local Obligation Tactic := zcongruence. -Instance mul_wd : Proper (eq ==> eq ==> eq) mul. -Proof. -wcongruence. -Qed. +Program Instance succ_wd : Proper (eq ==> eq) succ. +Program Instance pred_wd : Proper (eq ==> eq) pred. +Program Instance add_wd : Proper (eq ==> eq ==> eq) add. +Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. +Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. Theorem gt_wB_1 : 1 < wB. Proof. @@ -97,39 +77,41 @@ Proof. pose proof gt_wB_1; auto with zarith. 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. -pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zplus_mod. -reflexivity. -now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]]. +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. -pattern 1 at 2. replace 1 with (1 mod wB). rewrite <- Zminus_mod. -reflexivity. -now rewrite Zmod_small; [ | split; [auto with zarith | apply gt_wB_1]]. +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 w_spec.(spec_to_Z). +intro n; rewrite Zmod_small. reflexivity. apply ZnZ.spec_to_Z. Qed. Theorem pred_succ : forall n, P (S n) == n. Proof. -intro n. wsimpl. +intro n. zify. rewrite <- pred_mod_wB. -replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod. +replace ([| n |] + 1 - 1)%Z with [| n |] by ring. apply NZ_to_Z_mod. Qed. -Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0. +Theorem one_succ : one == succ zero. Proof. -unfold NZ_to_Z, Z_to_NZ. wsimpl. -rewrite znz_of_Z_correct; auto. -exact w_spec. split; [auto with zarith |apply gt_wB_0]. +zify; simpl. now rewrite one_mod_wB. +Qed. + +Theorem two_succ : two == succ one. +Proof. +reflexivity. Qed. Section Induction. @@ -140,21 +122,22 @@ Hypothesis A0 : A 0. Hypothesis AS : forall n, A n <-> A (S n). (* Below, we use only -> direction *) -Let B (n : Z) := A (Z_to_NZ n). +Let B (n : Z) := A (ZnZ.of_Z n). Lemma B0 : B 0. Proof. -unfold B. now rewrite Z_to_NZ_0. +unfold B. +setoid_replace (ZnZ.of_Z 0) with zero. assumption. +red; zify. apply ZnZ.of_Z_correct. auto using gt_wB_0 with zarith. 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 (Z_to_NZ (n + 1)) with (S (Z_to_NZ n)). assumption. -wsimpl. -unfold NZ_to_Z, Z_to_NZ. -do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]). +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; auto with zarith. symmetry; apply Zmod_small; auto with zarith. Qed. @@ -167,25 +150,23 @@ Qed. Theorem bi_induction : forall n, A n. Proof. -intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)). -apply B_holds. apply w_spec.(spec_to_Z). -unfold eq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct. -reflexivity. -exact w_spec. -apply w_spec.(spec_to_Z). +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. wsimpl. -rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)]. +intro n. zify. +rewrite Zplus_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. wsimpl. +intros n m. zify. rewrite succ_mod_wB. repeat rewrite Zplus_mod_idemp_l; try apply gt_wB_0. rewrite <- (Zplus_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l. rewrite (Zplus_comm 1 [| m |]); now rewrite Zplus_assoc. @@ -193,25 +174,27 @@ Qed. Theorem sub_0_r : forall n, n - 0 == n. Proof. -intro n. wsimpl. rewrite Zminus_0_r. apply NZ_to_Z_mod. +intro n. zify. rewrite Zminus_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. wsimpl. rewrite Zminus_mod_idemp_r, Zminus_mod_idemp_l. +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 auto with zarith. + by ring. Qed. Theorem mul_0_l : forall n, 0 * n == 0. Proof. -intro n. wsimpl. now rewrite Zmult_0_l. +intro n. now zify. Qed. Theorem mul_succ_l : forall n m, (S n) * m == n * m + m. Proof. -intros n m. wsimpl. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. +intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. now rewrite Zmult_plus_distr_l, Zmult_1_l. Qed. +Definition t := t. + End NZCyclicAxiomsMod. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index 305d77a9..deb216dd 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v index 3d44f96b..e6c5a0e0 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,16 +8,16 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. -Require Import ZArith. +Require Import ZArith Ndigits. Require Import BigNumPrelude. Require Import DoubleType. Local Open Scope Z_scope. +Local Infix "<<" := Pos.shiftl_nat (at level 30). + Section DoubleBase. Variable w : Type. Variable w_0 : w. @@ -70,13 +70,7 @@ Section DoubleBase. end end. - Fixpoint double_digits (n:nat) : positive := - match n with - | O => w_digits - | S n => xO (double_digits n) - end. - - Definition double_wB n := base (double_digits n). + Definition double_wB n := base (w_digits << n). Fixpoint double_to_Z (n:nat) : word w n -> Z := match n return word w n -> Z with @@ -167,11 +161,7 @@ Section DoubleBase. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_to_Z : forall x, 0 <= [|x|] < wB. Variable spec_w_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + w_compare x y = Zcompare [|x|] [|y|]. Lemma wwB_wBwB : wwB = wB^2. Proof. @@ -297,11 +287,10 @@ Section DoubleBase. Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n). Proof. intros n;unfold double_wB;simpl. - unfold base;rewrite (Zpos_xO (double_digits n)). - replace (2 * Zpos (double_digits n)) with - (Zpos (double_digits n) + Zpos (double_digits n)). + unfold base. rewrite Pshiftl_nat_S, (Zpos_xO (_ << _)). + replace (2 * Zpos (w_digits << n)) with + (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring. symmetry; apply Zpower_exp;intro;discriminate. - ring. Qed. Lemma double_wB_pos: @@ -315,7 +304,7 @@ Section DoubleBase. Proof. clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. intros n; elim n; clear n; auto. - unfold double_wB, double_digits; auto with zarith. + unfold double_wB, "<<"; auto with zarith. intros n H1; rewrite <- double_wB_wwB. apply Zle_trans with (wB * 1). rewrite Zmult_1_r; apply Zle_refl. @@ -408,35 +397,40 @@ Section DoubleBase. intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. Qed. + Ltac comp2ord := match goal with + | |- Lt = (?x ?= ?y) => symmetry; change (x < y) + | |- Gt = (?x ?= ?y) => symmetry; change (x > y); apply Zlt_gt + end. + Lemma spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Proof. destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial. - generalize (spec_w_compare w_0 yh);destruct (w_compare w_0 yh); - intros H;rewrite spec_w_0 in H. - rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare. - change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. + (* 1st case *) + rewrite 2 spec_w_compare, spec_w_0. + destruct (Zcompare_spec 0 [|yh|]) as [H|H|H]. + rewrite <- H;simpl. reflexivity. + symmetry. change (0 < [|yh|]*wB+[|yl|]). + change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. apply wB_lex_inv;trivial. - absurd (0 <= [|yh|]). apply Zgt_not_le;trivial. + absurd (0 <= [|yh|]). apply Zlt_not_le; trivial. destruct (spec_to_Z yh);trivial. - generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0); - intros H;rewrite spec_w_0 in H. - rewrite H;simpl;rewrite <- spec_w_0;apply spec_w_compare. - absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial. + (* 2nd case *) + rewrite 2 spec_w_compare, spec_w_0. + destruct (Zcompare_spec [|xh|] 0) as [H|H|H]. + rewrite H;simpl;reflexivity. + absurd (0 <= [|xh|]). apply Zlt_not_le; trivial. destruct (spec_to_Z xh);trivial. - apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;apply Zgt_lt;trivial. - - generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H. - rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl); - intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l]; - trivial. + comp2ord. + change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. apply wB_lex_inv;trivial. - apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. + (* 3rd case *) + rewrite 2 spec_w_compare. + destruct (Zcompare_spec [|xh|] [|yh|]) as [H|H|H]. + rewrite H. + symmetry. apply Zcompare_plus_compat. + comp2ord. apply wB_lex_inv;trivial. + comp2ord. apply wB_lex_inv;trivial. Qed. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index 006da1b3..00a84052 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -30,65 +28,65 @@ Local Open Scope Z_scope. Section Z_2nZ. - Variable w : Type. - Variable w_op : znz_op w. - Let w_digits := w_op.(znz_digits). - Let w_zdigits := w_op.(znz_zdigits). + Context {t : Type}{ops : ZnZ.Ops t}. + + Let w_digits := ZnZ.digits. + Let w_zdigits := ZnZ.zdigits. - Let w_to_Z := w_op.(znz_to_Z). - Let w_of_pos := w_op.(znz_of_pos). - Let w_head0 := w_op.(znz_head0). - Let w_tail0 := w_op.(znz_tail0). + Let w_to_Z := ZnZ.to_Z. + Let w_of_pos := ZnZ.of_pos. + Let w_head0 := ZnZ.head0. + Let w_tail0 := ZnZ.tail0. - Let w_0 := w_op.(znz_0). - Let w_1 := w_op.(znz_1). - Let w_Bm1 := w_op.(znz_Bm1). + Let w_0 := ZnZ.zero. + Let w_1 := ZnZ.one. + Let w_Bm1 := ZnZ.minus_one. - Let w_compare := w_op.(znz_compare). - Let w_eq0 := w_op.(znz_eq0). + Let w_compare := ZnZ.compare. + Let w_eq0 := ZnZ.eq0. - Let w_opp_c := w_op.(znz_opp_c). - Let w_opp := w_op.(znz_opp). - Let w_opp_carry := w_op.(znz_opp_carry). + Let w_opp_c := ZnZ.opp_c. + Let w_opp := ZnZ.opp. + Let w_opp_carry := ZnZ.opp_carry. - Let w_succ_c := w_op.(znz_succ_c). - Let w_add_c := w_op.(znz_add_c). - Let w_add_carry_c := w_op.(znz_add_carry_c). - Let w_succ := w_op.(znz_succ). - Let w_add := w_op.(znz_add). - Let w_add_carry := w_op.(znz_add_carry). + Let w_succ_c := ZnZ.succ_c. + Let w_add_c := ZnZ.add_c. + Let w_add_carry_c := ZnZ.add_carry_c. + Let w_succ := ZnZ.succ. + Let w_add := ZnZ.add. + Let w_add_carry := ZnZ.add_carry. - Let w_pred_c := w_op.(znz_pred_c). - Let w_sub_c := w_op.(znz_sub_c). - Let w_sub_carry_c := w_op.(znz_sub_carry_c). - Let w_pred := w_op.(znz_pred). - Let w_sub := w_op.(znz_sub). - Let w_sub_carry := w_op.(znz_sub_carry). + Let w_pred_c := ZnZ.pred_c. + Let w_sub_c := ZnZ.sub_c. + Let w_sub_carry_c := ZnZ.sub_carry_c. + Let w_pred := ZnZ.pred. + Let w_sub := ZnZ.sub. + Let w_sub_carry := ZnZ.sub_carry. - Let w_mul_c := w_op.(znz_mul_c). - Let w_mul := w_op.(znz_mul). - Let w_square_c := w_op.(znz_square_c). + Let w_mul_c := ZnZ.mul_c. + Let w_mul := ZnZ.mul. + Let w_square_c := ZnZ.square_c. - Let w_div21 := w_op.(znz_div21). - Let w_div_gt := w_op.(znz_div_gt). - Let w_div := w_op.(znz_div). + Let w_div21 := ZnZ.div21. + Let w_div_gt := ZnZ.div_gt. + Let w_div := ZnZ.div. - Let w_mod_gt := w_op.(znz_mod_gt). - Let w_mod := w_op.(znz_mod). + Let w_mod_gt := ZnZ.modulo_gt. + Let w_mod := ZnZ.modulo. - Let w_gcd_gt := w_op.(znz_gcd_gt). - Let w_gcd := w_op.(znz_gcd). + Let w_gcd_gt := ZnZ.gcd_gt. + Let w_gcd := ZnZ.gcd. - Let w_add_mul_div := w_op.(znz_add_mul_div). + Let w_add_mul_div := ZnZ.add_mul_div. - Let w_pos_mod := w_op.(znz_pos_mod). + Let w_pos_mod := ZnZ.pos_mod. - Let w_is_even := w_op.(znz_is_even). - Let w_sqrt2 := w_op.(znz_sqrt2). - Let w_sqrt := w_op.(znz_sqrt). + Let w_is_even := ZnZ.is_even. + Let w_sqrt2 := ZnZ.sqrt2. + Let w_sqrt := ZnZ.sqrt. - Let _zn2z := zn2z w. + Let _zn2z := zn2z t. Let wB := base w_digits. @@ -105,9 +103,9 @@ Section Z_2nZ. Let to_Z := zn2z_to_Z wB w_to_Z. - Let w_W0 := znz_W0 w_op. - Let w_0W := znz_0W w_op. - Let w_WW := znz_WW w_op. + Let w_W0 := ZnZ.WO. + Let w_0W := ZnZ.OW. + Let w_WW := ZnZ.WW. Let ww_of_pos p := match w_of_pos p with @@ -124,15 +122,15 @@ Section Z_2nZ. Eval lazy beta delta [ww_tail0] in ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. - Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w). - Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W w). - Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 w). + Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t). + Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t). + Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t). (* ** Comparison ** *) Let compare := Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - Let eq0 (x:zn2z w) := + Let eq0 (x:zn2z t) := match x with | W0 => true | _ => false @@ -226,7 +224,7 @@ Section Z_2nZ. Eval lazy beta iota delta [ww_div21] in ww_div21 w_0 w_0W div32 ww_1 compare sub. - Let low (p: zn2z w) := match p with WW _ p1 => p1 | _ => w_0 end. + Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end. Let add_mul_div := Eval lazy beta delta [ww_add_mul_div] in @@ -287,8 +285,8 @@ Section Z_2nZ. (* ** Record of operators on 2 words *) - Definition mk_zn2z_op := - mk_znz_op _ww_digits _ww_zdigits + Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 := + ZnZ.MkOps _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 @@ -307,8 +305,8 @@ Section Z_2nZ. sqrt2 sqrt. - Definition mk_zn2z_op_karatsuba := - mk_znz_op _ww_digits _ww_zdigits + Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 := + ZnZ.MkOps _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 @@ -328,51 +326,51 @@ Section Z_2nZ. sqrt. (* Proof *) - Variable op_spec : znz_spec w_op. + Context {specs : ZnZ.Specs ops}. Hint Resolve - (spec_to_Z op_spec) - (spec_of_pos op_spec) - (spec_0 op_spec) - (spec_1 op_spec) - (spec_Bm1 op_spec) - (spec_compare op_spec) - (spec_eq0 op_spec) - (spec_opp_c op_spec) - (spec_opp op_spec) - (spec_opp_carry op_spec) - (spec_succ_c op_spec) - (spec_add_c op_spec) - (spec_add_carry_c op_spec) - (spec_succ op_spec) - (spec_add op_spec) - (spec_add_carry op_spec) - (spec_pred_c op_spec) - (spec_sub_c op_spec) - (spec_sub_carry_c op_spec) - (spec_pred op_spec) - (spec_sub op_spec) - (spec_sub_carry op_spec) - (spec_mul_c op_spec) - (spec_mul op_spec) - (spec_square_c op_spec) - (spec_div21 op_spec) - (spec_div_gt op_spec) - (spec_div op_spec) - (spec_mod_gt op_spec) - (spec_mod op_spec) - (spec_gcd_gt op_spec) - (spec_gcd op_spec) - (spec_head0 op_spec) - (spec_tail0 op_spec) - (spec_add_mul_div op_spec) - (spec_pos_mod) - (spec_is_even) - (spec_sqrt2) - (spec_sqrt) - (spec_W0 op_spec) - (spec_0W op_spec) - (spec_WW op_spec). + ZnZ.spec_to_Z + ZnZ.spec_of_pos + ZnZ.spec_0 + ZnZ.spec_1 + ZnZ.spec_m1 + ZnZ.spec_compare + ZnZ.spec_eq0 + ZnZ.spec_opp_c + ZnZ.spec_opp + ZnZ.spec_opp_carry + ZnZ.spec_succ_c + ZnZ.spec_add_c + ZnZ.spec_add_carry_c + ZnZ.spec_succ + ZnZ.spec_add + ZnZ.spec_add_carry + ZnZ.spec_pred_c + ZnZ.spec_sub_c + ZnZ.spec_sub_carry_c + ZnZ.spec_pred + ZnZ.spec_sub + ZnZ.spec_sub_carry + ZnZ.spec_mul_c + ZnZ.spec_mul + ZnZ.spec_square_c + ZnZ.spec_div21 + ZnZ.spec_div_gt + ZnZ.spec_div + ZnZ.spec_modulo_gt + ZnZ.spec_modulo + ZnZ.spec_gcd_gt + ZnZ.spec_gcd + ZnZ.spec_head0 + ZnZ.spec_tail0 + ZnZ.spec_add_mul_div + ZnZ.spec_pos_mod + ZnZ.spec_is_even + ZnZ.spec_sqrt2 + ZnZ.spec_sqrt + ZnZ.spec_WO + ZnZ.spec_OW + ZnZ.spec_WW. Ltac wwauto := unfold ww_to_Z; auto. @@ -395,16 +393,17 @@ Section Z_2nZ. Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. Proof. unfold ww_of_pos;intros. - assert (H:= spec_of_pos op_spec p);unfold w_of_pos; - destruct (znz_of_pos w_op p). simpl in H. - rewrite H;clear H;destruct n;simpl to_Z. - simpl;unfold w_to_Z,w_0;rewrite (spec_0 op_spec);trivial. - unfold Z_of_N; assert (H:= spec_of_pos op_spec p0); - destruct (znz_of_pos w_op p0). simpl in H. - rewrite H;unfold fst, snd,Z_of_N, to_Z. - rewrite (spec_WW op_spec). + rewrite (ZnZ.spec_of_pos p). unfold w_of_pos. + case (ZnZ.of_pos p); intros. simpl. + destruct n; simpl ZnZ.to_Z. + simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial. + unfold Z_of_N. + rewrite (ZnZ.spec_of_pos p0). + case (ZnZ.of_pos p0); intros. simpl. + unfold fst, snd,Z_of_N, to_Z, wB, w_digits, w_to_Z, w_WW. + rewrite ZnZ.spec_WW. replace wwB with (wB*wB). - unfold wB,w_to_Z,w_digits;clear H;destruct n;ring. + unfold wB,w_to_Z,w_digits;destruct n;ring. symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). Qed. @@ -418,15 +417,9 @@ Section Z_2nZ. Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. Let spec_ww_compare : - forall x y, - match compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, compare x y = Zcompare [|x|] [|y|]. Proof. refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. - exact (spec_compare op_spec). Qed. Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. @@ -531,8 +524,7 @@ Section Z_2nZ. Proof. refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - unfold w_digits; apply spec_more_than_1_digit; auto. - exact (spec_compare op_spec). + unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto. Qed. Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. @@ -559,11 +551,10 @@ Section Z_2nZ. w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. unfold w_Bm2, w_to_Z, w_pred, w_Bm1. - rewrite (spec_pred op_spec);rewrite (spec_Bm1 op_spec). + rewrite ZnZ.spec_pred, ZnZ.spec_m1. unfold w_digits;rewrite Zmod_small. ring. - assert (H:= wB_pos(znz_digits w_op)). omega. - exact (spec_compare op_spec). - exact (spec_div21 op_spec). + assert (H:= wB_pos(ZnZ.digits)). omega. + exact ZnZ.spec_div21. Qed. Let spec_ww_div21 : forall a1 a2 b, @@ -580,22 +571,19 @@ Section Z_2nZ. Let spec_add2: forall x y, [|w_add2 x y|] = w_to_Z x + w_to_Z y. unfold w_add2. - intros xh xl; generalize (spec_add_c op_spec xh xl). - unfold w_add_c; case znz_add_c; unfold interp_carry; simpl ww_to_Z. + intros xh xl; generalize (ZnZ.spec_add_c xh xl). + unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z. intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0. - unfold w_0; rewrite spec_0; simpl; auto with zarith. + unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith. intros w0; rewrite Zmult_1_l; simpl. - unfold w_to_Z, w_1; rewrite spec_1; auto with zarith. + unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith. rewrite Zmult_1_l; auto. Qed. Let spec_low: forall x, w_to_Z (low x) = [|x|] mod wB. intros x; case x; simpl low. - unfold ww_to_Z, w_to_Z, w_0; rewrite (spec_0 op_spec); simpl. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - unfold wB, base; auto with zarith. + unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; auto. intros xh xl; simpl. rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith. rewrite Zmod_small; auto with zarith. @@ -608,7 +596,7 @@ Section Z_2nZ. unfold w_to_Z, _ww_zdigits. rewrite spec_add2. unfold w_to_Z, w_zdigits, w_digits. - rewrite spec_zdigits; auto. + rewrite ZnZ.spec_zdigits; auto. rewrite Zpos_xO; auto with zarith. Qed. @@ -618,9 +606,8 @@ Section Z_2nZ. refine (spec_ww_head00 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto. - exact (spec_compare op_spec). - exact (spec_head00 op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_head00. + exact ZnZ.spec_zdigits. Qed. Let spec_ww_head0 : forall x, 0 < [|x|] -> @@ -629,8 +616,7 @@ Section Z_2nZ. refine (spec_ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. - exact (spec_compare op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. Qed. Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. @@ -638,9 +624,8 @@ Section Z_2nZ. refine (spec_ww_tail00 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto. - exact (spec_compare op_spec). - exact (spec_tail00 op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_tail00. + exact ZnZ.spec_zdigits. Qed. @@ -649,8 +634,7 @@ Section Z_2nZ. Proof. refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. - exact (spec_compare op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. Qed. Lemma spec_ww_add_mul_div : forall x y p, @@ -659,10 +643,10 @@ Section Z_2nZ. ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. Proof. - refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div + refine (@spec_ww_add_mul_div t w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_digits w_zdigits low w_to_Z _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. Qed. Let spec_ww_div_gt : forall a b, @@ -671,29 +655,29 @@ Section Z_2nZ. [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. refine -(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 +(@spec_ww_div_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ). - exact (spec_0 op_spec). - exact (spec_to_Z op_spec). + exact ZnZ.spec_0. + exact ZnZ.spec_to_Z. wwauto. wwauto. - exact (spec_compare op_spec). - exact (spec_eq0 op_spec). - exact (spec_opp_c op_spec). - exact (spec_opp op_spec). - exact (spec_opp_carry op_spec). - exact (spec_sub_c op_spec). - exact (spec_sub op_spec). - exact (spec_sub_carry op_spec). - exact (spec_div_gt op_spec). - exact (spec_add_mul_div op_spec). - exact (spec_head0 op_spec). - exact (spec_div21 op_spec). + exact ZnZ.spec_compare. + exact ZnZ.spec_eq0. + exact ZnZ.spec_opp_c. + exact ZnZ.spec_opp. + exact ZnZ.spec_opp_carry. + exact ZnZ.spec_sub_c. + exact ZnZ.spec_sub. + exact ZnZ.spec_sub_carry. + exact ZnZ.spec_div_gt. + exact ZnZ.spec_add_mul_div. + exact ZnZ.spec_head0. + exact ZnZ.spec_div21. exact spec_w_div32. - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. exact spec_ww_digits. exact spec_ww_1. exact spec_ww_add_mul_div. @@ -711,15 +695,14 @@ refine [|a|] > [|b|] -> 0 < [|b|] -> [|mod_gt a b|] = [|a|] mod [|b|]. Proof. - refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 + refine (@spec_ww_mod_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_compare op_spec). - exact (spec_div_gt op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_div_gt. + exact ZnZ.spec_div21. + exact ZnZ.spec_zdigits. exact spec_ww_add_mul_div. Qed. @@ -731,37 +714,33 @@ refine Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. Proof. - refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ + refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _ w_0 w_0 w_eq0 w_gcd_gt _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. - refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp + refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_compare op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_div21. + exact ZnZ.spec_zdigits. exact spec_ww_add_mul_div. - refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare + refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare _ _);auto. - exact (spec_compare op_spec). Qed. Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. Proof. - refine (@spec_ww_gcd w w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt + refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. - refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp + refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_compare op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_div21. + exact ZnZ.spec_zdigits. exact spec_ww_add_mul_div. - refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare + refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare _ _);auto. - exact (spec_compare op_spec). Qed. Let spec_ww_is_even : forall x, @@ -770,8 +749,8 @@ refine | false => [|x|] mod 2 = 1 end. Proof. - refine (@spec_ww_is_even w w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto. - exact (spec_is_even op_spec). + refine (@spec_ww_is_even t w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto. + exact ZnZ.spec_is_even. Qed. Let spec_ww_sqrt2 : forall x y, @@ -781,60 +760,57 @@ refine [+|r|] <= 2 * [|s|]. Proof. intros x y H. - refine (@spec_ww_sqrt2 w w_is_even w_compare w_0 w_1 w_Bm1 + refine (@spec_ww_sqrt2 t w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits _ww_zdigits w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact (spec_zdigits op_spec). - exact (spec_more_than_1_digit op_spec). - exact (spec_is_even op_spec). - exact (spec_compare op_spec). - exact (spec_div21 op_spec). - exact (spec_ww_add_mul_div). - exact (spec_sqrt2 op_spec). + exact ZnZ.spec_zdigits. + exact ZnZ.spec_more_than_1_digit. + exact ZnZ.spec_is_even. + exact ZnZ.spec_div21. + exact spec_ww_add_mul_div. + exact ZnZ.spec_sqrt2. Qed. Let spec_ww_sqrt : forall x, [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. Proof. - refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 + refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact (spec_zdigits op_spec). - exact (spec_more_than_1_digit op_spec). - exact (spec_is_even op_spec). - exact (spec_ww_add_mul_div). - exact (spec_sqrt2 op_spec). + exact ZnZ.spec_zdigits. + exact ZnZ.spec_more_than_1_digit. + exact ZnZ.spec_is_even. + exact spec_ww_add_mul_div. + exact ZnZ.spec_sqrt2. Qed. - Lemma mk_znz2_spec : znz_spec mk_zn2z_op. + Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops. Proof. - apply mk_znz_spec;auto. + apply ZnZ.MkSpecs; auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_pos_mod op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. unfold w_to_Z, w_zdigits. - rewrite (spec_zdigits op_spec). + rewrite ZnZ.spec_zdigits. rewrite <- Zpos_xO; exact spec_ww_digits. Qed. - Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba. + Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba. Proof. - apply mk_znz_spec;auto. + apply ZnZ.MkSpecs; auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact (spec_pos_mod op_spec). - exact (spec_zdigits op_spec). + exact ZnZ.spec_zdigits. unfold w_to_Z, w_zdigits. - rewrite (spec_zdigits op_spec). + rewrite ZnZ.spec_zdigits. rewrite <- Zpos_xO; exact spec_ww_digits. Qed. @@ -842,17 +818,14 @@ End Z_2nZ. Section MulAdd. - Variable w: Type. - Variable op: znz_op w. - Variable sop: znz_spec op. + Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. - Definition mul_add:= w_mul_add (znz_0 op) (znz_succ op) (znz_add_c op) (znz_mul_c op). + Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c. - Notation "[| x |]" := (znz_to_Z op x) (at level 0, x at level 99). + Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). Notation "[|| x ||]" := - (zn2z_to_Z (base (znz_digits op)) (znz_to_Z op) x) (at level 0, x at level 99). - + (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x) (at level 0, x at level 99). Lemma spec_mul_add: forall x y z, let (zh, zl) := mul_add x y z in @@ -860,11 +833,11 @@ Section MulAdd. Proof. intros x y z. refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto. - exact (spec_0 sop). - exact (spec_to_Z sop). - exact (spec_succ sop). - exact (spec_add_c sop). - exact (spec_mul_c sop). + exact ZnZ.spec_0. + exact ZnZ.spec_to_Z. + exact ZnZ.spec_succ. + exact ZnZ.spec_add_c. + exact ZnZ.spec_mul_c. Qed. End MulAdd. @@ -873,13 +846,13 @@ End MulAdd. (** Modular versions of DoubleCyclic *) Module DoubleCyclic (C:CyclicType) <: CyclicType. - Definition w := zn2z C.w. - Definition w_op := mk_zn2z_op C.w_op. - Definition w_spec := mk_znz2_spec C.w_spec. + Definition t := zn2z C.t. + Instance ops : ZnZ.Ops t := mk_zn2z_ops. + Instance specs : ZnZ.Specs ops := mk_zn2z_specs. End DoubleCyclic. Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType. - Definition w := zn2z C.w. - Definition w_op := mk_zn2z_op_karatsuba C.w_op. - Definition w_spec := mk_znz2_karatsuba_spec C.w_spec. + Definition t := zn2z C.t. + Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba. + Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba. End DoubleCyclicKaratsuba. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index 4e6eccea..0cb6848e 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleDiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -82,11 +80,7 @@ Section POS_MOD. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Variable spec_ww_sub: forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. @@ -105,8 +99,8 @@ Section POS_MOD. intros w1 p; case (spec_to_w_Z p); intros HH1 HH2. unfold ww_pos_mod; case w1. simpl; rewrite Zmod_small; split; auto with zarith. - intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; + intros xh xl; rewrite spec_ww_compare. + case Zcompare_spec; rewrite spec_w_0W; rewrite spec_zdigits; fold wB; intros H1. rewrite H1; simpl ww_to_Z. @@ -134,8 +128,8 @@ Section POS_MOD. rewrite Z_mod_mult; auto with zarith. autorewrite with w_rewrite rm10. rewrite Zmod_mod; auto with zarith. -generalize (spec_ww_compare p ww_zdigits); - case ww_compare; rewrite spec_ww_zdigits; + rewrite spec_ww_compare. + case Zcompare_spec; rewrite spec_ww_zdigits; rewrite spec_zdigits; intros H2. replace (2^[[p]]) with wwB. rewrite Zmod_small; auto with zarith. @@ -266,12 +260,7 @@ Section DoubleDiv32. Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, w_compare x y = Zcompare [|x|] [|y|]. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. Variable spec_w_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. @@ -343,7 +332,7 @@ Section DoubleDiv32. (WW (w_sub a2 b2) a3) (WW b1 b2) | Gt => (w_0, W0) (* cas absurde *) end. - assert (Hcmp:=spec_compare a1 b1);destruct (w_compare a1 b1). + rewrite spec_compare. case Zcompare_spec; intro Hcmp. simpl in Hlt. rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). @@ -545,11 +534,7 @@ Section DoubleDiv21. 0 <= [[r]] < [|b1|] * wB + [|b2|]. Variable spec_ww_1 : [[ww_1]] = 1. Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Theorem wwB_div: wwB = 2 * (wwB / 2). @@ -576,10 +561,9 @@ Section DoubleDiv21. intros a1 a2 b H Hlt; unfold ww_div21. Spec_ww_to_Z b; assert (Eq: 0 < [[b]]). Spec_ww_to_Z a1;omega. generalize Hlt H ;clear Hlt H;case a1. - intros H1 H2;simpl in H1;Spec_ww_to_Z a2; - match goal with |-context [ww_compare ?Y ?Z] => - generalize (spec_ww_compare Y Z); case (ww_compare Y Z) - end; simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. + intros H1 H2;simpl in H1;Spec_ww_to_Z a2. + rewrite spec_ww_compare. case Zcompare_spec; + simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith. split. ring. assert (wwB <= 2*[[b]]);zarith. @@ -809,12 +793,7 @@ Section DoubleDivGt. Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, w_compare x y = Zcompare [|x|] [|y|]. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. @@ -914,7 +893,7 @@ Section DoubleDivGt. end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]). assert (Hh := spec_head0 Hpos). lazy zeta. - generalize (spec_compare (w_head0 bh) w_0); case w_compare; + rewrite spec_compare; case Zcompare_spec; rewrite spec_w_0; intros HH. generalize Hh; rewrite HH; simpl Zpower; rewrite Zmult_1_l; intros (HH1, HH2); clear HH. @@ -1058,14 +1037,13 @@ Section DoubleDivGt. assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl). repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial. clear H. - assert (Hcmp := spec_compare w_0 bh); destruct (w_compare w_0 bh). + rewrite spec_compare; case Zcompare_spec; intros Hcmp. rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]). rewrite <- Hcmp;rewrite Zmult_0_l;rewrite Zplus_0_l. simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos. assert (H2:= @spec_double_divn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). - unfold double_to_Z,double_wB,double_digits in H2. destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl). @@ -1154,7 +1132,7 @@ Section DoubleDivGt. rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial. destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. clear H. - assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh). + rewrite spec_compare; case Zcompare_spec; intros H2. rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 @@ -1227,13 +1205,14 @@ Section DoubleDivGt. end | Gt => W0 (* absurde *) end). - assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). - simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh; + rewrite spec_compare, spec_w_0. + case Zcompare_spec; intros Hbh. + simpl ww_to_Z in *. rewrite <- Hbh. rewrite Zmult_0_l;rewrite Zplus_0_l. - assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). - rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0. + rewrite spec_compare, spec_w_0. + case Zcompare_spec; intros Hbl. + rewrite <- Hbl;apply Zis_gcd_0. simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - rewrite spec_w_0 in Hbl. apply Zis_gcd_mod;zarith. change ([|ah|] * wB + [|al|]) with (double_to_Z w_digits w_to_Z 1 (WW ah al)). rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div @@ -1243,20 +1222,20 @@ Section DoubleDivGt. rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;exfalso;omega. - rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). + Spec_w_to_Z bl;exfalso;omega. + assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). assert (H2 : 0 < [[WW bh bl]]). simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith. apply Zmult_lt_0_compat;zarith. apply Zis_gcd_mod;trivial. rewrite <- H. simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. simpl;apply Zis_gcd_0;zarith. - assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). - simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl. - assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). - rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;simpl. - rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith. + rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hmh. + simpl;rewrite <- Hmh;simpl. + rewrite spec_compare, spec_w_0; case Zcompare_spec; intros Hml. + rewrite <- Hml;simpl;apply Zis_gcd_0. + simpl; rewrite spec_w_0; simpl. + apply Zis_gcd_mod;zarith. change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)). rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div @@ -1265,8 +1244,8 @@ Section DoubleDivGt. rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hml;Spec_w_to_Z ml;exfalso;omega. - rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]). + Spec_w_to_Z ml;exfalso;omega. + assert ([[WW bh bl]] > [[WW mh ml]]). rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). @@ -1300,8 +1279,8 @@ Section DoubleDivGt. rewrite Z_div_mult;zarith. assert (2^1 <= 2^n). change (2^1) with 2;zarith. assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. - rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;exfalso;zarith. - rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;exfalso;zarith. + Spec_w_to_Z mh;exfalso;zarith. + Spec_w_to_Z bh;exfalso;zarith. Qed. Lemma spec_ww_gcd_gt_aux : @@ -1374,11 +1353,7 @@ Section DoubleDiv. Variable spec_to_Z : forall x, 0 <= [|x|] < wB. Variable spec_ww_1 : [[ww_1]] = 1. Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> let (q,r) := ww_div_gt a b in [[a]] = [[q]] * [[b]] + [[r]] /\ @@ -1400,20 +1375,20 @@ Section DoubleDiv. 0 <= [[r]] < [[b]]. Proof. intros a b Hpos;unfold ww_div. - assert (H:=spec_ww_compare a b);destruct (ww_compare a b). + rewrite spec_ww_compare; case Zcompare_spec; intros. simpl;rewrite spec_ww_1;split;zarith. simpl;split;[ring|Spec_ww_to_Z a;zarith]. - apply spec_ww_div_gt;trivial. + apply spec_ww_div_gt;auto with zarith. Qed. Lemma spec_ww_mod : forall a b, 0 < [[b]] -> [[ww_mod a b]] = [[a]] mod [[b]]. Proof. intros a b Hpos;unfold ww_mod. - assert (H := spec_ww_compare a b);destruct (ww_compare a b). + rewrite spec_ww_compare; case Zcompare_spec; intros. simpl;apply Zmod_unique with 1;try rewrite H;zarith. Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. - apply spec_ww_mod_gt;trivial. + apply spec_ww_mod_gt;auto with zarith. Qed. @@ -1431,12 +1406,7 @@ Section DoubleDiv. Variable spec_w_0 : [|w_0|] = 0. Variable spec_w_1 : [|w_1|] = 1. Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, w_compare x y = Zcompare [|x|] [|y|]. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. @@ -1468,14 +1438,14 @@ Section DoubleDiv. assert (0 <= 1 < wB). split;zarith. apply wB_pos. assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). Spec_w_to_Z yh;zarith. - unfold gcd_cont;assert (Hcmpy:=spec_compare w_1 yl); - rewrite spec_w_1 in Hcmpy. - simpl;rewrite H;simpl;destruct (w_compare w_1 yl). + unfold gcd_cont; rewrite spec_compare, spec_w_1. + case Zcompare_spec; intros Hcmpy. + simpl;rewrite H;simpl; rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. rewrite H in Hle; exfalso;zarith. - assert ([|yl|] = 0). Spec_w_to_Z yl;zarith. - rewrite H0;simpl;apply Zis_gcd_0;trivial. + assert (H0 : [|yl|] = 0) by (Spec_w_to_Z yl;zarith). + simpl. rewrite H0, H;simpl;apply Zis_gcd_0;trivial. Qed. @@ -1528,7 +1498,7 @@ Section DoubleDiv. | Eq => a | Lt => ww_gcd_gt b a end). - assert (Hcmp := spec_ww_compare a b);destruct (ww_compare a b). + rewrite spec_ww_compare; case Zcompare_spec; intros Hcmp. Spec_ww_to_Z b;rewrite Hcmp. apply Zis_gcd_for_euclid with 1;zarith. ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index 4bdb75d6..062282f2 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,17 +8,17 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleDivn1.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. -Require Import ZArith. +Require Import ZArith Ndigits. Require Import BigNumPrelude. Require Import DoubleType. Require Import DoubleBase. Local Open Scope Z_scope. +Local Infix "<<" := Pos.shiftl_nat (at level 30). + Section GENDIVN1. Variable w : Type. @@ -62,12 +62,7 @@ Section GENDIVN1. [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, w_compare x y = Zcompare [|x|] [|y|]. Variable spec_sub: forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. @@ -162,14 +157,10 @@ Section GENDIVN1. | S n => double_divn1_p_aux n (double_divn1_p n) end. - Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (double_digits w_digits n). + Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (w_digits << n). Proof. -(* - induction n;simpl. destruct p_bounded;trivial. - case (spec_to_Z p); rewrite Zpos_xO;auto with zarith. -*) induction n;simpl. trivial. - case (spec_to_Z p); rewrite Zpos_xO;auto with zarith. + case (spec_to_Z p); rewrite Pshiftl_nat_S, Zpos_xO;auto with zarith. Qed. Lemma spec_double_divn1_p : forall n r h l, @@ -177,14 +168,14 @@ Section GENDIVN1. let (q,r') := double_divn1_p n r h l in [|r|] * double_wB w_digits n + ([!n|h!]*2^[|p|] + - [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|]))) + [!n|l!] / (2^(Zpos(w_digits << n) - [|p|]))) mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ 0 <= [|r'|] < [|b2p|]. Proof. case (spec_to_Z p); intros HH0 HH1. induction n;intros. simpl (double_divn1_p 0 r h l). - unfold double_to_Z, double_wB, double_digits. + unfold double_to_Z, double_wB, "<<". rewrite <- spec_add_mul_divp. exact (spec_div21 (w_add_mul_div p h l) b2p_le H). simpl (double_divn1_p (S n) r h l). @@ -196,24 +187,24 @@ Section GENDIVN1. replace ([|r|] * (double_wB w_digits n * double_wB w_digits n) + (([!n|hh!] * double_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] + ([!n|lh!] * double_wB w_digits n + [!n|ll!]) / - 2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod + 2^(Zpos (w_digits << (S n)) - [|p|])) mod (double_wB w_digits n * double_wB w_digits n)) with (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + - [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod + [!n|hl!] / 2^(Zpos (w_digits << n) - [|p|])) mod double_wB w_digits n) * double_wB w_digits n + ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod + [!n|lh!] / 2^(Zpos (w_digits << n) - [|p|])) mod double_wB w_digits n). generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh); intros (H3,H4);rewrite H3. assert ([|rh|] < [|b2p|]). omega. replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod + [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod double_wB w_digits n) with ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod + [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod double_wB w_digits n)). 2:ring. generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl); intros (H5,H6);rewrite H5. @@ -229,52 +220,52 @@ Section GENDIVN1. unfold double_wB,base. assert (UU:=p_lt_double_digits n). rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (double_digits w_digits (S n))) - with (2*Zpos (double_digits w_digits n));auto with zarith. - replace (2 ^ (Zpos (double_digits w_digits (S n)) - [|p|])) with - (2^(Zpos (double_digits w_digits n) - [|p|])*2^Zpos (double_digits w_digits n)). + 2:change (Zpos (w_digits << (S n))) + with (2*Zpos (w_digits << n));auto with zarith. + replace (2 ^ (Zpos (w_digits << (S n)) - [|p|])) with + (2^(Zpos (w_digits << n) - [|p|])*2^Zpos (w_digits << n)). rewrite Zdiv_mult_cancel_r;auto with zarith. rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). pattern ([!n|hl!] * 2^[|p|]) at 2; - rewrite (shift_unshift_mod (Zpos(double_digits w_digits n))([|p|])([!n|hl!])); + rewrite (shift_unshift_mod (Zpos(w_digits << n))([|p|])([!n|hl!])); auto with zarith. rewrite Zplus_assoc. replace - ([!n|hh!] * 2^Zpos (double_digits w_digits n)* 2^[|p|] + - ([!n|hl!] / 2^(Zpos (double_digits w_digits n)-[|p|])* - 2^Zpos(double_digits w_digits n))) + ([!n|hh!] * 2^Zpos (w_digits << n)* 2^[|p|] + + ([!n|hl!] / 2^(Zpos (w_digits << n)-[|p|])* + 2^Zpos(w_digits << n))) with (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / - 2^(Zpos (double_digits w_digits n)-[|p|])) - * 2^Zpos(double_digits w_digits n));try (ring;fail). + 2^(Zpos (w_digits << n)-[|p|])) + * 2^Zpos(w_digits << n));try (ring;fail). rewrite <- Zplus_assoc. rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. replace - (2 ^ Zpos (double_digits w_digits n) * 2 ^ Zpos (double_digits w_digits n)) with - (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))). - rewrite (Zmod_shift_r (Zpos (double_digits w_digits n)));auto with zarith. - replace (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))) - with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). + (2 ^ Zpos (w_digits << n) * 2 ^ Zpos (w_digits << n)) with + (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))). + rewrite (Zmod_shift_r (Zpos (w_digits << n)));auto with zarith. + replace (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))) + with (2^Zpos(w_digits << n) *2^Zpos(w_digits << n)). rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] + - [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))). + [!n|hl!] / 2 ^ (Zpos (w_digits << n) - [|p|])))). rewrite Zmult_mod_distr_l;auto with zarith. ring. rewrite Zpower_exp;auto with zarith. - assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity. + assert (0 < Zpos (w_digits << n)). unfold Zlt;reflexivity. auto with zarith. apply Z_mod_lt;auto with zarith. rewrite Zpower_exp;auto with zarith. split;auto with zarith. apply Zdiv_lt_upper_bound;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with - (Zpos(double_digits w_digits n));auto with zarith. + replace ([|p|] + (Zpos (w_digits << n) - [|p|])) with + (Zpos(w_digits << n));auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits (S n)) - [|p|]) with - (Zpos (double_digits w_digits n) - [|p|] + - Zpos (double_digits w_digits n));trivial. - change (Zpos (double_digits w_digits (S n))) with - (2*Zpos (double_digits w_digits n)). ring. + replace (Zpos (w_digits << (S n)) - [|p|]) with + (Zpos (w_digits << n) - [|p|] + + Zpos (w_digits << n));trivial. + change (Zpos (w_digits << (S n))) with + (2*Zpos (w_digits << n)). ring. Qed. Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= @@ -311,20 +302,21 @@ Section GENDIVN1. end end. - Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n). + Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (w_digits << n). Proof. induction n;simpl;auto with zarith. - change (Zpos (xO (double_digits w_digits n))) with - (2*Zpos (double_digits w_digits n)). - assert (0 < Zpos w_digits);auto with zarith. - exact (refl_equal Lt). + rewrite Pshiftl_nat_S. + change (Zpos (xO (w_digits << n))) with + (2*Zpos (w_digits << n)). + assert (0 < Zpos w_digits) by reflexivity. + auto with zarith. Qed. Lemma spec_high : forall n (x:word w n), - [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits). + [|high n x|] = [!n|x!] / 2^(Zpos (w_digits << n) - Zpos w_digits). Proof. induction n;intros. - unfold high,double_digits,double_to_Z. + unfold high,double_to_Z. rewrite Pshiftl_nat_0. replace (Zpos w_digits - Zpos w_digits) with 0;try ring. simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. assert (U2 := spec_double_digits n). @@ -336,18 +328,18 @@ Section GENDIVN1. assert (U1 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w1). simpl [!S n|WW w0 w1!]. unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith. - replace (2 ^ (Zpos (double_digits w_digits (S n)) - Zpos w_digits)) with - (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * - 2^Zpos (double_digits w_digits n)). + replace (2 ^ (Zpos (w_digits << (S n)) - Zpos w_digits)) with + (2^(Zpos (w_digits << n) - Zpos w_digits) * + 2^Zpos (w_digits << n)). rewrite Zdiv_mult_cancel_r;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + - Zpos (double_digits w_digits n)) with - (Zpos (double_digits w_digits (S n)) - Zpos w_digits);trivial. - change (Zpos (double_digits w_digits (S n))) with - (2*Zpos (double_digits w_digits n));ring. - change (Zpos (double_digits w_digits (S n))) with - (2*Zpos (double_digits w_digits n)); auto with zarith. + replace (Zpos (w_digits << n) - Zpos w_digits + + Zpos (w_digits << n)) with + (Zpos (w_digits << (S n)) - Zpos w_digits);trivial. + change (Zpos (w_digits << (S n))) with + (2*Zpos (w_digits << n));ring. + change (Zpos (w_digits << (S n))) with + (2*Zpos (w_digits << n)); auto with zarith. Qed. Definition double_divn1 (n:nat) (a:word w n) (b:w) := @@ -373,7 +365,7 @@ Section GENDIVN1. intros n a b H. unfold double_divn1. case (spec_head0 H); intros H0 H1. case (spec_to_Z (w_head0 b)); intros HH1 HH2. - generalize (spec_compare (w_head0 b) w_0); case w_compare; + rewrite spec_compare; case Zcompare_spec; rewrite spec_0; intros H2; auto with zarith. assert (Hv1: wB/2 <= [|b|]). generalize H0; rewrite H2; rewrite Zpower_0_r; @@ -432,13 +424,13 @@ Section GENDIVN1. rewrite spec_add_mul_div in H7;auto with zarith. rewrite spec_0 in H7;rewrite Zmult_0_l in H7;rewrite Zplus_0_l in H7. assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB - = [!n|a!] / 2^(Zpos (double_digits w_digits n) - [|w_head0 b|])). + = [!n|a!] / 2^(Zpos (w_digits << n) - [|w_head0 b|])). rewrite Zmod_small;auto with zarith. rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + + replace (Zpos (w_digits << n) - Zpos w_digits + (Zpos w_digits - [|w_head0 b|])) - with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring. + with (Zpos (w_digits << n) - [|w_head0 b|]);trivial;ring. assert (H8 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. split;auto with zarith. apply Zle_lt_trans with ([|high n a|]);auto with zarith. @@ -506,7 +498,7 @@ Section GENDIVN1. double_modn1 n a b = snd (double_divn1 n a b). Proof. intros n a b;unfold double_divn1,double_modn1. - generalize (spec_compare (w_head0 b) w_0); case w_compare; + rewrite spec_compare; case Zcompare_spec; rewrite spec_0; intros H2; auto with zarith. apply spec_double_modn1_0. apply spec_double_modn1_0. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v index 36e3da9b..a6a0fc8e 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleLift.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -106,17 +104,9 @@ Section DoubleLift. Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + w_compare x y = Zcompare [|x|] [|y|]. Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Variable spec_ww_digits : ww_Digits = xO w_digits. Variable spec_w_head00 : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits. Variable spec_w_head0 : forall x, 0 < [|x|] -> @@ -159,7 +149,7 @@ Section DoubleLift. absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - generalize (spec_compare w_0 xh); case w_compare. + rewrite spec_compare. case Zcompare_spec. intros H; simpl. rewrite spec_w_add; rewrite spec_w_head00. rewrite spec_zdigits; rewrite spec_ww_digits. @@ -176,9 +166,8 @@ Section DoubleLift. rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB. assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H. unfold Zlt in H;discriminate H. - assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0. - destruct (w_compare w_0 xh). - rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H. + rewrite spec_compare, spec_w_0. case Zcompare_spec; intros H0. + rewrite <- H0 in *. simpl Zplus. simpl in H. case (spec_to_Z w_zdigits); case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. rewrite spec_w_add. @@ -233,7 +222,7 @@ Section DoubleLift. apply Zmult_lt_0_compat; auto with zarith. assert (F2: [|xl|] = 0). rewrite F1 in Hx; auto with zarith. - generalize (spec_compare w_0 xl); case w_compare. + rewrite spec_compare; case Zcompare_spec. intros H; simpl. rewrite spec_w_add; rewrite spec_w_tail00; auto. rewrite spec_zdigits; rewrite spec_ww_digits. @@ -248,8 +237,7 @@ Section DoubleLift. clear spec_ww_zdigits. destruct x as [ |xh xl];simpl ww_to_Z;intros H. unfold Zlt in H;discriminate H. - assert (H0 := spec_compare w_0 xl);rewrite spec_w_0 in H0. - destruct (w_compare w_0 xl). + rewrite spec_compare, spec_w_0. case Zcompare_spec; intros H0. rewrite <- H0; rewrite Zplus_0_r. case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. generalize H; rewrite <- H0; rewrite Zplus_0_r; clear H; intros H. @@ -323,7 +311,7 @@ Section DoubleLift. assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl); assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy. - generalize (spec_ww_compare p zdigits); case ww_compare; intros H1. + rewrite spec_ww_compare; case Zcompare_spec; intros H1. rewrite H1; unfold zdigits; rewrite spec_w_0W. rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r. simpl ww_to_Z; w_rewrite;zarith. @@ -365,7 +353,7 @@ Section DoubleLift. ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith. assert (Hv: [[p]] > Zpos w_digits). generalize H1; clear H1. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto. + unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith. clear H1. assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits). rewrite spec_low. @@ -446,8 +434,7 @@ Section DoubleLift. clear H1;w_rewrite);simpl ww_add_mul_div. replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. intros Heq;rewrite <- Heq;clear Heq; auto. - generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; intros H1; w_rewrite. + rewrite spec_ww_compare. case Zcompare_spec; intros H1; w_rewrite. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. assert (HH0: [|low p|] = [[p]]). @@ -464,7 +451,8 @@ Section DoubleLift. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. rewrite Zpos_xO in H;zarith. assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits). - generalize H1; clear H1. + symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1. + revert H1. rewrite spec_low. rewrite spec_ww_sub; w_rewrite; intros H1. rewrite <- Zmod_div_mod; auto with zarith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v index 834e85d2..0032d2c3 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -248,12 +246,7 @@ Section DoubleMul. Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_w_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + forall x y, w_compare x y = Zcompare [|x|] [|y|]. Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. @@ -408,9 +401,9 @@ Section DoubleMul. assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). - generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; + rewrite spec_w_compare; case Zcompare_spec; intros Hxlh; try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. + rewrite spec_w_compare; case Zcompare_spec; intros Hylh. rewrite Hylh; rewrite spec_w_0; try (ring; fail). rewrite spec_w_0; try (ring; fail). repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). @@ -430,7 +423,7 @@ Section DoubleMul. rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. + rewrite spec_w_compare; case Zcompare_spec; intros Hylh. rewrite Hylh; rewrite spec_w_0; try (ring; fail). match goal with |- context[ww_add_c ?x ?y] => generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; @@ -455,9 +448,9 @@ Section DoubleMul. apply Zmult_le_0_compat; auto with zarith. (** there is a carry in hh + ll **) rewrite Zmult_1_l. - generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; + rewrite spec_w_compare; case Zcompare_spec; intros Hxlh; try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + rewrite spec_w_compare; case Zcompare_spec; intros Hylh; try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). match goal with |- context[ww_sub_c ?x ?y] => generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; @@ -480,7 +473,7 @@ Section DoubleMul. ring. rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + rewrite spec_w_compare; case Zcompare_spec; intros Hylh; try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). match goal with |- context[ww_add_c ?x ?y] => generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index 4394178f..b073d6be 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleSqrt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -220,12 +218,8 @@ Section DoubleSqrt. Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. Variable spec_w_is_even : forall x, if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. - Variable spec_w_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. + Variable spec_w_compare : forall x y, + w_compare x y = Zcompare [|x|] [|y|]. Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. Variable spec_w_div21 : forall a1 a2 b, @@ -257,11 +251,7 @@ Section DoubleSqrt. Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. + ww_compare x y = Zcompare [[x]] [[y]]. Variable spec_ww_head0 : forall x, 0 < [[x]] -> wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. Variable spec_low: forall x, [|low x|] = [[x]] mod wB. @@ -299,10 +289,7 @@ intros x; case x; simpl ww_is_even. apply Zlt_le_trans with (2 := Hb); auto with zarith. apply Zlt_le_trans with 1; auto with zarith. apply Zdiv_le_lower_bound; auto with zarith. - repeat match goal with |- context[w_compare ?y ?z] => - generalize (spec_w_compare y z); - case (w_compare y z) - end. + rewrite !spec_w_compare. repeat case Zcompare_spec. intros H1 H2; split. unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. rewrite H1; rewrite H2; ring. @@ -1108,12 +1095,12 @@ intros x; case x; simpl ww_is_even. rewrite wwB_wBwB; rewrite Zpower_2. apply Zmult_le_compat_r; auto with zarith. case (spec_to_Z w4);auto with zarith. - Qed. +Qed. Lemma spec_ww_is_zero: forall x, if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. intro x; unfold ww_is_zero. - generalize (spec_ww_compare W0 x); case (ww_compare W0 x); + rewrite spec_ww_compare. case Zcompare_spec; auto with zarith. simpl ww_to_Z. assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. @@ -1198,7 +1185,7 @@ intros x; case x; simpl ww_is_even. simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl; auto with zarith. intros H1. - generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare; + rewrite spec_ww_compare. case Zcompare_spec; simpl ww_to_Z; autorewrite with rm10. generalize H1; case x. intros HH; contradict HH; simpl ww_to_Z; auto with zarith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v index 3167f4c7..e63e20c6 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleSub.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v index eb1132d4..a274b839 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: DoubleType.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Set Implicit Arguments. Require Import ZArith. @@ -55,7 +53,7 @@ Section Zn2Z. End Zn2Z. -Implicit Arguments W0 [znz]. +Arguments W0 [znz]. (** From a cyclic representation [w], we iterate the [zn2z] construct [n] times, gaining the type of binary trees of depth at most [n], diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 36a1157d..2dd1c3ee 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cyclic31.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) (** @@ -907,9 +905,11 @@ Section Basics. apply nshiftr_n_0. Qed. - Lemma p2ibis_spec : forall n p, n<=size -> - Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + - phi (snd (p2ibis n p)))%Z. + Local Open Scope Z_scope. + + Lemma p2ibis_spec : forall n p, (n<=size)%nat -> + Zpos p = (Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + + phi (snd (p2ibis n p)). Proof. induction n; intros. simpl; rewrite Pmult_1_r; auto. @@ -917,7 +917,7 @@ Section Basics. (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; auto with zarith). rewrite (Zmult_comm 2). - assert (n<=size) by omega. + assert (n<=size)%nat by omega. destruct p; simpl; [ | | auto]; specialize (IHn p H0); generalize (p2ibis_bounded n p); @@ -973,7 +973,8 @@ Section Basics. (** Moreover, [p2ibis] is also related with [p2i] and hence with [positive_to_int31]. *) - Lemma double_twice_firstl : forall x, firstl x = D0 -> Twon*x = twice x. + Lemma double_twice_firstl : forall x, firstl x = D0 -> + (Twon*x = twice x)%int31. Proof. intros. unfold mul31. @@ -981,7 +982,7 @@ Section Basics. Qed. Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> - Twon*x+In = twice_plus_one x. + (Twon*x+In = twice_plus_one x)%int31. Proof. intros. rewrite double_twice_firstl; auto. @@ -1015,8 +1016,8 @@ Section Basics. Qed. Lemma positive_to_int31_spec : forall p, - Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + - phi (snd (positive_to_int31 p)))%Z. + Zpos p = (Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + + phi (snd (positive_to_int31 p)). Proof. unfold positive_to_int31. intros; rewrite p2i_p2ibis; auto. @@ -1033,7 +1034,7 @@ Section Basics. intros. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_double. - assert (0 <= Zdouble (phi x))%Z. + assert (0 <= Zdouble (phi x)). rewrite Zdouble_mult; generalize (phi_bounded x); omega. destruct (Zdouble (phi x)). simpl; auto. @@ -1047,7 +1048,7 @@ Section Basics. intros. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_double_plus_one. - assert (0 <= Zdouble_plus_one (phi x))%Z. + assert (0 <= Zdouble_plus_one (phi x)). rewrite Zdouble_plus_one_mult; generalize (phi_bounded x); omega. destruct (Zdouble_plus_one (phi x)). simpl; auto. @@ -1061,7 +1062,7 @@ Section Basics. intros. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_incr. - assert (0 <= Zsucc (phi x))%Z. + assert (0 <= Zsucc (phi x)). change (Zsucc (phi x)) with ((phi x)+1)%Z; generalize (phi_bounded x); omega. destruct (Zsucc (phi x)). @@ -1083,7 +1084,7 @@ Section Basics. rewrite incr_twice, phi_twice_plus_one. remember (phi (complement_negative p)) as q. rewrite Zdouble_plus_one_mult. - replace (2*q+1)%Z with (2*(Zsucc q)-1)%Z by omega. + replace (2*q+1) with (2*(Zsucc q)-1) by omega. rewrite <- Zminus_mod_idemp_l, <- Zmult_mod_idemp_r, IHp. rewrite Zmult_mod_idemp_r, Zminus_mod_idemp_l; auto with zarith. @@ -1106,81 +1107,61 @@ Section Basics. End Basics. - -Section Int31_Op. - -(** Nullity test *) -Let w_iszero i := match i ?= 0 with Eq => true | _ => false end. - -(** Modulo [2^p] *) -Let w_pos_mod p i := - match compare31 p 31 with +Instance int31_ops : ZnZ.Ops int31 := +{ + digits := 31%positive; (* number of digits *) + zdigits := 31; (* number of digits *) + to_Z := phi; (* conversion to Z *) + of_pos := positive_to_int31; (* positive -> N*int31 : p => N,i + where p = N*2^31+phi i *) + head0 := head031; (* number of head 0 *) + tail0 := tail031; (* number of tail 0 *) + zero := 0; + one := 1; + minus_one := Tn; (* 2^31 - 1 *) + compare := compare31; + eq0 := fun i => match i ?= 0 with Eq => true | _ => false end; + opp_c := fun i => 0 -c i; + opp := opp31; + opp_carry := fun i => 0-i-1; + succ_c := fun i => i +c 1; + add_c := add31c; + add_carry_c := add31carryc; + succ := fun i => i + 1; + add := add31; + add_carry := fun i j => i + j + 1; + pred_c := fun i => i -c 1; + sub_c := sub31c; + sub_carry_c := sub31carryc; + pred := fun i => i - 1; + sub := sub31; + sub_carry := fun i j => i - j - 1; + mul_c := mul31c; + mul := mul31; + square_c := fun x => x *c x; + div21 := div3121; + div_gt := div31; (* this is supposed to be the special case of + division a/b where a > b *) + div := div31; + modulo_gt := fun i j => let (_,r) := i/j in r; + modulo := fun i j => let (_,r) := i/j in r; + gcd_gt := gcd31; + gcd := gcd31; + add_mul_div := addmuldiv31; + pos_mod := (* modulo 2^p *) + fun p i => + match p ?= 31 with | Lt => addmuldiv31 p 0 (addmuldiv31 (31-p) i 0) | _ => i - end. + end; + is_even := + fun i => let (_,r) := i/2 in + match r ?= 0 with Eq => true | _ => false end; + sqrt2 := sqrt312; + sqrt := sqrt31 +}. -(** Parity test *) -Let w_iseven i := - let (_,r) := i/2 in - match r ?= 0 with Eq => true | _ => false end. - -Definition int31_op := (mk_znz_op - 31%positive (* number of digits *) - 31 (* number of digits *) - phi (* conversion to Z *) - positive_to_int31 (* positive -> N*int31 : p => N,i where p = N*2^31+phi i *) - head031 (* number of head 0 *) - tail031 (* number of tail 0 *) - (* Basic constructors *) - 0 - 1 - Tn (* 2^31 - 1 *) - (* Comparison *) - compare31 - w_iszero - (* Basic arithmetic operations *) - (fun i => 0 -c i) - opp31 - (fun i => 0-i-1) - (fun i => i +c 1) - add31c - add31carryc - (fun i => i + 1) - add31 - (fun i j => i + j + 1) - (fun i => i -c 1) - sub31c - sub31carryc - (fun i => i - 1) - sub31 - (fun i j => i - j - 1) - mul31c - mul31 - (fun x => x *c x) - (* special (euclidian) division operations *) - div3121 - div31 (* this is supposed to be the special case of division a/b where a > b *) - div31 - (* euclidian division remainder *) - (* again special case for a > b *) - (fun i j => let (_,r) := i/j in r) - (fun i j => let (_,r) := i/j in r) - gcd31 (*gcd_gt*) - gcd31 (*gcd*) - (* shift operations *) - addmuldiv31 (*add_mul_div *) - (* modulo 2^p *) - w_pos_mod - (* is i even ? *) - w_iseven - (* square root operations *) - sqrt312 (* sqrt2 *) - sqrt31 (* sqrt *) -). - -End Int31_Op. - -Section Int31_Spec. +Section Int31_Specs. Local Open Scope Z_scope. @@ -1222,22 +1203,14 @@ Section Int31_Spec. reflexivity. Qed. - Lemma spec_Bm1 : [| Tn |] = wB - 1. + Lemma spec_m1 : [| Tn |] = wB - 1. Proof. reflexivity. Qed. Lemma spec_compare : forall x y, - match (x ?= y)%int31 with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Proof. - clear; unfold compare31; simpl; intros. - case_eq ([|x|] ?= [|y|]); auto. - intros; apply Zcompare_Eq_eq; auto. - Qed. + (x ?= y)%int31 = ([|x|] ?= [|y|]). + Proof. reflexivity. Qed. (** Addition *) @@ -1654,12 +1627,10 @@ Section Int31_Spec. rewrite Zmult_comm, Z_div_mult; auto with zarith. Qed. - Let w_pos_mod := int31_op.(znz_pos_mod). - Lemma spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. - unfold w_pos_mod, znz_pos_mod, int31_op, compare31. + unfold ZnZ.pos_mod, int31_ops, compare31. change [|31|] with 31%Z. assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). intros. @@ -1721,7 +1692,7 @@ Section Int31_Spec. unfold head031, recl. change On with (phi_inv (Z_of_nat (31-size))). replace (head031_alt size x) with - (head031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). + (head031_alt size x + (31 - size))%nat by auto. assert (size <= 31)%nat by auto with arith. revert x H; induction size; intros. @@ -1829,7 +1800,7 @@ Section Int31_Spec. unfold tail031, recr. change On with (phi_inv (Z_of_nat (31-size))). replace (tail031_alt size x) with - (tail031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). + (tail031_alt size x + (31 - size))%nat by auto. assert (size <= 31)%nat by auto with arith. revert x H; induction size; intros. @@ -2018,8 +1989,8 @@ Section Int31_Spec. Proof. assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. - generalize (spec_compare (fst (i/j)%int31) j); case compare31; - rewrite div31_phi; auto; intros Hc; + rewrite spec_compare, div31_phi; auto. + case Zcompare_spec; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). apply Hrec; repeat rewrite div31_phi; auto with zarith. replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]). @@ -2072,7 +2043,7 @@ Section Int31_Spec. [|sqrt31 x|] ^ 2 <= [|x|] < ([|sqrt31 x|] + 1) ^ 2. Proof. intros i; unfold sqrt31. - generalize (spec_compare 1 i); case compare31; change [|1|] with 1; + rewrite spec_compare. case Zcompare_spec; change [|1|] with 1; intros Hi; auto with zarith. repeat rewrite Zpower_2; auto with zarith. apply iter31_sqrt_correct; auto with zarith. @@ -2157,7 +2128,7 @@ Section Int31_Spec. unfold phi2; apply Zlt_le_trans with ([|ih|] * base)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. apply Zlt_le_trans with (2:= Hih); auto with zarith. - generalize (spec_compare ih j); case compare31; intros Hc1. + rewrite spec_compare. case Zcompare_spec; intros Hc1. split; auto. apply sqrt_test_true; auto. unfold phi2, base; auto with zarith. @@ -2166,7 +2137,7 @@ Section Int31_Spec. rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. unfold Zpower, Zpower_pos in Hj1; simpl in Hj1; auto with zarith. case (Zle_or_lt (2 ^ 30) [|j|]); intros Hjj. - generalize (spec_compare (fst (div3121 ih il j)) j); case compare31; + rewrite spec_compare; case Zcompare_spec; rewrite div312_phi; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). apply Hrec. @@ -2274,7 +2245,7 @@ Section Int31_Spec. 2: simpl; unfold Zpower_pos; simpl; auto with zarith. case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4. unfold base, Zpower, Zpower_pos in H2,H4; simpl in H2,H4. - unfold phi2,Zpower, Zpower_pos; simpl iter_pos; auto with zarith. + unfold phi2,Zpower, Zpower_pos. simpl Pos.iter; auto with zarith. case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith. change [|Tn|] with 2147483647; auto with zarith. intros j1 _ HH; contradict HH. @@ -2300,7 +2271,7 @@ Section Int31_Spec. generalize (spec_sub_c il il1). case sub31c; intros il2 Hil2. simpl interp_carry in Hil2. - generalize (spec_compare ih ih1); case compare31. + rewrite spec_compare; case Zcompare_spec. unfold interp_carry. intros H1; split. rewrite Zpower_2, <- Hihl1. @@ -2347,7 +2318,7 @@ Section Int31_Spec. case (phi_bounded ih); intros H1 H2. generalize Hih; change (2 ^ Z_of_nat size / 4) with 536870912. split; auto with zarith. - generalize (spec_compare (ih - 1) ih1); case compare31. + rewrite spec_compare; case Zcompare_spec. rewrite Hsih. intros H1; split. rewrite Zpower_2, <- Hihl1. @@ -2414,15 +2385,13 @@ Section Int31_Spec. replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. rewrite <-Hil2. change (-1 * 2 ^ Z_of_nat size) with (-base); ring. - Qed. +Qed. (** [iszero] *) - Let w_eq0 := int31_op.(znz_eq0). - - Lemma spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. + Lemma spec_eq0 : forall x, ZnZ.eq0 x = true -> [|x|] = 0. Proof. - clear; unfold w_eq0, znz_eq0; simpl. + clear; unfold ZnZ.eq0; simpl. unfold compare31; simpl; intros. change [|0|] with 0 in H. apply Zcompare_Eq_eq. @@ -2431,12 +2400,10 @@ Section Int31_Spec. (* Even *) - Let w_is_even := int31_op.(znz_is_even). - Lemma spec_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. + if ZnZ.is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. Proof. - unfold w_is_even; simpl; intros. + unfold ZnZ.is_even; simpl; intros. generalize (spec_div x 2). destruct (x/2)%int31 as (q,r); intros. unfold compare31. @@ -2445,77 +2412,60 @@ Section Int31_Spec. destruct H; auto with zarith. replace ([|x|] mod 2) with [|r|]. destruct H; auto with zarith. - case_eq ([|r|] ?= 0)%Z; intros. - apply Zcompare_Eq_eq; auto. - change ([|r|] < 0)%Z in H; auto with zarith. - change ([|r|] > 0)%Z in H; auto with zarith. + case Zcompare_spec; auto with zarith. apply Zmod_unique with [|q|]; auto with zarith. Qed. - Definition int31_spec : znz_spec int31_op. - split. - exact phi_bounded. - exact positive_to_int31_spec. - exact spec_zdigits. - exact spec_more_than_1_digit. - - exact spec_0. - exact spec_1. - exact spec_Bm1. - - exact spec_compare. - exact spec_eq0. - - exact spec_opp_c. - exact spec_opp. - exact spec_opp_carry. - - exact spec_succ_c. - exact spec_add_c. - exact spec_add_carry_c. - exact spec_succ. - exact spec_add. - exact spec_add_carry. - - exact spec_pred_c. - exact spec_sub_c. - exact spec_sub_carry_c. - exact spec_pred. - exact spec_sub. - exact spec_sub_carry. - - exact spec_mul_c. - exact spec_mul. - exact spec_square_c. - - exact spec_div21. - intros; apply spec_div; auto. - exact spec_div. - - intros; unfold int31_op; simpl; apply spec_mod; auto. - exact spec_mod. - - intros; apply spec_gcd; auto. - exact spec_gcd. - - exact spec_head00. - exact spec_head0. - exact spec_tail00. - exact spec_tail0. - - exact spec_add_mul_div. - exact spec_pos_mod. - - exact spec_is_even. - exact spec_sqrt2. - exact spec_sqrt. - Qed. - -End Int31_Spec. + Global Instance int31_specs : ZnZ.Specs int31_ops := { + spec_to_Z := phi_bounded; + spec_of_pos := positive_to_int31_spec; + spec_zdigits := spec_zdigits; + spec_more_than_1_digit := spec_more_than_1_digit; + spec_0 := spec_0; + spec_1 := spec_1; + spec_m1 := spec_m1; + spec_compare := spec_compare; + spec_eq0 := spec_eq0; + spec_opp_c := spec_opp_c; + spec_opp := spec_opp; + spec_opp_carry := spec_opp_carry; + spec_succ_c := spec_succ_c; + spec_add_c := spec_add_c; + spec_add_carry_c := spec_add_carry_c; + spec_succ := spec_succ; + spec_add := spec_add; + spec_add_carry := spec_add_carry; + spec_pred_c := spec_pred_c; + spec_sub_c := spec_sub_c; + spec_sub_carry_c := spec_sub_carry_c; + spec_pred := spec_pred; + spec_sub := spec_sub; + spec_sub_carry := spec_sub_carry; + spec_mul_c := spec_mul_c; + spec_mul := spec_mul; + spec_square_c := spec_square_c; + spec_div21 := spec_div21; + spec_div_gt := fun a b _ => spec_div a b; + spec_div := spec_div; + spec_modulo_gt := fun a b _ => spec_mod a b; + spec_modulo := spec_mod; + spec_gcd_gt := fun a b _ => spec_gcd a b; + spec_gcd := spec_gcd; + spec_head00 := spec_head00; + spec_head0 := spec_head0; + spec_tail00 := spec_tail00; + spec_tail0 := spec_tail0; + spec_add_mul_div := spec_add_mul_div; + spec_pos_mod := spec_pos_mod; + spec_is_even := spec_is_even; + spec_sqrt2 := spec_sqrt2; + spec_sqrt := spec_sqrt }. + +End Int31_Specs. Module Int31Cyclic <: CyclicType. - Definition w := int31. - Definition w_op := int31_op. - Definition w_spec := int31_spec. + Definition t := int31. + Definition ops := int31_ops. + Definition specs := int31_specs. End Int31Cyclic. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 5e1cd0e1..20f750f6 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,15 +8,11 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: Int31.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NaryFunctions. Require Import Wf_nat. Require Export ZArith. Require Export DoubleType. -Unset Boxed Definitions. - (** * 31-bit integers *) (** This file contains basic definitions of a 31-bit integer @@ -353,16 +349,16 @@ Register div31 as int31 div in "coq_int31" by True. Register compare31 as int31 compare in "coq_int31" by True. Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. -Definition gcd31 (i j:int31) := - (fix euler (guard:nat) (i j:int31) {struct guard} := - match guard with - | O => In - | S p => match j ?= On with - | Eq => i - | _ => euler p j (let (_, r ) := i/j in r) - end - end) - (2*size)%nat i j. +Fixpoint euler (guard:nat) (i j:int31) {struct guard} := + match guard with + | O => In + | S p => match j ?= On with + | Eq => i + | _ => euler p j (let (_, r ) := i/j in r) + end + end. + +Definition gcd31 (i j:int31) := euler (2*size)%nat i j. (** Square root functions using newton iteration we use a very naive upper-bound on the iteration diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index 37dc0871..23e8bd33 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ring31.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped with a ring structure and a ring tactic *) @@ -83,9 +81,10 @@ Qed. Lemma eqb31_eq : forall x y, eqb31 x y = true <-> x=y. Proof. unfold eqb31. intros x y. -generalize (Cyclic31.spec_compare x y). -destruct (x ?= y); intuition; subst; auto with zarith; try discriminate. -apply Int31_canonic; auto. +rewrite Cyclic31.spec_compare. case Zcompare_spec. +intuition. apply Int31_canonic; auto. +intuition; subst; auto with zarith; try discriminate. +intuition; subst; auto with zarith; try discriminate. Qed. Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index aef729bf..d039fdcb 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZModulo.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] as defined abstractly in CyclicAxioms. *) @@ -33,25 +31,23 @@ Section ZModulo. Definition wB := base digits. - Definition znz := Z. - Definition znz_digits := digits. - Definition znz_zdigits := Zpos digits. - Definition znz_to_Z x := x mod wB. + Definition t := Z. + Definition zdigits := Zpos digits. + Definition to_Z x := x mod wB. - Notation "[| x |]" := (znz_to_Z x) (at level 0, x at level 99). + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). Notation "[+| c |]" := - (interp_carry 1 wB znz_to_Z c) (at level 0, x at level 99). + (interp_carry 1 wB to_Z c) (at level 0, x at level 99). Notation "[-| c |]" := - (interp_carry (-1) wB znz_to_Z c) (at level 0, x at level 99). + (interp_carry (-1) wB to_Z c) (at level 0, x at level 99). Notation "[|| x ||]" := - (zn2z_to_Z wB znz_to_Z x) (at level 0, x at level 99). + (zn2z_to_Z wB to_Z x) (at level 0, x at level 99). Lemma spec_more_than_1_digit: 1 < Zpos digits. Proof. - unfold znz_digits. generalize digits_ne_1; destruct digits; auto. destruct 1; auto. Qed. @@ -65,12 +61,12 @@ Section ZModulo. Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. Proof. - unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. + unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. Lemma spec_to_Z_2 : forall x, [|x|] < wB. Proof. - unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. + unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. Hint Resolve spec_to_Z_1 spec_to_Z_2. @@ -79,16 +75,16 @@ Section ZModulo. auto. Qed. - Definition znz_of_pos x := + Definition of_pos x := let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r). Lemma spec_of_pos : forall p, - Zpos p = (Z_of_N (fst (znz_of_pos p)))*wB + [|(snd (znz_of_pos p))|]. + Zpos p = (Z_of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|]. Proof. - intros; unfold znz_of_pos; simpl. + intros; unfold of_pos; simpl. generalize (Z_div_mod_POS wB wB_pos p). destruct (Zdiv_eucl_POS p wB); simpl; destruct 1. - unfold znz_to_Z; rewrite Zmod_small; auto. + unfold to_Z; rewrite Zmod_small; auto. assert (0 <= z). replace z with (Zpos p / wB) by (symmetry; apply Zdiv_unique with z0; auto). @@ -98,37 +94,37 @@ Section ZModulo. rewrite Zmult_comm; auto. Qed. - Lemma spec_zdigits : [|znz_zdigits|] = Zpos znz_digits. + Lemma spec_zdigits : [|zdigits|] = Zpos digits. Proof. - unfold znz_to_Z, znz_zdigits, znz_digits. + unfold to_Z, zdigits. apply Zmod_small. unfold wB, base. split; auto with zarith. apply Zpower2_lt_lin; auto with zarith. Qed. - Definition znz_0 := 0. - Definition znz_1 := 1. - Definition znz_Bm1 := wB - 1. + Definition zero := 0. + Definition one := 1. + Definition minus_one := wB - 1. - Lemma spec_0 : [|znz_0|] = 0. + Lemma spec_0 : [|zero|] = 0. Proof. - unfold znz_to_Z, znz_0. + unfold to_Z, zero. apply Zmod_small; generalize wB_pos; auto with zarith. Qed. - Lemma spec_1 : [|znz_1|] = 1. + Lemma spec_1 : [|one|] = 1. Proof. - unfold znz_to_Z, znz_1. + unfold to_Z, one. apply Zmod_small; split; auto with zarith. unfold wB, base. apply Zlt_trans with (Zpos digits); auto. apply Zpower2_lt_lin; auto with zarith. Qed. - Lemma spec_Bm1 : [|znz_Bm1|] = wB - 1. + Lemma spec_Bm1 : [|minus_one|] = wB - 1. Proof. - unfold znz_to_Z, znz_Bm1. + unfold to_Z, minus_one. apply Zmod_small; split; auto with zarith. unfold wB, base. cut (1 <= 2 ^ Zpos digits); auto with zarith. @@ -136,54 +132,46 @@ Section ZModulo. apply Zpower2_le_lin; auto with zarith. Qed. - Definition znz_compare x y := Zcompare [|x|] [|y|]. + Definition compare x y := Zcompare [|x|] [|y|]. Lemma spec_compare : forall x y, - match znz_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Proof. - intros; unfold znz_compare, Zlt, Zgt. - case_eq (Zcompare [|x|] [|y|]); auto. - intros; apply Zcompare_Eq_eq; auto. - Qed. + compare x y = Zcompare [|x|] [|y|]. + Proof. reflexivity. Qed. - Definition znz_eq0 x := + Definition eq0 x := match [|x|] with Z0 => true | _ => false end. - Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0. + Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0. Proof. - unfold znz_eq0; intros; now destruct [|x|]. + unfold eq0; intros; now destruct [|x|]. Qed. - Definition znz_opp_c x := - if znz_eq0 x then C0 0 else C1 (- x). - Definition znz_opp x := - x. - Definition znz_opp_carry x := - x - 1. + Definition opp_c x := + if eq0 x then C0 0 else C1 (- x). + Definition opp x := - x. + Definition opp_carry x := - x - 1. - Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|]. + Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|]. Proof. - intros; unfold znz_opp_c, znz_to_Z; auto. - case_eq (znz_eq0 x); intros; unfold interp_carry. + intros; unfold opp_c, to_Z; auto. + case_eq (eq0 x); intros; unfold interp_carry. fold [|x|]; rewrite (spec_eq0 x H); auto. assert (x mod wB <> 0). - unfold znz_eq0, znz_to_Z in H. + unfold eq0, to_Z in H. intro H0; rewrite H0 in H; discriminate. rewrite Z_mod_nz_opp_full; auto with zarith. Qed. - Lemma spec_opp : forall x, [|znz_opp x|] = (-[|x|]) mod wB. + Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB. Proof. - intros; unfold znz_opp, znz_to_Z; auto. + intros; unfold opp, to_Z; auto. change ((- x) mod wB = (0 - (x mod wB)) mod wB). rewrite Zminus_mod_idemp_r; simpl; auto. Qed. - Lemma spec_opp_carry : forall x, [|znz_opp_carry x|] = wB - [|x|] - 1. + Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1. Proof. - intros; unfold znz_opp_carry, znz_to_Z; auto. + intros; unfold opp_carry, to_Z; auto. replace (- x - 1) with (- 1 - x) by omega. rewrite <- Zminus_mod_idemp_r. replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega. @@ -194,21 +182,21 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos); omega. Qed. - Definition znz_succ_c x := + Definition succ_c x := let y := Zsucc x in - if znz_eq0 y then C1 0 else C0 y. + if eq0 y then C1 0 else C0 y. - Definition znz_add_c x y := + Definition add_c x y := let z := [|x|] + [|y|] in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - Definition znz_add_carry_c x y := + Definition add_carry_c x y := let z := [|x|]+[|y|]+1 in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - Definition znz_succ := Zsucc. - Definition znz_add := Zplus. - Definition znz_add_carry x y := x + y + 1. + Definition succ := Zsucc. + Definition add := Zplus. + Definition add_carry x y := x + y + 1. Lemma Zmod_equal : forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. @@ -221,10 +209,10 @@ Section ZModulo. rewrite Zplus_comm, Zmult_comm, Z_mod_plus; auto. Qed. - Lemma spec_succ_c : forall x, [+|znz_succ_c x|] = [|x|] + 1. + Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. Proof. - intros; unfold znz_succ_c, znz_to_Z, Zsucc. - case_eq (znz_eq0 (x+1)); intros; unfold interp_carry. + intros; unfold succ_c, to_Z, Zsucc. + case_eq (eq0 (x+1)); intros; unfold interp_carry. rewrite Zmult_1_l. replace (wB + 0 mod wB) with wB by auto with zarith. @@ -236,7 +224,7 @@ Section ZModulo. apply Zmod_equal; auto. assert ((x+1) mod wB <> 0). - unfold znz_eq0, znz_to_Z in *; now destruct ((x+1) mod wB). + unfold eq0, to_Z in *; now destruct ((x+1) mod wB). assert (x mod wB + 1 <> wB). contradict H0. rewrite Zeq_plus_swap in H0; simpl in H0. @@ -247,9 +235,9 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos); omega. Qed. - Lemma spec_add_c : forall x y, [+|znz_add_c x y|] = [|x|] + [|y|]. + Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. Proof. - intros; unfold znz_add_c, znz_to_Z, interp_carry. + intros; unfold add_c, to_Z, interp_carry. destruct Z_lt_le_dec. apply Zmod_small; generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. @@ -258,9 +246,9 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. Qed. - Lemma spec_add_carry_c : forall x y, [+|znz_add_carry_c x y|] = [|x|] + [|y|] + 1. + Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1. Proof. - intros; unfold znz_add_carry_c, znz_to_Z, interp_carry. + intros; unfold add_carry_c, to_Z, interp_carry. destruct Z_lt_le_dec. apply Zmod_small; generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. @@ -269,59 +257,59 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. Qed. - Lemma spec_succ : forall x, [|znz_succ x|] = ([|x|] + 1) mod wB. + Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB. Proof. - intros; unfold znz_succ, znz_to_Z, Zsucc. + intros; unfold succ, to_Z, Zsucc. symmetry; apply Zplus_mod_idemp_l. Qed. - Lemma spec_add : forall x y, [|znz_add x y|] = ([|x|] + [|y|]) mod wB. + Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB. Proof. - intros; unfold znz_add, znz_to_Z; apply Zplus_mod. + intros; unfold add, to_Z; apply Zplus_mod. Qed. Lemma spec_add_carry : - forall x y, [|znz_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. Proof. - intros; unfold znz_add_carry, znz_to_Z. + intros; unfold add_carry, to_Z. rewrite <- Zplus_mod_idemp_l. rewrite (Zplus_mod x y). rewrite Zplus_mod_idemp_l; auto. Qed. - Definition znz_pred_c x := - if znz_eq0 x then C1 (wB-1) else C0 (x-1). + Definition pred_c x := + if eq0 x then C1 (wB-1) else C0 (x-1). - Definition znz_sub_c x y := + Definition sub_c x y := let z := [|x|]-[|y|] in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - Definition znz_sub_carry_c x y := + Definition sub_carry_c x y := let z := [|x|]-[|y|]-1 in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - Definition znz_pred := Zpred. - Definition znz_sub := Zminus. - Definition znz_sub_carry x y := x - y - 1. + Definition pred := Zpred. + Definition sub := Zminus. + Definition sub_carry x y := x - y - 1. - Lemma spec_pred_c : forall x, [-|znz_pred_c x|] = [|x|] - 1. + Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. Proof. - intros; unfold znz_pred_c, znz_to_Z, interp_carry. - case_eq (znz_eq0 x); intros. + intros; unfold pred_c, to_Z, interp_carry. + case_eq (eq0 x); intros. fold [|x|]; rewrite spec_eq0; auto. replace ((wB-1) mod wB) with (wB-1); auto with zarith. symmetry; apply Zmod_small; generalize wB_pos; omega. assert (x mod wB <> 0). - unfold znz_eq0, znz_to_Z in *; now destruct (x mod wB). + unfold eq0, to_Z in *; now destruct (x mod wB). rewrite <- Zminus_mod_idemp_l. apply Zmod_small. generalize (Z_mod_lt x wB wB_pos); omega. Qed. - Lemma spec_sub_c : forall x y, [-|znz_sub_c x y|] = [|x|] - [|y|]. + Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. Proof. - intros; unfold znz_sub_c, znz_to_Z, interp_carry. + intros; unfold sub_c, to_Z, interp_carry. destruct Z_lt_le_dec. replace ((wB + (x mod wB - y mod wB)) mod wB) with (wB + (x mod wB - y mod wB)). @@ -333,9 +321,9 @@ Section ZModulo. generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. Qed. - Lemma spec_sub_carry_c : forall x y, [-|znz_sub_carry_c x y|] = [|x|] - [|y|] - 1. + Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1. Proof. - intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry. + intros; unfold sub_carry_c, to_Z, interp_carry. destruct Z_lt_le_dec. replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with (wB + (x mod wB - y mod wB -1)). @@ -347,38 +335,38 @@ Section ZModulo. generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. Qed. - Lemma spec_pred : forall x, [|znz_pred x|] = ([|x|] - 1) mod wB. + Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB. Proof. - intros; unfold znz_pred, znz_to_Z, Zpred. + intros; unfold pred, to_Z, Zpred. rewrite <- Zplus_mod_idemp_l; auto. Qed. - Lemma spec_sub : forall x y, [|znz_sub x y|] = ([|x|] - [|y|]) mod wB. + Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB. Proof. - intros; unfold znz_sub, znz_to_Z; apply Zminus_mod. + intros; unfold sub, to_Z; apply Zminus_mod. Qed. Lemma spec_sub_carry : - forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. Proof. - intros; unfold znz_sub_carry, znz_to_Z. + intros; unfold sub_carry, to_Z. rewrite <- Zminus_mod_idemp_l. rewrite (Zminus_mod x y). rewrite Zminus_mod_idemp_l. auto. Qed. - Definition znz_mul_c x y := + Definition mul_c x y := let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in - if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l. + if eq0 h then if eq0 l then W0 else WW h l else WW h l. - Definition znz_mul := Zmult. + Definition mul := Zmult. - Definition znz_square_c x := znz_mul_c x x. + Definition square_c x := mul_c x x. - Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|]. + Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|]. Proof. - intros; unfold znz_mul_c, zn2z_to_Z. + intros; unfold mul_c, zn2z_to_Z. assert (Zdiv_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)). unfold Zmod, Zdiv; destruct Zdiv_eucl; auto. generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Zdiv_eucl as (h,l). @@ -394,31 +382,31 @@ Section ZModulo. apply Zdiv_lt_upper_bound; auto with zarith. apply Zmult_lt_compat; auto with zarith. clear H H0 H1 H2. - case_eq (znz_eq0 h); simpl; intros. - case_eq (znz_eq0 l); simpl; intros. + case_eq (eq0 h); simpl; intros. + case_eq (eq0 l); simpl; intros. rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith. rewrite H3, H4; auto with zarith. rewrite H3, H4; auto with zarith. Qed. - Lemma spec_mul : forall x y, [|znz_mul x y|] = ([|x|] * [|y|]) mod wB. + Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB. Proof. - intros; unfold znz_mul, znz_to_Z; apply Zmult_mod. + intros; unfold mul, to_Z; apply Zmult_mod. Qed. - Lemma spec_square_c : forall x, [|| znz_square_c x||] = [|x|] * [|x|]. + Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|]. Proof. intros x; exact (spec_mul_c x x). Qed. - Definition znz_div x y := Zdiv_eucl [|x|] [|y|]. + Definition div x y := Zdiv_eucl [|x|] [|y|]. Lemma spec_div : forall a b, 0 < [|b|] -> - let (q,r) := znz_div a b in + let (q,r) := div a b in [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. - intros; unfold znz_div. + intros; unfold div. assert ([|b|]>0) by auto with zarith. assert (Zdiv_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])). unfold Zmod, Zdiv; destruct Zdiv_eucl; auto. @@ -440,10 +428,10 @@ Section ZModulo. rewrite H5, H6; rewrite Zmult_comm; auto with zarith. Qed. - Definition znz_div_gt := znz_div. + Definition div_gt := div. Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := znz_div_gt a b in + let (q,r) := div_gt a b in [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. @@ -451,34 +439,34 @@ Section ZModulo. apply spec_div; auto. Qed. - Definition znz_mod x y := [|x|] mod [|y|]. - Definition znz_mod_gt x y := [|x|] mod [|y|]. + Definition modulo x y := [|x|] mod [|y|]. + Definition modulo_gt x y := [|x|] mod [|y|]. - Lemma spec_mod : forall a b, 0 < [|b|] -> - [|znz_mod a b|] = [|a|] mod [|b|]. + Lemma spec_modulo : forall a b, 0 < [|b|] -> + [|modulo a b|] = [|a|] mod [|b|]. Proof. - intros; unfold znz_mod. + intros; unfold modulo. apply Zmod_small. assert ([|b|]>0) by auto with zarith. generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos). fold [|b|]; omega. Qed. - Lemma spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|znz_mod_gt a b|] = [|a|] mod [|b|]. + Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|modulo_gt a b|] = [|a|] mod [|b|]. Proof. - intros; apply spec_mod; auto. + intros; apply spec_modulo; auto. Qed. - Definition znz_gcd x y := Zgcd [|x|] [|y|]. - Definition znz_gcd_gt x y := Zgcd [|x|] [|y|]. + Definition gcd x y := Zgcd [|x|] [|y|]. + Definition gcd_gt x y := Zgcd [|x|] [|y|]. Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Zgcd a b <= Zmax a b. Proof. intros. generalize (Zgcd_is_gcd a b); inversion_clear 1. - destruct H2; destruct H3; clear H4. - assert (H3:=Zgcd_is_pos a b). + destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4. + assert (H4:=Zgcd_is_pos a b). destruct (Z_eq_dec (Zgcd a b) 0). rewrite e; generalize (Zmax_spec a b); omega. assert (0 <= q). @@ -489,15 +477,15 @@ Section ZModulo. generalize (Zmax_spec 0 b) (Zabs_spec b); omega. apply Zle_trans with a. - rewrite H1 at 2. + rewrite H2 at 2. rewrite <- (Zmult_1_l (Zgcd a b)) at 1. apply Zmult_le_compat; auto with zarith. generalize (Zmax_spec a b); omega. Qed. - Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|znz_gcd a b|]. + Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. Proof. - intros; unfold znz_gcd. + intros; unfold gcd. generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros. fold [|a|] in *; fold [|b|] in *. replace ([|Zgcd [|a|] [|b|]|]) with (Zgcd [|a|] [|b|]). @@ -511,22 +499,22 @@ Section ZModulo. Qed. Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|znz_gcd_gt a b|]. + Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. Proof. intros. apply spec_gcd; auto. Qed. - Definition znz_div21 a1 a2 b := + Definition div21 a1 a2 b := Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|]. Lemma spec_div21 : forall a1 a2 b, wB/2 <= [|b|] -> [|a1|] < [|b|] -> - let (q,r) := znz_div21 a1 a2 b in + let (q,r) := div21 a1 a2 b in [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. - intros; unfold znz_div21. + intros; unfold div21. generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros. generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros. assert ([|b|]>0) by auto with zarith. @@ -552,22 +540,22 @@ Section ZModulo. rewrite H8, H9; rewrite Zmult_comm; auto with zarith. Qed. - Definition znz_add_mul_div p x y := - ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))). + Definition add_mul_div p x y := + ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))). Lemma spec_add_mul_div : forall x y p, - [|p|] <= Zpos znz_digits -> - [| znz_add_mul_div p x y |] = + [|p|] <= Zpos digits -> + [| add_mul_div p x y |] = ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))) mod wB. + [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB. Proof. - intros; unfold znz_add_mul_div; auto. + intros; unfold add_mul_div; auto. Qed. - Definition znz_pos_mod p w := [|w|] mod (2 ^ [|p|]). + Definition pos_mod p w := [|w|] mod (2 ^ [|p|]). Lemma spec_pos_mod : forall w p, - [|znz_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. - intros; unfold znz_pos_mod. + intros; unfold pos_mod. apply Zmod_small. generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. split. @@ -576,65 +564,58 @@ Section ZModulo. apply Zmod_le; auto with zarith. Qed. - Definition znz_is_even x := + Definition is_even x := if Z_eq_dec ([|x|] mod 2) 0 then true else false. Lemma spec_is_even : forall x, - if znz_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. + if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. Proof. - intros; unfold znz_is_even; destruct Z_eq_dec; auto. + intros; unfold is_even; destruct Z_eq_dec; auto. generalize (Z_mod_lt [|x|] 2); omega. Qed. - Definition znz_sqrt x := Zsqrt_plain [|x|]. + Definition sqrt x := Z.sqrt [|x|]. Lemma spec_sqrt : forall x, - [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2. + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. Proof. intros. - unfold znz_sqrt. + unfold sqrt. repeat rewrite Zpower_2. - replace [|Zsqrt_plain [|x|]|] with (Zsqrt_plain [|x|]). - apply Zsqrt_interval; auto with zarith. + replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]). + apply Z.sqrt_spec; auto with zarith. symmetry; apply Zmod_small. - split. - apply Zsqrt_plain_is_pos; auto with zarith. - - cut (Zsqrt_plain [|x|] <= (wB-1)); try omega. - rewrite <- (Zsqrt_square_id (wB-1)). - apply Zsqrt_le. - split; auto. - apply Zle_trans with (wB-1); auto with zarith. - generalize (spec_to_Z x); auto with zarith. - apply Zsquare_le. - generalize wB_pos; auto with zarith. + split. apply Z.sqrt_nonneg; auto. + apply Zle_lt_trans with [|x|]; auto. + apply Z.sqrt_le_lin; auto. Qed. - Definition znz_sqrt2 x y := + Definition sqrt2 x y := let z := [|x|]*wB+[|y|] in match z with | Z0 => (0, C0 0) | Zpos p => - let (s,r,_,_) := sqrtrempos p in + let (s,r) := Z.sqrtrem (Zpos p) in (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB)) | Zneg _ => (0, C0 0) end. Lemma spec_sqrt2 : forall x y, wB/ 4 <= [|x|] -> - let (s,r) := znz_sqrt2 x y in + let (s,r) := sqrt2 x y in [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ [+|r|] <= 2 * [|s|]. Proof. - intros; unfold znz_sqrt2. + intros; unfold sqrt2. simpl zn2z_to_Z. remember ([|x|]*wB+[|y|]) as z. destruct z. auto with zarith. - destruct sqrtrempos; intros. + generalize (Z.sqrtrem_spec (Zpos p)). + destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith. assert (s < wB). destruct (Z_lt_le_dec s wB); auto. assert (wB * wB <= Zpos p). - rewrite e. + rewrite U. apply Zle_trans with (s*s); try omega. apply Zmult_le_compat; generalize wB_pos; auto with zarith. assert (Zpos p < wB*wB). @@ -665,15 +646,15 @@ Section ZModulo. apply two_power_pos_correct. Qed. - Definition znz_head0 x := match [|x|] with - | Z0 => znz_zdigits - | Zpos p => znz_zdigits - log_inf p - 1 + Definition head0 x := match [|x|] with + | Z0 => zdigits + | Zpos p => zdigits - log_inf p - 1 | _ => 0 end. - Lemma spec_head00: forall x, [|x|] = 0 -> [|znz_head0 x|] = Zpos znz_digits. + Lemma spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits. Proof. - unfold znz_head0; intros. + unfold head0; intros. rewrite H; simpl. apply spec_zdigits. Qed. @@ -701,43 +682,43 @@ Section ZModulo. Lemma spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|znz_head0 x|]) * [|x|] < wB. + wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. Proof. - intros; unfold znz_head0. + intros; unfold head0. generalize (spec_to_Z x). destruct [|x|]; try discriminate. intros. destruct (log_inf_correct p). rewrite 2 two_p_power2 in H2; auto with zarith. - assert (0 <= znz_zdigits - log_inf p - 1 < wB). + assert (0 <= zdigits - log_inf p - 1 < wB). split. - cut (log_inf p < znz_zdigits); try omega. - unfold znz_zdigits. + cut (log_inf p < zdigits); try omega. + unfold zdigits. unfold wB, base in *. apply log_inf_bounded; auto with zarith. - apply Zlt_trans with znz_zdigits. + apply Zlt_trans with zdigits. omega. - unfold znz_zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. + unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. - unfold znz_to_Z; rewrite (Zmod_small _ _ H3). + unfold to_Z; rewrite (Zmod_small _ _ H3). destruct H2. split. - apply Zle_trans with (2^(znz_zdigits - log_inf p - 1)*(2^log_inf p)). + apply Zle_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)). apply Zdiv_le_upper_bound; auto with zarith. rewrite <- Zpower_exp; auto with zarith. rewrite Zmult_comm; rewrite <- Zpower_Zsucc; auto with zarith. - replace (Zsucc (znz_zdigits - log_inf p -1 +log_inf p)) with znz_zdigits + replace (Zsucc (zdigits - log_inf p -1 +log_inf p)) with zdigits by ring. - unfold wB, base, znz_zdigits; auto with zarith. + unfold wB, base, zdigits; auto with zarith. apply Zmult_le_compat; auto with zarith. apply Zlt_le_trans - with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))). + with (2^(zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))). apply Zmult_lt_compat_l; auto with zarith. rewrite <- Zpower_exp; auto with zarith. - replace (znz_zdigits - log_inf p -1 +Zsucc (log_inf p)) with znz_zdigits + replace (zdigits - log_inf p -1 +Zsucc (log_inf p)) with zdigits by ring. - unfold wB, base, znz_zdigits; auto with zarith. + unfold wB, base, zdigits; auto with zarith. Qed. Fixpoint Ptail p := match p with @@ -774,24 +755,24 @@ Section ZModulo. rewrite <- H1; omega. Qed. - Definition znz_tail0 x := + Definition tail0 x := match [|x|] with - | Z0 => znz_zdigits + | Z0 => zdigits | Zpos p => Ptail p | Zneg _ => 0 end. - Lemma spec_tail00: forall x, [|x|] = 0 -> [|znz_tail0 x|] = Zpos znz_digits. + Lemma spec_tail00: forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits. Proof. - unfold znz_tail0; intros. + unfold tail0; intros. rewrite H; simpl. apply spec_zdigits. Qed. Lemma spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]). + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]). Proof. - intros; unfold znz_tail0. + intros; unfold tail0. generalize (spec_to_Z x). destruct [|x|]; try discriminate; intros. assert ([|Ptail p|] = Ptail p). @@ -818,60 +799,60 @@ Section ZModulo. (** Let's now group everything in two records *) - Definition zmod_op := mk_znz_op - (znz_digits : positive) - (znz_zdigits: znz) - (znz_to_Z : znz -> Z) - (znz_of_pos : positive -> N * znz) - (znz_head0 : znz -> znz) - (znz_tail0 : znz -> znz) - - (znz_0 : znz) - (znz_1 : znz) - (znz_Bm1 : znz) - - (znz_compare : znz -> znz -> comparison) - (znz_eq0 : znz -> bool) - - (znz_opp_c : znz -> carry znz) - (znz_opp : znz -> znz) - (znz_opp_carry : znz -> znz) - - (znz_succ_c : znz -> carry znz) - (znz_add_c : znz -> znz -> carry znz) - (znz_add_carry_c : znz -> znz -> carry znz) - (znz_succ : znz -> znz) - (znz_add : znz -> znz -> znz) - (znz_add_carry : znz -> znz -> znz) - - (znz_pred_c : znz -> carry znz) - (znz_sub_c : znz -> znz -> carry znz) - (znz_sub_carry_c : znz -> znz -> carry znz) - (znz_pred : znz -> znz) - (znz_sub : znz -> znz -> znz) - (znz_sub_carry : znz -> znz -> znz) - - (znz_mul_c : znz -> znz -> zn2z znz) - (znz_mul : znz -> znz -> znz) - (znz_square_c : znz -> zn2z znz) - - (znz_div21 : znz -> znz -> znz -> znz*znz) - (znz_div_gt : znz -> znz -> znz * znz) - (znz_div : znz -> znz -> znz * znz) - - (znz_mod_gt : znz -> znz -> znz) - (znz_mod : znz -> znz -> znz) - - (znz_gcd_gt : znz -> znz -> znz) - (znz_gcd : znz -> znz -> znz) - (znz_add_mul_div : znz -> znz -> znz -> znz) - (znz_pos_mod : znz -> znz -> znz) - - (znz_is_even : znz -> bool) - (znz_sqrt2 : znz -> znz -> znz * carry znz) - (znz_sqrt : znz -> znz). - - Definition zmod_spec := mk_znz_spec zmod_op + Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps + (digits : positive) + (zdigits: t) + (to_Z : t -> Z) + (of_pos : positive -> N * t) + (head0 : t -> t) + (tail0 : t -> t) + + (zero : t) + (one : t) + (minus_one : t) + + (compare : t -> t -> comparison) + (eq0 : t -> bool) + + (opp_c : t -> carry t) + (opp : t -> t) + (opp_carry : t -> t) + + (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) + + (div21 : t -> t -> t -> t*t) + (div_gt : t -> t -> t * t) + (div : t -> t -> t * t) + + (modulo_gt : t -> t -> t) + (modulo : t -> t -> t) + + (gcd_gt : t -> t -> t) + (gcd : t -> t -> t) + (add_mul_div : t -> t -> t -> t) + (pos_mod : t -> t -> t) + + (is_even : t -> bool) + (sqrt2 : t -> t -> t * carry t) + (sqrt : t -> t). + + Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs spec_to_Z spec_of_pos spec_zdigits @@ -910,8 +891,8 @@ Section ZModulo. spec_div_gt spec_div - spec_mod_gt - spec_mod + spec_modulo_gt + spec_modulo spec_gcd_gt spec_gcd @@ -934,12 +915,12 @@ End ZModulo. Module Type PositiveNotOne. Parameter p : positive. - Axiom not_one : p<> 1%positive. + Axiom not_one : p <> 1%positive. End PositiveNotOne. Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. - Definition w := Z. - Definition w_op := zmod_op P.p. - Definition w_spec := zmod_spec P.not_one. + Definition t := Z. + Instance ops : ZnZ.Ops t := zmod_ops P.p. + Instance specs : ZnZ.Specs ops := zmod_specs P.not_one. End ZModuloCyclicType. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index d9624ea3..647ab0ac 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,34 +8,33 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZBase. -Module ZAddPropFunct (Import Z : ZAxiomsSig'). -Include ZBasePropFunct Z. +Module ZAddProp (Import Z : ZAxiomsMiniSig'). +Include ZBaseProp Z. (** Theorems that are either not valid on N or have different proofs on N and Z *) +Hint Rewrite opp_0 : nz. + Theorem add_pred_l : forall n m, P n + m == P (n + m). Proof. intros n m. rewrite <- (succ_pred n) at 2. -rewrite add_succ_l. now rewrite pred_succ. +now rewrite add_succ_l, pred_succ. Qed. Theorem add_pred_r : forall n m, n + P m == P (n + m). Proof. -intros n m; rewrite (add_comm n (P m)), (add_comm n m); -apply add_pred_l. +intros n m; rewrite 2 (add_comm n); apply add_pred_l. Qed. Theorem add_opp_r : forall n m, n + (- m) == n - m. Proof. nzinduct m. -rewrite opp_0; rewrite sub_0_r; now rewrite add_0_r. -intro m. rewrite opp_succ, sub_succ_r, add_pred_r; now rewrite pred_inj_wd. +now nzsimpl. +intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd. Qed. Theorem sub_0_l : forall n, 0 - n == - n. @@ -45,7 +44,7 @@ Qed. Theorem sub_succ_l : forall n m, S n - m == S (n - m). Proof. -intros n m; do 2 rewrite <- add_opp_r; now rewrite add_succ_l. +intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l. Qed. Theorem sub_pred_l : forall n m, P n - m == P (n - m). @@ -69,7 +68,7 @@ Qed. Theorem sub_diag : forall n, n - n == 0. Proof. nzinduct n. -now rewrite sub_0_r. +now nzsimpl. intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. Qed. @@ -90,20 +89,20 @@ Qed. Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p. Proof. -intros n m p; do 2 rewrite <- add_opp_r; now rewrite add_assoc. +intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc. Qed. Theorem opp_involutive : forall n, - (- n) == n. Proof. nzinduct n. -now do 2 rewrite opp_0. -intro n. rewrite opp_succ, opp_pred; now rewrite succ_inj_wd. +now nzsimpl. +intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd. Qed. Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m). Proof. intros n m; nzinduct n. -rewrite opp_0; now do 2 rewrite add_0_l. +now nzsimpl. intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. now rewrite pred_inj_wd. Qed. @@ -116,12 +115,12 @@ Qed. Theorem opp_inj : forall n m, - n == - m -> n == m. Proof. -intros n m H. apply opp_wd in H. now do 2 rewrite opp_involutive in H. +intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H. Qed. Theorem opp_inj_wd : forall n m, - n == - m <-> n == m. Proof. -intros n m; split; [apply opp_inj | apply opp_wd]. +intros n m; split; [apply opp_inj | intros; now f_equiv]. Qed. Theorem eq_opp_l : forall n m, - n == m <-> n == - m. @@ -137,7 +136,7 @@ Qed. Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. Proof. intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc. -now do 2 rewrite add_opp_r. +now rewrite 2 add_opp_r. Qed. Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p. @@ -148,7 +147,7 @@ Qed. Theorem sub_opp_l : forall n m, - n - m == - m - n. Proof. -intros n m. do 2 rewrite <- add_opp_r. now rewrite add_comm. +intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm. Qed. Theorem sub_opp_r : forall n m, n - (- m) == n + m. @@ -165,7 +164,7 @@ Qed. Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p. Proof. intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)). -do 2 rewrite add_sub_assoc. rewrite add_opp_diag_l; do 2 rewrite sub_0_l. +rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. apply opp_inj_wd. Qed. @@ -252,6 +251,11 @@ Proof. intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r. Qed. +Theorem sub_add : forall n m, m - n + n == m. +Proof. + intros. now rewrite <- add_sub_swap, add_simpl_r. +Qed. + (** Now we have two sums or differences; the name includes the two operators and the position of the terms being canceled *) @@ -289,5 +293,5 @@ Qed. (** Of course, there are many other variants *) -End ZAddPropFunct. +End ZAddProp. diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index 6ce54f88..423cdf58 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,180 +8,173 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZLt. -Module ZAddOrderPropFunct (Import Z : ZAxiomsSig'). -Include ZOrderPropFunct Z. +Module ZAddOrderProp (Import Z : ZAxiomsMiniSig'). +Include ZOrderProp Z. (** 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 n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono. +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 n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono. +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 n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono. +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 n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono. +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. stepl (0 + n < m - n + n) by symmetry; apply add_lt_mono_r. -rewrite add_0_l; now rewrite sub_simpl_r. +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; stepl (0 + n <= m - n + n) by symmetry; apply add_le_mono_r. -rewrite add_0_l; now rewrite sub_simpl_r. +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. stepl (n - m + m < 0 + m) by symmetry; apply add_lt_mono_r. -rewrite add_0_l; now rewrite sub_simpl_r. +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. stepl (n - m + m <= 0 + m) by symmetry; apply add_le_mono_r. -rewrite add_0_l; now rewrite sub_simpl_r. +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. stepr (m + - m < m + - n) by symmetry; apply add_lt_mono_l. -do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply lt_0_sub. +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. stepr (m + - m <= m + - n) by symmetry; apply add_le_mono_l. -do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply le_0_sub. +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; rewrite (opp_lt_mono n 0); now rewrite opp_0. +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. rewrite (opp_lt_mono 0 n). now rewrite opp_0. +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; rewrite (opp_le_mono n 0); now rewrite opp_0. +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. rewrite (opp_le_mono 0 n). now rewrite opp_0. +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 n m p. do 2 rewrite <- add_opp_r. rewrite <- add_lt_mono_l. -apply opp_lt_mono. +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 n m p; do 2 rewrite <- add_opp_r; apply add_lt_mono_r. +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]. +[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 n m p; do 2 rewrite <- add_opp_r; rewrite <- add_le_mono_l; -apply opp_le_mono. +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 n m p; do 2 rewrite <- add_opp_r; apply add_le_mono_r. +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]. +[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]. +[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]. +[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 do 2 rewrite add_opp_r]. +[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 do 2 rewrite add_opp_r]. +[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 do 2 rewrite add_opp_r]. +[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. stepl (n + p - p < m - p) by symmetry; apply sub_lt_mono_r. -now rewrite add_simpl_r. +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. stepl (n + p - p <= m - p) by symmetry; apply sub_le_mono_r. -now rewrite add_simpl_r. +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. @@ -196,14 +189,12 @@ Qed. Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p. Proof. -intros n m p. stepl (n - p + p < m + p) by symmetry; apply add_lt_mono_r. -now rewrite sub_simpl_r. +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. stepl (n - p + p <= m + p) by symmetry; apply add_le_mono_r. -now rewrite sub_simpl_r. +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. @@ -218,74 +209,68 @@ 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. rewrite lt_sub_lt_add_l. rewrite add_sub_assoc. -now rewrite <- lt_add_lt_sub_r. +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. rewrite le_sub_le_add_l. rewrite add_sub_assoc. -now rewrite <- le_add_le_sub_r. +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. stepr (n - m < n - 0) by now rewrite sub_0_r. apply sub_lt_mono_l. +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. stepr (n - m <= n - 0) by now rewrite sub_0_r. apply sub_le_mono_l. +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 n m p q H. rewrite lt_sub_lt_add in H. now apply add_lt_cases. +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 n m p q H. rewrite le_sub_le_add in H. now apply add_le_cases. +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 H; rewrite <- add_opp_r in H. -setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply opp_neg_pos). -now apply add_neg_cases. +intros. +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 H; rewrite <- add_opp_r in H. -setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply opp_pos_neg). -now apply add_pos_cases. +intros. +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 H; rewrite <- add_opp_r in H. -setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply opp_nonpos_nonneg). -now apply add_nonpos_cases. +intros. +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 H; rewrite <- add_opp_r in H. -setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply opp_nonneg_nonpos). -now apply add_nonneg_cases. +intros. +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 (Z.eq ==> iff) P. +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 in H3. apply H2 in H3. destruct H3 as [_ 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. @@ -295,6 +280,6 @@ End PosNeg. Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg). -End ZAddOrderPropFunct. +End ZAddOrderProp. diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v index fd14cff0..fd20ce72 100644 --- a/theories/Numbers/Integer/Abstract/ZAxioms.v +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,11 +8,19 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NZAxioms. +Require Import Bool NZParity NZPow NZSqrt NZLog NZGcd NZDiv NZBits. + +(** We obtain integers by postulating that successor of predecessor + is identity. *) + +Module Type ZAxiom (Import Z : NZAxiomsSig'). + Axiom succ_pred : forall n, S (P n) == n. +End ZAxiom. -Set Implicit Arguments. +(** For historical reasons, ZAxiomsMiniSig isn't just NZ + ZAxiom, + we also add an [opp] function, that can be seen as a shortcut + for [sub 0]. *) Module Type Opp (Import T:Typ). Parameter Inline opp : t -> t. @@ -24,15 +32,91 @@ End OppNotation. Module Type Opp' (T:Typ) := Opp T <+ OppNotation T. -(** We obtain integers by postulating that every number has a predecessor. *) - Module Type IsOpp (Import Z : NZAxiomsSig')(Import O : Opp' Z). Declare Instance opp_wd : Proper (eq==>eq) opp. - Axiom succ_pred : forall n, S (P n) == n. Axiom opp_0 : - 0 == 0. Axiom opp_succ : forall n, - (S n) == P (- n). End IsOpp. -Module Type ZAxiomsSig := NZOrdAxiomsSig <+ Opp <+ IsOpp. -Module Type ZAxiomsSig' := NZOrdAxiomsSig' <+ Opp' <+ IsOpp. +Module Type OppCstNotation (Import A : NZAxiomsSig)(Import B : Opp A). + Notation "- 1" := (opp one). + Notation "- 2" := (opp two). +End OppCstNotation. + +Module Type ZAxiomsMiniSig := NZOrdAxiomsSig <+ ZAxiom <+ Opp <+ IsOpp. +Module Type ZAxiomsMiniSig' := NZOrdAxiomsSig' <+ ZAxiom <+ Opp' <+ IsOpp + <+ OppCstNotation. + + +(** Other functions and their specifications *) + +(** 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. +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<n -> sgn n == 1. + Axiom sgn_neg : forall n, n<0 -> sgn n == -1. +End HasSgn. + +(** Divisions *) + +(** First, the usual Coq convention of Truncated-Toward-Bottom + (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. +End ZDivSpecific. + +Module Type ZDiv (Z:ZAxiomsMiniSig) := NZDiv.NZDiv Z <+ ZDivSpecific Z. +Module Type ZDiv' (Z:ZAxiomsMiniSig) := NZDiv.NZDiv' Z <+ ZDivSpecific Z. + +(** Then, the Truncated-Toward-Zero convention. + For not colliding with Floor operations, we use different names +*) + +Module Type QuotRem (Import A : Typ). + 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). +End QuotRemNotation. + +Module Type QuotRem' (A : Typ) := QuotRem A <+ QuotRemNotation A. + +Module Type QuotRemSpec (Import A : ZAxiomsMiniSig')(Import B : QuotRem' A). + Declare Instance quot_wd : Proper (eq==>eq==>eq) quot. + 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<b -> 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. +Module Type ZQuot' (Z:ZAxiomsMiniSig) := QuotRem' Z <+ QuotRemSpec Z. + +(** For all other functions, the NZ axiomatizations are enough. *) + +(** Let's group everything *) + +Module Type ZAxiomsSig := ZAxiomsMiniSig <+ OrderFunctions + <+ HasAbs <+ HasSgn <+ NZParity.NZParity + <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 <+ NZGcd.NZGcd + <+ ZDiv <+ ZQuot <+ NZBits.NZBits <+ NZSquare. +Module Type ZAxiomsSig' := ZAxiomsMiniSig' <+ OrderFunctions' + <+ HasAbs <+ HasSgn <+ NZParity.NZParity + <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 <+ NZGcd.NZGcd' + <+ ZDiv' <+ ZQuot' <+ NZBits.NZBits' <+ NZSquare. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index aa7979ae..51054852 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,26 +8,29 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Decidable. Require Export ZAxioms. Require Import NZProperties. -Module ZBasePropFunct (Import Z : ZAxiomsSig'). -Include NZPropFunct Z. +Module ZBaseProp (Import Z : ZAxiomsMiniSig'). +Include NZProp Z. (* 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 do 2 rewrite succ_pred in H. +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 | apply pred_wd]. +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. -End ZBasePropFunct. +End ZBaseProp. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v new file mode 100644 index 00000000..92afbcb5 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -0,0 +1,1947 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import + Bool ZAxioms ZMulOrder ZPow ZDivFloor ZSgnAbs ZParity NZLog. + +(** 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. +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. + +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. + +(** 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_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 caracterisations of [testbit] *) + +(** 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 caracterisation 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 caracterisation + 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. 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 -> 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 [Psize] and [Psize_pos]). +*) + +(** 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. + +(** Accesing 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<m -> 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<m -> 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. + 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<n -> (a*2^n).[m] = false. +Proof. + intros. + 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<n -> + (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. + +Instance eqf_equiv : Equivalence eqf. +Proof. + split; congruence. +Qed. + +Local Infix "===" := eqf (at level 70, no associativity). + +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. + +Ltac bitwise := apply bits_inj'; intros ?m ?Hm; autorewrite with bitwise. + +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] + 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. + 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 *) + +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. + +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. + 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. + destruct (le_ge_cases 0 n). + 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<a /\ log2 a < n). +Proof. + intros a n. + destruct (le_gt_cases 0 n) as [Hn|Hn]. + rewrite shiftr_div_pow2, div_small_iff by order_nz. + destruct (lt_trichotomy a 0) as [LT|[EQ|LT]]. + split. + intros [(H,_)|(H,H')]. order. generalize (pow_nonneg 2 n le_0_2); order. + intros [H|(H,H')]; order. + rewrite EQ. split. now left. intros _; left. split; order_pos. + split. intros [(H,H')|(H,H')]; right. split; trivial. + apply log2_lt_pow2; trivial. + generalize (pow_nonneg 2 n le_0_2); order. + intros [H|(H,H')]. order. left. + split. order. now apply log2_lt_pow2. + rewrite shiftr_mul_pow2 by order. rewrite eq_mul_0. + split; intros [H|H]. + now left. + elim (pow_nonzero 2 (-n)); try apply opp_nonneg_nonpos; order'. + now left. + destruct H. generalize (log2_nonneg a); order. +Qed. + +Lemma shiftr_eq_0 : forall a n, 0<=a -> 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. + +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. *) + +Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance land_wd : Proper (eq ==> eq ==> eq) land. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance lor_wd : Proper (eq ==> eq ==> eq) lor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +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. + 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. + 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. + +Instance setbit_wd : Proper (eq==>eq==>eq) setbit. +Proof. unfold setbit. solve_proper. Qed. + +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. 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. + 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. + 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. 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). + +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. 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. 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. 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. + 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<<n). + +Instance ones_wd : Proper (eq==>eq) ones. +Proof. unfold ones. solve_proper. Qed. + +Lemma ones_equiv : forall n, ones n == P (2^n). +Proof. + intros. 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<n -> (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<n). +Proof. + intros n m Hn. split. intros H. + destruct (lt_ge_cases m 0) as [Hm|Hm]. + now rewrite testbit_neg_r in H. + split; trivial. apply lt_nge. intro H'. rewrite ones_spec_high in H. + discriminate. now split. + apply ones_spec_low. +Qed. + +Lemma lor_ones_low : forall a n, 0<=a -> log2 a < n -> + lor a (ones n) == ones n. +Proof. + intros a n Ha H. bitwise. 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. 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. 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. 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. 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)). + now apply Hk. order. + 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<m -> 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<a -> log2 (a >> n) == max 0 (log2 a - n). +Proof. + intros a n Ha. + destruct (le_gt_cases 0 (log2 a - n)); + [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<a -> 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<a -> 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. + 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, + 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. + 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. + 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 + 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. + 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. + 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 4555e733..fe951a75 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -1,11 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + (** * Euclidean Division for integers, Euclid convention We use here the "usual" formulation of the Euclid Theorem @@ -19,37 +21,29 @@ Vol. 14, No.2, pp. 127-144, April 1992. See files [ZDivTrunc] and [ZDivFloor] for others conventions. -*) - -Require Import ZAxioms ZProperties NZDiv. -Module Type ZDivSpecific (Import Z : ZAxiomsExtSig')(Import DM : DivMod' Z). - Axiom mod_always_pos : forall a b, 0 <= a mod b < abs b. -End ZDivSpecific. - -Module Type ZDiv (Z:ZAxiomsExtSig) - := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. + We simply extend NZDiv with a bound for modulo that holds + regardless of the sign of a and b. This new specification + subsume mod_bound_pos, which nonetheless stays there for + subtyping. Note also that ZAxiomSig now already contain + a div and a modulo (that follow the Floor convention). + We just ignore them here. +*) -Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. -Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. +Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod' A). + Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= a mod b < abs b. +End EuclidSpec. -Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). +Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z. +Module Type ZEuclid' (Z:ZAxiomsSig) := NZDiv.NZDiv' Z <+ EuclidSpec Z. -(** We benefit from what already exists for NZ *) +Module ZEuclidProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B) + (Import D : ZEuclid' A). - Module ZD <: NZDiv Z. - Definition div := div. - Definition modulo := modulo. - Definition div_wd := div_wd. - Definition mod_wd := mod_wd. - Definition div_mod := div_mod. - Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. - Proof. - intros. rewrite <- (abs_eq b) at 3 by now apply lt_le_incl. - apply mod_always_pos. - Qed. - End ZD. - Module Import NZDivP := NZDivPropFunct Z ZP ZD. + Module Import Private_NZDiv := Nop <+ NZDivProp A D B. (** Another formulation of the main equation *) @@ -117,7 +111,7 @@ 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; apply mod_always_pos. +rewrite abs_opp; now apply mod_always_pos. rewrite mul_opp_opp; now apply div_mod. Qed. @@ -125,7 +119,7 @@ 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; apply mod_always_pos. +rewrite abs_opp; now apply mod_always_pos. rewrite mul_opp_opp; now apply div_mod. Qed. @@ -274,6 +268,11 @@ 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. *) @@ -296,7 +295,7 @@ intros a b Hb. split. intros EQ. rewrite (div_mod a b Hb), EQ; nzsimpl. -apply mod_always_pos. +now apply mod_always_pos. intros. pos_or_neg b. apply div_small. now rewrite <- (abs_eq b). @@ -365,7 +364,7 @@ intros. nzsimpl. rewrite (div_mod a b) at 1; try order. rewrite <- add_lt_mono_l. -destruct (mod_always_pos a b). +destruct (mod_always_pos a b). order. rewrite abs_eq in *; order. Qed. @@ -375,7 +374,7 @@ 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). +destruct (mod_always_pos a b). order. rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order. Qed. @@ -469,7 +468,7 @@ 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. -apply mod_always_pos. +now apply mod_always_pos. (* equation *) rewrite (div_mod a b) at 1 by order. rewrite mul_add_distr_r. @@ -556,17 +555,18 @@ Proof. Qed. (** With the current convention, the following result isn't always - true for negative divisors. For instance - [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *) + 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<b -> 0<c -> +Lemma div_div : forall a b c, 0<b -> 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<= ... <abs(b*c) *) rewrite abs_mul. - destruct (mod_always_pos (a/b) c), (mod_always_pos a b). + destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order. split. apply add_nonneg_nonneg; trivial. apply mul_nonneg_nonneg; order. @@ -581,6 +581,22 @@ Proof. apply div_mod; order. Qed. +(** Similarly, the following result doesn't always hold when [b<0]. + For instance [3 mod (-2*-2)) = 3] while + [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *) + +Lemma mod_mul_r : forall a b c, 0<b -> 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. + (** A last inequality: *) Theorem div_mul_le: @@ -590,16 +606,13 @@ Proof. exact div_mul_le. Qed. (** mod is related to divisibility *) Lemma mod_divides : forall a b, b~=0 -> - (a mod b == 0 <-> exists c, a == b*c). + (a mod b == 0 <-> (b|a)). Proof. intros a b Hb. split. -intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. - rewrite Hab; now nzsimpl. -intros (c,Hc). -rewrite Hc, mul_comm. -now apply mod_mul. +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 ZDivPropFunct. +End ZEuclidProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index efefab81..14003d89 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -1,11 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + (** * Euclidean Division for integers (Floor convention) We use here the convention known as Floor, or Round-Toward-Bottom, @@ -24,33 +26,13 @@ See files [ZDivTrunc] and [ZDivEucl] for others conventions. *) -Require Import ZAxioms ZProperties NZDiv. - -Module Type ZDivSpecific (Import Z:ZAxiomsSig')(Import DM : DivMod' Z). - 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:ZAxiomsSig) - := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. - -Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. -Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. - -Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). +Module Type ZDivProp + (Import A : ZAxiomsSig') + (Import B : ZMulOrderProp A) + (Import C : ZSgnAbsProp A B). (** We benefit from what already exists for NZ *) - - Module ZD <: NZDiv Z. - Definition div := div. - Definition modulo := modulo. - Definition div_wd := div_wd. - Definition mod_wd := mod_wd. - Definition div_mod := div_mod. - Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. - Proof. intros. now apply mod_pos_bound. Qed. - End ZD. - Module Import NZDivP := NZDivPropFunct Z ZP ZD. +Module Import Private_NZDiv := Nop <+ NZDivProp A A B. (** Another formulation of the main equation *) @@ -62,6 +44,18 @@ 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. +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, @@ -94,7 +88,7 @@ Theorem div_unique_pos: Proof. intros; apply div_unique with r; auto. Qed. Theorem div_unique_neg: - forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b. + forall a b q r, b<r<=0 -> a == b*q + r -> q == a/b. Proof. intros; apply div_unique with r; auto. Qed. Theorem mod_unique: @@ -230,11 +224,26 @@ 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] *) +(** 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. -(* TODO: a proper sgn function and theory *) +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 : forall a b, b~=0 -> (0 <= (a mod b) * b). +Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. Proof. intros. destruct (lt_ge_cases 0 b). apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. @@ -307,6 +316,11 @@ 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. *) @@ -585,15 +599,25 @@ Proof. Qed. (** With the current convention, the following result isn't always - true for negative divisors. For instance - [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ]. *) + 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, 0<b -> 0<c -> +Lemma div_div : forall a b c, b~=0 -> 0<c -> (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<= ... <b*c \/ ... *) + apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]. + right. + destruct (mod_pos_bound (a/b) c), (mod_neg_bound a b); trivial. + split. + apply le_lt_trans with (b*((a/b) mod c) + b). + now rewrite <- mul_succ_r, <- mul_le_mono_neg_l, le_succ_l. + now rewrite <- add_lt_mono_l. + apply add_nonpos_nonpos; trivial. + apply mul_nonpos_nonneg; order. left. destruct (mod_pos_bound (a/b) c), (mod_pos_bound a b); trivial. split. @@ -609,24 +633,27 @@ Proof. apply div_mod; order. Qed. +(** Similarly, the following result doesn't always hold when [c<0]. + For instance [3 mod (-2*-2)) = 3] while + [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. +*) + +Lemma rem_mul_r : forall a b c, b~=0 -> 0<c -> + 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. + (** A last inequality: *) Theorem div_mul_le: forall a b c, 0<=a -> 0<b -> 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 <-> exists c, a == b*c). -Proof. -intros a b Hb. split. -intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. - rewrite Hab. now nzsimpl. -intros (c,Hc). -rewrite Hc, mul_comm. -now apply mod_mul. -Qed. - -End ZDivPropFunct. - +End ZDivProp. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index 069d8a8d..bd8b6ce2 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -1,11 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv. + (** * Euclidean Division for integers (Trunc convention) We use here the convention known as Trunc, or Round-Toward-Zero, @@ -24,25 +26,24 @@ See files [ZDivFloor] and [ZDivEucl] for others conventions. *) -Require Import ZAxioms ZProperties NZDiv. - -Module Type ZDivSpecific (Import Z:ZAxiomsSig')(Import DM : DivMod' Z). - Axiom mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. - Axiom mod_opp_l : forall a b, b ~= 0 -> (-a) mod b == - (a mod b). - Axiom mod_opp_r : forall a b, b ~= 0 -> a mod (-b) == a mod b. -End ZDivSpecific. - -Module Type ZDiv (Z:ZAxiomsSig) - := DivMod Z <+ NZDivCommon Z <+ ZDivSpecific Z. - -Module Type ZDivSig := ZAxiomsExtSig <+ ZDiv. -Module Type ZDivSig' := ZAxiomsExtSig' <+ ZDiv <+ DivModNotation. - -Module ZDivPropFunct (Import Z : ZDivSig')(Import ZP : ZPropSig Z). +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 NZDivP := NZDivPropFunct Z ZP Z. + 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 @@ -51,175 +52,274 @@ Ltac pos_or_neg a := (** Another formulation of the main equation *) -Lemma mod_eq : - forall a b, b~=0 -> a mod b == a - b*(a/b). +Lemma rem_eq : + forall a b, b~=0 -> a rem b == a - b*(a÷b). Proof. intros. rewrite <- add_move_l. -symmetry. now apply div_mod. +symmetry. now apply quot_rem. Qed. (** A few sign rules (simple ones) *) -Lemma mod_opp_opp : forall a b, b ~= 0 -> (-a) mod (-b) == - (a mod b). -Proof. intros. now rewrite mod_opp_r, mod_opp_l. Qed. +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 div_opp_l : forall a b, b ~= 0 -> (-a)/b == -(a/b). +Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b). Proof. intros. rewrite <- (mul_cancel_l _ _ b) by trivial. -rewrite <- (add_cancel_r _ _ ((-a) mod b)). -now rewrite <- div_mod, mod_opp_l, mul_opp_r, <- opp_add_distr, <- div_mod. +rewrite <- (add_cancel_r _ _ ((-a) rem b)). +now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. Qed. -Lemma div_opp_r : forall a b, b ~= 0 -> a/(-b) == -(a/b). +Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b). Proof. intros. assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). rewrite <- (mul_cancel_l _ _ (-b)) by trivial. -rewrite <- (add_cancel_r _ _ (a mod (-b))). -now rewrite <- div_mod, mod_opp_r, mul_opp_opp, <- div_mod. -Qed. - -Lemma div_opp_opp : forall a b, b ~= 0 -> (-a)/(-b) == a/b. -Proof. intros. now rewrite div_opp_r, div_opp_l, opp_involutive. Qed. - -(** The sign of [a mod b] is the one of [a] *) - -(* TODO: a proper sgn function and theory *) - -Lemma mod_sign : forall a b, b~=0 -> 0 <= (a mod b) * a. -Proof. -assert (Aux : forall a b, 0<b -> 0 <= (a mod b) * a). - intros. pos_or_neg a. - apply mul_nonneg_nonneg; trivial. now destruct (mod_bound a b). - rewrite <- mul_opp_opp, <- mod_opp_l by order. - apply mul_nonneg_nonneg; try order. destruct (mod_bound (-a) b); order. -intros. pos_or_neg b. apply Aux; order. -rewrite <- mod_opp_r by order. apply Aux; order. +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 div_mod_unique : forall b q1 q2 r1 r2 : t, +Theorem quot_rem_unique : forall b q1 q2 r1 r2 : t, (0<=r1<b \/ b<r1<=0) -> (0<=r2<b \/ b<r2<=0) -> 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. +apply NZQuot.div_mod_unique with b; trivial. rewrite <- (opp_inj_wd r1 r2). -apply div_mod_unique with (-b); trivial. +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 div_unique: - forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a/b. -Proof. intros; now apply div_unique with r. Qed. +Theorem quot_unique: + forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a÷b. +Proof. intros; now apply NZQuot.div_unique with r. Qed. -Theorem mod_unique: - forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a mod b. -Proof. intros; now apply mod_unique with q. Qed. +Theorem rem_unique: + forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a rem b. +Proof. intros; now apply NZQuot.mod_unique with q. Qed. (** A division by itself returns 1 *) -Lemma div_same : forall a, a~=0 -> a/a == 1. +Lemma quot_same : forall a, a~=0 -> a÷a == 1. Proof. -intros. pos_or_neg a. apply div_same; order. -rewrite <- div_opp_opp by trivial. now apply div_same. +intros. pos_or_neg a. apply NZQuot.div_same; order. +rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. Qed. -Lemma mod_same : forall a, a~=0 -> a mod a == 0. +Lemma rem_same : forall a, a~=0 -> a rem a == 0. Proof. -intros. rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag. +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 div_small: forall a b, 0<=a<b -> a/b == 0. -Proof. exact div_small. Qed. +Theorem quot_small: forall a b, 0<=a<b -> a÷b == 0. +Proof. exact NZQuot.div_small. Qed. -(** Same situation, in term of modulo: *) +(** Same situation, in term of remulo: *) -Theorem mod_small: forall a b, 0<=a<b -> a mod b == a. -Proof. exact mod_small. Qed. +Theorem rem_small: forall a b, 0<=a<b -> a rem b == a. +Proof. exact NZQuot.mod_small. Qed. (** * Basic values of divisions and modulo. *) -Lemma div_0_l: forall a, a~=0 -> 0/a == 0. +Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0. Proof. -intros. pos_or_neg a. apply div_0_l; order. -rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. +intros. 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 mod_0_l: forall a, a~=0 -> 0 mod a == 0. +Lemma rem_0_l: forall a, a~=0 -> 0 rem a == 0. Proof. -intros; rewrite mod_eq, div_0_l; now nzsimpl. +intros; rewrite rem_eq, quot_0_l; now nzsimpl. Qed. -Lemma div_1_r: forall a, a/1 == a. +Lemma quot_1_r: forall a, a÷1 == a. Proof. -intros. pos_or_neg a. now apply div_1_r. -apply opp_inj. rewrite <- div_opp_l. apply div_1_r; order. +intros. 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 mod_1_r: forall a, a mod 1 == 0. +Lemma rem_1_r: forall a, a rem 1 == 0. Proof. -intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag. +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 div_1_l: forall a, 1<a -> 1/a == 0. -Proof. exact div_1_l. Qed. +Lemma quot_1_l: forall a, 1<a -> 1÷a == 0. +Proof. exact NZQuot.div_1_l. Qed. + +Lemma rem_1_l: forall a, 1<a -> 1 rem a == 1. +Proof. exact NZQuot.mod_1_l. Qed. -Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. -Proof. exact mod_1_l. Qed. +Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a. +Proof. +intros. 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 div_mul : forall a b, b~=0 -> (a*b)/b == a. +Lemma rem_mul : forall a b, b~=0 -> (a*b) rem b == 0. Proof. -intros. pos_or_neg a; pos_or_neg b. apply div_mul; order. -rewrite <- div_opp_opp, <- mul_opp_r by order. apply div_mul; order. -rewrite <- opp_inj_wd, <- div_opp_l, <- mul_opp_l by order. apply div_mul; order. -rewrite <- opp_inj_wd, <- div_opp_r, <- mul_opp_opp by order. apply div_mul; order. +intros. rewrite rem_eq, quot_mul by trivial. rewrite mul_comm; apply sub_diag. Qed. -Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0. +Theorem quot_unique_exact a b q: b~=0 -> a == b*q -> q == a÷b. Proof. -intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag. + intros Hb H. rewrite H, mul_comm. symmetry. now apply quot_mul. Qed. -(** * Order results about mod and div *) +(** 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. 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 mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. -Proof. exact mod_le. Qed. +Theorem rem_le: forall a b, 0<=a -> 0<b -> a rem b <= a. +Proof. exact NZQuot.mod_le. Qed. -Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b. -Proof. exact div_pos. Qed. +Theorem quot_pos : forall a b, 0<=a -> 0<b -> 0<= a÷b. +Proof. exact NZQuot.div_pos. Qed. -Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b. -Proof. exact div_str_pos. Qed. +Lemma quot_str_pos : forall a b, 0<b<=a -> 0 < a÷b. +Proof. exact NZQuot.div_str_pos. Qed. -Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> abs a < abs b). +Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b). Proof. intros. pos_or_neg a; pos_or_neg b. -rewrite div_small_iff; try order. rewrite 2 abs_eq; intuition; order. -rewrite <- opp_inj_wd, opp_0, <- div_opp_r, div_small_iff by order. +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, <- div_opp_l, div_small_iff by 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 <- div_opp_opp, div_small_iff by order. +rewrite <- quot_opp_opp, NZQuot.div_small_iff by order. rewrite (abs_neq' a), (abs_neq' b); intuition; order. Qed. -Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> abs a < abs b). +Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). Proof. -intros. rewrite mod_eq, <- div_small_iff by order. +intros. 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. @@ -227,306 +327,306 @@ Qed. (** As soon as the divisor is strictly greater than 1, the division is strictly decreasing. *) -Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. -Proof. exact div_lt. Qed. +Lemma quot_lt : forall a b, 0<a -> 1<b -> a÷b < a. +Proof. exact NZQuot.div_lt. Qed. (** [le] is compatible with a positive division. *) -Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c. +Lemma quot_le_mono : forall a b c, 0<c -> a<=b -> a÷c <= b÷c. Proof. -intros. pos_or_neg a. apply div_le_mono; auto. +intros. pos_or_neg a. apply NZQuot.div_le_mono; auto. pos_or_neg b. apply le_trans with 0. - rewrite <- opp_nonneg_nonpos, <- div_opp_l by order. - apply div_pos; order. - apply div_pos; order. -rewrite opp_le_mono in *. rewrite <- 2 div_opp_l by order. - apply div_le_mono; intuition; order. + 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 div is always done toward zero: *) + rounding of quot is always done toward zero: *) -Lemma mul_div_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a/b) <= a. +Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a. Proof. intros. pos_or_neg b. split. -apply mul_nonneg_nonneg; [|apply div_pos]; order. -apply mul_div_le; order. -rewrite <- mul_opp_opp, <- div_opp_r by order. +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 div_pos]; order. -apply mul_div_le; order. +apply mul_nonneg_nonneg; [|apply quot_pos]; order. +apply NZQuot.mul_div_le; order. Qed. -Lemma mul_div_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a/b) <= 0. +Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0. Proof. intros. -rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-div_opp_l by order. +rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. rewrite <- opp_nonneg_nonpos in *. -destruct (mul_div_le (-a) b); tauto. +destruct (mul_quot_le (-a) b); tauto. Qed. -(** For positive numbers, considering [S (a/b)] leads to an upper bound for [a] *) +(** For positive numbers, considering [S (a÷b)] leads to an upper bound for [a] *) -Lemma mul_succ_div_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a/b)). -Proof. exact mul_succ_div_gt. Qed. +Lemma mul_succ_quot_gt: forall a b, 0<=a -> 0<b -> a < b*(S (a÷b)). +Proof. exact NZQuot.mul_succ_div_gt. Qed. (** Similar results with negative numbers *) -Lemma mul_pred_div_lt: forall a b, a<=0 -> 0<b -> b*(P (a/b)) < a. +Lemma mul_pred_quot_lt: forall a b, a<=0 -> 0<b -> b*(P (a÷b)) < a. Proof. intros. -rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- div_opp_l by order. +rewrite opp_lt_mono, <- mul_opp_r, opp_pred, <- quot_opp_l by order. rewrite <- opp_nonneg_nonpos in *. -now apply mul_succ_div_gt. +now apply mul_succ_quot_gt. Qed. -Lemma mul_pred_div_gt: forall a b, 0<=a -> b<0 -> a < b*(P (a/b)). +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, <- div_opp_r by order. +rewrite <- mul_opp_opp, opp_pred, <- quot_opp_r by order. rewrite <- opp_pos_neg in *. -now apply mul_succ_div_gt. +now apply mul_succ_quot_gt. Qed. -Lemma mul_succ_div_lt: forall a b, a<=0 -> b<0 -> b*(S (a/b)) < a. +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, <- div_opp_opp by order. +rewrite opp_lt_mono, <- mul_opp_l, <- quot_opp_opp by order. rewrite <- opp_nonneg_nonpos, <- opp_pos_neg in *. -now apply mul_succ_div_gt. +now apply mul_succ_quot_gt. Qed. -(** Inequality [mul_div_le] is exact iff the modulo is zero. *) +(** Inequality [mul_quot_le] is exact iff the modulo is zero. *) -Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). +Lemma quot_exact : forall a b, b~=0 -> (a == b*(a÷b) <-> a rem b == 0). Proof. -intros. rewrite mod_eq by order. rewrite sub_move_r; nzsimpl; tauto. +intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. Qed. -(** Some additionnal inequalities about div. *) +(** Some additionnal inequalities about quot. *) -Theorem div_lt_upper_bound: - forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q. -Proof. exact div_lt_upper_bound. Qed. +Theorem quot_lt_upper_bound: + forall a b q, 0<=a -> 0<b -> a < b*q -> a÷b < q. +Proof. exact NZQuot.div_lt_upper_bound. Qed. -Theorem div_le_upper_bound: - forall a b q, 0<b -> a <= b*q -> a/b <= q. +Theorem quot_le_upper_bound: + forall a b q, 0<b -> a <= b*q -> a÷b <= q. Proof. intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. +rewrite <- (quot_mul q b) by order. +apply quot_le_mono; trivial. now rewrite mul_comm. Qed. -Theorem div_le_lower_bound: - forall a b q, 0<b -> b*q <= a -> q <= a/b. +Theorem quot_le_lower_bound: + forall a b q, 0<b -> b*q <= a -> q <= a÷b. Proof. intros. -rewrite <- (div_mul q b) by order. -apply div_le_mono; trivial. now rewrite mul_comm. +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 div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q. -Proof. exact div_le_compat_l. Qed. +Lemma quot_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p÷r <= p÷q. +Proof. exact NZQuot.div_le_compat_l. Qed. -(** * Relations between usual operations and mod and div *) +(** * 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) mod c <> a mod c] for [a=9,b=-5,c=2] *) + [(a+b*c) rem c <> a rem c] for [a=9,b=-5,c=2] *) -Lemma mod_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) mod c == a mod c. +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) mod c == a mod c). - intros. pos_or_neg c. apply mod_add; order. - rewrite <- (mod_opp_r a), <- (mod_opp_r (a+b*c)) by order. +assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). + intros. 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 mod_add; order. + 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 mod_opp_l, opp_add_distr, <- mul_opp_l by order. auto. +rewrite <- 2 rem_opp_l, opp_add_distr, <- mul_opp_l by order. auto. Qed. -Lemma div_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> - (a + b * c) / c == a / c + b. +Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> + (a + b * c) ÷ c == a ÷ c + b. Proof. intros. rewrite <- (mul_cancel_l _ _ c) by trivial. -rewrite <- (add_cancel_r _ _ ((a+b*c) mod c)). -rewrite <- div_mod, mod_add by trivial. -now rewrite mul_add_distr_l, add_shuffle0, <-div_mod, mul_comm. +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 div_add_l: forall a b c, b~=0 -> 0 <= (a*b+c)*c -> - (a * b + c) / b == a + c / b. +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 div_add. + intros a b c. rewrite add_comm, (add_comm a). now apply quot_add. Qed. (** Cancellations. *) -Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> - (a*c)/(b*c) == a/b. +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<b -> c~=0 -> (a*c)/(b*c) == a/b). - intros. pos_or_neg c. apply div_mul_cancel_r; order. - rewrite <- div_opp_opp, <- 2 mul_opp_r. apply div_mul_cancel_r; order. +assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)÷(b*c) == a÷b). + intros. 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). +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b). intros. pos_or_neg b. apply Aux1; order. - apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_l; try order. 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. pos_or_neg a. apply Aux2; order. -apply opp_inj. rewrite <- 2 div_opp_l, <- mul_opp_l; try order. 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 div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> - (c*a)/(c*b) == a/b. +Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> + (c*a)÷(c*b) == a÷b. Proof. -intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +intros. rewrite !(mul_comm c); now apply quot_mul_cancel_r. Qed. -Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> - (a*c) mod (b*c) == (a mod b) * c. +Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> + (a*c) rem (b*c) == (a rem b) * c. Proof. intros. assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). -rewrite ! mod_eq by trivial. -rewrite div_mul_cancel_r by order. -now rewrite mul_sub_distr_r, <- !mul_assoc, (mul_comm (a/b) c). +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_mod_distr_l: forall a b c, b~=0 -> c~=0 -> - (c*a) mod (c*b) == c * (a mod b). +Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> + (c*a) rem (c*b) == c * (a rem b). Proof. -intros; rewrite !(mul_comm c); now apply mul_mod_distr_r. +intros; rewrite !(mul_comm c); now apply mul_rem_distr_r. Qed. (** Operations modulo. *) -Theorem mod_mod: forall a n, n~=0 -> - (a mod n) mod n == a mod n. +Theorem rem_rem: forall a n, n~=0 -> + (a rem n) rem n == a rem n. Proof. -intros. pos_or_neg a; pos_or_neg n. apply mod_mod; order. -rewrite <- ! (mod_opp_r _ n) by trivial. apply mod_mod; order. -apply opp_inj. rewrite <- !mod_opp_l by order. apply mod_mod; order. -apply opp_inj. rewrite <- !mod_opp_opp by order. apply mod_mod; order. +intros. 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_mod_idemp_l : forall a b n, n~=0 -> - ((a mod n)*b) mod n == (a*b) mod n. +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 mod n)*b) mod n == (a*b) mod n). - intros. pos_or_neg n. apply mul_mod_idemp_l; order. - rewrite <- ! (mod_opp_r _ n) by order. apply mul_mod_idemp_l; order. + ((a rem n)*b) rem n == (a*b) rem n). + intros. 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 mod n)*b) mod n == (a*b) mod n). + ((a rem n)*b) rem n == (a*b) rem n). intros. pos_or_neg b. now apply Aux1. - apply opp_inj. rewrite <-2 mod_opp_l, <-2 mul_opp_r by order. + 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 mod_opp_l, <-2 mul_opp_l, <-mod_opp_l by order. +apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_l, <-rem_opp_l by order. apply Aux2; order. Qed. -Lemma mul_mod_idemp_r : forall a b n, n~=0 -> - (a*(b mod n)) mod n == (a*b) mod n. +Lemma mul_rem_idemp_r : forall a b n, n~=0 -> + (a*(b rem n)) rem n == (a*b) rem n. Proof. -intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. +intros. rewrite !(mul_comm a). now apply mul_rem_idemp_l. Qed. -Theorem mul_mod: forall a b n, n~=0 -> - (a * b) mod n == ((a mod n) * (b mod n)) mod n. +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_mod_idemp_l, mul_mod_idemp_r. +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) mod n = (a mod n + b mod n) mod n] + [(a+b) rem n = (a rem n + b rem n) rem n] for any a and b. - For instance, take (8 + (-10)) mod 3 = -2 whereas - (8 mod 3 + (-10 mod 3)) mod 3 = 1. + For instance, take (8 + (-10)) rem 3 = -2 whereas + (8 rem 3 + (-10 rem 3)) rem 3 = 1. *) -Lemma add_mod_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> - ((a mod n)+b) mod n == (a+b) mod n. +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 mod n)+b) mod n == (a+b) mod n). - intros. pos_or_neg n. apply add_mod_idemp_l; order. - rewrite <- ! (mod_opp_r _ n) by order. apply add_mod_idemp_l; order. + ((a rem n)+b) rem n == (a+b) rem n). + intros. 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 mod_opp_l, 2 opp_add_distr, <-mod_opp_l by order. +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_mod_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> - (a+(b mod n)) mod n == (a+b) mod n. +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. rewrite !(add_comm a). apply add_mod_idemp_l; trivial. +intros. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. now rewrite mul_comm. Qed. -Theorem add_mod: forall a b n, n~=0 -> 0 <= a*b -> - (a+b) mod n == (a mod n + b mod n) mod n. +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_mod_idemp_l, add_mod_idemp_r; trivial. +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 _ _ (mod_sign b n Hn)) as [(Hb',Hm)|(Hb',Hm)]; + 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 mod_0_l by order. nzsimpl; order. - setoid_replace b with 0 by order. rewrite mod_0_l by order. nzsimpl; order. + 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. *) -(** Conversely, the following result needs less restrictions here. *) - -Lemma div_div : forall a b c, b~=0 -> c~=0 -> - (a/b)/c == a/(b*c). +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<b -> c~=0 -> (a/b)/c == a/(b*c)). - intros. pos_or_neg c. apply div_div; order. - apply opp_inj. rewrite <- 2 div_opp_r, <- mul_opp_r; trivial. - apply div_div; order. +assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a÷b)÷c == a÷(b*c)). + intros. 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)). +assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)). intros. pos_or_neg b. apply Aux1; order. - apply opp_inj. rewrite <- div_opp_l, <- 2 div_opp_r, <- mul_opp_l; trivial. + 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. pos_or_neg a. apply Aux2; order. -apply opp_inj. rewrite <- 3 div_opp_l; try order. apply Aux2; order. +apply opp_inj. rewrite <- 3 quot_opp_l; try order. apply Aux2; order. rewrite <- neq_mul_0. tauto. Qed. -(** A last inequality: *) - -Theorem div_mul_le: - forall a b c, 0<=a -> 0<b -> 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 <-> exists c, a == b*c). +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 Hb. split. - intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 1. - rewrite Hab; now nzsimpl. - intros (c,Hc). rewrite Hc, mul_comm. now apply mod_mul. + 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. -End ZDivPropFunct. +(** A last inequality: *) + +Theorem quot_mul_le: + forall a b c, 0<=a -> 0<b -> 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 new file mode 100644 index 00000000..404fc0c4 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -0,0 +1,274 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Properties of the greatest common divisor *) + +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. 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. 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. + +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 strong_right_induction with (z:=0); trivial. + unfold Bezout. solve_proper. + clear n Hn. intros n Hn IHn. + apply le_lteq in Hn; destruct Hn as [Hn|Hn]. + intros m Hm; pattern m. + apply strong_right_induction with (z:=0); trivial. + unfold Bezout. solve_proper. + 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. 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. 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 new file mode 100644 index 00000000..06af04d1 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -0,0 +1,471 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor. + +(** * Least Common Multiple *) + +(** Unlike other functions around, we will define lcm below instead of + axiomatizing it. Indeed, there is no "prior art" about lcm in the + standard library to be compliant with, and the generic definition + of lcm via gcd is quite reasonable. + + By the way, we also state here some combined properties of div/mod + and quot/rem and gcd. +*) + +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<b -> a÷b == a/b. +Proof. + intros. 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<b -> a rem b == a mod b. +Proof. + intros. 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<b -> 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 -> (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 -> (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 + = (a*b) / gcd a b + + We had an abs in order to have an always-nonnegative lcm, + in the spirit of gcd. Nota: [lcm 0 0] should be 0, which + isn't garantee with the third equation above. +*) + +Definition lcm a b := abs (a*(b/gcd a b)). + +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. 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. 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]. + rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. 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 !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. 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. 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 57be0f0e..3a8e1f38 100644 --- a/theories/Numbers/Integer/Abstract/ZLt.v +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZLt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZMul. -Module ZOrderPropFunct (Import Z : ZAxiomsSig'). -Include ZMulPropFunct Z. +Module ZOrderProp (Import Z : ZAxiomsMiniSig'). +Include ZMulProp Z. (** Instances of earlier theorems for m == 0 *) @@ -70,12 +68,12 @@ Qed. Theorem lt_lt_pred : forall n m, n < m -> P n < m. Proof. -intros; apply <- lt_pred_le; now apply lt_le_incl. +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. +intros; apply lt_le_incl; now apply lt_pred_le. Qed. Theorem lt_pred_lt : forall n m, n < P m -> n < m. @@ -85,7 +83,7 @@ Qed. Theorem le_pred_lt : forall n m, n <= P m -> n <= m. Proof. -intros; apply lt_le_incl; now apply <- lt_le_pred. +intros; apply lt_le_incl; now apply lt_le_pred. Qed. Theorem pred_lt_mono : forall n m, n < m <-> P n < P m. @@ -123,12 +121,12 @@ Proof. intro; apply lt_neq; apply lt_pred_l. Qed. -Theorem lt_n1_r : forall n m, n < m -> m < 0 -> n < -(1). +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 opp_pred, opp_0. +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 ZOrderPropFunct. +End ZOrderProp. diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v new file mode 100644 index 00000000..4e653fee --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v @@ -0,0 +1,179 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import ZAxioms ZMulOrder GenericMinMax. + +(** * Properties of minimum and maximum specific to integer numbers *) + +Module Type ZMaxMinProp (Import Z : ZAxiomsMiniSig'). +Include ZMulOrderProp Z. + +(** The following results are concrete instances of [max_monotone] + and similar lemmas. *) + +(** Succ *) + +Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. +Qed. + +Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Proof. + intros. 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 : forall n m, P (max n m) == max (P n) (P m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono. +Qed. + +Lemma pred_min_distr : forall n m, P (min n m) == min (P n) (P m). +Proof. + intros. 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 : forall n m 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]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_max_distr_r : forall n m 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]; now rewrite <- ?add_le_mono_r. +Qed. + +Lemma add_min_distr_l : forall n m 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]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_min_distr_r : forall n m 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]; now rewrite <- ?add_le_mono_r. +Qed. + +(** Opp *) + +Lemma opp_max_distr : forall n m, -(max n m) == min (-n) (-m). +Proof. + intros. 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 : forall n m, -(min n m) == max (-n) (-m). +Proof. + intros. 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 : forall n m p, max (p - n) (p - m) == p - min n m. +Proof. + intros. 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 : forall n m 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 sub_le_mono_r. +Qed. + +Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Proof. + intros. 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 : forall n m 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 sub_le_mono_r. +Qed. + +(** Mul *) + +Lemma mul_max_distr_nonneg_l : forall 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 : forall 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 : forall 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 : forall 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 : forall 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. reflexivity. now apply mul_le_mono_nonpos_l. + rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_l. +Qed. + +Lemma mul_max_distr_nonpos_r : forall 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. reflexivity. now apply mul_le_mono_nonpos_r. + rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_r. +Qed. + +Lemma mul_min_distr_nonpos_l : forall 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. reflexivity. now apply mul_le_mono_nonpos_l. + rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_l. +Qed. + +Lemma mul_min_distr_nonpos_r : forall 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. reflexivity. now apply mul_le_mono_nonpos_r. + rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_r. +Qed. + +End ZMaxMinProp. diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v index 83dc0e10..36f9c3d5 100644 --- a/theories/Numbers/Integer/Abstract/ZMul.v +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZAdd. -Module ZMulPropFunct (Import Z : ZAxiomsSig'). -Include ZAddPropFunct Z. +Module ZMulProp (Import Z : ZAxiomsMiniSig'). +Include ZAddProp Z. (** A note on naming: right (correspondingly, left) distributivity happens when the sum is multiplied by a number on the right @@ -41,7 +39,7 @@ Qed. Theorem mul_opp_l : forall n m, (- n) * m == - (n * m). Proof. -intros n m. apply -> add_move_0_r. +intros n m. apply add_move_0_r. now rewrite <- mul_add_distr_r, add_opp_diag_l, mul_0_l. Qed. @@ -55,6 +53,11 @@ 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_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. @@ -67,6 +70,6 @@ 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 ZMulPropFunct. +End ZMulProp. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index 06a5d168..d0d64faa 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,14 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZAddOrder. -Module Type ZMulOrderPropFunct (Import Z : ZAxiomsSig'). -Include ZAddOrderPropFunct Z. - -Local Notation "- 1" := (-(1)). +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. @@ -94,18 +90,11 @@ Qed. Notation mul_nonpos := le_mul_0 (only parsing). -Theorem le_0_square : forall n, 0 <= n * n. -Proof. -intro n; destruct (neg_nonneg_cases n). -apply lt_le_incl; now apply mul_neg_neg. -now apply mul_nonneg_nonneg. -Qed. - -Notation square_nonneg := le_0_square (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. +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. @@ -120,42 +109,38 @@ 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). -destruct (lt_ge_cases m n). -assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonpos. -apply -> le_ngt in F. false_hyp H2 F. -now apply le_lt_trans with 0. +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). -destruct (le_gt_cases m n). -assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonpos. -apply -> lt_nge in F. false_hyp H2 F. -apply lt_le_incl; now apply le_lt_trans with 0. +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. +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_n1_neg : forall n m, 1 < n -> m < 0 -> n * m < -1. +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_n1_r with m. +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_n1_pos : forall n m, n < -1 -> 0 < m -> n * m < -1. +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. +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_n1_r with (- m). +apply opp_neg_pos in H2. now apply lt_m1_r with (- m). assumption. Qed. @@ -163,39 +148,33 @@ 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_n1_neg. +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_n1_mul_r : forall n m, n < -1 -> +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_n1_pos. +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 : ~ 1 < -1). -intro H. -assert (H1 : -1 < 0). apply <- opp_neg_pos. apply lt_succ_diag_r. -assert (H2 : 1 < 0) by now apply lt_trans with (-1). -false_hyp H2 nlt_succ_diag_l. +assert (F := lt_m1_0). zero_pos_neg n. -intros m H; rewrite mul_0_l in H; false_hyp H neq_succ_diag_r. -intros n H; split; apply <- le_succ_l in H; le_elim H. -intros m H1; apply (lt_1_mul_l n m) in H. -rewrite H1 in H; destruct H as [H | [H | H]]. -false_hyp H F. false_hyp H neq_succ_diag_l. false_hyp H lt_irrefl. -intros; now left. -intros m H1; apply (lt_1_mul_l n m) in H. rewrite mul_opp_l in H1; -apply -> eq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]]. -false_hyp H lt_irrefl. apply -> eq_opp_l in H. rewrite opp_0 in H. -false_hyp H neq_succ_diag_l. false_hyp H F. -intros; right; symmetry; now apply opp_wd. +(* 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). @@ -229,5 +208,9 @@ apply mul_lt_mono_nonneg. now apply lt_le_incl. assumption. apply le_0_1. assumption. Qed. -End ZMulOrderPropFunct. +(** 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 new file mode 100644 index 00000000..b364ec3f --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZParity.v @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. +Qed. + +Lemma even_pred : forall n, even (P n) = odd n. +Proof. + intros. 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. 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 new file mode 100644 index 00000000..53d84dce --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZPow.v @@ -0,0 +1,124 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Properties of the power function *) + +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. + +(** Parity of power *) + +Lemma even_pow : forall a b, 0<b -> 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<b -> 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. 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). + 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/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v index ae7c3209..c0455196 100644 --- a/theories/Numbers/Integer/Abstract/ZProperties.v +++ b/theories/Numbers/Integer/Abstract/ZProperties.v @@ -1,24 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Export ZAxioms ZMaxMin ZSgnAbs ZParity ZPow ZDivTrunc ZDivFloor + ZGcd ZLcm NZLog NZSqrt ZBits. -Require Export ZAxioms ZMulOrder ZSgnAbs. - -(** This functor summarizes all known facts about Z. - For the moment it is only an alias to [ZMulOrderPropFunct], which - subsumes all others, plus properties of [sgn] and [abs]. -*) - -Module Type ZPropSig (Z:ZAxiomsExtSig) := - ZMulOrderPropFunct Z <+ ZSgnAbsPropSig Z. - -Module ZPropFunct (Z:ZAxiomsExtSig) <: ZPropSig Z. - Include ZPropSig Z. -End ZPropFunct. +(** This functor summarizes all known facts about Z. *) +Module Type ZProp (Z:ZAxiomsSig) := + ZMaxMinProp Z <+ ZSgnAbsProp Z <+ ZParityProp Z <+ ZPowProp Z + <+ NZSqrtProp Z Z <+ NZSqrtUpProp Z Z + <+ NZLog2Prop Z Z Z <+ NZLog2UpProp Z Z Z + <+ ZDivProp Z <+ ZQuotProp Z <+ ZGcdProp Z <+ ZLcmProp Z + <+ ZBitsProp Z. diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v index cecaa6a3..b2f6cc84 100644 --- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v +++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v @@ -1,25 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Require Export ZMulOrder. +(** Properties of [abs] and [sgn] *) -(** An axiomatization of [abs]. *) - -Module Type HasAbs(Import Z : ZAxiomsSig'). - 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. +Require Import ZMulOrder. (** Since we already have [max], we could have defined [abs]. *) -Module GenericAbs (Import Z : ZAxiomsSig') - (Import ZP : ZMulOrderPropFunct Z) <: HasAbs Z. +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. @@ -35,37 +29,28 @@ Module GenericAbs (Import Z : ZAxiomsSig') Qed. End GenericAbs. -(** An Axiomatization of [sgn]. *) - -Module Type HasSgn (Import Z : ZAxiomsSig'). - Parameter Inline sgn : t -> t. - Axiom sgn_null : forall n, n==0 -> sgn n == 0. - Axiom sgn_pos : forall n, 0<n -> sgn n == 1. - Axiom sgn_neg : forall n, n<0 -> sgn n == -(1). -End HasSgn. - (** We can deduce a [sgn] function from a [compare] function *) -Module Type ZDecAxiomsSig := ZAxiomsSig <+ HasCompare. -Module Type ZDecAxiomsSig' := ZAxiomsSig' <+ HasCompare. +Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare. +Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare. Module Type GenericSgn (Import Z : ZDecAxiomsSig') - (Import ZP : ZMulOrderPropFunct Z) <: HasSgn Z. + (Import ZP : ZMulOrderProp Z) <: HasSgn Z. Definition sgn n := - match compare 0 n with Eq => 0 | Lt => 1 | Gt => -(1) end. + match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. Lemma sgn_null : forall n, n==0 -> sgn n == 0. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. Lemma sgn_pos : forall n, 0<n -> sgn n == 1. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_neg : forall n, n<0 -> sgn n == -(1). + Lemma sgn_neg : forall n, n<0 -> sgn n == -1. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. End GenericSgn. -Module Type ZAxiomsExtSig := ZAxiomsSig <+ HasAbs <+ HasSgn. -Module Type ZAxiomsExtSig' := ZAxiomsSig' <+ HasAbs <+ HasSgn. -Module Type ZSgnAbsPropSig (Import Z : ZAxiomsExtSig') - (Import ZP : ZMulOrderPropFunct Z). +(** 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); @@ -183,6 +168,28 @@ Proof. 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. @@ -249,7 +256,7 @@ Qed. Lemma sgn_spec : forall n, 0 < n /\ sgn n == 1 \/ 0 == n /\ sgn n == 0 \/ - 0 > n /\ sgn n == -(1). + 0 > n /\ sgn n == -1. Proof. intros n. destruct_sgn n; [left|right;left|right;right]; auto with relations. @@ -264,7 +271,7 @@ Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n. Proof. split; try apply sgn_pos. destruct_sgn n; auto. intros. elim (lt_neq 0 1); auto. apply lt_0_1. - intros. elim (lt_neq (-(1)) 1); auto. + intros. elim (lt_neq (-1) 1); auto. apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. Qed. @@ -272,16 +279,16 @@ Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0. Proof. 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. + 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. +Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. Proof. split; try apply sgn_neg. destruct_sgn n; auto with relations. - intros. elim (lt_neq (-(1)) 1); 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. + intros. elim (lt_neq (-1) 0); auto with relations. rewrite opp_neg_pos. apply lt_0_1. Qed. @@ -343,6 +350,15 @@ Proof. rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. Qed. -End ZSgnAbsPropSig. +Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. +Proof. + intros. + 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/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index 7df8909f..443777f5 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigZ.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export BigN. Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake. @@ -21,77 +19,59 @@ Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake. - [ZMake.Make BigN] provides the operations and basic specs w.r.t. ZArith - [ZTypeIsZAxioms] shows (mainly) that these operations implement the interface [ZAxioms] - - [ZPropSig] adds all generic properties derived from [ZAxioms] - - [ZDivPropFunct] provides generic properties of [div] and [mod] - ("Floor" variant) + - [ZProp] adds all generic properties derived from [ZAxioms] - [MinMax*Properties] provides properties of [min] and [max] *) +Delimit Scope bigZ_scope with bigZ. -Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder := - ZMake.Make BigN <+ ZTypeIsZAxioms - <+ !ZPropSig <+ !ZDivPropFunct <+ HasEqBool2Dec - <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. +Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder. + Include ZMake.Make BigN [scope abstract_scope to bigZ_scope]. + Bind Scope bigZ_scope with t t_. + Include ZTypeIsZAxioms + <+ ZProp [no inline] + <+ HasEqBool2Dec [no inline] + <+ MinMaxLogicalProperties [no inline] + <+ MinMaxDecProperties [no inline]. +End BigZ. -(** Notations about [BigZ] *) +(** For precision concerning the above scope handling, see comment in BigN *) -Notation bigZ := BigZ.t. +(** Notations about [BigZ] *) -Delimit Scope bigZ_scope with bigZ. -Bind Scope bigZ_scope with bigZ. -Bind Scope bigZ_scope with BigZ.t. -Bind Scope bigZ_scope with BigZ.t_. -(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) -Arguments Scope BigZ.Pos [bigN_scope]. -Arguments Scope BigZ.Neg [bigN_scope]. -Arguments Scope BigZ.to_Z [bigZ_scope]. -Arguments Scope BigZ.succ [bigZ_scope]. -Arguments Scope BigZ.pred [bigZ_scope]. -Arguments Scope BigZ.opp [bigZ_scope]. -Arguments Scope BigZ.square [bigZ_scope]. -Arguments Scope BigZ.add [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.sub [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.mul [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.div [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.eq [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.lt [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.le [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.eq [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.compare [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.min [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.max [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.eq_bool [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.power_pos [bigZ_scope positive_scope]. -Arguments Scope BigZ.power [bigZ_scope N_scope]. -Arguments Scope BigZ.sqrt [bigZ_scope]. -Arguments Scope BigZ.div_eucl [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.modulo [bigZ_scope bigZ_scope]. -Arguments Scope BigZ.gcd [bigZ_scope bigZ_scope]. +Local Open Scope bigZ_scope. +Notation bigZ := BigZ.t. +Bind Scope bigZ_scope with bigZ BigZ.t BigZ.t_. +Arguments BigZ.Pos _%bigN. +Arguments BigZ.Neg _%bigN. Local Notation "0" := BigZ.zero : bigZ_scope. Local Notation "1" := BigZ.one : bigZ_scope. +Local Notation "2" := BigZ.two : bigZ_scope. Infix "+" := BigZ.add : bigZ_scope. Infix "-" := BigZ.sub : bigZ_scope. Notation "- x" := (BigZ.opp x) : bigZ_scope. Infix "*" := BigZ.mul : bigZ_scope. Infix "/" := BigZ.div : bigZ_scope. -Infix "^" := BigZ.power : bigZ_scope. +Infix "^" := BigZ.pow : bigZ_scope. Infix "?=" := BigZ.compare : bigZ_scope. +Infix "=?" := BigZ.eqb (at level 70, no associativity) : bigZ_scope. +Infix "<=?" := BigZ.leb (at level 70, no associativity) : bigZ_scope. +Infix "<?" := BigZ.ltb (at level 70, no associativity) : bigZ_scope. Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope. -Notation "x != y" := (~x==y)%bigZ (at level 70, no associativity) : bigZ_scope. +Notation "x != y" := (~x==y) (at level 70, no associativity) : bigZ_scope. Infix "<" := BigZ.lt : bigZ_scope. Infix "<=" := BigZ.le : bigZ_scope. -Notation "x > y" := (BigZ.lt y x)(only parsing) : bigZ_scope. -Notation "x >= y" := (BigZ.le y x)(only parsing) : bigZ_scope. -Notation "x < y < z" := (x<y /\ y<z)%bigZ : bigZ_scope. -Notation "x < y <= z" := (x<y /\ y<=z)%bigZ : bigZ_scope. -Notation "x <= y < z" := (x<=y /\ y<z)%bigZ : bigZ_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z)%bigZ : bigZ_scope. +Notation "x > y" := (y < x) (only parsing) : bigZ_scope. +Notation "x >= y" := (y <= x) (only parsing) : bigZ_scope. +Notation "x < y < z" := (x<y /\ y<z) : bigZ_scope. +Notation "x < y <= z" := (x<y /\ y<=z) : bigZ_scope. +Notation "x <= y < z" := (x<=y /\ y<z) : bigZ_scope. +Notation "x <= y <= z" := (x<=y /\ y<=z) : bigZ_scope. Notation "[ i ]" := (BigZ.to_Z i) : bigZ_scope. -Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigN_scope. - -Local Open Scope bigZ_scope. +Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigZ_scope. +Infix "÷" := BigZ.quot (at level 40, left associativity) : bigZ_scope. (** Some additional results about [BigZ] *) @@ -135,24 +115,26 @@ symmetry. apply BigZ.add_opp_r. exact BigZ.add_opp_diag_r. Qed. -Lemma BigZeqb_correct : forall x y, BigZ.eq_bool x y = true -> x==y. +Lemma BigZeqb_correct : forall x y, (x =? y) = true -> x==y. Proof. now apply BigZ.eqb_eq. Qed. -Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq (@id N) BigZ.power. +Definition BigZ_of_N n := BigZ.of_Z (Z_of_N n). + +Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq BigZ_of_N BigZ.pow. Proof. constructor. -intros. red. rewrite BigZ.spec_power. unfold id. -destruct Zpower_theory as [EQ]. rewrite EQ. +intros. unfold BigZ.eq, BigZ_of_N. rewrite BigZ.spec_pow, BigZ.spec_of_Z. +rewrite Zpower_theory.(rpow_pow_N). destruct n; simpl. reflexivity. induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto. Qed. Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _) - (fun a b => if BigZ.eq_bool b 0 then (0,a) else BigZ.div_eucl a b). + (fun a b => if b =? 0 then (0,a) else BigZ.div_eucl a b). Proof. constructor. unfold id. intros a b. BigZ.zify. -generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0). +case Z.eqb_spec. BigZ.zify. auto with zarith. intros NEQ. generalize (BigZ.spec_div_eucl a b). @@ -170,6 +152,7 @@ Ltac isBigZcst t := | BigZ.Neg ?t => isBigNcst t | BigZ.zero => constr:true | BigZ.one => constr:true + | BigZ.two => constr:true | BigZ.minus_one => constr:true | _ => constr:false end. @@ -180,16 +163,25 @@ Ltac BigZcst t := | false => constr:NotConstant end. +Ltac BigZ_to_N t := + match t with + | BigZ.Pos ?t => BigN_to_N t + | BigZ.zero => constr:0%N + | BigZ.one => constr:1%N + | BigZ.two => constr:2%N + | _ => constr:NotConstant + end. + (** Registration for the "ring" tactic *) Add Ring BigZr : BigZring (decidable BigZeqb_correct, constants [BigZcst], - power_tac BigZpower [Ncst], + power_tac BigZpower [BigZ_to_N], div BigZdiv). Section TestRing. -Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. +Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + (y + 1*x)*x. Proof. intros. ring_simplify. reflexivity. Qed. diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index 48db793c..0142b36b 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMake.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import ZArith. Require Import BigNumPrelude. Require Import NSig. @@ -31,8 +29,11 @@ Module Make (N:NType) <: ZType. Definition t := t_. + Bind Scope abstract_scope with t t_. + Definition zero := Pos N.zero. Definition one := Pos N.one. + Definition two := Pos N.two. Definition minus_one := Neg N.one. Definition of_Z x := @@ -66,6 +67,10 @@ Module Make (N:NType) <: ZType. exact N.spec_1. Qed. + Theorem spec_2: to_Z two = 2. + exact N.spec_2. + Qed. + Theorem spec_m1: to_Z minus_one = -1. simpl; rewrite N.spec_1; auto. Qed. @@ -104,21 +109,49 @@ Module Make (N:NType) <: ZType. exfalso. omega. Qed. - Definition eq_bool x y := + Definition eqb x y := match compare x y with | Eq => true | _ => false end. - Theorem spec_eq_bool: - forall x y, eq_bool x y = Zeq_bool (to_Z x) (to_Z y). + Theorem spec_eqb x y : eqb x y = Z.eqb (to_Z x) (to_Z y). Proof. - unfold eq_bool, Zeq_bool; intros; rewrite spec_compare; reflexivity. + apply Bool.eq_iff_eq_true. + unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. + split; [now destruct Z.compare | now intros ->]. Qed. Definition lt n m := to_Z n < to_Z m. Definition le n m := to_Z n <= to_Z m. + + Definition ltb (x y : t) : bool := + match compare x y with + | Lt => true + | _ => false + end. + + Theorem spec_ltb x y : ltb x y = Z.ltb (to_Z x) (to_Z y). + Proof. + apply Bool.eq_iff_eq_true. + rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. + split; [now destruct Z.compare | now intros ->]. + Qed. + + Definition leb (x y : t) : bool := + match compare x y with + | Gt => false + | _ => true + end. + + Theorem spec_leb x y : leb x y = Z.leb (to_Z x) (to_Z y). + Proof. + apply Bool.eq_iff_eq_true. + rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. + destruct Z.compare; split; try easy. now destruct 1. + Qed. + Definition min n m := match compare n m with Gt => m | _ => n end. Definition max n m := match compare n m with Lt => m | _ => n end. @@ -273,23 +306,23 @@ Module Make (N:NType) <: ZType. unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring. Qed. - Definition power_pos x p := + Definition pow_pos x p := match x with - | Pos nx => Pos (N.power_pos nx p) + | Pos nx => Pos (N.pow_pos nx p) | Neg nx => match p with | xH => x - | xO _ => Pos (N.power_pos nx p) - | xI _ => Neg (N.power_pos nx p) + | xO _ => Pos (N.pow_pos nx p) + | xI _ => Neg (N.pow_pos nx p) end end. - Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. + Theorem spec_pow_pos: forall x n, to_Z (pow_pos x n) = to_Z x ^ Zpos n. Proof. assert (F0: forall x, (-x)^2 = x^2). intros x; rewrite Zpower_2; ring. - unfold power_pos, to_Z; intros [x | x] [p | p |]; - try rewrite N.spec_power_pos; try ring. + unfold pow_pos, to_Z; intros [x | x] [p | p |]; + try rewrite N.spec_pow_pos; try ring. assert (F: 0 <= 2 * Zpos p). assert (0 <= Zpos p); auto with zarith. rewrite Zpos_xI; repeat rewrite Zpower_exp; auto with zarith. @@ -302,18 +335,47 @@ Module Make (N:NType) <: ZType. rewrite F0; ring. Qed. - Definition power x n := + Definition pow_N x n := match n with | N0 => one - | Npos p => power_pos x p + | Npos p => pow_pos x p + end. + + Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z_of_N n. + Proof. + destruct n; simpl. apply N.spec_1. + apply spec_pow_pos. + Qed. + + Definition pow x y := + match to_Z y with + | Z0 => one + | Zpos p => pow_pos x p + | Zneg p => zero end. - Theorem spec_power: forall x n, to_Z (power x n) = to_Z x ^ Z_of_N n. + Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y. Proof. - destruct n; simpl. rewrite N.spec_1; reflexivity. - apply spec_power_pos. + intros. unfold pow. destruct (to_Z y); simpl. + apply N.spec_1. + apply spec_pow_pos. + apply N.spec_0. Qed. + Definition log2 x := + match x with + | Pos nx => Pos (N.log2 nx) + | Neg nx => zero + end. + + Theorem spec_log2: forall x, to_Z (log2 x) = Z.log2 (to_Z x). + Proof. + intros. destruct x as [p|p]; simpl. apply N.spec_log2. + rewrite N.spec_0. + destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ]. + rewrite Z.log2_nonpos; auto with zarith. + now rewrite <- EQ. + Qed. Definition sqrt x := match x with @@ -321,15 +383,14 @@ Module Make (N:NType) <: ZType. | Neg nx => Neg N.zero end. - Theorem spec_sqrt: forall x, 0 <= to_Z x -> - to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2. + Theorem spec_sqrt: forall x, to_Z (sqrt x) = Z.sqrt (to_Z x). Proof. - unfold to_Z, sqrt; intros [x | x] H. - exact (N.spec_sqrt x). - replace (N.to_Z x) with 0. - rewrite N.spec_0; simpl Zpower; unfold Zpower_pos, iter_pos; - auto with zarith. - generalize (N.spec_pos x); auto with zarith. + destruct x as [p|p]; simpl. + apply N.spec_sqrt. + rewrite N.spec_0. + destruct (Z_le_lt_eq_dec _ _ (N.spec_pos p)) as [LT|EQ]. + rewrite Z.sqrt_neg; auto with zarith. + now rewrite <- EQ. Qed. Definition div_eucl x y := @@ -339,12 +400,12 @@ Module Make (N:NType) <: ZType. (Pos q, Pos r) | Pos nx, Neg ny => let (q, r) := N.div_eucl nx ny in - if N.eq_bool N.zero r + if N.eqb N.zero r then (Neg q, zero) else (Neg (N.succ q), Neg (N.sub ny r)) | Neg nx, Pos ny => let (q, r) := N.div_eucl nx ny in - if N.eq_bool N.zero r + if N.eqb N.zero r then (Neg q, zero) else (Neg (N.succ q), Pos (N.sub ny r)) | Neg nx, Neg ny => @@ -368,32 +429,32 @@ Module Make (N:NType) <: ZType. (* Pos Neg *) generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr; + try (injection 1; intros Hr Hq; rewrite N.spec_eqb, N.spec_0, Hr; simpl; rewrite Hq, N.spec_0; auto). change (- Zpos py) with (Zneg py). assert (GT : Zpos py > 0) by (compute; auto). generalize (Z_div_mod (Zpos px) (Zpos py) GT). unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r'). intros (EQ,MOD). injection 1. intros Hr' Hq'. - rewrite N.spec_eq_bool, N.spec_0, Hr'. + rewrite N.spec_eqb, N.spec_0, Hr'. break_nonneg r pr EQr. subst; simpl. rewrite N.spec_0; auto. - subst. lazy iota beta delta [Zeq_bool Zcompare]. + subst. lazy iota beta delta [Z.eqb]. rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *. (* Neg Pos *) generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr; + try (injection 1; intros Hr Hq; rewrite N.spec_eqb, N.spec_0, Hr; simpl; rewrite Hq, N.spec_0; auto). change (- Zpos px) with (Zneg px). assert (GT : Zpos py > 0) by (compute; auto). generalize (Z_div_mod (Zpos px) (Zpos py) GT). unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r'). intros (EQ,MOD). injection 1. intros Hr' Hq'. - rewrite N.spec_eq_bool, N.spec_0, Hr'. + rewrite N.spec_eqb, N.spec_0, Hr'. break_nonneg r pr EQr. subst; simpl. rewrite N.spec_0; auto. - subst. lazy iota beta delta [Zeq_bool Zcompare]. + subst. lazy iota beta delta [Z.eqb]. rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *. (* Neg Neg *) generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r). @@ -422,6 +483,50 @@ Module Make (N:NType) <: ZType. intros q r q11 r1 H; injection H; auto. Qed. + Definition quot x y := + match x, y with + | Pos nx, Pos ny => Pos (N.div nx ny) + | Pos nx, Neg ny => Neg (N.div nx ny) + | Neg nx, Pos ny => Neg (N.div nx ny) + | Neg nx, Neg ny => Pos (N.div nx ny) + end. + + Definition rem x y := + if eqb y zero then x + else + match x, y with + | Pos nx, Pos ny => Pos (N.modulo nx ny) + | Pos nx, Neg ny => Pos (N.modulo nx ny) + | Neg nx, Pos ny => Neg (N.modulo nx ny) + | Neg nx, Neg ny => Neg (N.modulo nx ny) + end. + + Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y). + Proof. + intros [x|x] [y|y]; simpl; symmetry; rewrite N.spec_div; + (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *) + destruct (Z.eq_dec (N.to_Z y) 0) as [EQ|NEQ]; + try (rewrite EQ; now destruct (N.to_Z x)); + rewrite ?Z.quot_opp_r, ?Z.quot_opp_l, ?Z.opp_involutive, ?Z.opp_inj_wd; + trivial; apply Z.quot_div_nonneg; + generalize (N.spec_pos x) (N.spec_pos y); Z.order. + Qed. + + Lemma spec_rem : forall x y, + to_Z (rem x y) = Z.rem (to_Z x) (to_Z y). + Proof. + intros x y. unfold rem. rewrite spec_eqb, spec_0. + case Z.eqb_spec; intros Hy. + (* Nota: we rely here on [Z.rem a 0 = a] *) + rewrite Hy. now destruct (to_Z x). + destruct x as [x|x], y as [y|y]; simpl in *; symmetry; + rewrite ?Z.eq_opp_l, ?Z.opp_0 in Hy; + rewrite N.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive, + ?Z.opp_inj_wd; + trivial; apply Z.rem_mod_nonneg; + generalize (N.spec_pos x) (N.spec_pos y); Z.order. + Qed. + Definition gcd x y := match x, y with | Pos nx, Pos ny => Pos (N.gcd nx ny) @@ -453,4 +558,204 @@ Module Make (N:NType) <: ZType. rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith. Qed. + Definition even z := + match z with + | Pos n => N.even n + | Neg n => N.even n + end. + + Definition odd z := + match z with + | Pos n => N.odd n + | Neg n => N.odd n + end. + + Lemma spec_even : forall z, even z = Zeven_bool (to_Z z). + Proof. + intros [n|n]; simpl; rewrite N.spec_even; trivial. + destruct (N.to_Z n) as [|p|p]; now try destruct p. + Qed. + + Lemma spec_odd : forall z, odd z = Zodd_bool (to_Z z). + Proof. + intros [n|n]; simpl; rewrite N.spec_odd; trivial. + destruct (N.to_Z n) as [|p|p]; now try destruct p. + Qed. + + Definition norm_pos z := + match z with + | Pos _ => z + | Neg n => if N.eqb n N.zero then Pos n else z + end. + + Definition testbit a n := + match norm_pos n, norm_pos a with + | Pos p, Pos a => N.testbit a p + | Pos p, Neg a => negb (N.testbit (N.pred a) p) + | Neg p, _ => false + end. + + Definition shiftl a n := + match norm_pos a, n with + | Pos a, Pos n => Pos (N.shiftl a n) + | Pos a, Neg n => Pos (N.shiftr a n) + | Neg a, Pos n => Neg (N.shiftl a n) + | Neg a, Neg n => Neg (N.succ (N.shiftr (N.pred a) n)) + end. + + Definition shiftr a n := shiftl a (opp n). + + Definition lor a b := + match norm_pos a, norm_pos b with + | Pos a, Pos b => Pos (N.lor a b) + | Neg a, Pos b => Neg (N.succ (N.ldiff (N.pred a) b)) + | Pos a, Neg b => Neg (N.succ (N.ldiff (N.pred b) a)) + | Neg a, Neg b => Neg (N.succ (N.land (N.pred a) (N.pred b))) + end. + + Definition land a b := + match norm_pos a, norm_pos b with + | Pos a, Pos b => Pos (N.land a b) + | Neg a, Pos b => Pos (N.ldiff b (N.pred a)) + | Pos a, Neg b => Pos (N.ldiff a (N.pred b)) + | Neg a, Neg b => Neg (N.succ (N.lor (N.pred a) (N.pred b))) + end. + + Definition ldiff a b := + match norm_pos a, norm_pos b with + | Pos a, Pos b => Pos (N.ldiff a b) + | Neg a, Pos b => Neg (N.succ (N.lor (N.pred a) b)) + | Pos a, Neg b => Pos (N.land a (N.pred b)) + | Neg a, Neg b => Pos (N.ldiff (N.pred b) (N.pred a)) + end. + + Definition lxor a b := + match norm_pos a, norm_pos b with + | Pos a, Pos b => Pos (N.lxor a b) + | Neg a, Pos b => Neg (N.succ (N.lxor (N.pred a) b)) + | Pos a, Neg b => Neg (N.succ (N.lxor a (N.pred b))) + | Neg a, Neg b => Pos (N.lxor (N.pred a) (N.pred b)) + end. + + Definition div2 x := shiftr x one. + + Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x. + Proof. + unfold Z.lnot, Zpred; auto with zarith. + Qed. + + Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x. + Proof. + unfold Z.lnot, Zpred; auto with zarith. + Qed. + + Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1. + Proof. + unfold Z.lnot, Zpred; auto with zarith. + Qed. + + Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x. + Proof. + intros [x|x]; simpl; trivial. + rewrite N.spec_eqb, N.spec_0. + case Z.eqb_spec; simpl; auto with zarith. + Qed. + + Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y -> + 0 < N.to_Z y. + Proof. + intros [x|x] y; simpl; try easy. + rewrite N.spec_eqb, N.spec_0. + case Z.eqb_spec; simpl; try easy. + inversion 2. subst. generalize (N.spec_pos y); auto with zarith. + Qed. + + Ltac destr_norm_pos x := + rewrite <- (spec_norm_pos x); + let H := fresh in + let x' := fresh x in + assert (H := spec_norm_pos_pos x); + destruct (norm_pos x) as [x'|x']; + specialize (H x' (eq_refl _)) || clear H. + + Lemma spec_testbit: forall x p, testbit x p = Z.testbit (to_Z x) (to_Z p). + Proof. + intros x p. unfold testbit. + destr_norm_pos p; simpl. destr_norm_pos x; simpl. + apply N.spec_testbit. + rewrite N.spec_testbit, N.spec_pred, Zmax_r by auto with zarith. + symmetry. apply Z.bits_opp. apply N.spec_pos. + symmetry. apply Z.testbit_neg_r; auto with zarith. + Qed. + + Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Z.shiftl (to_Z x) (to_Z p). + Proof. + intros x p. unfold shiftl. + destr_norm_pos x; destruct p as [p|p]; simpl; + assert (Hp := N.spec_pos p). + apply N.spec_shiftl. + rewrite Z.shiftl_opp_r. apply N.spec_shiftr. + rewrite !N.spec_shiftl. + rewrite !Z.shiftl_mul_pow2 by apply N.spec_pos. + apply Zopp_mult_distr_l. + rewrite Z.shiftl_opp_r, N.spec_succ, N.spec_shiftr, N.spec_pred, Zmax_r + by auto with zarith. + now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2. + Qed. + + Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Z.shiftr (to_Z x) (to_Z p). + Proof. + intros. unfold shiftr. rewrite spec_shiftl, spec_opp. + apply Z.shiftl_opp_r. + Qed. + + Lemma spec_land: forall x y, to_Z (land x y) = Z.land (to_Z x) (to_Z y). + Proof. + intros x y. unfold land. + destr_norm_pos x; destr_norm_pos y; simpl; + rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor, + ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith. + now rewrite Z.ldiff_land, Zlnot_alt2. + now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2. + now rewrite Z.lnot_lor, !Zlnot_alt2. + Qed. + + Lemma spec_lor: forall x y, to_Z (lor x y) = Z.lor (to_Z x) (to_Z y). + Proof. + intros x y. unfold lor. + destr_norm_pos x; destr_norm_pos y; simpl; + rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor, + ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith. + now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2. + now rewrite Z.lnot_ldiff, Zlnot_alt2. + now rewrite Z.lnot_land, !Zlnot_alt2. + Qed. + + Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Z.ldiff (to_Z x) (to_Z y). + Proof. + intros x y. unfold ldiff. + destr_norm_pos x; destr_norm_pos y; simpl; + rewrite ?N.spec_succ, ?N.spec_land, ?N.spec_ldiff, ?N.spec_lor, + ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; auto with zarith. + now rewrite Z.ldiff_land, Zlnot_alt3. + now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2. + now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3. + Qed. + + Lemma spec_lxor: forall x y, to_Z (lxor x y) = Z.lxor (to_Z x) (to_Z y). + Proof. + intros x y. unfold lxor. + destr_norm_pos x; destr_norm_pos y; simpl; + rewrite ?N.spec_succ, ?N.spec_lxor, ?N.spec_pred, ?Zmax_r, ?Zlnot_alt1; + auto with zarith. + now rewrite !Z.lnot_lxor_r, Zlnot_alt2. + now rewrite !Z.lnot_lxor_l, Zlnot_alt2. + now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2. + Qed. + + Lemma spec_div2: forall x, to_Z (div2 x) = Z.div2 (to_Z x). + Proof. + intros x. unfold div2. now rewrite spec_shiftr, Z.div2_spec, spec_1. + Qed. + End Make. diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v index a7e05fee..d7c0abd8 100644 --- a/theories/Numbers/Integer/Binary/ZBinary.v +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,103 +8,31 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBinary.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZAxioms ZProperties. -Require Import ZArith_base. +Require Import ZAxioms ZProperties BinInt. Local Open Scope Z_scope. -(** * Implementation of [ZAxiomsSig] by [BinInt.Z] *) - -Module ZBinAxiomsMod <: ZAxiomsExtSig. - -(** Bi-directional induction. *) - -Theorem bi_induction : - forall A : Z -> Prop, Proper (eq ==> iff) A -> - A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n. -Proof. -intros A A_wd A0 AS n; apply Zind; clear n. -assumption. -intros; rewrite <- Zsucc_succ'. now apply -> AS. -intros n H. rewrite <- Zpred_pred'. rewrite Zsucc_pred in H. now apply <- AS. -Qed. - -(** Basic operations. *) - -Definition eq_equiv : Equivalence (@eq Z) := eq_equivalence. -Local Obligation Tactic := simpl_relation. -Program Instance succ_wd : Proper (eq==>eq) Zsucc. -Program Instance pred_wd : Proper (eq==>eq) Zpred. -Program Instance add_wd : Proper (eq==>eq==>eq) Zplus. -Program Instance sub_wd : Proper (eq==>eq==>eq) Zminus. -Program Instance mul_wd : Proper (eq==>eq==>eq) Zmult. - -Definition pred_succ n := eq_sym (Zpred_succ n). -Definition add_0_l := Zplus_0_l. -Definition add_succ_l := Zplus_succ_l. -Definition sub_0_r := Zminus_0_r. -Definition sub_succ_r := Zminus_succ_r. -Definition mul_0_l := Zmult_0_l. -Definition mul_succ_l := Zmult_succ_l. - -(** Order *) - -Program Instance lt_wd : Proper (eq==>eq==>iff) Zlt. - -Definition lt_eq_cases := Zle_lt_or_eq_iff. -Definition lt_irrefl := Zlt_irrefl. -Definition lt_succ_r := Zlt_succ_r. +(** BinInt.Z is already implementing [ZAxiomsMiniSig] *) -Definition min_l := Zmin_l. -Definition min_r := Zmin_r. -Definition max_l := Zmax_l. -Definition max_r := Zmax_r. +Module Z + <: ZAxiomsSig <: UsualOrderedTypeFull <: TotalOrder + <: UsualDecidableTypeFull + := BinInt.Z. -(** Properties specific to integers, not natural numbers. *) +(** * An [order] tactic for integers *) -Program Instance opp_wd : Proper (eq==>eq) Zopp. +Ltac z_order := Z.order. -Definition succ_pred n := eq_sym (Zsucc_pred n). -Definition opp_0 := Zopp_0. -Definition opp_succ := Zopp_succ. +(** Note that [z_order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) -(** Absolute value and sign *) - -Definition abs_eq := Zabs_eq. -Definition abs_neq := Zabs_non_eq. - -Lemma sgn_null : forall x, x = 0 -> Zsgn x = 0. -Proof. intros. apply <- Zsgn_null; auto. Qed. -Lemma sgn_pos : forall x, 0 < x -> Zsgn x = 1. -Proof. intros. apply <- Zsgn_pos; auto. Qed. -Lemma sgn_neg : forall x, x < 0 -> Zsgn x = -1. -Proof. intros. apply <- Zsgn_neg; auto. Qed. - -(** The instantiation of operations. - Placing them at the very end avoids having indirections in above lemmas. *) - -Definition t := Z. -Definition eq := (@eq Z). -Definition zero := 0. -Definition succ := Zsucc. -Definition pred := Zpred. -Definition add := Zplus. -Definition sub := Zminus. -Definition mul := Zmult. -Definition lt := Zlt. -Definition le := Zle. -Definition min := Zmin. -Definition max := Zmax. -Definition opp := Zopp. -Definition abs := Zabs. -Definition sgn := Zsgn. - -End ZBinAxiomsMod. - -Module Export ZBinPropMod := ZPropFunct ZBinAxiomsMod. +Section TestOrder. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + z_order. + Qed. +End TestOrder. (** Z forms a ring *) @@ -123,18 +51,3 @@ exact Zadd_opp_r. Qed. Add Ring ZR : Zring.*) - - - -(* -Theorem eq_equiv_e : forall x y : Z, E x y <-> e x y. -Proof. -intros x y; unfold E, e, Zeq_bool; split; intro H. -rewrite H; now rewrite Zcompare_refl. -rewrite eq_true_unfold_pos in H. -assert (H1 : (x ?= y) = Eq). -case_eq (x ?= y); intro H1; rewrite H1 in H; simpl in H; -[reflexivity | discriminate H | discriminate H]. -now apply Zcompare_Eq_eq. -Qed. -*) diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index ea3d9ad9..dbcc1961 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,25 +8,25 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZNatPairs.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import NProperties. (* The most complete file for N *) -Require Export ZProperties. (* The most complete file for Z *) +Require Import NSub ZAxioms. Require Export Ring. Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. -Open Local Scope pair_scope. +Local Open Scope pair_scope. -Module ZPairsAxiomsMod (Import N : NAxiomsSig) <: ZAxiomsSig. -Module Import NPropMod := NPropFunct N. (* Get all properties of N *) +Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig. + Module Import NProp. + Include NSubProp N. + End NProp. 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.succ 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. @@ -44,6 +44,8 @@ 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). @@ -74,7 +76,8 @@ 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.succ 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. @@ -128,15 +131,14 @@ Qed. 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. -apply add_wd, opp_wd; auto. +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). -apply N.add_wd; apply N.add_wd; apply mul_comm. +do 2 f_equiv; apply mul_comm. Qed. Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul. @@ -160,20 +162,22 @@ 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%N)); [intro H1 |]. -cut (forall p, A (0%N, p)); [intro H2 |]. +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%N, p)) by (rewrite add_0_l; now rewrite add_comm). +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%N)) by now rewrite add_0_r. apply H1. +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%N, p) (1%N, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l]. -now apply <- AS. +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%N with (snd (p, 0%N)); [| reflexivity]. -replace (N.succ p) with (N.succ (fst (p, 0%N))); [| reflexivity]. now apply -> AS. +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. @@ -190,6 +194,16 @@ 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. @@ -298,6 +312,8 @@ 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. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v index ff797e32..98ac5dfc 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,9 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZArith Znumtheory. +Require Import BinInt. Open Scope Z_scope. @@ -35,11 +33,14 @@ Module Type ZType. Parameter spec_of_Z: forall x, to_Z (of_Z x) = x. Parameter compare : t -> t -> comparison. - Parameter eq_bool : t -> t -> bool. + Parameter eqb : t -> t -> bool. + Parameter ltb : t -> t -> bool. + Parameter leb : t -> t -> bool. Parameter min : t -> t -> t. Parameter max : t -> t -> t. Parameter zero : t. Parameter one : t. + Parameter two : t. Parameter minus_one : t. Parameter succ : t -> t. Parameter add : t -> t -> t. @@ -48,22 +49,39 @@ Module Type ZType. Parameter opp : t -> t. Parameter mul : t -> t -> t. Parameter square : t -> t. - Parameter power_pos : t -> positive -> t. - Parameter power : t -> N -> t. + Parameter pow_pos : t -> positive -> t. + Parameter pow_N : t -> N -> t. + Parameter pow : t -> t -> t. Parameter sqrt : t -> t. + Parameter log2 : t -> t. Parameter div_eucl : t -> t -> t * t. Parameter div : t -> t -> t. Parameter modulo : t -> t -> t. + Parameter quot : t -> t -> t. + Parameter rem : t -> t -> t. Parameter gcd : t -> t -> t. Parameter sgn : t -> t. Parameter abs : t -> t. + Parameter even : t -> bool. + Parameter odd : t -> bool. + Parameter testbit : t -> t -> bool. + Parameter shiftr : t -> t -> t. + Parameter shiftl : t -> t -> t. + Parameter land : t -> t -> t. + Parameter lor : t -> t -> t. + Parameter ldiff : t -> t -> t. + Parameter lxor : t -> t -> t. + Parameter div2 : t -> t. - Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y]. - Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y]. - Parameter spec_min : forall x y, [min x y] = Zmin [x] [y]. - Parameter spec_max : forall x y, [max x y] = Zmax [x] [y]. + Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). + Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). + Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]). + Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]). + Parameter spec_min : forall x y, [min x y] = Z.min [x] [y]. + Parameter spec_max : forall x y, [max x y] = Z.max [x] [y]. Parameter spec_0: [zero] = 0. Parameter spec_1: [one] = 1. + Parameter spec_2: [two] = 2. Parameter spec_m1: [minus_one] = -1. Parameter spec_succ: forall n, [succ n] = [n] + 1. Parameter spec_add: forall x y, [add x y] = [x] + [y]. @@ -72,17 +90,30 @@ Module Type ZType. Parameter spec_opp: forall x, [opp x] = - [x]. Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. - Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. - Parameter spec_sqrt: forall x, 0 <= [x] -> - [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. + Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. + Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n]. + Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. + Parameter spec_log2: forall x, [log2 x] = Z.log2 [x]. Parameter spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y]. Parameter spec_div: forall x y, [div x y] = [x] / [y]. Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. - Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b). - Parameter spec_sgn : forall x, [sgn x] = Zsgn [x]. - Parameter spec_abs : forall x, [abs x] = Zabs [x]. + Parameter spec_quot: forall x y, [quot x y] = [x] ÷ [y]. + Parameter spec_rem: forall x y, [rem x y] = Z.rem [x] [y]. + Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. + Parameter spec_sgn : forall x, [sgn x] = Z.sgn [x]. + Parameter spec_abs : forall x, [abs x] = Z.abs [x]. + Parameter spec_even : forall x, even x = Z.even [x]. + Parameter spec_odd : forall x, odd x = Z.odd [x]. + Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. + Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. + Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. + Parameter spec_land: forall x y, [land x y] = Z.land [x] [y]. + Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. + Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. + Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. + Parameter spec_div2: forall x, [div2 x] = Z.div2 [x]. End ZType. @@ -90,12 +121,15 @@ Module Type ZType_Notation (Import Z:ZType). Notation "[ x ]" := (to_Z x). Infix "==" := eq (at level 70). Notation "0" := zero. + Notation "1" := one. + Notation "2" := two. Infix "+" := add. Infix "-" := sub. Infix "*" := mul. + Infix "^" := pow. Notation "- x" := (opp x). Infix "<=" := le. Infix "<" := lt. End ZType_Notation. -Module Type ZType' := ZType <+ ZType_Notation.
\ No newline at end of file +Module Type ZType' := ZType <+ ZType_Notation. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v index 879a17dd..bfbc063c 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -1,27 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZSigZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Import Bool ZArith OrdersFacts Nnat ZAxioms ZSig. -Require Import ZArith ZAxioms ZDivFloor ZSig. +(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *) -(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] - - It also provides [sgn], [abs], [div], [mod] -*) - - -Module ZTypeIsZAxioms (Import Z : ZType'). +Module ZTypeIsZAxioms (Import ZZ : ZType'). Hint Rewrite - spec_0 spec_1 spec_add spec_sub spec_pred spec_succ - spec_mul spec_opp spec_of_Z spec_div spec_modulo - spec_compare spec_eq_bool spec_max spec_min spec_abs spec_sgn + spec_0 spec_1 spec_2 spec_add spec_sub spec_pred spec_succ + spec_mul spec_opp spec_of_Z spec_div spec_modulo spec_square spec_sqrt + spec_compare spec_eqb spec_ltb spec_leb spec_max spec_min + spec_abs spec_sgn spec_pow spec_log2 spec_even spec_odd spec_gcd + spec_quot spec_rem spec_testbit spec_shiftl spec_shiftr + spec_land spec_lor spec_ldiff spec_lxor spec_div2 : zsimpl. Ltac zsimpl := autorewrite with zsimpl. @@ -44,9 +41,19 @@ Proof. intros. zify. auto with zarith. Qed. +Theorem one_succ : 1 == succ 0. +Proof. +now zify. +Qed. + +Theorem two_succ : 2 == succ 1. +Proof. +now zify. +Qed. + Section Induction. -Variable A : Z.t -> Prop. +Variable A : ZZ.t -> Prop. Hypothesis A_wd : Proper (eq==>iff) A. Hypothesis A0 : A 0. Hypothesis AS : forall n, A n <-> A (succ n). @@ -131,36 +138,66 @@ Qed. (** Order *) -Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Lemma eqb_eq x y : eqb x y = true <-> x == y. +Proof. + zify. apply Z.eqb_eq. +Qed. + +Lemma leb_le x y : leb x y = true <-> x <= y. +Proof. + zify. apply Z.leb_le. +Qed. + +Lemma ltb_lt x y : ltb x y = true <-> x < y. Proof. - intros. zify. destruct (Zcompare_spec [x] [y]); auto. + zify. apply Z.ltb_lt. Qed. -Definition eqb := eq_bool. +Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. +Proof. + intros. zify. apply Z.compare_eq_iff. +Qed. + +Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. +Proof. + intros. zify. reflexivity. +Qed. -Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y. +Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. Proof. - intros. zify. symmetry. apply Zeq_is_eq_bool. + intros. zify. reflexivity. Qed. +Lemma compare_antisym n m : compare m n = CompOpp (compare n m). +Proof. + intros. zify. apply Z.compare_antisym. +Qed. + +Include BoolOrderFacts ZZ ZZ ZZ [no inline]. + Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. Proof. -intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. +Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. Proof. -intros. zify. omega. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Theorem lt_irrefl : forall n, ~ n < n. +Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. Proof. -intros. zify. omega. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. +Qed. + +Instance lt_wd : Proper (eq ==> eq ==> iff) lt. +Proof. +intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. Qed. Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. @@ -190,13 +227,15 @@ Qed. (** Part specific to integers, not natural numbers *) -Program Instance opp_wd : Proper (eq ==> eq) opp. - Theorem succ_pred : forall n, succ (pred n) == n. Proof. intros. zify. auto with zarith. Qed. +(** Opp *) + +Program Instance opp_wd : Proper (eq ==> eq) opp. + Theorem opp_0 : - 0 == 0. Proof. intros. zify. auto with zarith. @@ -207,6 +246,8 @@ Proof. intros. zify. auto with zarith. Qed. +(** Abs / Sgn *) + Theorem abs_eq : forall n, 0 <= n -> abs n == n. Proof. intros n. zify. omega with *. @@ -222,16 +263,102 @@ Proof. intros n. zify. omega with *. Qed. -Theorem sgn_pos : forall n, 0<n -> sgn n == succ 0. +Theorem sgn_pos : forall n, 0<n -> sgn n == 1. Proof. intros n. zify. omega with *. Qed. -Theorem sgn_neg : forall n, n<0 -> sgn n == opp (succ 0). +Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1. Proof. intros n. zify. omega with *. Qed. +(** Power *) + +Program Instance pow_wd : Proper (eq==>eq==>eq) pow. + +Lemma pow_0_r : forall a, a^0 == 1. +Proof. + intros. now zify. +Qed. + +Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. +Proof. + intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r. +Qed. + +Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. +Proof. + intros a b. zify. intros Hb. + destruct [b]; reflexivity || discriminate. +Qed. + +Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)). +Proof. + intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id. +Qed. + +Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). +Proof. + intros a b. red. now rewrite spec_pow_N, spec_pow_pos. +Qed. + +(** Square *) + +Lemma square_spec n : square n == n * n. +Proof. + now zify. +Qed. + +(** Sqrt *) + +Lemma sqrt_spec : forall n, 0<=n -> + (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). +Proof. + intros n. zify. apply Z.sqrt_spec. +Qed. + +Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. +Proof. + intros n. zify. apply Z.sqrt_neg. +Qed. + +(** Log2 *) + +Lemma log2_spec : forall n, 0<n -> + 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). +Proof. + intros n. zify. apply Z.log2_spec. +Qed. + +Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. +Proof. + intros n. zify. apply Z.log2_nonpos. +Qed. + +(** Even / Odd *) + +Definition Even n := exists m, n == 2*m. +Definition Odd n := exists m, n == 2*m+1. + +Lemma even_spec n : even n = true <-> Even n. +Proof. + unfold Even. zify. rewrite Z.even_spec. + split; intros (m,Hm). + - exists (of_Z m). now zify. + - exists [m]. revert Hm. now zify. +Qed. + +Lemma odd_spec n : odd n = true <-> Odd n. +Proof. + unfold Odd. zify. rewrite Z.odd_spec. + split; intros (m,Hm). + - exists (of_Z m). now zify. + - exists [m]. revert Hm. now zify. +Qed. + +(** Div / Mod *) + Program Instance div_wd : Proper (eq==>eq==>eq) div. Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. @@ -252,8 +379,149 @@ Proof. intros a b. zify. intros. apply Z_mod_neg; auto with zarith. Qed. +Definition mod_bound_pos : + forall a b, 0<=a -> 0<b -> 0 <= modulo a b /\ modulo a b < b := + fun a b _ H => mod_pos_bound a b H. + +(** Quot / Rem *) + +Program Instance quot_wd : Proper (eq==>eq==>eq) quot. +Program Instance rem_wd : Proper (eq==>eq==>eq) rem. + +Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b. +Proof. +intros a b. zify. apply Z.quot_rem. +Qed. + +Theorem rem_bound_pos : + forall a b, 0<=a -> 0<b -> 0 <= rem a b /\ rem a b < b. +Proof. +intros a b. zify. apply Z.rem_bound_pos. +Qed. + +Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b). +Proof. +intros a b. zify. apply Z.rem_opp_l. +Qed. + +Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b. +Proof. +intros a b. zify. apply Z.rem_opp_r. +Qed. + +(** Gcd *) + +Definition divide n m := exists p, m == p*n. +Local Notation "( x | y )" := (divide x y) (at level 0). + +Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. +Proof. + intros n m. split. + - intros (p,H). exists [p]. revert H; now zify. + - intros (z,H). exists (of_Z z). now zify. +Qed. + +Lemma gcd_divide_l : forall n m, (gcd n m | n). +Proof. + intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. +Qed. + +Lemma gcd_divide_r : forall n m, (gcd n m | m). +Proof. + intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. +Qed. + +Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). +Proof. + intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. +Qed. + +Lemma gcd_nonneg : forall n m, 0 <= gcd n m. +Proof. + intros. zify. apply Z.gcd_nonneg. +Qed. + +(** Bitwise operations *) + +Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. + +Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. +Proof. + intros. zify. apply Z.testbit_odd_0. +Qed. + +Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. +Proof. + intros. zify. apply Z.testbit_even_0. +Qed. + +Lemma testbit_odd_succ : forall a n, 0<=n -> + testbit (2*a+1) (succ n) = testbit a n. +Proof. + intros a n. zify. apply Z.testbit_odd_succ. +Qed. + +Lemma testbit_even_succ : forall a n, 0<=n -> + testbit (2*a) (succ n) = testbit a n. +Proof. + intros a n. zify. apply Z.testbit_even_succ. +Qed. + +Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. +Proof. + intros a n. zify. apply Z.testbit_neg_r. +Qed. + +Lemma shiftr_spec : forall a n m, 0<=m -> + testbit (shiftr a n) m = testbit a (m+n). +Proof. + intros a n m. zify. apply Z.shiftr_spec. +Qed. + +Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> + testbit (shiftl a n) m = testbit a (m-n). +Proof. + intros a n m. zify. intros Hn H. + now apply Z.shiftl_spec_high. +Qed. + +Lemma shiftl_spec_low : forall a n m, m<n -> + testbit (shiftl a n) m = false. +Proof. + intros a n m. zify. intros H. now apply Z.shiftl_spec_low. +Qed. + +Lemma land_spec : forall a b n, + testbit (land a b) n = testbit a n && testbit b n. +Proof. + intros a n m. zify. now apply Z.land_spec. +Qed. + +Lemma lor_spec : forall a b n, + testbit (lor a b) n = testbit a n || testbit b n. +Proof. + intros a n m. zify. now apply Z.lor_spec. +Qed. + +Lemma ldiff_spec : forall a b n, + testbit (ldiff a b) n = testbit a n && negb (testbit b n). +Proof. + intros a n m. zify. now apply Z.ldiff_spec. +Qed. + +Lemma lxor_spec : forall a b n, + testbit (lxor a b) n = xorb (testbit a n) (testbit b n). +Proof. + intros a n m. zify. now apply Z.lxor_spec. +Qed. + +Lemma div2_spec : forall a, div2 a == shiftr a 1. +Proof. + intros a. zify. now apply Z.div2_spec. +Qed. + End ZTypeIsZAxioms. -Module ZType_ZAxioms (Z : ZType) - <: ZAxiomsSig <: ZDivSig <: HasCompare Z <: HasEqBool Z <: HasMinMax Z - := Z <+ ZTypeIsZAxioms. +Module ZType_ZAxioms (ZZ : ZType) + <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ + := ZZ <+ ZTypeIsZAxioms. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 1d9a65dc..c1b7bafa 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *) (************************************************************************) -(*i $Id: NaryFunctions.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Local Open Scope type_scope. Require Import List. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 782619f0..8bed3027 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,16 +8,15 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms NZBase. -Module Type NZAddPropSig - (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ). +Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). Hint Rewrite pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz. +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. @@ -31,6 +30,11 @@ 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. + Hint Rewrite add_0_r add_succ_r : nz. Theorem add_comm : forall n m, n + m == m + n. @@ -41,14 +45,16 @@ Qed. Theorem add_1_l : forall n, 1 + n == S n. Proof. -intro n; now nzsimpl. +intro n; now nzsimpl'. Qed. Theorem add_1_r : forall n, n + 1 == S n. Proof. -intro n; now nzsimpl. +intro n; now nzsimpl'. Qed. +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. @@ -78,13 +84,19 @@ Qed. Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p). Proof. -intros n m p q. -rewrite 2 add_assoc, add_shuffle0, add_cancel_r. apply add_shuffle0. +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. +intro n; now nzsimpl'. Qed. -End NZAddPropSig. +Hint Rewrite sub_1_r : nz. + +End NZAddProp. diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index ed56cd8f..ee03e5f9 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms NZBase NZMul NZOrder. -Module Type NZAddOrderPropSig (Import NZ : NZOrdAxiomsSig'). -Include NZBasePropSig NZ <+ NZMulPropSig NZ <+ NZOrderPropSig NZ. +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. @@ -30,7 +28,7 @@ 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]. +[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. @@ -48,21 +46,21 @@ 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]. +[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]. +[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]. +[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. @@ -149,5 +147,22 @@ Proof. intros n m H; apply add_le_cases; now nzsimpl. Qed. -End NZAddOrderPropSig. +(** Substraction *) + +(** 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. + +(** For the moment, it doesn't seem possible to relate + this existing subtraction with [sub]. +*) + +End NZAddOrderProp. diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v index 33236cde..fcd98787 100644 --- a/theories/Numbers/NatInt/NZAxioms.v +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (** Initial Author : Evgeny Makarov, INRIA, 2007 *) -(*i $Id: NZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Equalities Orders NumPrelude GenericMinMax. (** Axiomatization of a domain with zero, successor, predecessor, @@ -20,7 +18,7 @@ Require Export Equalities Orders NumPrelude GenericMinMax. *) Module Type ZeroSuccPred (Import T:Typ). - Parameter Inline zero : t. + Parameter Inline(20) zero : t. Parameters Inline succ pred : t -> t. End ZeroSuccPred. @@ -28,8 +26,6 @@ Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T). Notation "0" := zero. Notation S := succ. Notation P := pred. - Notation "1" := (S 0). - Notation "2" := (S 1). End ZeroSuccPredNotation. Module Type ZeroSuccPred' (T:Typ) := @@ -44,9 +40,33 @@ Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E). A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n. End IsNZDomain. -Module Type NZDomainSig := EqualityType <+ ZeroSuccPred <+ IsNZDomain. -Module Type NZDomainSig' := EqualityType' <+ ZeroSuccPred' <+ IsNZDomain. +(** Axiomatization of some more constants + + Simply denoting "1" for (S 0) and so on works ok when implementing + by nat, but leaves some (Nsucc N0) when implementing by N. +*) + +Module Type OneTwo (Import T:Typ). + Parameter Inline(20) one two : t. +End OneTwo. +Module Type OneTwoNotation (T:Typ)(Import NZ:OneTwo T). + Notation "1" := one. + Notation "2" := two. +End OneTwoNotation. + +Module Type OneTwo' (T:Typ) := OneTwo T <+ OneTwoNotation T. + +Module Type IsOneTwo (E:Eq')(Z:ZeroSuccPred' E)(O:OneTwo' E). + Import E Z O. + Axiom one_succ : 1 == S 0. + Axiom two_succ : 2 == S 1. +End IsOneTwo. + +Module Type NZDomainSig := + EqualityType <+ ZeroSuccPred <+ IsNZDomain <+ OneTwo <+ IsOneTwo. +Module Type NZDomainSig' := + EqualityType' <+ ZeroSuccPred' <+ IsNZDomain <+ OneTwo' <+ IsOneTwo. (** Axiomatization of basic operations : [+] [-] [*] *) @@ -117,3 +137,9 @@ Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare. Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare. Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare. +(** A square function *) + +Module Type NZSquare (Import NZ : NZBasicFunsSig'). + Parameter Inline square : t -> t. + Axiom square_spec : forall n, square n == n * n. +End NZSquare. diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 119f8265..65b64635 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,11 +8,14 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms. -Module Type NZBasePropSig (Import NZ : NZDomainSig'). +Module Type NZBaseProp (Import NZ : NZDomainSig'). + +(** An artificial scope meant to be substituted later *) + +Delimit Scope abstract_scope with abstract. +Bind Scope abstract_scope with t. Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *) @@ -50,7 +53,7 @@ Theorem succ_inj_wd : forall n1 n2, S n1 == S n2 <-> n1 == n2. Proof. intros; split. apply succ_inj. -apply succ_wd. +intros. now f_equiv. Qed. Theorem succ_inj_wd_neg : forall n m, S n ~= S m <-> n ~= m. @@ -63,7 +66,7 @@ left-inverse to the successor at this point *) Section CentralInduction. -Variable A : predicate t. +Variable A : t -> Prop. Hypothesis A_wd : Proper (eq==>iff) A. Theorem central_induction : @@ -72,7 +75,7 @@ Theorem central_induction : forall n, A n. Proof. intros z Base Step; revert Base; pattern z; apply bi_induction. -solve_predicate_wd. +solve_proper. intro; now apply bi_induction. intro; pose proof (Step n); tauto. Qed. @@ -85,5 +88,5 @@ Tactic Notation "nzinduct" ident(n) := Tactic Notation "nzinduct" ident(n) constr(u) := induction_maker n ltac:(apply central_induction with (z := u)). -End NZBasePropSig. +End NZBaseProp. diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v new file mode 100644 index 00000000..dc97eeb1 --- /dev/null +++ b/theories/Numbers/NatInt/NZBits.v @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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. +End Bits. + +Module Type BitsNotation (Import A : Typ)(Import B : Bits A). + Notation "a .[ n ]" := (testbit a n) (at level 5, 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). + + 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<n -> (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. + +End NZBitsSpec. + +Module Type NZBits (A:NZOrdAxiomsSig) := Bits A <+ NZBitsSpec A. +Module Type NZBits' (A:NZOrdAxiomsSig) := Bits' A <+ NZBitsSpec A. + +(** In the functor of properties will also be defined: + - [setbit : t -> t -> t ] defined as [lor a (1<<n)]. + - [clearbit : t -> t -> t ] defined as [ldiff a (1<<n)]. + - [ones : t -> t], the number with [n] initial true bits, + corresponding to [2^n - 1]. + - a logical complement [lnot]. For integer numbers it will + be a [t->t], doing a swap of all bits, while on natural + numbers, it will be a bounded complement [t->t->t], swapping + only the first [n] bits. +*) + +(** For the moment, no shared properties about NZ here, + since properties and proofs for N and Z are quite different *) diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index ba1c171e..bc109ace 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,44 +12,36 @@ Require Import NZAxioms NZMulOrder. (** The first signatures will be common to all divisions over NZ, N and Z *) -Module Type DivMod (Import T:Typ). +Module Type DivMod (Import A : Typ). Parameters Inline div modulo : t -> t -> t. End DivMod. -Module Type DivModNotation (T:Typ)(Import NZ:DivMod T). +Module Type DivModNotation (A : Typ)(Import B : DivMod A). Infix "/" := div. Infix "mod" := modulo (at level 40, no associativity). End DivModNotation. -Module Type DivMod' (T:Typ) := DivMod T <+ DivModNotation T. +Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A. -Module Type NZDivCommon (Import NZ : NZAxiomsSig')(Import DM : DivMod' NZ). +Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A). Declare Instance div_wd : Proper (eq==>eq==>eq) div. Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo. Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b). -End NZDivCommon. + Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. +End NZDivSpec. (** The different divisions will only differ in the conditions - they impose on [modulo]. For NZ, we only describe behavior - on positive numbers. - - NB: This axiom would also be true for N and Z, but redundant. + they impose on [modulo]. For NZ, we have only described the + behavior on positive numbers. *) -Module Type NZDivSpecific (Import NZ : NZOrdAxiomsSig')(Import DM : DivMod' NZ). - Axiom mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. -End NZDivSpecific. - -Module Type NZDiv (NZ:NZOrdAxiomsSig) - := DivMod NZ <+ NZDivCommon NZ <+ NZDivSpecific NZ. +Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A. +Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A. -Module Type NZDiv' (NZ:NZOrdAxiomsSig) := NZDiv NZ <+ DivModNotation NZ. - -Module NZDivPropFunct - (Import NZ : NZOrdAxiomsSig') - (Import NZP : NZMulOrderPropSig NZ) - (Import NZD : NZDiv' NZ) -. +Module Type NZDivProp + (Import A : NZOrdAxiomsSig') + (Import B : NZDiv' A) + (Import C : NZMulOrderProp A). (** Uniqueness theorems *) @@ -84,7 +76,7 @@ Theorem div_unique: 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; order. +apply mod_bound_pos; order. rewrite <- div_mod; order. Qed. @@ -94,18 +86,21 @@ Theorem mod_unique: 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; order. +apply mod_bound_pos; order. rewrite <- div_mod; order. Qed. +Theorem div_unique_exact a b q: + 0<=a -> 0<b -> 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/a == 1. Proof. -intros. symmetry. -apply div_unique with 0; intuition; try order. -now nzsimpl. +intros. symmetry. apply div_unique_exact; nzsimpl; order. Qed. Lemma mod_same : forall a, 0<a -> a mod a == 0. @@ -147,9 +142,7 @@ Qed. Lemma div_1_r: forall a, 0<=a -> a/1 == a. Proof. -intros. symmetry. -apply div_unique with 0; try split; try order; try apply lt_0_1. -now nzsimpl. +intros. symmetry. apply div_unique_exact; nzsimpl; order'. Qed. Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. @@ -161,20 +154,19 @@ Qed. Lemma div_1_l: forall a, 1<a -> 1/a == 0. Proof. -intros; apply div_small; split; auto. apply le_succ_diag_r. +intros; apply div_small; split; auto. apply le_0_1. Qed. Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1. Proof. -intros; apply mod_small; split; auto. apply le_succ_diag_r. +intros; apply mod_small; split; auto. apply le_0_1. Qed. Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a. Proof. -intros; symmetry. -apply div_unique with 0; try split; try order. +intros; symmetry. apply div_unique_exact; trivial. apply mul_nonneg_nonneg; order. -nzsimpl; apply mul_comm. +apply mul_comm. Qed. Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0. @@ -194,7 +186,7 @@ Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. Proof. intros. destruct (le_gt_cases b a). apply le_trans with b; auto. -apply lt_le_incl. destruct (mod_bound a b); auto. +apply lt_le_incl. destruct (mod_bound_pos a b); auto. rewrite lt_eq_cases; right. apply mod_small; auto. Qed. @@ -216,7 +208,7 @@ Lemma div_str_pos : forall a b, 0<b<=a -> 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 a b); 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. @@ -263,7 +255,7 @@ 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 a b); order. +rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. Qed. (** [le] is compatible with a positive division. *) @@ -282,8 +274,8 @@ 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 b c); order. -rewrite <- add_le_mono_l. destruct (mod_bound a c); order. +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 *) @@ -293,7 +285,7 @@ Proof. intros. 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 a b); order. +rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. Qed. Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)). @@ -302,7 +294,7 @@ intros. rewrite (div_mod a b) at 1 by order. rewrite (mul_succ_r). rewrite <- add_lt_mono_l. -destruct (mod_bound a b); auto. +destruct (mod_bound_pos a b); auto. Qed. @@ -359,7 +351,7 @@ Proof. 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 p r); order. + rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order. Qed. @@ -371,7 +363,7 @@ Proof. intros. symmetry. apply mod_unique with (a/c+b); auto. - apply mod_bound; auto. + apply mod_bound_pos; auto. rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order. now rewrite mul_comm. Qed. @@ -404,8 +396,8 @@ Proof. apply div_unique with ((a mod b)*c). apply mul_nonneg_nonneg; order. split. - apply mul_nonneg_nonneg; destruct (mod_bound a b); order. - rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound a b); auto. + 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. @@ -441,7 +433,7 @@ Qed. Theorem mod_mod: forall a n, 0<=a -> 0<n -> (a mod n) mod n == a mod n. Proof. - intros. destruct (mod_bound a n); auto. now rewrite mod_small_iff. + intros. 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<n -> @@ -454,7 +446,7 @@ Proof. rewrite mul_add_distr_l, mul_assoc. intros. rewrite mod_add; auto. now rewrite mul_comm. - apply mul_nonneg_nonneg; destruct (mod_bound a n); auto. + 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<n -> @@ -467,7 +459,7 @@ Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a * b) mod n == ((a mod n) * (b mod n)) mod n. Proof. intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound b n). + now destruct (mod_bound_pos b n). Qed. Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -478,7 +470,7 @@ Proof. 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 a n); auto. + 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<n -> @@ -491,7 +483,7 @@ Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a+b) mod n == (a mod n + b mod n) mod n. Proof. intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity. - now destruct (mod_bound b n). + now destruct (mod_bound_pos b n). Qed. Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c -> @@ -500,7 +492,7 @@ Proof. intros a b c Ha Hb Hc. apply div_unique with (b*((a/b) mod c) + a mod b); trivial. (* begin 0<= ... <b*c *) - destruct (mod_bound (a/b) c), (mod_bound a b); auto using div_pos. + destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos. split. apply add_nonneg_nonneg; auto. apply mul_nonneg_nonneg; order. @@ -514,6 +506,18 @@ Proof. apply div_mod; order. Qed. +Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c -> + 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. + (** A last inequality: *) Theorem div_mul_le: @@ -538,5 +542,5 @@ Proof. rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. Qed. -End NZDivPropFunct. +End NZDivProp. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index 9dba3c3c..36aaa3e7 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NZDomain.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NumPrelude NZAxioms. Require Import NZBase NZOrder NZAddOrder Plus Minus. @@ -16,97 +14,36 @@ Require Import NZBase NZOrder NZAddOrder Plus Minus. translation from Peano numbers [nat] into NZ. *) -(** First, a section about iterating a function. *) - -Section Iter. -Variable A : Type. -Fixpoint iter (f:A->A)(n:nat) : A -> A := fun a => - match n with - | O => a - | S n => f (iter f n a) - end. -Infix "^" := iter. - -Lemma iter_alt : forall f n m, (f^(Datatypes.S n)) m = (f^n) (f m). -Proof. -induction n; simpl; auto. -intros; rewrite <- IHn; auto. -Qed. - -Lemma iter_plus : forall f n n' m, (f^(n+n')) m = (f^n) ((f^n') m). -Proof. -induction n; simpl; auto. -intros; rewrite IHn; auto. -Qed. +(** First, some complements about [nat_iter] *) -Lemma iter_plus_bis : forall f n n' m, (f^(n+n')) m = (f^n') ((f^n) m). -Proof. -induction n; simpl; auto. -intros. rewrite <- iter_alt, IHn; auto. -Qed. +Local Notation "f ^ n" := (nat_iter n f). -Global Instance iter_wd (R:relation A) : Proper ((R==>R)==>eq==>R==>R) iter. +Instance nat_iter_wd n {A} (R:relation A) : + Proper ((R==>R)==>R==>R) (nat_iter n). Proof. -intros f f' Hf n n' Hn; subst n'. induction n; simpl; red; auto. +intros f f' Hf. induction n; simpl; red; auto. Qed. -End Iter. -Implicit Arguments iter [A]. -Local Infix "^" := iter. - - Module NZDomainProp (Import NZ:NZDomainSig'). +Include NZBaseProp NZ. (** * Relationship between points thanks to [succ] and [pred]. *) -(** We prove that any points in NZ have a common descendant by [succ] *) - -Definition common_descendant n m := exists k, exists l, (S^k) n == (S^l) m. - -Instance common_descendant_wd : Proper (eq==>eq==>iff) common_descendant. -Proof. -unfold common_descendant. intros n n' Hn m m' Hm. -setoid_rewrite Hn. setoid_rewrite Hm. auto with *. -Qed. - -Instance common_descendant_equiv : Equivalence common_descendant. -Proof. -split; red. -intros x. exists O; exists O. simpl; auto with *. -intros x y (p & q & H); exists q; exists p; auto with *. -intros x y z (p & q & Hpq) (r & s & Hrs). -exists (r+p)%nat. exists (q+s)%nat. -rewrite !iter_plus. rewrite Hpq, <-Hrs, <-iter_plus, <- iter_plus_bis. -auto with *. -Qed. - -Lemma common_descendant_with_0 : forall n, common_descendant n 0. -Proof. -apply bi_induction. -intros n n' Hn. rewrite Hn; auto with *. -reflexivity. -split; intros (p & q & H). -exists p; exists (Datatypes.S q). rewrite <- iter_alt; simpl. - apply succ_wd; auto. -exists (Datatypes.S p); exists q. rewrite iter_alt; auto. -Qed. - -Lemma common_descendant_always : forall n m, common_descendant n m. -Proof. -intros. transitivity 0; [|symmetry]; apply common_descendant_with_0. -Qed. - -(** Thanks to [succ] being injective, we can then deduce that for any two - points, one is an iterated successor of the other. *) +(** For any two points, one is an iterated successor of the other. *) -Lemma itersucc_or_itersucc : forall n m, exists k, n == (S^k) m \/ m == (S^k) n. +Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n. Proof. -intros n m. destruct (common_descendant_always n m) as (k & l & H). -revert l H. induction k. -simpl. intros; exists l; left; auto with *. -intros. destruct l. -simpl in *. exists (Datatypes.S k); right; auto with *. -simpl in *. apply pred_wd in H; rewrite !pred_succ in H. eauto. +nzinduct n m. +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_iter_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_iter_succ_r. Qed. (** Generalized version of [pred_succ] when iterating *) @@ -116,7 +53,7 @@ Proof. induction k. simpl; auto with *. simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto. -rewrite <- iter_alt in H; auto. +rewrite <- nat_iter_succ_r in H; auto. Qed. (** From a given point, all others are iterated successors @@ -307,7 +244,7 @@ End NZOfNat. Module NZOfNatOrd (Import NZ:NZOrdSig'). Include NZOfNat NZ. -Include NZOrderPropFunct NZ. +Include NZBaseProp NZ <+ NZOrderProp NZ. Local Open Scope ofnat. Theorem ofnat_S_gt_0 : @@ -315,8 +252,8 @@ Theorem ofnat_S_gt_0 : Proof. unfold ofnat. intros n; induction n as [| n IH]; simpl in *. -apply lt_0_1. -apply lt_trans with 1. apply lt_0_1. now rewrite <- succ_lt_mono. +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 : @@ -375,14 +312,14 @@ 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; apply succ_wd; auto. + 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. - rewrite ofnat_succ. now apply succ_wd. + rewrite ofnat_succ. now f_equiv. Qed. Lemma ofnat_mul : forall n m, [n*m] == [n]*[m]. @@ -391,14 +328,14 @@ Proof. symmetry. apply mul_0_l. rewrite plus_comm. rewrite ofnat_succ, ofnat_add, mul_succ_l. - now apply add_wd. + now f_equiv. Qed. Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n. Proof. induction m; simpl; intros. rewrite ofnat_zero. apply sub_0_r. - rewrite ofnat_succ, sub_succ_r. now apply pred_wd. + rewrite ofnat_succ, sub_succ_r. now f_equiv. Qed. Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m]. @@ -409,7 +346,7 @@ Proof. intros. destruct n. inversion H. - rewrite iter_alt. + rewrite nat_iter_succ_r. simpl. rewrite ofnat_succ, pred_succ; auto with arith. Qed. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v new file mode 100644 index 00000000..f72023d9 --- /dev/null +++ b/theories/Numbers/NatInt/NZGcd.v @@ -0,0 +1,307 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Greatest Common Divisor *) + +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. +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. +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). +End DivideNotation. + +Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A. +Module Type NZGcd' (A : NZOrdAxiomsSig) := + Gcd A <+ NZGcdSpec A <+ DivideNotation A. + +(** Derived properties of gcd *) + +Module NZGcdProp + (Import A : NZOrdAxiomsSig') + (Import B : NZGcd' A) + (Import C : NZMulOrderProp A). + +(** Results concerning divisibility*) + +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. + +Hint Rewrite divide_1_l divide_0_r : nz. + +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. + +Instance divide_reflexive : Reflexive divide := divide_refl. +Instance divide_transitive : Transitive divide := 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. 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. + +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. 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. + 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. 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. 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 new file mode 100644 index 00000000..a5aa6d8a --- /dev/null +++ b/theories/Numbers/NatInt/NZLog.v @@ -0,0 +1,889 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Base-2 Logarithm *) + +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. +End Log2. + +Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A). + Import A B C. + Axiom log2_spec : forall a, 0<a -> 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. + +(** 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. *) + +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<a -> 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<a -> 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<n *) + +Lemma log2_pos : forall a, 1<a -> 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<a -> (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 -> (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<a -> 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<a -> 0<b -> + 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<a -> 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<a -> 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<a -> 0<b -> 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. + 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<a -> + (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<a -> 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] : + ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. + 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<a -> 0<b -> + 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<a -> 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<a -> + 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. + +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<b -> 2^(P b)<a<=2^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<a -> + 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<a -> (log2 a == log2_up a <-> exists b, a == 2^b). +Proof. + intros a Ha. + split. intros. 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<n *) + +Lemma log2_up_pos : forall a, 1<a -> 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<a -> (2^b<a <-> 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 -> (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<a -> 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<a -> 0<b -> + 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<a -> 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<a -> 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<a -> 0<b -> 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. + destruct (le_gt_cases (log2_up (S a)) (log2_up a)). + 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<a -> + (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<a -> + 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] : + ideally, we would have [2*log(a+b) >= log(2a)+log(2b) = 2+log a+log b]. + 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<a -> 0<b -> + 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 b1adcea9..2b5a1cf3 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,13 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms NZBase NZAdd. -Module Type NZMulPropSig - (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ). -Include NZAddPropSig NZ NZBase. +Module Type NZMulProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ). +Include NZAddProp NZ NZBase. Theorem mul_0_r : forall n, n * 0 == 0. Proof. @@ -59,12 +56,34 @@ Qed. Theorem mul_1_l : forall n, 1 * n == n. Proof. -intro n. now nzsimpl. +intro n. now nzsimpl'. Qed. Theorem mul_1_r : forall n, n * 1 == n. Proof. -intro n. now nzsimpl. +intro n. now nzsimpl'. +Qed. + +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 NZMulPropSig. +End NZMulProp. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 09e468ff..97306f93 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,13 +8,11 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms. Require Import NZAddOrder. -Module Type NZMulOrderPropSig (Import NZ : NZOrdAxiomsSig'). -Include NZAddOrderPropSig NZ. +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). @@ -26,17 +24,16 @@ Qed. Theorem mul_lt_mono_pos_l : forall p n m, 0 < p -> (n < m <-> p * n < p * m). Proof. -nzord_induct p. -intros n m H; false_hyp H lt_irrefl. -intros p H IH n m H1. nzsimpl. -le_elim H. assert (LR : forall n m, n < m -> p * n + n < p * m + m). -intros n1 m1 H2. apply add_lt_mono; [now apply -> IH | assumption]. -split; [apply LR |]. intro H2. apply -> lt_dne; intro H3. -apply <- le_ngt in H3. le_elim H3. -apply lt_asymm in H2. apply H2. now apply LR. -rewrite H3 in H2; false_hyp H2 lt_irrefl. -rewrite <- H; now nzsimpl. -intros p H1 _ n m H2. destruct (lt_asymm _ _ H1 H2). +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). @@ -48,19 +45,19 @@ Qed. Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). Proof. nzord_induct p. -intros n m H; false_hyp H lt_irrefl. -intros p H1 _ n m H2. apply lt_succ_l in H2. apply <- nle_gt in H2. -false_hyp H1 H2. -intros p H IH n m H1. apply <- le_succ_l in H. -le_elim H. assert (LR : forall n m, n < m -> p * m < p * n). -intros n1 m1 H2. apply (le_lt_add_lt n1 m1). -now apply lt_le_incl. rewrite <- 2 mul_succ_l. now apply -> IH. -split; [apply LR |]. intro H2. apply -> lt_dne; intro H3. -apply <- le_ngt in H3. le_elim H3. -apply lt_asymm in H2. apply H2. now apply LR. -rewrite H3 in H2; false_hyp H2 lt_irrefl. -rewrite (mul_lt_pred p (S p)) by reflexivity. -rewrite H; do 2 rewrite mul_0_l; now do 2 rewrite add_0_l. +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). @@ -72,7 +69,7 @@ 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. +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. @@ -80,7 +77,7 @@ 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. +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. @@ -99,20 +96,13 @@ Qed. Theorem mul_cancel_l : forall n m p, p ~= 0 -> (p * n == p * m <-> n == m). Proof. -intros n m p H; split; intro H1. -destruct (lt_trichotomy p 0) as [H2 | [H2 | H2]]. -apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3]. -assert (H4 : p * m < p * n); [now apply -> mul_lt_mono_neg_l |]. -rewrite H1 in H4; false_hyp H4 lt_irrefl. -assert (H4 : p * n < p * m); [now apply -> mul_lt_mono_neg_l |]. -rewrite H1 in H4; false_hyp H4 lt_irrefl. -false_hyp H2 H. -apply -> eq_dne; intro H3. apply -> lt_gt_cases in H3. destruct H3 as [H3 | H3]. -assert (H4 : p * n < p * m) by (now apply -> mul_lt_mono_pos_l). -rewrite H1 in H4; false_hyp H4 lt_irrefl. -assert (H4 : p * m < p * n) by (now apply -> mul_lt_mono_pos_l). -rewrite H1 in H4; false_hyp H4 lt_irrefl. -now rewrite H1. +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). @@ -183,17 +173,17 @@ 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. +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. +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. +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. @@ -206,9 +196,33 @@ Proof. intros. 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. +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. @@ -229,7 +243,7 @@ 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. +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. @@ -241,16 +255,22 @@ 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]. +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]. +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: *) + +Definition mul_eq_0 := eq_mul_0. +Definition mul_eq_0_l := eq_mul_0_l. +Definition mul_eq_0_r := eq_mul_0_r. + Theorem lt_0_mul : forall n m, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). Proof. intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. @@ -283,25 +303,100 @@ 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). -assumption. assert (F : m * m <= n * n) by now apply square_le_mono_nonneg. -apply -> le_ngt in F. false_hyp H2 F. +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). -assumption. assert (F : m * m < n * n) by now apply square_lt_mono_nonneg. -apply -> lt_nge in F. false_hyp H2 F. +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<a -> 1<b -> a+b <= a*b. +Proof. + assert (AUX : forall a b, 0<a -> 0<b -> (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. + intros. 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. -Theorem mul_2_mono_l : forall n m, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. +Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> + 2*2*a*b <= (a+b)*(a+b). Proof. -intros n m. rewrite <- le_succ_l, (mul_le_mono_pos_l (S n) m (1 + 1)). -rewrite !mul_add_distr_r; nzsimpl; now rewrite le_succ_l. -apply add_pos_pos; now apply lt_0_1. + intros. + 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 NZMulOrderPropSig. +End NZMulOrderProp. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 07805772..8cf5b26f 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,28 +8,26 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NZAxioms NZBase Decidable OrdersTac. -Module Type NZOrderPropSig - (Import NZ : NZOrdSig')(Import NZBase : NZBasePropSig NZ). +Module Type NZOrderProp + (Import NZ : NZOrdSig')(Import NZBase : NZBaseProp NZ). Instance le_wd : Proper (eq==>eq==>iff) le. Proof. -intros n n' Hn m m' Hm. rewrite !lt_eq_cases, !Hn, !Hm; auto with *. +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. +intros. apply lt_eq_cases. now left. Qed. Theorem le_refl : forall n, n <= n. Proof. -intro; apply <- lt_eq_cases; now right. +intro. apply lt_eq_cases. now right. Qed. Theorem lt_succ_diag_r : forall n, n < S n. @@ -99,7 +97,7 @@ 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. +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. @@ -148,7 +146,8 @@ Definition lt_compat := lt_wd. Definition lt_total := lt_trichotomy. Definition le_lteq := lt_eq_cases. -Module OrderElts <: TotalOrder. +Module Private_OrderTac. +Module Elts <: TotalOrder. Definition t := t. Definition eq := eq. Definition lt := lt. @@ -158,9 +157,10 @@ Module OrderElts <: TotalOrder. Definition lt_compat := lt_compat. Definition lt_total := lt_total. Definition le_lteq := le_lteq. -End OrderElts. -Module OrderTac := !MakeOrderTac OrderElts. -Ltac order := OrderTac.order. +End Elts. +Module Tac := !MakeOrderTac Elts. +End Private_OrderTac. +Ltac order := Private_OrderTac.Tac.order. (** Some direct consequences of [order]. *) @@ -208,12 +208,12 @@ Qed. Theorem lt_succ_l : forall n m, S n < m -> n < m. Proof. -intros n m H; apply -> le_succ_l; order. +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. rewrite <- lt_succ_r in LE. order. +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. @@ -233,19 +233,37 @@ Qed. Theorem lt_0_1 : 0 < 1. Proof. -apply lt_succ_diag_r. +rewrite one_succ. apply lt_succ_diag_r. Qed. Theorem le_0_1 : 0 <= 1. Proof. -apply le_succ_diag_r. +apply lt_le_incl, lt_0_1. Qed. -Theorem lt_1_l : forall n m, 0 < n -> n < m -> 1 < m. +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 le_0_2 : 0 <= 2. Proof. -intros n m H1 H2. apply <- le_succ_l in H1. order. +apply lt_le_incl, lt_0_2. Qed. +(** The order tactic enriched with some knowledge of 0,1,2 *) + +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. (** More Trichotomy, decidability and double negation elimination. *) @@ -347,7 +365,7 @@ Proof. intro z; nzinduct n z. order. intro n; split; intros IH m H1 H2. -apply -> le_succ_r in H2. destruct H2 as [H2 | H2]. +apply le_succ_r in H2. destruct H2 as [H2 | H2]. now apply IH. exists n. now split; [| rewrite <- lt_succ_r; rewrite <- H2]. apply IH. assumption. now apply le_le_succ_r. Qed. @@ -359,6 +377,13 @@ intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). assumption. apply le_refl. 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. + (** Stronger variant of induction with assumptions n >= 0 (n < 0) in the induction step *) @@ -390,14 +415,14 @@ Qed. Lemma rs'_rs'' : right_step' -> right_step''. Proof. intros RS' n; split; intros H1 m H2 H3. -apply -> lt_succ_r in H3; le_elim H3; +apply lt_succ_r in H3; le_elim H3; [now apply H1 | rewrite H3 in *; now apply RS']. apply H1; [assumption | now apply lt_lt_succ_r]. Qed. Lemma rbase : A' z. Proof. -intros m H1 H2. apply -> le_ngt in H1. false_hyp H2 H1. +intros m H1 H2. apply le_ngt in H1. false_hyp H2 H1. Qed. Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n. @@ -449,28 +474,28 @@ Let left_step'' := forall n, A' n <-> A' (S n). Lemma ls_ls' : A z -> left_step -> left_step'. Proof. intros Az LS n H1 H2. le_elim H1. -apply LS; trivial. apply H2; [now apply <- le_succ_l | now apply eq_le_incl]. +apply LS; trivial. apply H2; [now apply le_succ_l | now apply eq_le_incl]. rewrite H1; apply Az. Qed. Lemma ls'_ls'' : left_step' -> left_step''. Proof. intros LS' n; split; intros H1 m H2 H3. -apply -> le_succ_l in H3. apply lt_le_incl in H3. now apply H1. +apply le_succ_l in H3. apply lt_le_incl in H3. now apply H1. le_elim H3. -apply <- le_succ_l in H3. now apply H1. +apply le_succ_l in H3. now apply H1. rewrite <- H3 in *; now apply LS'. Qed. Lemma lbase : A' (S z). Proof. -intros m H1 H2. apply -> le_succ_l in H2. -apply -> le_ngt in H1. false_hyp H2 H1. +intros m H1 H2. apply le_succ_l in H2. +apply le_ngt in H1. false_hyp H2 H1. Qed. Lemma A'A_left : (forall n, A' n) -> forall n, n <= z -> A n. Proof. -intros H1 n H2. apply H1 with (n := n); [assumption | now apply eq_le_incl]. +intros H1 n H2. apply (H1 n); [assumption | now apply eq_le_incl]. Qed. Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. @@ -527,8 +552,8 @@ Theorem order_induction' : 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]. -apply -> (A_wd (P (S m)) m); [assumption | apply pred_succ]. +intros m H1 H2. apply AP in H2; [|now apply le_succ_l]. +now rewrite pred_succ in H2. Qed. End Center. @@ -555,11 +580,11 @@ Theorem lt_ind : forall (n : t), 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. +apply right_induction with (S n); [assumption | | now apply le_succ_l]. +intros; apply H2; try assumption. now apply le_succ_l. Qed. -(** Elimintation principle for <= *) +(** Elimination principle for <= *) Theorem le_ind : forall (n : t), A n -> @@ -582,8 +607,8 @@ Section WF. Variable z : t. -Let Rlt (n m : t) := z <= n /\ n < m. -Let Rgt (n m : t) := m < n /\ n <= z. +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. @@ -595,25 +620,13 @@ Proof. intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2. Qed. -Instance Acc_lt_wd : Proper (eq==>iff) (Acc Rlt). -Proof. -intros x1 x2 H; split; intro H1; destruct H1 as [H2]; -constructor; intros; apply H2; now (rewrite H || rewrite <- H). -Qed. - -Instance Acc_gt_wd : Proper (eq==>iff) (Acc Rgt). -Proof. -intros x1 x2 H; split; intro H1; destruct H1 as [H2]; -constructor; intros; apply H2; now (rewrite H || rewrite <- H). -Qed. - Theorem lt_wf : well_founded Rlt. Proof. unfold well_founded. apply strong_right_induction' with (z := z). -apply Acc_lt_wd. +auto with typeclass_instances. intros n H; constructor; intros y [H1 H2]. -apply <- nle_gt in H2. elim H2. now apply le_trans with z. +apply nle_gt in H2. elim H2. now apply le_trans with z. intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. Qed. @@ -621,24 +634,20 @@ Theorem gt_wf : well_founded Rgt. Proof. unfold well_founded. apply strong_left_induction' with (z := z). -apply Acc_gt_wd. +auto with typeclass_instances. intros n H; constructor; intros y [H1 H2]. -apply <- nle_gt in H2. elim H2. now apply le_lt_trans with n. +apply nle_gt in H2. elim H2. now apply le_lt_trans with n. intros n H1 H2; constructor; intros m [H3 H4]. -apply H2. assumption. now apply <- le_succ_l. +apply H2. assumption. now apply le_succ_l. Qed. End WF. -End NZOrderPropSig. - -Module NZOrderPropFunct (NZ : NZOrdSig) := - NZBasePropSig NZ <+ NZOrderPropSig NZ. +End NZOrderProp. (** If we have moreover a [compare] function, we can build an [OrderedType] structure. *) -Module NZOrderedTypeFunct (NZ : NZDecOrdSig') - <: DecidableTypeFull <: OrderedTypeFull := - NZ <+ NZOrderPropFunct <+ Compare2EqBool <+ HasEqBool2Dec. - +Module NZOrderedType (NZ : NZDecOrdSig') + <: DecidableTypeFull <: OrderedTypeFull + := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v new file mode 100644 index 00000000..29109ccb --- /dev/null +++ b/theories/Numbers/NatInt/NZParity.v @@ -0,0 +1,263 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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. +End NZParity. + +Module Type NZParityProp + (Import A : NZOrdAxiomsSig') + (Import B : NZParity A) + (Import C : NZMulOrderProp A). + +(** Morphisms *) + +Instance Even_wd : Proper (eq==>iff) Even. +Proof. unfold Even. solve_proper. Qed. + +Instance Odd_wd : Proper (eq==>iff) Odd. +Proof. unfold Odd. solve_proper. Qed. + +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. + +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. + 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<y). + destruct (lt_ge_cases 0 y) as [LT|GT]; [now exists 0 | exists x]. + rewrite <- le_succ_l, H. nzsimpl'. + rewrite <- (add_0_r y) at 3. now apply add_le_mono_l. + destruct LT as (z,LT). + destruct (lt_exists_pred z y LT) as (y' & Hy' & _). + exists y'. rewrite <- succ_inj_wd, H, Hy'. now nzsimpl'. + left. exists y. rewrite <- succ_inj_wd. rewrite H. now nzsimpl. +Qed. + +Lemma double_below : forall n m, n<=m -> 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<m -> 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. + 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. + 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. + 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. 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. + 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. 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. + +End NZParityProp.
\ No newline at end of file diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v new file mode 100644 index 00000000..58704735 --- /dev/null +++ b/theories/Numbers/NatInt/NZPow.v @@ -0,0 +1,411 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Power Function *) + +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. +End Pow. + +Module Type PowNotation (A : Typ)(Import B : Pow A). + Infix "^" := pow. +End PowNotation. + +Module Type Pow' (A : Typ) := Pow A <+ PowNotation A. + +Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A). + 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 + provable) for N. Having it here allows to already derive + some slightly more general statements. *) + +Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A. +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). + +Hint Rewrite pow_0_r pow_succ_r : nz. + +(** Power and basic constants *) + +Lemma pow_0_l : forall a, 0<a -> 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. + +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. + +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<b /\ a==0). +Proof. + intros a b. split. + intros H. + destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]]. + now left. + rewrite Hb, pow_0_r in H; order'. + right. split; trivial. apply pow_eq_0 with b; order. + intros [Hb|[Hb Ha]]. now rewrite pow_neg_r. + rewrite Ha. apply pow_0_l'. order. +Qed. + +(** Power and addition, multiplication *) + +Lemma pow_add_r : forall a b c, 0<=b -> 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<a -> 0<=b -> 0<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. now apply mul_pos_pos. +Qed. + +(** Monotonicity *) + +Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> 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<a -> (0<b <-> 1<a^b). +Proof. + intros a b Ha. split; intros Hb. + rewrite <- (pow_1_l b) by order. + apply pow_lt_mono_l; try split; order'. + destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial. + rewrite pow_neg_r in Hb; order'. + rewrite H, pow_0_r in Hb. order. +Qed. + +Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> 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<a -> 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<a<=c -> b<=d -> + a^b <= c^d. +Proof. + intros. 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<a<c -> 0<b<d -> + 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<c -> + 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<a -> 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<c -> + (a<b <-> 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<c -> + (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<a -> 0<=c -> + (b<c <-> 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<a -> 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<a -> 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<c -> + 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<c -> + (a+b)^c <= 2^(pred c) * (a^c + b^c). +Proof. + assert (aux : forall a b c, 0<=a<=b -> 0<c -> + (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/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v index 7279325d..13c26233 100644 --- a/theories/Numbers/NatInt/NZProperties.v +++ b/theories/Numbers/NatInt/NZProperties.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,13 +8,11 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NZAxioms NZMulOrder. (** This functor summarizes all known facts about NZ. - For the moment it is only an alias to [NZMulOrderPropFunct], which + For the moment it is only an alias to [NZMulOrderProp], which subsumes all others. *) -Module Type NZPropFunct := NZMulOrderPropSig. +Module Type NZProp := NZMulOrderProp. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v new file mode 100644 index 00000000..6e85c689 --- /dev/null +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -0,0 +1,734 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Square Root Function *) + +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. +End Sqrt. + +Module Type SqrtNotation (A : Typ)(Import B : Sqrt A). + 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. +End NZSqrtSpec. + +Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A. +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) (at level 5, 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. 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 *) + +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<a -> √(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<b² <-> √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. rewrite <- sqrt_lt_square; try order'. + rewrite <- (mul_1_r a) at 1. + rewrite <- mul_lt_mono_pos_l; order'. +Qed. + +Lemma sqrt_le_lin : forall a, 0<=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. + - 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 : + - 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<b /\ S a == b²). +Proof. + intros a Ha. split. + intros EQ. exists (S (√a)). + split. apply lt_succ_r, sqrt_nonneg. + generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l. + assert (Ha' : 0 <= S a) by now apply le_le_succ_r. + generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order. + intros (b & Hb & H). + rewrite H. rewrite sqrt_square; try order. + symmetry. + rewrite <- (lt_succ_pred 0 b Hb). f_equiv. + rewrite <- (lt_succ_pred 0 b²) in H. apply succ_inj in H. + now rewrite H, sqrt_pred_square. + now apply mul_pos_pos. +Qed. + +(** Sqrt and addition *) + +Lemma sqrt_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_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. + +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) (at level 5, 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 -> √°a == S √(P a). +Proof. + intros a Ha. unfold sqrt_up. case compare_spec; try order. +Qed. + +Lemma sqrt_up_spec : forall a, 0<a -> (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. 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 *) + +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<b -> (P b)² < a <= b² -> √°a == b. +Proof. + intros a b Hb (LEb,LTb). + assert (Ha : 0<a) + by (apply le_lt_trans with (P b)²; trivial using square_nonneg). + rewrite sqrt_up_eqn; trivial. + assert (Hb' := lt_succ_pred 0 b Hb). + rewrite <- Hb'. f_equiv. apply sqrt_unique. + rewrite <- le_succ_l, <- lt_succ_r, Hb'. + rewrite (lt_succ_pred 0 a Ha). now split. +Qed. + +(** [sqrt_up] is exact on squares *) + +Lemma sqrt_up_square : forall a, 0<=a -> √°(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. 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 < 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<a -> 0<b -> (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 : + - 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 + 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. + +End NZSqrtUpProp. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 4185de95..72e09f15 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAdd.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NBase. -Module NAddPropFunct (Import N : NAxiomsSig'). -Include NBasePropFunct N. +Module NAddProp (Import N : NAxiomsMiniSig'). +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 *) @@ -24,9 +22,9 @@ intros n m; induct n. nzsimpl; intuition. intros n IH. nzsimpl. setoid_replace (S (n + m) == 0) with False by - (apply -> neg_false; apply neq_succ_0). + (apply neg_false; apply neq_succ_0). setoid_replace (S n == 0) with False by - (apply -> neg_false; apply neq_succ_0). tauto. + (apply neg_false; apply neq_succ_0). tauto. Qed. Theorem eq_add_succ : @@ -47,13 +45,13 @@ Qed. Theorem eq_add_1 : forall n m, n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. Proof. -intros n m H. +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]]. +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. +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. +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). @@ -77,5 +75,5 @@ intros n m H; rewrite (add_comm n (P m)); rewrite (add_comm n m); now apply add_pred_l. Qed. -End NAddPropFunct. +End NAddProp. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 0282a6b8..da41886f 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NOrder. -Module NAddOrderPropFunct (Import N : NAxiomsSig'). -Include NOrderPropFunct N. +Module NAddOrderProp (Import N : NAxiomsMiniSig'). +Include NOrderProp N. (** Theorems true for natural numbers, not for integers *) @@ -45,4 +43,4 @@ Proof. intros; apply add_nonneg_pos. apply le_0_l. assumption. Qed. -End NAddOrderPropFunct. +End NAddOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v index d1cc9972..ca6ccc1b 100644 --- a/theories/Numbers/Natural/Abstract/NAxioms.v +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,32 +8,60 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Export Bool NZAxioms NZParity NZPow NZSqrt NZLog NZDiv NZGcd NZBits. -Require Export NZAxioms. +(** From [NZ], we obtain natural numbers just by stating that [pred 0] == 0 *) -Set Implicit Arguments. +Module Type NAxiom (Import NZ : NZDomainSig'). + Axiom pred_0 : P 0 == 0. +End NAxiom. -Module Type NAxioms (Import NZ : NZDomainSig'). +Module Type NAxiomsMiniSig := NZOrdAxiomsSig <+ NAxiom. +Module Type NAxiomsMiniSig' := NZOrdAxiomsSig' <+ NAxiom. -Axiom pred_0 : P 0 == 0. +(** Let's now add some more functions and their specification *) -Parameter Inline recursion : forall A : Type, A -> (t -> A -> A) -> t -> A. -Implicit Arguments recursion [A]. +(** Division Function : we reuse NZDiv.DivMod and NZDiv.NZDivCommon, + and add to that a N-specific constraint. *) -Declare Instance recursion_wd (A : Type) (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). +Module Type NDivSpecific (Import N : NAxiomsMiniSig')(Import DM : DivMod' N). + Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. +End NDivSpecific. + +(** For all other functions, the NZ axiomatizations are enough. *) + +(** We now group everything together. *) + +Module Type NAxiomsSig := NAxiomsMiniSig <+ OrderFunctions + <+ NZParity.NZParity <+ NZPow.NZPow <+ NZSqrt.NZSqrt <+ NZLog.NZLog2 + <+ NZGcd.NZGcd <+ NZDiv.NZDiv <+ NZBits.NZBits <+ NZSquare. + +Module Type NAxiomsSig' := NAxiomsMiniSig' <+ OrderFunctions' + <+ NZParity.NZParity <+ NZPow.NZPow' <+ NZSqrt.NZSqrt' <+ NZLog.NZLog2 + <+ NZGcd.NZGcd' <+ NZDiv.NZDiv' <+ NZBits.NZBits' <+ NZSquare. + + +(** It could also be interesting to have a constructive recursor function. *) + +Module Type NAxiomsRec (Import NZ : NZDomainSig'). + +Parameter Inline recursion : forall {A : Type}, A -> (t -> A -> A) -> t -> A. + +Declare Instance recursion_wd {A : Type} (Aeq : relation A) : + Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion. Axiom recursion_0 : - forall (A : Type) (a : A) (f : t -> A -> A), recursion a f 0 = a. + forall {A} (a : A) (f : t -> A -> A), recursion a f 0 = a. Axiom recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : t -> A -> A), + 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 NAxioms. +End NAxiomsRec. -Module Type NAxiomsSig := NZOrdAxiomsSig <+ NAxioms. -Module Type NAxiomsSig' := NZOrdAxiomsSig' <+ NAxioms. +Module Type NAxiomsRecSig := NAxiomsMiniSig <+ NAxiomsRec. +Module Type NAxiomsRecSig' := NAxiomsMiniSig' <+ NAxiomsRec. +Module Type NAxiomsFullSig := NAxiomsSig <+ NAxiomsRec. +Module Type NAxiomsFullSig' := NAxiomsSig' <+ NAxiomsRec. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index efaba960..ac8a0522 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,48 +8,23 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Decidable. Require Export NAxioms. Require Import NZProperties. -Module NBasePropFunct (Import N : NAxiomsSig'). +Module NBaseProp (Import N : NAxiomsMiniSig'). (** First, we import all known facts about both natural numbers and integers. *) -Include NZPropFunct N. - -(** We prove that the successor of a number is not zero by defining a -function (by recursion) that maps 0 to false and the successor to true *) - -Definition if_zero (A : Type) (a b : A) (n : N.t) : A := - recursion a (fun _ _ => b) n. - -Implicit Arguments if_zero [A]. - -Instance if_zero_wd (A : Type) : - Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A). -Proof. -intros; unfold if_zero. -repeat red; intros. apply recursion_wd; auto. repeat red; auto. -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. +Include NZProp N. -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. +(** 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 H. -generalize (Logic.eq_refl (if_zero false true 0)). -rewrite <- H at 1. rewrite if_zero_0, if_zero_succ; discriminate. + 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. @@ -66,7 +41,7 @@ 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]. +intro H; apply le_succ_r in H; destruct H as [H | H]. assumption. symmetry in H; false_hyp H neq_succ_0. Qed. @@ -119,12 +94,11 @@ Qed. Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1. Proof. cases n. -rewrite pred_0. setoid_replace (0 == 1) with False using relation iff. tauto. -split; intro H; [symmetry in H; false_hyp H neq_succ_0 | elim H]. +rewrite pred_0. now split; [left|]. intro n. rewrite pred_succ. -setoid_replace (S n == 0) with False using relation iff by - (apply -> neg_false; apply neq_succ_0). -rewrite succ_inj_wd. tauto. +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 : forall n, n ~= 0 -> S (P n) == n. @@ -155,6 +129,7 @@ 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))]. induct n; [ | intros n [IH1 IH2]]; auto. @@ -204,7 +179,7 @@ Ltac double_induct n m := try intros until n; try intros until m; pattern n, m; apply double_induction; clear n m; - [solve_relation_wd | | | ]. + [solve_proper | | | ]. -End NBasePropFunct. +End NBaseProp. diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v new file mode 100644 index 00000000..c66f003e --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -0,0 +1,1463 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +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'. +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. + +Instance b2n_proper : Proper (Logic.eq ==> eq) b2n. +Proof. solve_proper. 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] + [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_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. + +(** Alternative caracterisations of [testbit] *) + +(** 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 caracterisation 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 caracterisation + 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. 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 [Psize] and [Psize_pos]). +*) + +(** Testing bits after division or multiplication by a power of two *) + +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. + 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<n -> (a*2^n).[m] = false. +Proof. + intros. 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<n -> + (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. + +Instance eqf_equiv : Equivalence eqf. +Proof. + split; congruence. +Qed. + +Local Infix "===" := eqf (at level 70, no associativity). + +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;[solve_proper|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. + +Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. + +Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise. + +(** 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. bitwise. + 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. + +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. + +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. + 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. + 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 /\ log2 a < n). +Proof. + intros a n. + rewrite shiftr_div_pow2, div_small_iff by order_nz. + destruct (eq_0_gt_0_cases a) as [EQ|LT]. + rewrite EQ. split. now left. intros _. + assert (H : 2~=0) by order'. + generalize (pow_nonzero 2 n H) (le_0_l (2^n)); order. + rewrite log2_lt_pow2; trivial. + split. right; split; trivial. intros [H|[_ H]]; now order. +Qed. + +Lemma shiftr_eq_0 : forall a n, log2 a < n -> 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. + +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. *) + +Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance land_wd : Proper (eq ==> eq ==> eq) land. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +Instance lor_wd : Proper (eq ==> eq ==> eq) lor. +Proof. + intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb. +Qed. + +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. + 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. + 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. + +Instance setbit_wd : Proper (eq==>eq==>eq) setbit. +Proof. unfold setbit. solve_proper. Qed. + +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. 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. + 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. 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. 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. + 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. bitwise. + 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. bitwise. + 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. bitwise. + 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. + +(** 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). + +Instance ones_wd : Proper (eq==>eq) ones. +Proof. unfold ones. solve_proper. Qed. + +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_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<n -> (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. + 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<n. +Proof. + intros. split. intros H. + apply lt_nge. intro H'. apply ones_spec_high in H'. + rewrite H in H'; discriminate. + apply ones_spec_low. +Qed. + +Lemma lnot_spec_low : forall a n m, m<n -> + (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. + 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. + +(** 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. 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. 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 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. 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. 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. 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. + 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. + 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. 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. 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. 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. 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. 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. 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. 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. + 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<m -> 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. + 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. + 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. + 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. + 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. + 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'. + 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. + 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. + 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 7b38c148..ad7a9f3a 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,14 +8,41 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NDefOps.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Bool. (* To get the orb and negb function *) Require Import RelationPairs. Require Export NStrongRec. -Module NdefOpsPropFunct (Import N : NAxiomsSig'). -Include NStrongRecPropFunct N. +(** In this module, we derive generic implementations of usual operators + 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. + +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 *) @@ -24,17 +51,9 @@ Definition def_add (x y : N.t) := recursion y (fun _ => S) x. Local Infix "+++" := def_add (at level 50, left associativity). -Instance def_add_prewd : Proper (N.eq==>N.eq==>N.eq) (fun _ => S). -Proof. -intros _ _ _ p p' Epp'; now rewrite Epp'. -Qed. - Instance def_add_wd : Proper (N.eq ==> N.eq ==> N.eq) def_add. Proof. -intros x x' Exx' y y' Eyy'. unfold def_add. -(* TODO: why rewrite Exx' don't work here (or verrrry slowly) ? *) -apply recursion_wd with (Aeq := N.eq); auto with *. -apply def_add_prewd. +unfold def_add. f_equiv'. Qed. Theorem def_add_0_l : forall y, 0 +++ y == y. @@ -45,7 +64,7 @@ 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; auto with *. +rewrite recursion_succ; f_equiv'. Qed. Theorem def_add_add : forall n m, n +++ m == n + m. @@ -62,18 +81,10 @@ Definition def_mul (x y : N.t) := recursion 0 (fun _ p => p +++ x) y. Local Infix "**" := def_mul (at level 40, left associativity). -Instance def_mul_prewd : - Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun x _ p => p +++ x). -Proof. -repeat red; intros; now apply def_add_wd. -Qed. - Instance def_mul_wd : Proper (N.eq ==> N.eq ==> N.eq) def_mul. Proof. -unfold def_mul. -intros x x' Exx' y y' Eyy'. -apply recursion_wd; auto with *. -now apply def_mul_prewd. +unfold def_mul. (* TODO : solve_proper SLOW + BUG *) +f_equiv'. Qed. Theorem def_mul_0_r : forall x, x ** 0 == 0. @@ -85,7 +96,7 @@ 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 *. -now apply def_mul_prewd. +f_equiv'. Qed. Theorem def_mul_mul : forall n m, n ** m == n * m. @@ -106,25 +117,9 @@ recursion Local Infix "<<" := ltb (at level 70, no associativity). -Instance ltb_prewd1 : Proper (N.eq==>Logic.eq) (if_zero false true). -Proof. -red; intros; apply if_zero_wd; auto. -Qed. - -Instance ltb_prewd2 : Proper (N.eq==>(N.eq==>Logic.eq)==>N.eq==>Logic.eq) - (fun _ f n => recursion false (fun n' _ => f n') n). -Proof. -repeat red; intros; simpl. -apply recursion_wd; auto with *. -repeat red; auto. -Qed. - Instance ltb_wd : Proper (N.eq ==> N.eq ==> Logic.eq) ltb. Proof. -unfold ltb. -intros n n' Hn m m' Hm. -apply f_equiv; auto with *. -apply recursion_wd; auto; [ apply ltb_prewd1 | apply ltb_prewd2 ]. +unfold ltb. f_equiv'. Qed. Theorem ltb_base : forall n, 0 << n = if_zero false true n. @@ -136,11 +131,9 @@ Theorem ltb_step : forall m n, S m << n = recursion false (fun n' _ => m << n') n. Proof. intros m n; unfold ltb at 1. -apply f_equiv; auto with *. -rewrite recursion_succ by (apply ltb_prewd1||apply ltb_prewd2). -fold (ltb m). -repeat red; intros. apply recursion_wd; auto. -repeat red; intros; now apply ltb_wd. +f_equiv. +rewrite recursion_succ; f_equiv'. +reflexivity. Qed. (* Above, we rewrite applications of function. Is it possible to rewrite @@ -162,8 +155,7 @@ Qed. Theorem succ_ltb_mono : forall n m, (S n << S m) = (n << m). Proof. intros n m. -rewrite ltb_step. rewrite recursion_succ; try reflexivity. -repeat red; intros; now apply ltb_wd. +rewrite ltb_step. rewrite recursion_succ; f_equiv'. Qed. Theorem ltb_lt : forall n m, n << m = true <-> n < m. @@ -188,9 +180,7 @@ Definition even (x : N.t) := recursion true (fun _ p => negb p) x. Instance even_wd : Proper (N.eq==>Logic.eq) even. Proof. -intros n n' Hn. unfold even. -apply recursion_wd; auto. -congruence. +unfold even. f_equiv'. Qed. Theorem even_0 : even 0 = true. @@ -202,19 +192,12 @@ Qed. Theorem even_succ : forall x, even (S x) = negb (even x). Proof. unfold even. -intro x; rewrite recursion_succ; try reflexivity. -congruence. +intro x; rewrite recursion_succ; f_equiv'. Qed. (*****************************************************) (** Division by 2 *) -Local Notation "a <= b <= c" := (a<=b /\ b<=c). -Local Notation "a <= b < c" := (a<=b /\ b<c). -Local Notation "a < b <= c" := (a<b /\ b<=c). -Local Notation "a < b < c" := (a<b /\ b<c). -Local Notation "2" := (S 1). - Definition half_aux (x : N.t) : N.t * N.t := recursion (0, 0) (fun _ p => let (x1, x2) := p in (S x2, x1)) x. @@ -223,14 +206,14 @@ Definition half (x : N.t) := snd (half_aux x). Instance half_aux_wd : Proper (N.eq ==> N.eq*N.eq) half_aux. Proof. intros x x' Hx. unfold half_aux. -apply recursion_wd; auto with *. +f_equiv; trivial. intros y y' Hy (u,v) (u',v') (Hu,Hv). compute in *. rewrite Hu, Hv; auto with *. Qed. Instance half_wd : Proper (N.eq==>N.eq) half. Proof. -intros x x' Hx. unfold half. rewrite Hx; auto with *. +unfold half. f_equiv'. Qed. Lemma half_aux_0 : half_aux 0 = (0,0). @@ -245,8 +228,7 @@ intros. remember (half_aux x) as h. destruct h as (f,s); simpl in *. unfold half_aux in *. -rewrite recursion_succ, <- Heqh; simpl; auto. -repeat red; intros; subst; auto. +rewrite recursion_succ, <- Heqh; simpl; f_equiv'. Qed. Theorem half_aux_spec : forall n, @@ -258,7 +240,7 @@ rewrite half_aux_0; simpl; rewrite add_0_l; auto with *. intros. rewrite half_aux_succ. simpl. rewrite add_succ_l, add_comm; auto. -apply succ_wd; auto. +now f_equiv. Qed. Theorem half_aux_spec2 : forall n, @@ -271,7 +253,7 @@ rewrite half_aux_0; simpl. auto with *. intros. rewrite half_aux_succ; simpl. destruct H; auto with *. -right; apply succ_wd; auto with *. +right; now f_equiv. Qed. Theorem half_0 : half 0 == 0. @@ -281,14 +263,14 @@ Qed. Theorem half_1 : half 1 == 0. Proof. -unfold half. rewrite half_aux_succ, half_aux_0; simpl; auto with *. +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. +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. @@ -319,24 +301,23 @@ 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. -destruct (nlt_0_r _ LT). -rewrite <- succ_lt_mono in LT. -destruct (nlt_0_r _ 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; - rewrite ?mul_succ_l, ?mul_0_l, ?add_0_l, ?add_assoc. +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. -rewrite add_succ_l. apply lt_0_succ. +apply lt_0_succ. Qed. @@ -347,17 +328,9 @@ Definition pow (n m : N.t) := recursion 1 (fun _ r => n*r) m. Local Infix "^^" := pow (at level 30, right associativity). -Instance pow_prewd : - Proper (N.eq==>N.eq==>N.eq==>N.eq) (fun n _ r => n*r). -Proof. -intros n n' Hn x x' Hx y y' Hy. rewrite Hn, Hy; auto with *. -Qed. - Instance pow_wd : Proper (N.eq==>N.eq==>N.eq) pow. Proof. -intros n n' Hn m m' Hm. unfold pow. -apply recursion_wd; auto with *. -now apply pow_prewd. +unfold pow. f_equiv'. Qed. Lemma pow_0 : forall n, n^^0 == 1. @@ -367,8 +340,7 @@ Qed. Lemma pow_succ : forall n m, n^^(S m) == n*(n^^m). Proof. -intros. unfold pow. rewrite recursion_succ; auto with *. -now apply pow_prewd. +intros. unfold pow. rewrite recursion_succ; f_equiv'. Qed. @@ -389,15 +361,13 @@ Proof. intros g g' Hg n n' Hn. rewrite Hn. destruct (n' << 2); auto with *. -apply succ_wd. -apply Hg. rewrite Hn; auto with *. +f_equiv. apply Hg. now f_equiv. Qed. Instance log_wd : Proper (N.eq==>N.eq) log. Proof. intros x x' Exx'. unfold log. -apply strong_rec_wd; auto with *. -apply log_prewd. +apply strong_rec_wd; f_equiv'. Qed. Lemma log_good_step : forall n h1 h2, @@ -408,9 +378,9 @@ Proof. intros n h1 h2 E. destruct (n<<2) as [ ]_eqn:H. auto with *. -apply succ_wd, E, half_decrease. -rewrite <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. -apply lt_succ_l; auto. +f_equiv. apply E, half_decrease. +rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. +order'. Qed. Hint Resolve log_good_step. @@ -441,14 +411,14 @@ 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 in Hk2. +rewrite <- le_succ_l, <- one_succ in Hk2. le_elim Hk2. -rewrite <- nle_gt, le_succ_l in LT. destruct LT; auto. +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 le_succ_l in LE. +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. @@ -458,22 +428,13 @@ split. rewrite <- le_succ_l in IH1. apply mul_le_mono_l with (p:=2) in IH1. eapply lt_le_trans; eauto. -nzsimpl. +nzsimpl'. rewrite lt_succ_r. eapply le_trans; [ eapply half_lower_bound | ]. -nzsimpl; apply le_refl. +nzsimpl'; apply le_refl. eapply le_trans; [ | eapply half_upper_bound ]. apply mul_le_mono_l; auto. Qed. -(** Later: - -Theorem log_mul : forall n m, 0 < n -> 0 < m -> - log (n*m) == log n + log m. - -Theorem log_pow2 : forall n, log (2^^n) = n. - -*) - -End NdefOpsPropFunct. +End NdefOpsProp. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index 171530f0..6db8e448 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -1,40 +1,36 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Euclidean Division *) +Require Import NAxioms NSub NZDiv. -Require Import NAxioms NProperties NZDiv. +(** Properties of Euclidean Division *) -Module Type NDivSpecific (Import N : NAxiomsSig')(Import DM : DivMod' N). - Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. -End NDivSpecific. +Module Type NDivProp (Import N : NAxiomsSig')(Import NP : NSubProp N). -Module Type NDivSig := NAxiomsSig <+ DivMod <+ NZDivCommon <+ NDivSpecific. -Module Type NDivSig' := NAxiomsSig' <+ DivMod' <+ NZDivCommon <+ NDivSpecific. +(** We benefit from what already exists for NZ *) +Module Import Private_NZDiv := Nop <+ NZDivProp N N NP. -Module NDivPropFunct (Import N : NDivSig')(Import NP : NPropSig N). +Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. -(** We benefit from what already exists for NZ *) +(** Let's now state again theorems, but without useless hypothesis. *) - Module ND <: NZDiv N. - Definition div := div. - Definition modulo := modulo. - Definition div_wd := div_wd. - Definition mod_wd := mod_wd. - Definition div_mod := div_mod. - Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b. - Proof. split. apply le_0_l. apply mod_upper_bound. order. Qed. - End ND. - Module Import NZDivP := NZDivPropFunct N NP ND. +Lemma mod_upper_bound : forall a b, b ~= 0 -> a mod b < b. +Proof. intros. apply mod_bound_pos; auto'. Qed. - Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l. +(** Another formulation of the main equation *) -(** Let's now state again theorems, but without useless hypothesis. *) +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 *) @@ -51,6 +47,9 @@ Theorem mod_unique: forall a b q r, r<b -> a == b*q + r -> r == a mod b. Proof. intros. 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. + (** A division by itself returns 1 *) Lemma div_same : forall a, a~=0 -> a/a == 1. @@ -223,6 +222,10 @@ 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. + (** A last inequality: *) Theorem div_mul_le: @@ -235,5 +238,4 @@ 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 NDivPropFunct. - +End NDivProp. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v new file mode 100644 index 00000000..ece369d8 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -0,0 +1,213 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Properties of the greatest common divisor *) + +Require Import NAxioms NSub NZGcd. + +Module Type NGcdProp + (Import A : NAxiomsSig') + (Import B : NSubProp A). + + Include NZGcdProp A A B. + +(** Results concerning divisibility*) + +Definition divide_1_r n : (n | 1) -> n == 1 + := divide_1_r_nonneg n (le_0_l n). + +Definition divide_antisym n m : (n | m) -> (m | n) -> n == m + := divide_antisym_nonneg n m (le_0_l n) (le_0_l m). + +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. + +(** 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). + +Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. +Proof. + intros. 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. + +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. + +(** For strictly positive numbers, we have Bezout in the two directions. *) + +Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m -> + Bezout n m (gcd n m) /\ Bezout m n (gcd n m). +Proof. + intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. + pattern n. apply strong_right_induction with (z:=1); trivial. + unfold Bezout. solve_proper. + clear n Hn. intros n Hn IHn. + intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm. + pattern m. apply strong_right_induction with (z:=1); trivial. + unfold Bezout. solve_proper. + 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), (a' & b' & EQ')). + rewrite one_succ, le_succ_l. + apply lt_add_lt_sub_l; now nzsimpl. + apply sub_lt; order'. + split. + exists (a+b). exists b. + rewrite mul_add_distr_r, EQ, mul_sub_distr_l, <- add_assoc. + rewrite gcd_sub_diag_r by order. + rewrite sub_add. reflexivity. apply mul_le_mono_l; order. + exists a'. exists (a'+b'). + rewrite gcd_sub_diag_r in EQ' by order. + rewrite (add_comm a'), mul_add_distr_r, add_assoc, <- EQ'. + rewrite mul_sub_distr_l, sub_add. reflexivity. apply mul_le_mono_l; order. + (* n = m *) + rewrite EQ. rewrite gcd_diag. + split. + exists 1. exists 0. now nzsimpl. + exists 1. exists 0. now nzsimpl. + (* m < n *) + rewrite gcd_comm, and_comm. + apply IHn; trivial. + now rewrite <- le_succ_l, <- one_succ. +Qed. + +Lemma gcd_bezout_pos : forall n m, 0<n -> Bezout n m (gcd n m). +Proof. + intros n m Hn. + destruct (eq_0_gt_0_cases m) as [EQ|LT]. + rewrite EQ, gcd_0_r. exists 1. exists 0. now nzsimpl. + now apply gcd_bezout_pos_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'. + 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. 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 d484a625..bcf746a7 100644 --- a/theories/Numbers/Natural/Abstract/NIso.v +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,11 +8,9 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NIso.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import NBase. -Module Homomorphism (N1 N2 : NAxiomsSig). +Module Homomorphism (N1 N2 : NAxiomsRecSig). Local Notation "n == m" := (N2.eq n m) (at level 70, no associativity). @@ -25,11 +23,8 @@ Definition natural_isomorphism : N1.t -> N2.t := Instance natural_isomorphism_wd : Proper (N1.eq ==> N2.eq) natural_isomorphism. Proof. unfold natural_isomorphism. -intros n m Eqxy. -apply N1.recursion_wd. -reflexivity. -intros _ _ _ y' y'' H. now apply N2.succ_wd. -assumption. +repeat red; intros. f_equiv; trivial. +repeat red; intros. now f_equiv. Qed. Theorem natural_isomorphism_0 : natural_isomorphism N1.zero == N2.zero. @@ -42,7 +37,7 @@ Theorem natural_isomorphism_succ : Proof. unfold natural_isomorphism. intro n. rewrite N1.recursion_succ; auto with *. -repeat red; intros. apply N2.succ_wd; auto. +repeat red; intros. now f_equiv. Qed. Theorem hom_nat_iso : homomorphism natural_isomorphism. @@ -53,9 +48,9 @@ Qed. End Homomorphism. -Module Inverse (N1 N2 : NAxiomsSig). +Module Inverse (N1 N2 : NAxiomsRecSig). -Module Import NBasePropMod1 := NBasePropFunct N1. +Module Import NBasePropMod1 := NBaseProp N1. (* This makes the tactic induct available. Since it is taken from (NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) @@ -76,7 +71,7 @@ Qed. End Inverse. -Module Isomorphism (N1 N2 : NAxiomsSig). +Module Isomorphism (N1 N2 : NAxiomsRecSig). Module Hom12 := Homomorphism N1 N2. Module Hom21 := Homomorphism N2 N1. diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v new file mode 100644 index 00000000..1e8e678c --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -0,0 +1,290 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import NAxioms NSub NDiv NGcd. + +(** * Least Common Multiple *) + +(** Unlike other functions around, we will define lcm below instead of + axiomatizing it. Indeed, there is no "prior art" about lcm in the + standard library to be compliant with, and the generic definition + of lcm via gcd is quite reasonable. + + By the way, we also state here some combined properties of div/mod + and gcd. +*) + +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: + + lcm a b = a * (b / gcd a b) + = (a / gcd a b) * b + = (a*b) / gcd a b + + Nota: [lcm 0 0] should be 0, which isn't garantee with the third + equation above. +*) + +Definition lcm a b := a*(b/gcd a b). + +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. 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/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v new file mode 100644 index 00000000..74827c6e --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NLog.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Base-2 Logarithm Properties *) + +Require Import NAxioms NSub NPow NParity NZLog. + +Module Type NLog2Prop + (A : NAxiomsSig) + (B : NSubProp A) + (C : NParityProp A B) + (D : NPowProp A B C). + + (** 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. +End NLog2Prop. diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v new file mode 100644 index 00000000..cdff6dbc --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -0,0 +1,135 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import NAxioms NSub GenericMinMax. + +(** * Properties of minimum and maximum specific to natural numbers *) + +Module Type NMaxMinProp (Import N : NAxiomsMiniSig'). +Include NSubProp N. + +(** Zero *) + +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 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. + +(** The following results are concrete instances of [max_monotone] + and similar lemmas. *) + +(** Succ *) + +Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Proof. + intros. destruct (le_ge_cases n m); + [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. +Qed. + +Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Proof. + intros. 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 : forall n m 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]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_max_distr_r : forall n m 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]; now rewrite <- ?add_le_mono_r. +Qed. + +Lemma add_min_distr_l : forall n m 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]; now rewrite <- ?add_le_mono_l. +Qed. + +Lemma add_min_distr_r : forall n m 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]; now rewrite <- ?add_le_mono_r. +Qed. + +(** Mul *) + +Lemma mul_max_distr_l : forall n m 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_l. +Qed. + +Lemma mul_max_distr_r : forall n m 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_r. +Qed. + +Lemma mul_min_distr_l : forall n m 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_l. +Qed. + +Lemma mul_min_distr_r : forall n m 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_r. +Qed. + +(** Sub *) + +Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Proof. + intros. 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 : forall n m 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 sub_le_mono_r. +Qed. + +Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Proof. + intros. 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 : forall n m 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 sub_le_mono_r. +Qed. + +End NMaxMinProp. diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v index bdd4b674..1d6e8ba0 100644 --- a/theories/Numbers/Natural/Abstract/NMulOrder.v +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMulOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NAddOrder. -Module NMulOrderPropFunct (Import N : NAxiomsSig'). -Include NAddOrderPropFunct N. +Module NMulOrderProp (Import N : NAxiomsMiniSig'). +Include NAddOrderProp N. (** Theorems that are either not valid on Z or have different proofs on N and Z *) @@ -55,7 +53,7 @@ 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. +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. @@ -67,14 +65,18 @@ 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. false_hyp H neq_0_succ. +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; false_hyp H neq_0_succ. -apply -> (mul_lt_mono_pos_r m) in H1; [| assumption]. rewrite mul_1_l in H1. +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. -End NMulOrderPropFunct. +(** 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 17dd3466..8bba7d72 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,18 +8,16 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NAdd. -Module NOrderPropFunct (Import N : NAxiomsSig'). -Include NAddPropFunct N. +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 /\ n < m). +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]. @@ -29,12 +27,12 @@ Defined. Theorem nlt_0_r : forall n, ~ n < 0. Proof. -intro n; apply -> le_ngt. apply le_0_l. +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. +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. @@ -65,6 +63,7 @@ Qed. Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. Proof. +setoid_rewrite one_succ. induct n. now left. cases n. intros; right; now left. intros n IH. destruct IH as [H | [H | H]]. @@ -75,6 +74,7 @@ Qed. Theorem lt_1_r : forall n, n < 1 <-> n == 0. Proof. +setoid_rewrite one_succ. cases n. split; intro; [reflexivity | apply lt_succ_diag_r]. intros n. rewrite <- succ_lt_mono. @@ -83,6 +83,7 @@ Qed. Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. Proof. +setoid_rewrite one_succ. cases n. split; intro; [now left | apply le_succ_diag_r]. intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. @@ -117,9 +118,9 @@ Proof. intros Base Step; induct n. intros; apply Base. intros n IH m H. elim H using le_ind. -solve_predicate_wd. +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. +intros k H1 H2. apply le_succ_l in H1. apply lt_le_incl in H1. auto. Qed. Theorem lt_ind_rel : @@ -131,7 +132,7 @@ intros Base Step; 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_predicate_wd. +solve_proper. apply Step; [| apply IH]; now apply lt_succ_diag_r. intros k H1 H2. apply lt_succ_l in H1. auto. Qed. @@ -175,7 +176,7 @@ Theorem lt_le_pred : forall n m, n < m -> n <= P m. Proof. intro n; cases m. intro H; false_hyp H nlt_0_r. -intros m IH. rewrite pred_succ; now apply -> lt_succ_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. @@ -183,7 +184,7 @@ Theorem lt_pred_le : forall n m, P n < m -> n <= m. 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. +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. @@ -200,7 +201,7 @@ 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_relation_wd. +solve_proper. intro; rewrite pred_0; apply le_0_l. intros p q H1 _; now do 2 rewrite pred_succ. Qed. @@ -208,12 +209,12 @@ 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. +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 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. +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. @@ -224,13 +225,13 @@ 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. +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. +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. @@ -240,5 +241,5 @@ rewrite pred_0. split; intro H; apply le_0_l. intro n. rewrite pred_succ. apply succ_le_mono. Qed. -End NOrderPropFunct. +End NOrderProp. diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v new file mode 100644 index 00000000..6a1e20ce --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Bool NSub NZParity. + +(** Some additionnal properties of [even], [odd]. *) + +Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). + +Include NZParityProp N N NP. + +Lemma odd_pred : forall 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 : forall 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 : forall 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 : forall 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 new file mode 100644 index 00000000..07aee9c6 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -0,0 +1,160 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Properties of the power function *) + +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). + + 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'. + +Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b. +Proof. wrap pow_succ_r. Qed. + +(** Power and basic constants *) + +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. + +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. + +(** 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_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. + +(** Power and nullity *) + +Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. +Proof. intros. 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_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 *) + +Lemma pow_lt_mono_l : forall a b c, c~=0 -> a<b -> 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_gt_1 : forall a b, 1<a -> b~=0 -> 1<a^b. +Proof. wrap pow_gt_1. Qed. + +Lemma pow_lt_mono_r : forall a b c, 1<a -> b<c -> 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 *) + +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. + +Definition pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d -> + a^b < c^d + := pow_lt_mono. + +(** 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_r : forall a b c, 1<a -> a^b == a^c -> b == c. +Proof. intros; eapply pow_inj_r; eauto; auto'. Qed. + +(** Monotonicity results, both ways *) + +Lemma pow_lt_mono_l_iff : forall a b c, c~=0 -> + (a<b <-> 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_lt_mono_r_iff : forall a b c, 1<a -> + (b<c <-> a^b < a^c). +Proof. wrap pow_lt_mono_r_iff. Qed. + +Lemma pow_le_mono_r_iff : forall a b c, 1<a -> + (b<=c <-> a^b <= a^c). +Proof. wrap pow_le_mono_r_iff. Qed. + +(** For any a>1, the a^x function is above the identity function *) + +Lemma pow_gt_lin_r : forall a b, 1<a -> b < a^b. +Proof. wrap pow_gt_lin_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, 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 : + 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. + +End NPowProp. diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v index c9e05113..1edb6b51 100644 --- a/theories/Numbers/Natural/Abstract/NProperties.v +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -1,22 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NProperties.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Export NAxioms. +Require Import NMaxMin NParity NPow NSqrt NLog NDiv NGcd NLcm NBits. -Require Export NAxioms NSub. +(** This functor summarizes all known facts about N. *) -(** This functor summarizes all known facts about N. - For the moment it is only an alias to [NSubPropFunct], which - subsumes all others. -*) - -Module Type NPropSig := NSubPropFunct. - -Module NPropFunct (N:NAxiomsSig) <: NPropSig N. - Include NPropSig N. -End NPropFunct. +Module Type NProp (N:NAxiomsSig) := + NMaxMinProp N <+ NParityProp N <+ NPowProp N <+ NSqrtProp N + <+ NLog2Prop N <+ NDivProp N <+ NGcdProp N <+ NLcmProp N + <+ NBitsProp N. diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v new file mode 100644 index 00000000..34b7d011 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NSqrt.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Properties of Square Root Function *) + +Require Import NAxioms NSub NZSqrt. + +Module NSqrtProp (Import A : NAxiomsSig')(Import B : NSubProp A). + + 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'. + + (** 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. + +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. + +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. + +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<b*b <-> √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_lt_lin : forall a, 1<a -> √a<a + := sqrt_lt_lin. + +Lemma sqrt_le_lin : forall a, √a<=a. +Proof. wrap sqrt_le_lin. Qed. + +Definition sqrt_mul_below : forall a b, √a * √b <= √(a*b) + := sqrt_mul_below. + +Lemma sqrt_mul_above : forall a b, √(a*b) < S (√a) * S (√b). +Proof. wrap sqrt_mul_above. Qed. + +Lemma sqrt_succ_le : forall a, √(S a) <= S (√a). +Proof. wrap sqrt_succ_le. Qed. + +Lemma sqrt_succ_or : forall a, √(S a) == S (√a) \/ √(S a) == √a. +Proof. wrap sqrt_succ_or. Qed. + +Definition sqrt_add_le : forall a b, √(a+b) <= √a + √b + := sqrt_add_le. + +Lemma add_sqrt_le : forall a b, √a + √b <= √(2*(a+b)). +Proof. wrap add_sqrt_le. Qed. + +(** For the moment, we include stuff about [sqrt_up] with patching them. *) + +Include NZSqrtUpProp A A B Private_NZSqrt. + +End NSqrtProp. diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index d9a2427d..607746d5 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,15 +8,15 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NStrongRec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file defined the strong (course-of-value, well-founded) recursion and proves its properties *) Require Export NSub. -Module NStrongRecPropFunct (Import N : NAxiomsSig'). -Include NSubPropFunct N. +Ltac f_equiv' := repeat progress (f_equiv; try intros ? ? ?; auto). + +Module NStrongRecProp (Import N : NAxiomsRecSig'). +Include NSubProp N. Section StrongRecursion. @@ -51,30 +51,18 @@ Proof. reflexivity. Qed. -(** We need a result similar to [f_equal], but for setoid equalities. *) -Lemma f_equiv : forall f g x y, - (N.eq==>Aeq)%signature f g -> N.eq x y -> Aeq (f x) (g y). -Proof. -auto. -Qed. - Instance strong_rec0_wd : Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq) strong_rec0. Proof. -unfold strong_rec0. -repeat red; intros. -apply f_equiv; auto. -apply recursion_wd; try red; auto. +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. -apply strong_rec0_wd; auto. -now rewrite Enn'. +rewrite !strong_rec_alt; f_equiv'. Qed. Section FixPoint. @@ -92,18 +80,16 @@ 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. -apply f_equiv; auto with *. -rewrite recursion_succ; try (repeat red; auto with *; fail). -apply f_wd. -apply recursion_wd; try red; auto with *. +f_equiv. +rewrite recursion_succ; f_equiv'. +reflexivity. 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. -apply f_wd; auto with *. -red; intros; rewrite strong_rec0_0; auto with *. +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) @@ -158,7 +144,7 @@ intros. transitivity (f (fun n => strong_rec0 a f (S n) n) n). rewrite strong_rec_alt. apply strong_rec0_fixpoint. -apply f_wd; auto with *. +f_equiv. intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *. Qed. @@ -204,7 +190,7 @@ Qed. End FixPoint. End StrongRecursion. -Implicit Arguments strong_rec [A]. +Arguments strong_rec [A] a f n. -End NStrongRecPropFunct. +End NStrongRecProp. diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index c0be3114..d7143c67 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,10 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NSub.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NMulOrder. -Module Type NSubPropFunct (Import N : NAxiomsSig'). -Include NMulOrderPropFunct N. +Module Type NSubProp (Import N : NAxiomsMiniSig'). +Include NMulOrderProp N. Theorem sub_0_l : forall n, 0 - n == 0. Proof. @@ -37,7 +35,7 @@ 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_relation_wd. +solve_proper. intro; rewrite sub_0_r; apply neq_succ_0. intros; now rewrite sub_succ. Qed. @@ -47,8 +45,8 @@ 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). +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. @@ -205,6 +203,26 @@ 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. 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. rewrite le_sub_le_add_r. + transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. +Qed. + (** Sub and mul *) Theorem mul_pred_r : forall n m, n * (P m) == n * m - n. @@ -224,10 +242,10 @@ 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); [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). +now apply add_cancel_l. +assert (H1 : S n <= m); [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. @@ -298,5 +316,5 @@ Theorem add_dichotomy : forall n m, (exists p, p + n == m) \/ (exists p, p + m == n). Proof. exact le_alt_dichotomy. Qed. -End NSubPropFunct. +End NSubProp. diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index 7c480862..7f205b38 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ Require Export Int31. Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake - NProperties NDiv GenericMinMax. + NProperties GenericMinMax. (** The following [BigN] module regroups both the operations and all the abstract properties: @@ -21,73 +21,63 @@ Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake w.r.t. ZArith - [NTypeIsNAxioms] shows (mainly) that these operations implement the interface [NAxioms] - - [NPropSig] adds all generic properties derived from [NAxioms] - - [NDivPropFunct] provides generic properties of [div] and [mod]. + - [NProp] adds all generic properties derived from [NAxioms] - [MinMax*Properties] provides properties of [min] and [max]. *) -Module BigN <: NType <: OrderedTypeFull <: TotalOrder := - NMake.Make Int31Cyclic <+ NTypeIsNAxioms - <+ !NPropSig <+ !NDivPropFunct <+ HasEqBool2Dec - <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. +Delimit Scope bigN_scope with bigN. +Module BigN <: NType <: OrderedTypeFull <: TotalOrder. + Include NMake.Make Int31Cyclic [scope abstract_scope to bigN_scope]. + Bind Scope bigN_scope with t t'. + Include NTypeIsNAxioms + <+ NProp [no inline] + <+ HasEqBool2Dec [no inline] + <+ MinMaxLogicalProperties [no inline] + <+ MinMaxDecProperties [no inline]. +End BigN. + +(** Nota concerning scopes : for the first Include, we cannot bind + the scope bigN_scope to a type that doesn't exists yet. + We hence need to explicitely declare the scope substitution. + For the next Include, the abstract type t (in scope abstract_scope) + gets substituted to concrete BigN.t (in scope bigN_scope), + and the corresponding argument scope are fixed automatically. +*) (** Notations about [BigN] *) -Notation bigN := BigN.t. - -Delimit Scope bigN_scope with bigN. -Bind Scope bigN_scope with bigN. -Bind Scope bigN_scope with BigN.t. -Bind Scope bigN_scope with BigN.t_. -(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) -Arguments Scope BigN.to_Z [bigN_scope]. -Arguments Scope BigN.succ [bigN_scope]. -Arguments Scope BigN.pred [bigN_scope]. -Arguments Scope BigN.square [bigN_scope]. -Arguments Scope BigN.add [bigN_scope bigN_scope]. -Arguments Scope BigN.sub [bigN_scope bigN_scope]. -Arguments Scope BigN.mul [bigN_scope bigN_scope]. -Arguments Scope BigN.div [bigN_scope bigN_scope]. -Arguments Scope BigN.eq [bigN_scope bigN_scope]. -Arguments Scope BigN.lt [bigN_scope bigN_scope]. -Arguments Scope BigN.le [bigN_scope bigN_scope]. -Arguments Scope BigN.eq [bigN_scope bigN_scope]. -Arguments Scope BigN.compare [bigN_scope bigN_scope]. -Arguments Scope BigN.min [bigN_scope bigN_scope]. -Arguments Scope BigN.max [bigN_scope bigN_scope]. -Arguments Scope BigN.eq_bool [bigN_scope bigN_scope]. -Arguments Scope BigN.power_pos [bigN_scope positive_scope]. -Arguments Scope BigN.power [bigN_scope N_scope]. -Arguments Scope BigN.sqrt [bigN_scope]. -Arguments Scope BigN.div_eucl [bigN_scope bigN_scope]. -Arguments Scope BigN.modulo [bigN_scope bigN_scope]. -Arguments Scope BigN.gcd [bigN_scope bigN_scope]. +Local Open Scope bigN_scope. +Notation bigN := BigN.t. +Bind Scope bigN_scope with bigN BigN.t BigN.t'. +Arguments BigN.N0 _%int31. Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *) Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *) +Local Notation "2" := BigN.two : bigN_scope. (* temporary notation *) Infix "+" := BigN.add : bigN_scope. Infix "-" := BigN.sub : bigN_scope. Infix "*" := BigN.mul : bigN_scope. Infix "/" := BigN.div : bigN_scope. -Infix "^" := BigN.power : bigN_scope. +Infix "^" := BigN.pow : bigN_scope. Infix "?=" := BigN.compare : bigN_scope. +Infix "=?" := BigN.eqb (at level 70, no associativity) : bigN_scope. +Infix "<=?" := BigN.leb (at level 70, no associativity) : bigN_scope. +Infix "<?" := BigN.ltb (at level 70, no associativity) : bigN_scope. Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope. -Notation "x != y" := (~x==y)%bigN (at level 70, no associativity) : bigN_scope. +Notation "x != y" := (~x==y) (at level 70, no associativity) : bigN_scope. Infix "<" := BigN.lt : bigN_scope. Infix "<=" := BigN.le : bigN_scope. -Notation "x > y" := (BigN.lt y x)(only parsing) : bigN_scope. -Notation "x >= y" := (BigN.le y x)(only parsing) : bigN_scope. -Notation "x < y < z" := (x<y /\ y<z)%bigN : bigN_scope. -Notation "x < y <= z" := (x<y /\ y<=z)%bigN : bigN_scope. -Notation "x <= y < z" := (x<=y /\ y<z)%bigN : bigN_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z)%bigN : bigN_scope. +Notation "x > y" := (y < x) (only parsing) : bigN_scope. +Notation "x >= y" := (y <= x) (only parsing) : bigN_scope. +Notation "x < y < z" := (x<y /\ y<z) : bigN_scope. +Notation "x < y <= z" := (x<y /\ y<=z) : bigN_scope. +Notation "x <= y < z" := (x<=y /\ y<z) : bigN_scope. +Notation "x <= y <= z" := (x<=y /\ y<=z) : bigN_scope. Notation "[ i ]" := (BigN.to_Z i) : bigN_scope. Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope. -Local Open Scope bigN_scope. - (** Example of reasoning about [BigN] *) Theorem succ_pred: forall q : bigN, @@ -107,24 +97,24 @@ exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm. exact BigN.mul_assoc. exact BigN.mul_add_distr_r. Qed. -Lemma BigNeqb_correct : forall x y, BigN.eq_bool x y = true -> x==y. +Lemma BigNeqb_correct : forall x y, (x =? y) = true -> x==y. Proof. now apply BigN.eqb_eq. Qed. -Lemma BigNpower : power_theory 1 BigN.mul BigN.eq (@id N) BigN.power. +Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow. Proof. constructor. -intros. red. rewrite BigN.spec_power. unfold id. -destruct Zpower_theory as [EQ]. rewrite EQ. +intros. red. rewrite BigN.spec_pow, BigN.spec_of_N. +rewrite Zpower_theory.(rpow_pow_N). destruct n; simpl. reflexivity. induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto. Qed. Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _) - (fun a b => if BigN.eq_bool b 0 then (0,a) else BigN.div_eucl a b). + (fun a b => if b =? 0 then (0,a) else BigN.div_eucl a b). Proof. constructor. unfold id. intros a b. BigN.zify. -generalize (Zeq_bool_if [b] 0); destruct (Zeq_bool [b] 0). +case Z.eqb_spec. BigN.zify. auto with zarith. intros NEQ. generalize (BigN.spec_div_eucl a b). @@ -163,6 +153,7 @@ Ltac isBigNcst t := end | BigN.zero => constr:true | BigN.one => constr:true + | BigN.two => constr:true | _ => constr:false end. @@ -172,6 +163,12 @@ Ltac BigNcst t := | false => constr:NotConstant end. +Ltac BigN_to_N t := + match isBigNcst t with + | true => eval vm_compute in (BigN.to_N t) + | false => constr:NotConstant + end. + Ltac Ncst t := match isNcst t with | true => constr:t @@ -183,11 +180,11 @@ Ltac Ncst t := Add Ring BigNr : BigNring (decidable BigNeqb_correct, constants [BigNcst], - power_tac BigNpower [Ncst], + power_tac BigNpower [BigN_to_N], div BigNdiv). Section TestRing. -Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. +Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. intros. ring_simplify. reflexivity. Qed. End TestRing. diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v index 2b70f1bb..952f6183 100644 --- a/theories/Numbers/Natural/BigN/NMake.v +++ b/theories/Numbers/Natural/BigN/NMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,18 +16,176 @@ representation. The representation-dependent (and macro-generated) part is now in [NMake_gen]. *) -Require Import BigNumPrelude ZArith CyclicAxioms. -Require Import Nbasic Wf_nat StreamMemo NSig NMake_gen. +Require Import Bool BigNumPrelude ZArith Nnat Ndigits CyclicAxioms DoubleType + Nbasic Wf_nat StreamMemo NSig NMake_gen. -Module Make (Import W0:CyclicType) <: NType. +Module Make (W0:CyclicType) <: NType. - (** Macro-generated part *) + (** Let's include the macro-generated part. Even if we can't functorize + things (due to Eval red_t below), the rest of the module only uses + elements mentionned in interface [NAbstract]. *) Include NMake_gen.Make W0. + Open Scope Z_scope. + + Local Notation "[ x ]" := (to_Z x). + + Definition eq (x y : t) := [x] = [y]. + + Declare Reduction red_t := + lazy beta iota delta + [iter_t reduce same_level mk_t mk_t_S succ_t dom_t dom_op]. + + Ltac red_t := + match goal with |- ?u => let v := (eval red_t in u) in change v end. + + (** * Generic results *) + + Tactic Notation "destr_t" constr(x) "as" simple_intropattern(pat) := + destruct (destr_t x) as pat; cbv zeta; + rewrite ?iter_mk_t, ?spec_mk_t, ?spec_reduce. + + Lemma spec_same_level : forall A (P:Z->Z->A->Prop) + (f : forall n, dom_t n -> dom_t n -> A), + (forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)) -> + forall x y, P [x] [y] (same_level f x y). + Proof. + intros. apply spec_same_level_dep with (P:=fun _ => P); auto. + Qed. + + Theorem spec_pos: forall x, 0 <= [x]. + Proof. + intros x. destr_t x as (n,x). now case (ZnZ.spec_to_Z x). + Qed. + + Lemma digits_dom_op_incr : forall n m, (n<=m)%nat -> + (ZnZ.digits (dom_op n) <= ZnZ.digits (dom_op m))%positive. + Proof. + intros. + change (Zpos (ZnZ.digits (dom_op n)) <= Zpos (ZnZ.digits (dom_op m))). + rewrite !digits_dom_op, !Pshiftl_nat_Zpower. + apply Zmult_le_compat_l; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. + Qed. + + Definition to_N (x : t) := Z.to_N (to_Z x). + + (** * Zero, One *) + + Definition zero := mk_t O ZnZ.zero. + Definition one := mk_t O ZnZ.one. + + Theorem spec_0: [zero] = 0. + Proof. + unfold zero. rewrite spec_mk_t. exact ZnZ.spec_0. + Qed. + + Theorem spec_1: [one] = 1. + Proof. + unfold one. rewrite spec_mk_t. exact ZnZ.spec_1. + Qed. + + (** * Successor *) + + (** NB: it is crucial here and for the rest of this file to preserve + the let-in's. They allow to pre-compute once and for all the + field access to Z/nZ initial structures (when n=0..6). *) + + Local Notation succn := (fun n => + let op := dom_op n in + let succ_c := ZnZ.succ_c in + let one := ZnZ.one in + fun x => match succ_c x with + | C0 r => mk_t n r + | C1 r => mk_t_S n (WW one r) + end). + + Definition succ : t -> t := Eval red_t in iter_t succn. + + Lemma succ_fold : succ = iter_t succn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_succ: forall n, [succ n] = [n] + 1. + Proof. + intros x. rewrite succ_fold. destr_t x as (n,x). + generalize (ZnZ.spec_succ_c x); case ZnZ.succ_c. + intros. rewrite spec_mk_t. assumption. + intros. unfold interp_carry in *. + rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_1. assumption. + Qed. + + (** Two *) + + (** Not really pretty, but since W0 might be Z/2Z, we're not sure + there's a proper 2 there. *) + + Definition two := succ one. + + Lemma spec_2 : [two] = 2. + Proof. + unfold two. now rewrite spec_succ, spec_1. + Qed. + + (** * Addition *) + + Local Notation addn := (fun n => + let op := dom_op n in + let add_c := ZnZ.add_c in + let one := ZnZ.one in + fun x y =>match add_c x y with + | C0 r => mk_t n r + | C1 r => mk_t_S n (WW one r) + end). + + Definition add : t -> t -> t := Eval red_t in same_level addn. + + Lemma add_fold : add = same_level addn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_add: forall x y, [add x y] = [x] + [y]. + Proof. + intros x y. rewrite add_fold. apply spec_same_level; clear x y. + intros n x y. simpl. + generalize (ZnZ.spec_add_c x y); case ZnZ.add_c; intros z H. + rewrite spec_mk_t. assumption. + rewrite spec_mk_t_S. unfold interp_carry in H. + simpl. rewrite ZnZ.spec_1. assumption. + Qed. (** * Predecessor *) + Local Notation predn := (fun n => + let pred_c := ZnZ.pred_c in + fun x => match pred_c x with + | C0 r => reduce n r + | C1 _ => zero + end). + + Definition pred : t -> t := Eval red_t in iter_t predn. + + Lemma pred_fold : pred = iter_t predn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1. + Proof. + intros x. rewrite pred_fold. destr_t x as (n,x). intros H. + generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. + rewrite spec_reduce. assumption. + exfalso. unfold interp_carry in *. + generalize (ZnZ.spec_to_Z x) (ZnZ.spec_to_Z y); auto with zarith. + Qed. + + Theorem spec_pred0 : forall x, [x] = 0 -> [pred x] = 0. + Proof. + intros x. rewrite pred_fold. destr_t x as (n,x). intros H. + generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. + rewrite spec_reduce. + unfold interp_carry in H'. + generalize (ZnZ.spec_to_Z y); auto with zarith. + exact spec_0. + Qed. + Lemma spec_pred : forall x, [pred x] = Zmax 0 ([x]-1). Proof. intros. destruct (Zle_lt_or_eq _ _ (spec_pos x)). @@ -36,9 +194,42 @@ Module Make (Import W0:CyclicType) <: NType. rewrite <- H; apply spec_pred0; auto. Qed. - (** * Subtraction *) + Local Notation subn := (fun n => + let sub_c := ZnZ.sub_c in + fun x y => match sub_c x y with + | C0 r => reduce n r + | C1 r => zero + end). + + Definition sub : t -> t -> t := Eval red_t in same_level subn. + + Lemma sub_fold : sub = same_level subn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. + Proof. + intros x y. rewrite sub_fold. apply spec_same_level. clear x y. + intros n x y. simpl. + generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. + rewrite spec_reduce. assumption. + unfold interp_carry in H. + exfalso. + generalize (ZnZ.spec_to_Z z); auto with zarith. + Qed. + + Theorem spec_sub0 : forall x y, [x] < [y] -> [sub x y] = 0. + Proof. + intros x y. rewrite sub_fold. apply spec_same_level. clear x y. + intros n x y. simpl. + generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. + rewrite spec_reduce. + unfold interp_carry in H. + generalize (ZnZ.spec_to_Z z); auto with zarith. + exact spec_0. + Qed. + Lemma spec_sub : forall x y, [sub x y] = Zmax 0 ([x]-[y]). Proof. intros. destruct (Zle_or_lt [y] [x]). @@ -48,35 +239,112 @@ Module Make (Import W0:CyclicType) <: NType. (** * Comparison *) - Theorem spec_compare : forall x y, compare x y = Zcompare [x] [y]. + Definition comparen_m n : + forall m, word (dom_t n) (S m) -> dom_t n -> comparison := + let op := dom_op n in + let zero := @ZnZ.zero _ op in + let compare := @ZnZ.compare _ op in + let compare0 := compare zero in + fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). + + Let spec_comparen_m: + forall n m (x : word (dom_t n) (S m)) (y : dom_t n), + comparen_m n m x y = Zcompare (eval n (S m) x) (ZnZ.to_Z y). + Proof. + intros n m x y. + unfold comparen_m, eval. + rewrite nmake_double. + apply spec_compare_mn_1. + exact ZnZ.spec_0. + intros. apply ZnZ.spec_compare. + exact ZnZ.spec_to_Z. + exact ZnZ.spec_compare. + exact ZnZ.spec_compare. + exact ZnZ.spec_to_Z. + Qed. + + Definition comparenm n m wx wy := + let mn := Max.max n m in + let d := diff n m in + let op := make_op mn in + ZnZ.compare + (castm (diff_r n m) (extend_tr wx (snd d))) + (castm (diff_l n m) (extend_tr wy (fst d))). + + Local Notation compare_folded := + (iter_sym _ + (fun n => @ZnZ.compare _ (dom_op n)) + comparen_m + comparenm + CompOpp). + + Definition compare : t -> t -> comparison := + Eval lazy beta iota delta [iter_sym dom_op dom_t comparen_m] in + compare_folded. + + Lemma compare_fold : compare = compare_folded. Proof. - intros x y. generalize (spec_compare_aux x y); destruct compare; - intros; symmetry; try rewrite Zcompare_Eq_iff_eq; assumption. + lazy beta iota delta [iter_sym dom_op dom_t comparen_m]. reflexivity. Qed. - Definition eq_bool x y := +(** TODO: no need for ZnZ.Spec_rect , Spec_ind, and so on... *) + + Theorem spec_compare : forall x y, + compare x y = Zcompare [x] [y]. + Proof. + intros x y. rewrite compare_fold. apply spec_iter_sym; clear x y. + intros. apply ZnZ.spec_compare. + intros. cbv beta zeta. apply spec_comparen_m. + intros n m x y; unfold comparenm. + rewrite (spec_cast_l n m x), (spec_cast_r n m y). + unfold to_Z; apply ZnZ.spec_compare. + intros. subst. apply Zcompare_antisym. + Qed. + + Definition eqb (x y : t) : bool := match compare x y with | Eq => true | _ => false end. - Theorem spec_eq_bool : forall x y, eq_bool x y = Zeq_bool [x] [y]. + Theorem spec_eqb x y : eqb x y = Z.eqb [x] [y]. Proof. - intros. unfold eq_bool, Zeq_bool. rewrite spec_compare; reflexivity. + apply eq_iff_eq_true. + unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. + split; [now destruct Z.compare | now intros ->]. Qed. - Theorem spec_eq_bool_aux: forall x y, - if eq_bool x y then [x] = [y] else [x] <> [y]. + Definition lt (n m : t) := [n] < [m]. + Definition le (n m : t) := [n] <= [m]. + + Definition ltb (x y : t) : bool := + match compare x y with + | Lt => true + | _ => false + end. + + Theorem spec_ltb x y : ltb x y = Z.ltb [x] [y]. Proof. - intros x y; unfold eq_bool. - generalize (spec_compare_aux x y); case compare; auto with zarith. + apply eq_iff_eq_true. + rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. + split; [now destruct Z.compare | now intros ->]. Qed. - Definition lt n m := [n] < [m]. - Definition le n m := [n] <= [m]. + Definition leb (x y : t) : bool := + match compare x y with + | Gt => false + | _ => true + end. + + Theorem spec_leb x y : leb x y = Z.leb [x] [y]. + Proof. + apply eq_iff_eq_true. + rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. + destruct Z.compare; split; try easy. now destruct 1. + Qed. - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. + Definition min (n m : t) : t := match compare n m with Gt => m | _ => n end. + Definition max (n m : t) : t := match compare n m with Lt => m | _ => n end. Theorem spec_max : forall n m, [max n m] = Zmax [n] [m]. Proof. @@ -88,46 +356,239 @@ Module Make (Import W0:CyclicType) <: NType. intros. unfold min, Zmin. rewrite spec_compare; destruct Zcompare; reflexivity. Qed. + (** * Multiplication *) + + Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := + let op := dom_op n in + let zero := @ZnZ.zero _ op in + let succ := @ZnZ.succ _ op in + let add_c := @ZnZ.add_c _ op in + let mul_c := @ZnZ.mul_c _ op in + let ww := @ZnZ.WW _ op in + let ow := @ZnZ.OW _ op in + let eq0 := @ZnZ.eq0 _ op in + let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in + let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in + fun m x y => + let (w,r) := mul_add_n1 (S m) x y zero in + if eq0 w then mk_t_w' n m r + else mk_t_w' n (S m) (WW (extend n m w) r). + + Definition mulnm n m x y := + let mn := Max.max n m in + let d := diff n m in + let op := make_op mn in + reduce_n (S mn) (ZnZ.mul_c + (castm (diff_r n m) (extend_tr x (snd d))) + (castm (diff_l n m) (extend_tr y (fst d)))). + + Local Notation mul_folded := + (iter_sym _ + (fun n => let mul_c := ZnZ.mul_c in + fun x y => reduce (S n) (succ_t _ (mul_c x y))) + wn_mul + mulnm + (fun x => x)). + + Definition mul : t -> t -> t := + Eval lazy beta iota delta + [iter_sym dom_op dom_t reduce succ_t extend zeron + wn_mul DoubleMul.w_mul_add mk_t_w'] in + mul_folded. + + Lemma mul_fold : mul = mul_folded. + Proof. + lazy beta iota delta + [iter_sym dom_op dom_t reduce succ_t extend zeron + wn_mul DoubleMul.w_mul_add mk_t_w']. reflexivity. + Qed. - (** * Power *) + Lemma spec_muln: + forall n (x: word _ (S n)) y, + [Nn (S n) (ZnZ.mul_c (Ops:=make_op n) x y)] = [Nn n x] * [Nn n y]. + Proof. + intros n x y; unfold to_Z. + rewrite <- ZnZ.spec_mul_c. + rewrite make_op_S. + case ZnZ.mul_c; auto. + Qed. - Fixpoint power_pos (x:t) (p:positive) {struct p} : t := - match p with - | xH => x - | xO p => square (power_pos x p) - | xI p => mul (square (power_pos x p)) x - end. + Lemma spec_mul_add_n1: forall n m x y z, + let (q,r) := DoubleMul.double_mul_add_n1 ZnZ.zero ZnZ.WW ZnZ.OW + (DoubleMul.w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c) + (S m) x y z in + ZnZ.to_Z q * (base (ZnZ.digits (nmake_op _ (dom_op n) (S m)))) + + eval n (S m) r = + eval n (S m) x * ZnZ.to_Z y + ZnZ.to_Z z. + Proof. + intros n m x y z. + rewrite digits_nmake. + unfold eval. rewrite nmake_double. + apply DoubleMul.spec_double_mul_add_n1. + apply ZnZ.spec_0. + exact ZnZ.spec_WW. + exact ZnZ.spec_OW. + apply DoubleCyclic.spec_mul_add. + Qed. - Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + Lemma spec_wn_mul : forall n m x y, + [wn_mul n m x y] = (eval n (S m) x) * ZnZ.to_Z y. Proof. - intros x n; generalize x; elim n; clear n x; simpl power_pos. - intros; rewrite spec_mul; rewrite spec_square; rewrite H. - rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith. - rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. - rewrite Zpower_2; rewrite Zpower_1_r; auto. - intros; rewrite spec_square; rewrite H. - rewrite Zpos_xO; auto with zarith. - rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. - rewrite Zpower_2; auto. - intros; rewrite Zpower_1_r; auto. + intros; unfold wn_mul. + generalize (spec_mul_add_n1 n m x y ZnZ.zero). + case DoubleMul.double_mul_add_n1; intros q r Hqr. + rewrite ZnZ.spec_0, Zplus_0_r in Hqr. rewrite <- Hqr. + generalize (ZnZ.spec_eq0 q); case ZnZ.eq0; intros HH. + rewrite HH; auto. simpl. apply spec_mk_t_w'. + clear. + rewrite spec_mk_t_w'. + set (m' := S m) in *. + unfold eval. + rewrite nmake_WW. f_equal. f_equal. + rewrite <- spec_mk_t. + symmetry. apply spec_extend. Qed. - Definition power x (n:N) := match n with - | BinNat.N0 => one - | BinNat.Npos p => power_pos x p - end. + Theorem spec_mul : forall x y, [mul x y] = [x] * [y]. + Proof. + intros x y. rewrite mul_fold. apply spec_iter_sym; clear x y. + intros n x y. cbv zeta beta. + rewrite spec_reduce, spec_succ_t, <- ZnZ.spec_mul_c; auto. + apply spec_wn_mul. + intros n m x y; unfold mulnm. rewrite spec_reduce_n. + rewrite (spec_cast_l n m x), (spec_cast_r n m y). + apply spec_muln. + intros. rewrite Zmult_comm; auto. + Qed. - Theorem spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. + (** * Division by a smaller number *) + + Definition wn_divn1 n := + let op := dom_op n in + let zd := ZnZ.zdigits op in + let zero := @ZnZ.zero _ op in + let ww := @ZnZ.WW _ op in + let head0 := @ZnZ.head0 _ op in + let add_mul_div := @ZnZ.add_mul_div _ op in + let div21 := @ZnZ.div21 _ op in + let compare := @ZnZ.compare _ op in + let sub := @ZnZ.sub _ op in + let ddivn1 := + DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in + fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). + + Let div_gtnm n m wx wy := + let mn := Max.max n m in + let d := diff n m in + let op := make_op mn in + let (q, r):= ZnZ.div_gt + (castm (diff_r n m) (extend_tr wx (snd d))) + (castm (diff_l n m) (extend_tr wy (fst d))) in + (reduce_n mn q, reduce_n mn r). + + Local Notation div_gt_folded := + (iter _ + (fun n => let div_gt := ZnZ.div_gt in + fun x y => let (u,v) := div_gt x y in (reduce n u, reduce n v)) + (fun n => + let div_gt := ZnZ.div_gt in + fun m x y => + let y' := DoubleBase.get_low (zeron n) (S m) y in + let (u,v) := div_gt x y' in (reduce n u, reduce n v)) + wn_divn1 + div_gtnm). + + Definition div_gt := + Eval lazy beta iota delta + [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t] in + div_gt_folded. + + Lemma div_gt_fold : div_gt = div_gt_folded. Proof. - destruct n; simpl. apply (spec_1 w0_spec). - apply spec_power_pos. + lazy beta iota delta [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t]. + reflexivity. Qed. + Lemma spec_get_endn: forall n m x y, + eval n m x <= [mk_t n y] -> + [mk_t n (DoubleBase.get_low (zeron n) m x)] = eval n m x. + Proof. + intros n m x y H. + unfold eval. rewrite nmake_double. + rewrite spec_mk_t in *. + apply DoubleBase.spec_get_low. + apply spec_zeron. + exact ZnZ.spec_to_Z. + apply Zle_lt_trans with (ZnZ.to_Z y); auto. + rewrite <- nmake_double; auto. + case (ZnZ.spec_to_Z y); auto. + Qed. - (** * Div *) + Let spec_divn1 n := + DoubleDivn1.spec_double_divn1 + (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) + ZnZ.WW ZnZ.head0 + ZnZ.add_mul_div ZnZ.div21 + ZnZ.compare ZnZ.sub ZnZ.to_Z + ZnZ.spec_to_Z + ZnZ.spec_zdigits + ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 + ZnZ.spec_add_mul_div ZnZ.spec_div21 + ZnZ.spec_compare ZnZ.spec_sub. + + Lemma spec_div_gt_aux : forall x y, [x] > [y] -> 0 < [y] -> + let (q,r) := div_gt x y in + [x] = [q] * [y] + [r] /\ 0 <= [r] < [y]. + Proof. + intros x y. rewrite div_gt_fold. apply spec_iter; clear x y. + intros n x y H1 H2. simpl. + generalize (ZnZ.spec_div_gt x y H1 H2); case ZnZ.div_gt. + intros u v. rewrite 2 spec_reduce. auto. + intros n m x y H1 H2. cbv zeta beta. + generalize (ZnZ.spec_div_gt x + (DoubleBase.get_low (zeron n) (S m) y)). + case ZnZ.div_gt. + intros u v H3; repeat rewrite spec_reduce. + generalize (spec_get_endn n (S m) y x). rewrite !spec_mk_t. intros H4. + rewrite H4 in H3; auto with zarith. + intros n m x y H1 H2. + generalize (spec_divn1 n (S m) x y H2). + unfold wn_divn1; case DoubleDivn1.double_divn1. + intros u v H3. + rewrite spec_mk_t_w', spec_mk_t. + rewrite <- !nmake_double in H3; auto. + intros n m x y H1 H2; unfold div_gtnm. + generalize (ZnZ.spec_div_gt + (castm (diff_r n m) + (extend_tr x (snd (diff n m)))) + (castm (diff_l n m) + (extend_tr y (fst (diff n m))))). + case ZnZ.div_gt. + intros xx yy HH. + repeat rewrite spec_reduce_n. + rewrite (spec_cast_l n m x), (spec_cast_r n m y). + unfold to_Z; apply HH. + rewrite (spec_cast_l n m x) in H1; auto. + rewrite (spec_cast_r n m y) in H1; auto. + rewrite (spec_cast_r n m y) in H2; auto. + Qed. + + Theorem spec_div_gt: forall x y, [x] > [y] -> 0 < [y] -> + let (q,r) := div_gt x y in + [q] = [x] / [y] /\ [r] = [x] mod [y]. + Proof. + intros x y H1 H2; generalize (spec_div_gt_aux x y H1 H2); case div_gt. + intros q r (H3, H4); split. + apply (Zdiv_unique [x] [y] [q] [r]); auto. + rewrite Zmult_comm; auto. + apply (Zmod_unique [x] [y] [q] [r]); auto. + rewrite Zmult_comm; auto. + Qed. - Definition div_eucl x y := - if eq_bool y zero then (zero,zero) else + (** * General Division *) + + Definition div_eucl (x y : t) : t * t := + if eqb y zero then (zero,zero) else match compare x y with | Eq => (one, zero) | Lt => (zero, x) @@ -138,32 +599,27 @@ Module Make (Import W0:CyclicType) <: NType. let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. Proof. - assert (F0: [zero] = 0). - exact (spec_0 w0_spec). - assert (F1: [one] = 1). - exact (spec_1 w0_spec). intros x y. unfold div_eucl. - generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0. - intro H. rewrite H. destruct [x]; auto. - intro H'. - assert (0 < [y]) by (generalize (spec_pos y); auto with zarith). + rewrite spec_eqb, spec_compare, spec_0. + case Z.eqb_spec. + intros ->. rewrite spec_0. destruct [x]; auto. + intros H'. + assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). clear H'. - generalize (spec_compare_aux x y); case compare; try rewrite F0; - try rewrite F1; intros; auto with zarith. - rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H)) - (Z_mod_same [y] (Zlt_gt _ _ H)); + case Zcompare_spec; intros Cmp; + rewrite ?spec_0, ?spec_1; intros; auto with zarith. + rewrite Cmp; generalize (Z_div_same [y] (Zlt_gt _ _ H)) + (Z_mod_same [y] (Zlt_gt _ _ H)); unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. - assert (F2: 0 <= [x] < [y]). - generalize (spec_pos x); auto. - generalize (Zdiv_small _ _ F2) - (Zmod_small _ _ F2); + assert (LeLt: 0 <= [x] < [y]) by (generalize (spec_pos x); auto). + generalize (Zdiv_small _ _ LeLt) (Zmod_small _ _ LeLt); unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. - generalize (spec_div_gt _ _ H0 H); auto. + generalize (spec_div_gt _ _ (Zlt_gt _ _ Cmp) H); auto. unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt. intros a b c d (H1, H2); subst; auto. Qed. - Definition div x y := fst (div_eucl x y). + Definition div (x y : t) : t := fst (div_eucl x y). Theorem spec_div: forall x y, [div x y] = [x] / [y]. @@ -174,11 +630,90 @@ Module Make (Import W0:CyclicType) <: NType. injection H; auto. Qed. + (** * Modulo by a smaller number *) + + Definition wn_modn1 n := + let op := dom_op n in + let zd := ZnZ.zdigits op in + let zero := @ZnZ.zero _ op in + let head0 := @ZnZ.head0 _ op in + let add_mul_div := @ZnZ.add_mul_div _ op in + let div21 := @ZnZ.div21 _ op in + let compare := @ZnZ.compare _ op in + let sub := @ZnZ.sub _ op in + let dmodn1 := + DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in + fun m x y => reduce n (dmodn1 (S m) x y). + + Let mod_gtnm n m wx wy := + let mn := Max.max n m in + let d := diff n m in + let op := make_op mn in + reduce_n mn (ZnZ.modulo_gt + (castm (diff_r n m) (extend_tr wx (snd d))) + (castm (diff_l n m) (extend_tr wy (fst d)))). + + Local Notation mod_gt_folded := + (iter _ + (fun n => let modulo_gt := ZnZ.modulo_gt in + fun x y => reduce n (modulo_gt x y)) + (fun n => let modulo_gt := ZnZ.modulo_gt in + fun m x y => + reduce n (modulo_gt x (DoubleBase.get_low (zeron n) (S m) y))) + wn_modn1 + mod_gtnm). + + Definition mod_gt := + Eval lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron] in + mod_gt_folded. + + Lemma mod_gt_fold : mod_gt = mod_gt_folded. + Proof. + lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron]. + reflexivity. + Qed. + + Let spec_modn1 n := + DoubleDivn1.spec_double_modn1 + (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) + ZnZ.WW ZnZ.head0 + ZnZ.add_mul_div ZnZ.div21 + ZnZ.compare ZnZ.sub ZnZ.to_Z + ZnZ.spec_to_Z + ZnZ.spec_zdigits + ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 + ZnZ.spec_add_mul_div ZnZ.spec_div21 + ZnZ.spec_compare ZnZ.spec_sub. + + Theorem spec_mod_gt: + forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y]. + Proof. + intros x y. rewrite mod_gt_fold. apply spec_iter; clear x y. + intros n x y H1 H2. simpl. rewrite spec_reduce. + exact (ZnZ.spec_modulo_gt x y H1 H2). + intros n m x y H1 H2. cbv zeta beta. rewrite spec_reduce. + rewrite <- spec_mk_t in H1. + rewrite <- (spec_get_endn n (S m) y x); auto with zarith. + rewrite spec_mk_t. + apply ZnZ.spec_modulo_gt; auto. + rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H1; auto with zarith. + rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H2; auto with zarith. + intros n m x y H1 H2. unfold wn_modn1. rewrite spec_reduce. + unfold eval; rewrite nmake_double. + apply (spec_modn1 n); auto. + intros n m x y H1 H2; unfold mod_gtnm. + repeat rewrite spec_reduce_n. + rewrite (spec_cast_l n m x), (spec_cast_r n m y). + unfold to_Z; apply ZnZ.spec_modulo_gt. + rewrite (spec_cast_l n m x) in H1; auto. + rewrite (spec_cast_r n m y) in H1; auto. + rewrite (spec_cast_r n m y) in H2; auto. + Qed. - (** * Modulo *) + (** * General Modulo *) - Definition modulo x y := - if eq_bool y zero then zero else + Definition modulo (x y : t) : t := + if eqb y zero then zero else match compare x y with | Eq => zero | Lt => x @@ -188,24 +723,129 @@ Module Make (Import W0:CyclicType) <: NType. Theorem spec_modulo: forall x y, [modulo x y] = [x] mod [y]. Proof. - assert (F0: [zero] = 0). - exact (spec_0 w0_spec). - assert (F1: [one] = 1). - exact (spec_1 w0_spec). intros x y. unfold modulo. - generalize (spec_eq_bool_aux y zero). destruct eq_bool; rewrite F0. - intro H; rewrite H. destruct [x]; auto. + rewrite spec_eqb, spec_compare, spec_0. + case Z.eqb_spec. + intros ->; rewrite spec_0. destruct [x]; auto. intro H'. assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). clear H'. - generalize (spec_compare_aux x y); case compare; try rewrite F0; - try rewrite F1; intros; try split; auto with zarith. + case Zcompare_spec; + rewrite ?spec_0, ?spec_1; intros; try split; auto with zarith. rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith. apply sym_equal; apply Zmod_small; auto with zarith. generalize (spec_pos x); auto with zarith. - apply spec_mod_gt; auto. + apply spec_mod_gt; auto with zarith. + Qed. + + (** * Square *) + + Local Notation squaren := (fun n => + let square_c := ZnZ.square_c in + fun x => reduce (S n) (succ_t _ (square_c x))). + + Definition square : t -> t := Eval red_t in iter_t squaren. + + Lemma square_fold : square = iter_t squaren. + Proof. red_t; reflexivity. Qed. + + Theorem spec_square: forall x, [square x] = [x] * [x]. + Proof. + intros x. rewrite square_fold. destr_t x as (n,x). + rewrite spec_succ_t. exact (ZnZ.spec_square_c x). + Qed. + + (** * Square Root *) + + Local Notation sqrtn := (fun n => + let sqrt := ZnZ.sqrt in + fun x => reduce n (sqrt x)). + + Definition sqrt : t -> t := Eval red_t in iter_t sqrtn. + + Lemma sqrt_fold : sqrt = iter_t sqrtn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_sqrt_aux: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + Proof. + intros x. rewrite sqrt_fold. destr_t x as (n,x). exact (ZnZ.spec_sqrt x). + Qed. + + Theorem spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. + Proof. + intros x. + symmetry. apply Z.sqrt_unique. + rewrite <- ! Zpower_2. apply spec_sqrt_aux. + Qed. + + (** * Power *) + + Fixpoint pow_pos (x:t)(p:positive) : t := + match p with + | xH => x + | xO p => square (pow_pos x p) + | xI p => mul (square (pow_pos x p)) x + end. + + Theorem spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. + Proof. + intros x n; generalize x; elim n; clear n x; simpl pow_pos. + intros; rewrite spec_mul; rewrite spec_square; rewrite H. + rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith. + rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. + rewrite Zpower_2; rewrite Zpower_1_r; auto. + intros; rewrite spec_square; rewrite H. + rewrite Zpos_xO; auto with zarith. + rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. + rewrite Zpower_2; auto. + intros; rewrite Zpower_1_r; auto. Qed. + Definition pow_N (x:t)(n:N) : t := match n with + | BinNat.N0 => one + | BinNat.Npos p => pow_pos x p + end. + + Theorem spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z_of_N n. + Proof. + destruct n; simpl. apply spec_1. + apply spec_pow_pos. + Qed. + + Definition pow (x y:t) : t := pow_N x (to_N y). + + Theorem spec_pow : forall x y, [pow x y] = [x] ^ [y]. + Proof. + intros. unfold pow, to_N. + now rewrite spec_pow_N, Z2N.id by apply spec_pos. + Qed. + + + (** * digits + + Number of digits in the representation of a numbers + (including head zero's). + NB: This function isn't a morphism for setoid [eq]. + *) + + Local Notation digitsn := (fun n => + let digits := ZnZ.digits (dom_op n) in + fun _ => digits). + + Definition digits : t -> positive := Eval red_t in iter_t digitsn. + + Lemma digits_fold : digits = iter_t digitsn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x). + Proof. + intros x. rewrite digits_fold. destr_t x as (n,x). exact (ZnZ.spec_to_Z x). + Qed. + + Lemma digits_level : forall x, digits x = ZnZ.digits (dom_op (level x)). + Proof. + intros x. rewrite digits_fold. unfold level. destr_t x as (n,x). reflexivity. + Qed. (** * Gcd *) @@ -226,15 +866,12 @@ Module Make (Import W0:CyclicType) <: NType. Zis_gcd [a1] [b1] [cont a1 b1]) -> Zis_gcd [a] [b] [gcd_gt_body a b cont]. Proof. - assert (F1: [zero] = 0). - unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. intros a b cont p H2 H3 H4; unfold gcd_gt_body. - generalize (spec_compare_aux b zero); case compare; try rewrite F1. - intros HH; rewrite HH; apply Zis_gcd_0. + rewrite ! spec_compare, spec_0. case Zcompare_spec. + intros ->; apply Zis_gcd_0. intros HH; absurd (0 <= [b]); auto with zarith. case (spec_digits b); auto with zarith. - intros H5; generalize (spec_compare_aux (mod_gt a b) zero); - case compare; try rewrite F1. + intros H5; case Zcompare_spec. intros H6; rewrite <- (Zmult_1_r [b]). rewrite (Z_div_mod_eq [a] [b]); auto with zarith. rewrite <- spec_mod_gt; auto with zarith. @@ -273,7 +910,7 @@ Module Make (Import W0:CyclicType) <: NType. intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith. Qed. - Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t := + Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) : t := gcd_gt_body a b (fun a b => match p with @@ -310,12 +947,7 @@ Module Make (Import W0:CyclicType) <: NType. (Zpos p + n - 1); auto with zarith. intros a3 b3 H12 H13; apply H4; auto with zarith. apply Zlt_le_trans with (1 := H12). - case (Zle_or_lt 1 n); intros HH. - apply Zpower_le_monotone; auto with zarith. - apply Zle_trans with 0; auto with zarith. - assert (HH1: n - 1 < 0); auto with zarith. - generalize HH1; case (n - 1); auto with zarith. - intros p1 HH2; discriminate. + apply Zpower_le_monotone2; auto with zarith. intros n a b cont H H2 H3. simpl gcd_gt_aux. apply Zspec_gcd_gt_body with (n + 1); auto with zarith. @@ -345,7 +977,7 @@ Module Make (Import W0:CyclicType) <: NType. intros; apply False_ind; auto with zarith. Qed. - Definition gcd a b := + Definition gcd (a b : t) : t := match compare a b with | Eq => a | Lt => gcd_gt b a @@ -357,7 +989,7 @@ Module Make (Import W0:CyclicType) <: NType. intros a b. case (spec_digits a); intros H1 H2. case (spec_digits b); intros H3 H4. - unfold gcd; generalize (spec_compare_aux a b); case compare. + unfold gcd. rewrite spec_compare. case Zcompare_spec. intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto. apply Zis_gcd_refl. intros; apply trans_equal with (Zgcd [b] [a]). @@ -365,13 +997,91 @@ Module Make (Import W0:CyclicType) <: NType. apply Zis_gcd_gcd; auto with zarith. apply Zgcd_is_pos. apply Zis_gcd_sym; apply Zgcd_is_gcd. - intros; apply spec_gcd_gt; auto. + intros; apply spec_gcd_gt; auto with zarith. + Qed. + + (** * Parity test *) + + Definition even : t -> bool := Eval red_t in + iter_t (fun n x => ZnZ.is_even x). + + Definition odd x := negb (even x). + + Lemma even_fold : even = iter_t (fun n x => ZnZ.is_even x). + Proof. red_t; reflexivity. Qed. + + Theorem spec_even_aux: forall x, + if even x then [x] mod 2 = 0 else [x] mod 2 = 1. + Proof. + intros x. rewrite even_fold. destr_t x as (n,x). + exact (ZnZ.spec_is_even x). + Qed. + + Theorem spec_even: forall x, even x = Zeven_bool [x]. + Proof. + intros x. assert (H := spec_even_aux x). symmetry. + rewrite (Z_div_mod_eq_full [x] 2); auto with zarith. + destruct (even x); rewrite H, ?Zplus_0_r. + rewrite Zeven_bool_iff. apply Zeven_2p. + apply not_true_is_false. rewrite Zeven_bool_iff. + apply Zodd_not_Zeven. apply Zodd_2p_plus_1. Qed. + Theorem spec_odd: forall x, odd x = Zodd_bool [x]. + Proof. + intros x. unfold odd. + assert (H := spec_even_aux x). symmetry. + rewrite (Z_div_mod_eq_full [x] 2); auto with zarith. + destruct (even x); rewrite H, ?Zplus_0_r; simpl negb. + apply not_true_is_false. rewrite Zodd_bool_iff. + apply Zeven_not_Zodd. apply Zeven_2p. + apply Zodd_bool_iff. apply Zodd_2p_plus_1. + Qed. (** * Conversion *) - Definition of_N x := + Definition pheight p := + Peano.pred (nat_of_P (get_height (ZnZ.digits (dom_op 0)) (plength p))). + + Theorem pheight_correct: forall p, + Zpos p < 2 ^ (Zpos (ZnZ.digits (dom_op 0)) * 2 ^ (Z_of_nat (pheight p))). + Proof. + intros p; unfold pheight. + assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1). + intros x. + assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith. + rewrite <- inj_S. + rewrite <- (fun x => S_pred x 0); auto with zarith. + rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto. + apply lt_le_trans with 1%nat; auto with zarith. + exact (le_Pmult_nat x 1). + rewrite F1; clear F1. + assert (F2:= (get_height_correct (ZnZ.digits (dom_op 0)) (plength p))). + apply Zlt_le_trans with (Zpos (Psucc p)). + rewrite Zpos_succ_morphism; auto with zarith. + apply Zle_trans with (1 := plength_pred_correct (Psucc p)). + rewrite Ppred_succ. + apply Zpower_le_monotone2; auto with zarith. + Qed. + + Definition of_pos (x:positive) : t := + let n := pheight x in + reduce n (snd (ZnZ.of_pos x)). + + Theorem spec_of_pos: forall x, + [of_pos x] = Zpos x. + Proof. + intros x; unfold of_pos. + rewrite spec_reduce. + simpl. + apply ZnZ.of_pos_correct. + unfold base. + apply Zlt_le_trans with (1 := pheight_correct x). + apply Zpower_le_monotone2; auto with zarith. + rewrite (digits_dom_op (_ _)), Pshiftl_nat_Zpower. auto with zarith. + Qed. + + Definition of_N (x:N) : t := match x with | BinNat.N0 => zero | Npos p => of_pos p @@ -381,51 +1091,437 @@ Module Make (Import W0:CyclicType) <: NType. [of_N x] = Z_of_N x. Proof. intros x; case x. - simpl of_N. - unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. + simpl of_N. exact spec_0. intros p; exact (spec_of_pos p). Qed. + (** * [head0] and [tail0] - (** * Shift *) + Number of zero at the beginning and at the end of + the representation of the number. + NB: these functions are not morphism for setoid [eq]. + *) - Definition shiftr n x := - match compare n (Ndigits x) with - | Lt => unsafe_shiftr n x - | _ => N0 w_0 - end. + Local Notation head0n := (fun n => + let head0 := ZnZ.head0 in + fun x => reduce n (head0 x)). + + Definition head0 : t -> t := Eval red_t in iter_t head0n. + + Lemma head0_fold : head0 = iter_t head0n. + Proof. red_t; reflexivity. Qed. + + Theorem spec_head00: forall x, [x] = 0 -> [head0 x] = Zpos (digits x). + Proof. + intros x. rewrite head0_fold, digits_fold. destr_t x as (n,x). + exact (ZnZ.spec_head00 x). + Qed. + + Lemma pow2_pos_minus_1 : forall z, 0<z -> 2^(z-1) = 2^z / 2. + Proof. + intros. apply Zdiv_unique with 0; auto with zarith. + change 2 with (2^1) at 2. + rewrite <- Zpower_exp; auto with zarith. + rewrite Zplus_0_r. f_equal. auto with zarith. + Qed. - Theorem spec_shiftr: forall n x, - [shiftr n x] = [x] / 2 ^ [n]. - Proof. - intros n x; unfold shiftr; - generalize (spec_compare_aux n (Ndigits x)); case compare; intros H. - apply trans_equal with (1 := spec_0 w0_spec). - apply sym_equal; apply Zdiv_small; rewrite H. - rewrite spec_Ndigits; exact (spec_digits x). - rewrite <- spec_unsafe_shiftr; auto with zarith. - apply trans_equal with (1 := spec_0 w0_spec). - apply sym_equal; apply Zdiv_small. - rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2. - split; auto. - apply Zlt_le_trans with (1 := H2). - apply Zpower_le_monotone; auto with zarith. - Qed. - - Definition shiftl_aux_body cont n x := - match compare n (head0 x) with - Gt => cont n (double_size x) - | _ => unsafe_shiftl n x + Theorem spec_head0: forall x, 0 < [x] -> + 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x). + Proof. + intros x. rewrite pow2_pos_minus_1 by (red; auto). + rewrite head0_fold, digits_fold. destr_t x as (n,x). exact (ZnZ.spec_head0 x). + Qed. + + Local Notation tail0n := (fun n => + let tail0 := ZnZ.tail0 in + fun x => reduce n (tail0 x)). + + Definition tail0 : t -> t := Eval red_t in iter_t tail0n. + + Lemma tail0_fold : tail0 = iter_t tail0n. + Proof. red_t; reflexivity. Qed. + + Theorem spec_tail00: forall x, [x] = 0 -> [tail0 x] = Zpos (digits x). + Proof. + intros x. rewrite tail0_fold, digits_fold. destr_t x as (n,x). + exact (ZnZ.spec_tail00 x). + Qed. + + Theorem spec_tail0: forall x, + 0 < [x] -> exists y, 0 <= y /\ [x] = (2 * y + 1) * 2 ^ [tail0 x]. + Proof. + intros x. rewrite tail0_fold. destr_t x as (n,x). exact (ZnZ.spec_tail0 x). + Qed. + + (** * [Ndigits] + + Same as [digits] but encoded using large integers + NB: this function is not a morphism for setoid [eq]. + *) + + Local Notation Ndigitsn := (fun n => + let d := reduce n (ZnZ.zdigits (dom_op n)) in + fun _ => d). + + Definition Ndigits : t -> t := Eval red_t in iter_t Ndigitsn. + + Lemma Ndigits_fold : Ndigits = iter_t Ndigitsn. + Proof. red_t; reflexivity. Qed. + + Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x). + Proof. + intros x. rewrite Ndigits_fold, digits_fold. destr_t x as (n,x). + apply ZnZ.spec_zdigits. + Qed. + + (** * Binary logarithm *) + + Local Notation log2n := (fun n => + let op := dom_op n in + let zdigits := ZnZ.zdigits op in + let head0 := ZnZ.head0 in + let sub_carry := ZnZ.sub_carry in + fun x => reduce n (sub_carry zdigits (head0 x))). + + Definition log2 : t -> t := Eval red_t in + let log2 := iter_t log2n in + fun x => if eqb x zero then zero else log2 x. + + Lemma log2_fold : + log2 = fun x => if eqb x zero then zero else iter_t log2n x. + Proof. red_t; reflexivity. Qed. + + Lemma spec_log2_0 : forall x, [x] = 0 -> [log2 x] = 0. + Proof. + intros x H. rewrite log2_fold. + rewrite spec_eqb, H. rewrite spec_0. simpl. exact spec_0. + Qed. + + Lemma head0_zdigits : forall n (x : dom_t n), + 0 < ZnZ.to_Z x -> + ZnZ.to_Z (ZnZ.head0 x) < ZnZ.to_Z (ZnZ.zdigits (dom_op n)). + Proof. + intros n x H. + destruct (ZnZ.spec_head0 x H) as (_,H0). + intros. + assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). + assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). + unfold base in *. + rewrite ZnZ.spec_zdigits in H2 |- *. + set (h := ZnZ.to_Z (ZnZ.head0 x)) in *; clearbody h. + set (d := ZnZ.digits (dom_op n)) in *; clearbody d. + destruct (Z_lt_le_dec h (Zpos d)); auto. exfalso. + assert (1 * 2^Zpos d <= ZnZ.to_Z x * 2^h). + apply Zmult_le_compat; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. + rewrite Zmult_comm in H0. auto with zarith. + Qed. + + Lemma spec_log2_pos : forall x, [x]<>0 -> + 2^[log2 x] <= [x] < 2^([log2 x]+1). + Proof. + intros x H. rewrite log2_fold. + rewrite spec_eqb. rewrite spec_0. + case Z.eqb_spec. + auto with zarith. + clear H. + destr_t x as (n,x). intros H. + rewrite ZnZ.spec_sub_carry. + assert (H0 := ZnZ.spec_to_Z x). + assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). + assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). + assert (H3 := head0_zdigits n x). + rewrite Zmod_small by auto with zarith. + rewrite (Z.mul_lt_mono_pos_l (2^(ZnZ.to_Z (ZnZ.head0 x)))); + auto with zarith. + rewrite (Z.mul_le_mono_pos_l _ _ (2^(ZnZ.to_Z (ZnZ.head0 x)))); + auto with zarith. + rewrite <- 2 Zpower_exp; auto with zarith. + rewrite Z.add_sub_assoc, Zplus_minus. + rewrite Z.sub_simpl_r, Zplus_minus. + rewrite ZnZ.spec_zdigits. + rewrite pow2_pos_minus_1 by (red; auto). + apply ZnZ.spec_head0; auto with zarith. + Qed. + + Lemma spec_log2 : forall x, [log2 x] = Z.log2 [x]. + Proof. + intros. destruct (Z_lt_ge_dec 0 [x]). + symmetry. apply Z.log2_unique. apply spec_pos. + apply spec_log2_pos. intro EQ; rewrite EQ in *; auto with zarith. + rewrite spec_log2_0. rewrite Z.log2_nonpos; auto with zarith. + generalize (spec_pos x); auto with zarith. + Qed. + + Lemma log2_digits_head0 : forall x, 0 < [x] -> + [log2 x] = Zpos (digits x) - [head0 x] - 1. + Proof. + intros. rewrite log2_fold. + rewrite spec_eqb. rewrite spec_0. + case Z.eqb_spec. + auto with zarith. + intros _. revert H. rewrite digits_fold, head0_fold. destr_t x as (n,x). + rewrite ZnZ.spec_sub_carry. + intros. + generalize (head0_zdigits n x H). + generalize (ZnZ.spec_to_Z (ZnZ.head0 x)). + generalize (ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). + rewrite ZnZ.spec_zdigits. intros. apply Zmod_small. + auto with zarith. + Qed. + + (** * Right shift *) + + Local Notation shiftrn := (fun n => + let op := dom_op n in + let zdigits := ZnZ.zdigits op in + let sub_c := ZnZ.sub_c in + let add_mul_div := ZnZ.add_mul_div in + let zzero := ZnZ.zero in + fun x p => match sub_c zdigits p with + | C0 d => reduce n (add_mul_div d zzero x) + | C1 _ => zero + end). + + Definition shiftr : t -> t -> t := Eval red_t in + same_level shiftrn. + + Lemma shiftr_fold : shiftr = same_level shiftrn. + Proof. red_t; reflexivity. Qed. + + Lemma div_pow2_bound :forall x y z, + 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z. + Proof. + intros x y z HH HH1 HH2. + split; auto with zarith. + apply Zle_lt_trans with (2 := HH2); auto with zarith. + apply Zdiv_le_upper_bound; auto with zarith. + pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith. + apply Zmult_le_compat_l; auto. + apply Zpower_le_monotone2; auto with zarith. + rewrite Zpower_0_r; ring. + Qed. + + Theorem spec_shiftr_pow2 : forall x n, + [shiftr x n] = [x] / 2 ^ [n]. + Proof. + intros x y. rewrite shiftr_fold. apply spec_same_level. clear x y. + intros n x p. simpl. + assert (Hx := ZnZ.spec_to_Z x). + assert (Hy := ZnZ.spec_to_Z p). + generalize (ZnZ.spec_sub_c (ZnZ.zdigits (dom_op n)) p). + case ZnZ.sub_c; intros d H; unfold interp_carry in *; simpl. + (** Subtraction without underflow : [ p <= digits ] *) + rewrite spec_reduce. + rewrite ZnZ.spec_zdigits in H. + rewrite ZnZ.spec_add_mul_div by auto with zarith. + rewrite ZnZ.spec_0, Zmult_0_l, Zplus_0_l. + rewrite Zmod_small. + f_equal. f_equal. auto with zarith. + split. auto with zarith. + apply div_pow2_bound; auto with zarith. + (** Subtraction with underflow : [ digits < p ] *) + rewrite ZnZ.spec_0. symmetry. + apply Zdiv_small. + split; auto with zarith. + apply Zlt_le_trans with (base (ZnZ.digits (dom_op n))); auto with zarith. + unfold base. apply Zpower_le_monotone2; auto with zarith. + rewrite ZnZ.spec_zdigits in H. + generalize (ZnZ.spec_to_Z d); auto with zarith. + Qed. + + Lemma spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. + Proof. + intros. + now rewrite spec_shiftr_pow2, Z.shiftr_div_pow2 by apply spec_pos. + Qed. + + (** * Left shift *) + + (** First an unsafe version, working correctly only if + the representation is large enough *) + + Local Notation unsafe_shiftln := (fun n => + let op := dom_op n in + let add_mul_div := ZnZ.add_mul_div in + let zero := ZnZ.zero in + fun x p => reduce n (add_mul_div p x zero)). + + Definition unsafe_shiftl : t -> t -> t := Eval red_t in + same_level unsafe_shiftln. + + Lemma unsafe_shiftl_fold : unsafe_shiftl = same_level unsafe_shiftln. + Proof. red_t; reflexivity. Qed. + + Theorem spec_unsafe_shiftl_aux : forall x p K, + 0 <= K -> + [x] < 2^K -> + [p] + K <= Zpos (digits x) -> + [unsafe_shiftl x p] = [x] * 2 ^ [p]. + Proof. + intros x p. + rewrite unsafe_shiftl_fold. rewrite digits_level. + apply spec_same_level_dep. + intros n m z z' r LE H K HK H1 H2. apply (H K); auto. + transitivity (Zpos (ZnZ.digits (dom_op n))); auto. + apply digits_dom_op_incr; auto. + clear x p. + intros n x p K HK Hx Hp. simpl. rewrite spec_reduce. + destruct (ZnZ.spec_to_Z x). + destruct (ZnZ.spec_to_Z p). + rewrite ZnZ.spec_add_mul_div by (omega with *). + rewrite ZnZ.spec_0, Zdiv_0_l, Zplus_0_r. + apply Zmod_small. unfold base. + split; auto with zarith. + rewrite Zmult_comm. + apply Zlt_le_trans with (2^(ZnZ.to_Z p + K)). + rewrite Zpower_exp; auto with zarith. + apply Zmult_lt_compat_l; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. + Qed. + + Theorem spec_unsafe_shiftl: forall x p, + [p] <= [head0 x] -> [unsafe_shiftl x p] = [x] * 2 ^ [p]. + Proof. + intros. + destruct (Z_eq_dec [x] 0) as [EQ|NEQ]. + (* [x] = 0 *) + apply spec_unsafe_shiftl_aux with 0; auto with zarith. + now rewrite EQ. + rewrite spec_head00 in *; auto with zarith. + (* [x] <> 0 *) + apply spec_unsafe_shiftl_aux with ([log2 x] + 1); auto with zarith. + generalize (spec_pos (log2 x)); auto with zarith. + destruct (spec_log2_pos x); auto with zarith. + rewrite log2_digits_head0; auto with zarith. + generalize (spec_pos x); auto with zarith. + Qed. + + (** Then we define a function doubling the size of the representation + but without changing the value of the number. *) + + Local Notation double_size_n := (fun n => + let zero := ZnZ.zero in + fun x => mk_t_S n (WW zero x)). + + Definition double_size : t -> t := Eval red_t in + iter_t double_size_n. + + Lemma double_size_fold : double_size = iter_t double_size_n. + Proof. red_t; reflexivity. Qed. + + Lemma double_size_level : forall x, level (double_size x) = S (level x). + Proof. + intros x. rewrite double_size_fold; unfold level at 2. destr_t x as (n,x). + apply mk_t_S_level. + Qed. + + Theorem spec_double_size_digits: + forall x, Zpos (digits (double_size x)) = 2 * (Zpos (digits x)). + Proof. + intros x. rewrite ! digits_level, double_size_level. + rewrite 2 digits_dom_op, 2 Pshiftl_nat_Zpower, + inj_S, Zpower_Zsucc; auto with zarith. + ring. + Qed. + + Theorem spec_double_size: forall x, [double_size x] = [x]. + Proof. + intros x. rewrite double_size_fold. destr_t x as (n,x). + rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_0. auto with zarith. + Qed. + + Theorem spec_double_size_head0: + forall x, 2 * [head0 x] <= [head0 (double_size x)]. + Proof. + intros x. + assert (F1:= spec_pos (head0 x)). + assert (F2: 0 < Zpos (digits x)). + red; auto. + case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH. + generalize HH; rewrite <- (spec_double_size x); intros HH1. + case (spec_head0 x HH); intros _ HH2. + case (spec_head0 _ HH1). + rewrite (spec_double_size x); rewrite (spec_double_size_digits x). + intros HH3 _. + case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4. + absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto. + apply Zle_not_lt. + apply Zmult_le_compat_r; auto with zarith. + apply Zpower_le_monotone2; auto; auto with zarith. + assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)). + case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5. + apply Zmult_le_reg_r with (2 ^ 1); auto with zarith. + rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith. + assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp]. + apply Zle_trans with (2 := Zlt_le_weak _ _ HH2). + apply Zmult_le_compat_l; auto with zarith. + rewrite Zpower_1_r; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. + case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6. + absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith. + rewrite <- HH5; rewrite Zmult_1_r. + apply Zpower_le_monotone2; auto with zarith. + rewrite (Zmult_comm 2). + rewrite Zpower_mult; auto with zarith. + rewrite Zpower_2. + apply Zlt_le_trans with (2 := HH3). + rewrite <- Zmult_assoc. + replace (2 * Zpos (digits x) - 1) with + ((Zpos (digits x) - 1) + (Zpos (digits x))). + rewrite Zpower_exp; auto with zarith. + apply Zmult_lt_compat2; auto with zarith. + split; auto with zarith. + apply Zmult_lt_0_compat; auto with zarith. + rewrite Zpos_xO; ring. + apply Zlt_le_weak; auto. + repeat rewrite spec_head00; auto. + rewrite spec_double_size_digits. + rewrite Zpos_xO; auto with zarith. + rewrite spec_double_size; auto. + Qed. + + Theorem spec_double_size_head0_pos: + forall x, 0 < [head0 (double_size x)]. + Proof. + intros x. + assert (F: 0 < Zpos (digits x)). + red; auto. + case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0. + case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1. + apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith. + case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3. + generalize F3; rewrite <- (spec_double_size x); intros F4. + absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))). + apply Zle_not_lt. + apply Zpower_le_monotone2; auto with zarith. + rewrite Zpos_xO; auto with zarith. + case (spec_head0 x F3). + rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH. + apply Zle_lt_trans with (2 := HH). + case (spec_head0 _ F4). + rewrite (spec_double_size x); rewrite (spec_double_size_digits x). + rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto. + generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith. + Qed. + + (** Finally we iterate [double_size] enough before [unsafe_shiftl] + in order to get a fully correct [shiftl]. *) + + Definition shiftl_aux_body cont x n := + match compare n (head0 x) with + Gt => cont (double_size x) n + | _ => unsafe_shiftl x n end. - Theorem spec_shiftl_aux_body: forall n p x cont, + Theorem spec_shiftl_aux_body: forall n x p cont, 2^ Zpos p <= [head0 x] -> (forall x, 2 ^ (Zpos p + 1) <= [head0 x]-> - [cont n x] = [x] * 2 ^ [n]) -> - [shiftl_aux_body cont n x] = [x] * 2 ^ [n]. + [cont x n] = [x] * 2 ^ [n]) -> + [shiftl_aux_body cont x n] = [x] * 2 ^ [n]. Proof. - intros n p x cont H1 H2; unfold shiftl_aux_body. - generalize (spec_compare_aux n (head0 x)); case compare; intros H. + intros n x p cont H1 H2; unfold shiftl_aux_body. + rewrite spec_compare; case Zcompare_spec; intros H. apply spec_unsafe_shiftl; auto with zarith. apply spec_unsafe_shiftl; auto with zarith. rewrite H2. @@ -435,22 +1531,22 @@ Module Make (Import W0:CyclicType) <: NType. rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith. Qed. - Fixpoint shiftl_aux p cont n x {struct p} := + Fixpoint shiftl_aux p cont x n := shiftl_aux_body - (fun n x => match p with - | xH => cont n x - | xO p => shiftl_aux p (shiftl_aux p cont) n x - | xI p => shiftl_aux p (shiftl_aux p cont) n x - end) n x. + (fun x n => match p with + | xH => cont x n + | xO p => shiftl_aux p (shiftl_aux p cont) x n + | xI p => shiftl_aux p (shiftl_aux p cont) x n + end) x n. - Theorem spec_shiftl_aux: forall p q n x cont, + Theorem spec_shiftl_aux: forall p q x n cont, 2 ^ (Zpos q) <= [head0 x] -> (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] -> - [cont n x] = [x] * 2 ^ [n]) -> - [shiftl_aux p cont n x] = [x] * 2 ^ [n]. + [cont x n] = [x] * 2 ^ [n]) -> + [shiftl_aux p cont x n] = [x] * 2 ^ [n]. Proof. intros p; elim p; unfold shiftl_aux; fold shiftl_aux; clear p. - intros p Hrec q n x cont H1 H2. + intros p Hrec q x n cont H1 H2. apply spec_shiftl_aux_body with (q); auto. intros x1 H3; apply Hrec with (q + 1)%positive; auto. intros x2 H4; apply Hrec with (p + q + 1)%positive; auto. @@ -465,7 +1561,7 @@ Module Make (Import W0:CyclicType) <: NType. apply spec_shiftl_aux_body with (q); auto. intros x1 H3; apply Hrec with (q); auto. apply Zle_trans with (2 := H3); auto with zarith. - apply Zpower_le_monotone; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. intros x2 H4; apply Hrec with (p + q)%positive; auto. intros x3 H5; apply H2. rewrite (Zpos_xO p). @@ -477,20 +1573,20 @@ Module Make (Import W0:CyclicType) <: NType. rewrite Zplus_comm; auto. Qed. - Definition shiftl n x := + Definition shiftl x n := shiftl_aux_body (shiftl_aux_body - (shiftl_aux (digits n) unsafe_shiftl)) n x. + (shiftl_aux (digits n) unsafe_shiftl)) x n. - Theorem spec_shiftl: forall n x, - [shiftl n x] = [x] * 2 ^ [n]. + Theorem spec_shiftl_pow2 : forall x n, + [shiftl x n] = [x] * 2 ^ [n]. Proof. - intros n x; unfold shiftl, shiftl_aux_body. - generalize (spec_compare_aux n (head0 x)); case compare; intros H. + intros x n; unfold shiftl, shiftl_aux_body. + rewrite spec_compare; case Zcompare_spec; intros H. apply spec_unsafe_shiftl; auto with zarith. apply spec_unsafe_shiftl; auto with zarith. rewrite <- (spec_double_size x). - generalize (spec_compare_aux n (head0 (double_size x))); case compare; intros H1. + rewrite spec_compare; case Zcompare_spec; intros H1. apply spec_unsafe_shiftl; auto with zarith. apply spec_unsafe_shiftl; auto with zarith. rewrite <- (spec_double_size (double_size x)). @@ -504,21 +1600,67 @@ Module Make (Import W0:CyclicType) <: NType. apply Zle_trans with (2 := H2). apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith. case (spec_digits n); auto with zarith. - apply Zpower_le_monotone; auto with zarith. + apply Zpower_le_monotone2; auto with zarith. Qed. + Lemma spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. + Proof. + intros. + now rewrite spec_shiftl_pow2, Z.shiftl_mul_pow2 by apply spec_pos. + Qed. - (** * Zero and One *) + (** Other bitwise operations *) - Theorem spec_0: [zero] = 0. + Definition testbit x n := odd (shiftr x n). + + Lemma spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. Proof. - exact (spec_0 w0_spec). + intros. unfold testbit. symmetry. + rewrite spec_odd, spec_shiftr. apply Z.testbit_odd. Qed. - Theorem spec_1: [one] = 1. + Definition div2 x := shiftr x one. + + Lemma spec_div2: forall x, [div2 x] = Z.div2 [x]. Proof. - exact (spec_1 w0_spec). + intros. unfold div2. symmetry. + rewrite spec_shiftr, spec_1. apply Z.div2_spec. Qed. + (** TODO : provide efficient versions instead of just converting + from/to N (see with Laurent) *) + + Definition lor x y := of_N (N.lor (to_N x) (to_N y)). + Definition land x y := of_N (N.land (to_N x) (to_N y)). + Definition ldiff x y := of_N (N.ldiff (to_N x) (to_N y)). + Definition lxor x y := of_N (N.lxor (to_N x) (to_N y)). + + Lemma spec_land: forall x y, [land x y] = Z.land [x] [y]. + Proof. + intros x y. unfold land. rewrite spec_of_N. unfold to_N. + generalize (spec_pos x), (spec_pos y). + destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + Qed. + + Lemma spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. + Proof. + intros x y. unfold lor. rewrite spec_of_N. unfold to_N. + generalize (spec_pos x), (spec_pos y). + destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + Qed. + + Lemma spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. + Proof. + intros x y. unfold ldiff. rewrite spec_of_N. unfold to_N. + generalize (spec_pos x), (spec_pos y). + destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + Qed. + + Lemma spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. + Proof. + intros x y. unfold lxor. rewrite spec_of_N. unfold to_N. + generalize (spec_pos x), (spec_pos y). + destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2). + Qed. End Make. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 67a62c40..59d440c3 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,100 +8,88 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMake_gen.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) +(*S NMake_gen.ml : this file generates NMake_gen.v *) -(*S NMake_gen.ml : this file generates NMake.v *) - -(*s The two parameters that control the generation: *) +(*s The parameter that control the generation: *) let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ process before relying on a generic construct *) -let gen_proof = true (* should we generate proofs ? *) - (*s Some utilities *) -let t = "t" -let c = "N" -let pz n = if n == 0 then "w_0" else "W0" -let rec gen2 n = if n == 0 then "1" else if n == 1 then "2" - else "2 * " ^ (gen2 (n - 1)) -let rec genxO n s = - if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")" +let rec iter_str n s = if n = 0 then "" else (iter_str (n-1) s) ^ s -(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to - /dev/null, but for being compatible with earlier ocaml and not - relying on system-dependent stuff like open_out "/dev/null", - let's use instead a magical hack *) +let rec iter_str_gen n f = if n < 0 then "" else (iter_str_gen (n-1) f) ^ (f n) -(* Standard printer, with a final newline *) -let pr s = Printf.printf (s^^"\n") -(* Printing to /dev/null *) -let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) - : ('a, out_channel, unit) format -> 'a) -(* Proof printer : prints iff gen_proof is true *) -let pp = if gen_proof then pr else pn -(* Printer for admitted parts : prints iff gen_proof is false *) -let pa = if not gen_proof then pr else pn -(* Same as before, but without the final newline *) -let pr0 = Printf.printf -let pp0 = if gen_proof then pr0 else pn +let rec iter_name i j base sep = + if i >= j then base^(string_of_int i) + else (iter_name i (j-1) base sep)^sep^" "^base^(string_of_int j) +let pr s = Printf.printf (s^^"\n") (*s The actual printing *) let _ = - pr "(************************************************************************)"; - pr "(* v * The Coq Proof Assistant / The Coq Development Team *)"; - pr "(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)"; - pr "(* \\VV/ **************************************************************)"; - pr "(* // * This file is distributed under the terms of the *)"; - pr "(* * GNU Lesser General Public License Version 2.1 *)"; - pr "(************************************************************************)"; - pr "(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)"; - pr "(************************************************************************)"; - pr ""; - pr "(** * NMake *)"; - pr ""; - pr "(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)"; - pr ""; - pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; - pr ""; - pr "Require Import BigNumPrelude ZArith CyclicAxioms"; - pr " DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic"; - pr " Wf_nat StreamMemo."; - pr ""; - pr "Module Make (Import W0:CyclicType)."; - pr ""; +pr +"(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \\VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) - pr " Definition w0 := W0.w."; - for i = 1 to size do - pr " Definition w%i := zn2z w%i." i (i-1) - done; - pr ""; +(** * NMake_gen *) - pr " Definition w0_op := W0.w_op."; - for i = 1 to 3 do - pr " Definition w%i_op := mk_zn2z_op w%i_op." i (i-1) - done; - for i = 4 to size + 3 do - pr " Definition w%i_op := mk_zn2z_op_karatsuba w%i_op." i (i-1) - done; - pr ""; +(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*) + +(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *) + +Require Import BigNumPrelude ZArith Ndigits CyclicAxioms + DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic + Wf_nat StreamMemo. + +Module Make (W0:CyclicType) <: NAbstract. + + (** * The word types *) +"; + +pr " Local Notation w0 := W0.t."; +for i = 1 to size do + pr " Definition w%i := zn2z w%i." i (i-1) +done; +pr ""; + +pr " (** * The operation type classes for the word types *) +"; + +pr " Local Notation w0_op := W0.ops."; +for i = 1 to min 3 size do + pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops w%i_op." i i (i-1) +done; +for i = 4 to size do + pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops_karatsuba w%i_op." i i (i-1) +done; +for i = size+1 to size+3 do + pr " Instance w%i_op : ZnZ.Ops (word w%i %i) := mk_zn2z_ops_karatsuba w%i_op." i size (i-size) (i-1) +done; +pr ""; pr " Section Make_op."; - pr " Variable mk : forall w', znz_op w' -> znz_op (zn2z w')."; + pr " Variable mk : forall w', ZnZ.Ops w' -> ZnZ.Ops (zn2z w')."; pr ""; - pr " Fixpoint make_op_aux (n:nat) : znz_op (word w%i (S n)):=" size; - pr " match n return znz_op (word w%i (S n)) with" size; + pr " Fixpoint make_op_aux (n:nat) : ZnZ.Ops (word w%i (S n)):=" size; + pr " match n return ZnZ.Ops (word w%i (S n)) with" size; pr " | O => w%i_op" (size+1); pr " | S n1 =>"; - pr " match n1 return znz_op (word w%i (S (S n1))) with" size; + pr " match n1 return ZnZ.Ops (word w%i (S (S n1))) with" size; pr " | O => w%i_op" (size+2); pr " | S n2 =>"; - pr " match n2 return znz_op (word w%i (S (S (S n2)))) with" size; + pr " match n2 return ZnZ.Ops (word w%i (S (S (S n2)))) with" size; pr " | O => w%i_op" (size+3); pr " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))"; pr " end"; @@ -110,2565 +98,912 @@ let _ = pr ""; pr " End Make_op."; pr ""; - pr " Definition omake_op := make_op_aux mk_zn2z_op_karatsuba."; + pr " Definition omake_op := make_op_aux mk_zn2z_ops_karatsuba."; pr ""; pr ""; pr " Definition make_op_list := dmemo_list _ omake_op."; pr ""; - pr " Definition make_op n := dmemo_get _ omake_op n make_op_list."; - pr ""; - pr " Lemma make_op_omake: forall n, make_op n = omake_op n."; - pr " intros n; unfold make_op, make_op_list."; - pr " refine (dmemo_get_correct _ _ _)."; - pr " Qed."; + pr " Instance make_op n : ZnZ.Ops (word w%i (S n))" size; + pr " := dmemo_get _ omake_op n make_op_list."; pr ""; - pr " Inductive %s_ :=" t; - for i = 0 to size do - pr " | %s%i : w%i -> %s_" c i i t - done; - pr " | %sn : forall n, word w%i (S n) -> %s_." c size t; - pr ""; - pr " Definition %s := %s_." t t; - pr ""; - pr " Definition w_0 := w0_op.(znz_0)."; - pr ""; +pr " Ltac unfold_ops := unfold omake_op, make_op_aux, w%i_op, w%i_op." (size+3) (size+2); - for i = 0 to size do - pr " Definition one%i := w%i_op.(znz_1)." i i - done; - pr ""; +pr +" + Lemma make_op_omake: forall n, make_op n = omake_op n. + Proof. + intros n; unfold make_op, make_op_list. + refine (dmemo_get_correct _ _ _). + Qed. + Theorem make_op_S: forall n, + make_op (S n) = mk_zn2z_ops_karatsuba (make_op n). + Proof. + intros n. do 2 rewrite make_op_omake. + revert n. fix IHn 1. + do 3 (destruct n; [unfold_ops; reflexivity|]). + simpl mk_zn2z_ops_karatsuba. simpl word in *. + rewrite <- (IHn n). auto. + Qed. - pr " Definition zero := %s0 w_0." c; - pr " Definition one := %s0 one0." c; - pr ""; + (** * The main type [t], isomorphic with [exists n, word w0 n] *) +"; - pr " Definition to_Z x :="; - pr " match x with"; + pr " Inductive t' :="; for i = 0 to size do - pr " | %s%i wx => w%i_op.(znz_to_Z) wx" c i i + pr " | N%i : w%i -> t'" i i done; - pr " | %sn n wx => (make_op n).(znz_to_Z) wx" c; - pr " end."; + pr " | Nn : forall n, word w%i (S n) -> t'." size; pr ""; - - pr " Open Scope Z_scope."; - pr " Notation \"[ x ]\" := (to_Z x)."; - pr ""; - - pr " Definition to_N x := Zabs_N (to_Z x)."; + pr " Definition t := t'."; pr ""; - - pr " Definition eq x y := (to_Z x = to_Z y)."; - pr ""; - - pp " (* Regular make op (no karatsuba) *)"; - pp " Fixpoint nmake_op (ww:Type) (ww_op: znz_op ww) (n: nat) :"; - pp " znz_op (word ww n) :="; - pp " match n return znz_op (word ww n) with"; - pp " O => ww_op"; - pp " | S n1 => mk_zn2z_op (nmake_op ww ww_op n1)"; - pp " end."; - pp ""; - pp " (* Simplification by rewriting for nmake_op *)"; - pp " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x,"; - pp " nmake_op _ w_op (S x) = mk_zn2z_op (nmake_op _ w_op x)."; - pp " auto."; - pp " Qed."; - pp ""; - - - pr " (* Eval and extend functions for each level *)"; - for i = 0 to size do - pp " Let nmake_op%i := nmake_op _ w%i_op." i i; - pp " Let eval%in n := znz_to_Z (nmake_op%i n)." i i; - if i == 0 then - pr " Let extend%i := DoubleBase.extend (WW w_0)." i - else - pr " Let extend%i := DoubleBase.extend (WW (W0: w%i))." i i; - done; + pr " Bind Scope abstract_scope with t t'."; pr ""; - - pp " Theorem digits_doubled:forall n ww (w_op: znz_op ww),"; - pp " znz_digits (nmake_op _ w_op n) ="; - pp " DoubleBase.double_digits (znz_digits w_op) n."; - pp " Proof."; - pp " intros n; elim n; auto; clear n."; - pp " intros n Hrec ww ww_op; simpl DoubleBase.double_digits."; - pp " rewrite <- Hrec; auto."; - pp " Qed."; - pp ""; - pp " Theorem nmake_double: forall n ww (w_op: znz_op ww),"; - pp " znz_to_Z (nmake_op _ w_op n) ="; - pp " @DoubleBase.double_to_Z _ (znz_digits w_op) (znz_to_Z w_op) n."; - pp " Proof."; - pp " intros n; elim n; auto; clear n."; - pp " intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z."; - pp " rewrite <- Hrec; auto."; - pp " unfold DoubleBase.double_wB; rewrite <- digits_doubled; auto."; - pp " Qed."; - pp ""; - - - pp " Theorem digits_nmake:forall n ww (w_op: znz_op ww),"; - pp " znz_digits (nmake_op _ w_op (S n)) ="; - pp " xO (znz_digits (nmake_op _ w_op n))."; - pp " Proof."; - pp " auto."; - pp " Qed."; - pp ""; - - - pp " Theorem znz_nmake_op: forall ww ww_op n xh xl,"; - pp " znz_to_Z (nmake_op ww ww_op (S n)) (WW xh xl) ="; - pp " znz_to_Z (nmake_op ww ww_op n) xh *"; - pp " base (znz_digits (nmake_op ww ww_op n)) +"; - pp " znz_to_Z (nmake_op ww ww_op n) xl."; - pp " Proof."; - pp " auto."; - pp " Qed."; - pp ""; - - pp " Theorem make_op_S: forall n,"; - pp " make_op (S n) = mk_zn2z_op_karatsuba (make_op n)."; - pp " intro n."; - pp " do 2 rewrite make_op_omake."; - pp " pattern n; apply lt_wf_ind; clear n."; - pp " intros n; case n; clear n."; - pp " intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal." (size + 2); - pp " intros n; case n; clear n."; - pp " intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal." (size + 3); - pp " intros n; case n; clear n."; - pp " intros _; unfold omake_op, make_op_aux, w%i_op, w%i_op; apply refl_equal." (size + 3) (size + 2); - pp " intros n Hrec."; - pp " change (omake_op (S (S (S (S n))))) with"; - pp " (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op (S n)))))."; - pp " change (omake_op (S (S (S n)))) with"; - pp " (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op n))))."; - pp " rewrite Hrec; auto with arith."; - pp " Qed."; - pp ""; - - - for i = 1 to size + 2 do - pp " Let znz_to_Z_%i: forall x y," i; - pp " znz_to_Z w%i_op (WW x y) =" i; - pp " znz_to_Z w%i_op x * base (znz_digits w%i_op) + znz_to_Z w%i_op y." (i-1) (i-1) (i-1); - pp " Proof."; - pp " auto."; - pp " Qed."; - pp ""; - done; - - pp " Let znz_to_Z_n: forall n x y,"; - pp " znz_to_Z (make_op (S n)) (WW x y) ="; - pp " znz_to_Z (make_op n) x * base (znz_digits (make_op n)) + znz_to_Z (make_op n) y."; - pp " Proof."; - pp " intros n x y; rewrite make_op_S; auto."; - pp " Qed."; - pp ""; - - pp " Let w0_spec: znz_spec w0_op := W0.w_spec."; - for i = 1 to 3 do - pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) - done; - for i = 4 to size + 3 do - pp " Let w%i_spec : znz_spec w%i_op := mk_znz2_karatsuba_spec w%i_spec." i i (i-1) - done; - pp ""; - - pp " Let wn_spec: forall n, znz_spec (make_op n)."; - pp " intros n; elim n; clear n."; - pp " exact w%i_spec." (size + 1); - pp " intros n Hrec; rewrite make_op_S."; - pp " exact (mk_znz2_karatsuba_spec Hrec)."; - pp " Qed."; - pp ""; - - for i = 0 to size do - pr " Definition w%i_eq0 := w%i_op.(znz_eq0)." i i; - pr " Let spec_w%i_eq0: forall x, if w%i_eq0 x then [%s%i x] = 0 else True." i i c i; - pa " Admitted."; - pp " Proof."; - pp " intros x; unfold w%i_eq0, to_Z; generalize (spec_eq0 w%i_spec x);" i i; - pp " case znz_eq0; auto."; - pp " Qed."; - pr ""; - done; + pr " (** * A generic toolbox for building and deconstructing [t] *)"; pr ""; - - for i = 0 to size do - pp " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; - if i == 0 then - pp " auto." - else - pp " rewrite digits_nmake; rewrite <- digits_w%i; auto." (i - 1); - pp " Qed."; - pp ""; - pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; - pp " Proof."; - pp " intros n; exact (nmake_double n w%i w%i_op)." i i; - pp " Qed."; - pp ""; - done; - - for i = 0 to size do - for j = 0 to (size - i) do - pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; - pp " Proof."; - if j == 0 then - if i == 0 then - pp " auto." - else - begin - pp " apply trans_equal with (xO (znz_digits w%i_op))." (i + j -1); - pp " auto."; - pp " unfold nmake_op; auto."; - end - else - begin - pp " apply trans_equal with (xO (znz_digits w%i_op))." (i + j -1); - pp " auto."; - pp " rewrite digits_nmake."; - pp " rewrite digits_w%in%i." i (j - 1); - pp " auto."; - end; - pp " Qed."; - pp ""; - pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; - pp " Proof."; - if j == 0 then - pp " intros x; rewrite spec_double_eval%in; unfold DoubleBase.double_to_Z, to_Z; auto." i - else - begin - pp " intros x; case x."; - pp " auto."; - pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (i + j); - pp " rewrite digits_w%in%i." i (j - 1); - pp " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH." i (j - 1); - pp " unfold eval%in, nmake_op%i." i i; - pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (j - 1); - end; - pp " Qed."; - if i + j <> size then - begin - pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; - if j == 0 then - begin - pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." i (i + j); - pp " unfold to_Z; rewrite znz_to_Z_%i." (i + j + 1); - pp " rewrite (spec_0 w%i_spec); auto." (i + j); - end - else - begin - pp " intros x; change (extend%i %i x) with (WW (znz_0 w%i_op) (extend%i %i x))." i j (i + j) i (j - 1); - pp " unfold to_Z; rewrite znz_to_Z_%i." (i + j + 1); - pp " rewrite (spec_0 w%i_spec)." (i + j); - pp " generalize (spec_extend%in%i x); unfold to_Z." i (i + j); - pp " intros HH; rewrite <- HH; auto."; - end; - pp " Qed."; - pp ""; - end; - done; - - pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i (size - i + 1) (size + 1) i (size - i + 1); - pp " Proof."; - pp " apply trans_equal with (xO (znz_digits w%i_op))." size; - pp " auto."; - pp " rewrite digits_nmake."; - pp " rewrite digits_w%in%i." i (size - i); - pp " auto."; - pp " Qed."; - pp ""; - - pp " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); - pp " Proof."; - pp " intros x; case x."; - pp " auto."; - pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 1); - pp " rewrite digits_w%in%i." i (size - i); - pp " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH." i (size - i); - pp " unfold eval%in, nmake_op%i." i i; - pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (size - i); - pp " Qed."; - pp ""; - - pp " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); - pp " intros x; case x."; - pp " auto."; - pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 2); - pp " rewrite digits_w%in%i." i (size + 1 - i); - pp " generalize (spec_eval%in%i); unfold to_Z; change (make_op 0) with (w%i_op); intros HH; repeat rewrite HH." i (size + 1 - i) (size + 1); - pp " unfold eval%in, nmake_op%i." i i; - pp " rewrite (znz_nmake_op _ w%i_op %i); auto." i (size + 1 - i); - pp " Qed."; - pp ""; - done; - - pp " Let digits_w%in: forall n," size; - pp " znz_digits (make_op n) = znz_digits (nmake_op _ w%i_op (S n))." size; - pp " intros n; elim n; clear n."; - pp " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size; - pp " rewrite nmake_op_S; apply sym_equal; auto."; - pp " intros n Hrec."; - pp " replace (znz_digits (make_op (S n))) with (xO (znz_digits (make_op n)))."; - pp " rewrite Hrec."; - pp " rewrite nmake_op_S; apply sym_equal; auto."; - pp " rewrite make_op_S; apply sym_equal; auto."; - pp " Qed."; - pp ""; - - pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; - pp " intros n; elim n; clear n."; - pp " exact spec_eval%in1." size; - pp " intros n Hrec x; case x; clear x."; - pp " unfold to_Z, eval%in, nmake_op%i." size size; - pp " rewrite make_op_S; rewrite nmake_op_S; auto."; - pp " intros xh xl."; - pp " unfold to_Z in Hrec |- *."; - pp " rewrite znz_to_Z_n."; - pp " rewrite digits_w%in." size; - pp " repeat rewrite Hrec."; - pp " unfold eval%in, nmake_op%i." size size; - pp " apply sym_equal; rewrite nmake_op_S; auto."; - pp " Qed."; - pp ""; - - pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; - pp " intros n; elim n; clear n."; - pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." size size; - pp " unfold to_Z."; - pp " change (make_op 0) with w%i_op." (size + 1); - pp " rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto." (size + 1) size; - pp " intros n Hrec x."; - pp " change (extend%i (S n) x) with (WW W0 (extend%i n x))." size size; - pp " unfold to_Z in Hrec |- *; rewrite znz_to_Z_n; auto."; - pp " rewrite <- Hrec."; - pp " replace (znz_to_Z (make_op n) W0) with 0; auto."; - pp " case n; auto; intros; rewrite make_op_S; auto."; - pp " Qed."; - pp ""; - - pr " Theorem spec_pos: forall x, 0 <= [x]."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; clear x."; - for i = 0 to size do - pp " intros x; case (spec_to_Z w%i_spec x); auto." i; - done; - pp " intros n x; case (spec_to_Z (wn_spec n) x); auto."; - pp " Qed."; + pr " Local Notation SizePlus n := %sn%s." + (iter_str size "(S ") (iter_str size ")"); + pr " Local Notation Size := (SizePlus O)."; pr ""; - pp " Let spec_extendn_0: forall n wx, [%sn n (extend n _ wx)] = [%sn 0 wx]." c c; - pp " intros n; elim n; auto."; - pp " intros n1 Hrec wx; simpl extend; rewrite <- Hrec; auto."; - pp " unfold to_Z."; - pp " case n1; auto; intros n2; repeat rewrite make_op_S; auto."; - pp " Qed."; - pp ""; - pp " Let spec_extendn0_0: forall n wx, [%sn (S n) (WW W0 wx)] = [%sn n wx]." c c; - pp " Proof."; - pp " intros n x; unfold to_Z."; - pp " rewrite znz_to_Z_n."; - pp " rewrite <- (Zplus_0_l (znz_to_Z (make_op n) x))."; - pp " apply (f_equal2 Zplus); auto."; - pp " case n; auto."; - pp " intros n1; rewrite make_op_S; auto."; - pp " Qed."; - pp ""; - pp " Let spec_extend_tr: forall m n (w: word _ (S n)),"; - pp " [%sn (m + n) (extend_tr w m)] = [%sn n w]." c c; - pp " Proof."; - pp " induction m; auto."; - pp " intros n x; simpl extend_tr."; - pp " simpl plus; rewrite spec_extendn0_0; auto."; - pp " Qed."; - pp ""; - pp " Let spec_cast_l: forall n m x1,"; - pp " [%sn (Max.max n m)" c; - pp " (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))] ="; - pp " [%sn n x1]." c; - pp " Proof."; - pp " intros n m x1; case (diff_r n m); simpl castm."; - pp " rewrite spec_extend_tr; auto."; - pp " Qed."; - pp ""; - pp " Let spec_cast_r: forall n m x1,"; - pp " [%sn (Max.max n m)" c; - pp " (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))] ="; - pp " [%sn m x1]." c; - pp " Proof."; - pp " intros n m x1; case (diff_l n m); simpl castm."; - pp " rewrite spec_extend_tr; auto."; - pp " Qed."; - pp ""; - - - pr " Section LevelAndIter."; - pr ""; - pr " Variable res: Type."; - pr " Variable xxx: res."; - pr " Variable P: Z -> Z -> res -> Prop."; - pr " (* Abstraction function for each level *)"; - for i = 0 to size do - pr " Variable f%i: w%i -> w%i -> res." i i i; - pr " Variable f%in: forall n, w%i -> word w%i (S n) -> res." i i i; - pr " Variable fn%i: forall n, word w%i (S n) -> w%i -> res." i i i; - pp " Variable Pf%i: forall x y, P [%s%i x] [%s%i y] (f%i x y)." i c i c i i; - if i == size then - begin - pp " Variable Pf%in: forall n x y, P [%s%i x] (eval%in (S n) y) (f%in n x y)." i c i i i; - pp " Variable Pfn%i: forall n x y, P (eval%in (S n) x) [%s%i y] (fn%i n x y)." i i c i i; - end - else - begin - pp " Variable Pf%in: forall n x y, Z_of_nat n <= %i -> P [%s%i x] (eval%in (S n) y) (f%in n x y)." i (size - i) c i i i; - pp " Variable Pfn%i: forall n x y, Z_of_nat n <= %i -> P (eval%in (S n) x) [%s%i y] (fn%i n x y)." i (size - i) i c i i; - end; - pr ""; - done; - pr " Variable fnn: forall n, word w%i (S n) -> word w%i (S n) -> res." size size; - pp " Variable Pfnn: forall n x y, P [%sn n x] [%sn n y] (fnn n x y)." c c; - pr " Variable fnm: forall n m, word w%i (S n) -> word w%i (S m) -> res." size size; - pp " Variable Pfnm: forall n m x y, P [%sn n x] [%sn m y] (fnm n m x y)." c c; - pr ""; - pr " (* Special zero functions *)"; - pr " Variable f0t: t_ -> res."; - pp " Variable Pf0t: forall x, P 0 [x] (f0t x)."; - pr " Variable ft0: t_ -> res."; - pp " Variable Pft0: forall x, P [x] 0 (ft0 x)."; + pr " Tactic Notation \"do_size\" tactic(t) := do %i t." (size+1); pr ""; - - pr " (* We level the two arguments before applying *)"; - pr " (* the functions at each leval *)"; - pr " Definition same_level (x y: t_): res :="; - pr0 " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - pr0 "extend%i " i; - done; - pr ""; - pr " DoubleBase.extend DoubleBase.extend_aux"; - pr " ] in"; - pr " match x, y with"; + pr " Definition dom_t n := match n with"; for i = 0 to size do - for j = 0 to i - 1 do - pr " | %s%i wx, %s%i wy => f%i wx (extend%i %i wy)" c i c j i j (i - j -1); - done; - pr " | %s%i wx, %s%i wy => f%i wx wy" c i c i i; - for j = i + 1 to size do - pr " | %s%i wx, %s%i wy => f%i (extend%i %i wx) wy" c i c j j i (j - i - 1); - done; - if i == size then - pr " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size - else - pr " | %s%i wx, %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c i c size i (size - i - 1); + pr " | %i => w%i" i i; done; - for i = 0 to size do - if i == size then - pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size - else - pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n (extend%i %i wy))" c c i size i (size - i - 1); - done; - pr " | %sn n wx, Nn m wy =>" c; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " fnn mn"; - pr " (castm (diff_r n m) (extend_tr wx (snd d)))"; - pr " (castm (diff_l n m) (extend_tr wy (fst d)))"; - pr " end."; + pr " | %sn => word w%i n" (if size=0 then "" else "SizePlus ") size; + pr " end."; pr ""; - pp " Lemma spec_same_level: forall x y, P [x] [y] (same_level x y)."; - pp " Proof."; - pp " intros x; case x; clear x; unfold same_level."; - for i = 0 to size do - pp " intros x y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y; rewrite spec_extend%in%i; apply Pf%i." j i i; - done; - pp " intros y; apply Pf%i." i; - for j = i + 1 to size do - pp " intros y; rewrite spec_extend%in%i; apply Pf%i." i j j; - done; - if i == size then - pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else - pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; - done; - pp " intros n x y; case y; clear y."; - for i = 0 to size do - if i == size then - pp " intros y; rewrite (spec_extend%in n); apply Pfnn." size - else - pp " intros y; rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; - done; - pp " intros m y; rewrite <- (spec_cast_l n m x);"; - pp " rewrite <- (spec_cast_r n m y); apply Pfnn."; - pp " Qed."; - pp ""; - - pr " (* We level the two arguments before applying *)"; - pr " (* the functions at each level (special zero case) *)"; - pr " Definition same_level0 (x y: t_): res :="; - pr0 " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - pr0 "extend%i " i; - done; - pr ""; - pr " DoubleBase.extend DoubleBase.extend_aux"; - pr " ] in"; - pr " match x with"; - for i = 0 to size do - pr " | %s%i wx =>" c i; - if i == 0 then - pr " if w0_eq0 wx then f0t y else"; - pr " match y with"; - for j = 0 to i - 1 do - pr " | %s%i wy =>" c j; - if j == 0 then - pr " if w0_eq0 wy then ft0 x else"; - pr " f%i wx (extend%i %i wy)" i j (i - j -1); - done; - pr " | %s%i wy => f%i wx wy" c i i; - for j = i + 1 to size do - pr " | %s%i wy => f%i (extend%i %i wx) wy" c j j i (j - i - 1); - done; - if i == size then - pr " | %sn m wy => fnn m (extend%i m wx) wy" c size - else - pr " | %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c size i (size - i - 1); - pr" end"; - done; - pr " | %sn n wx =>" c; - pr " match y with"; - for i = 0 to size do - pr " | %s%i wy =>" c i; - if i == 0 then - pr " if w0_eq0 wy then ft0 x else"; - if i == size then - pr " fnn n wx (extend%i n wy)" size - else - pr " fnn n wx (extend%i n (extend%i %i wy))" size i (size - i - 1); - done; - pr " | %sn m wy =>" c; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " fnn mn"; - pr " (castm (diff_r n m) (extend_tr wx (snd d)))"; - pr " (castm (diff_l n m) (extend_tr wy (fst d)))"; - pr " end"; - pr " end."; - pr ""; +pr +" Instance dom_op n : ZnZ.Ops (dom_t n) | 10. + Proof. + do_size (destruct n; [simpl;auto with *|]). + unfold dom_t. auto with *. + Defined. +"; - pp " Lemma spec_same_level0: forall x y, P [x] [y] (same_level0 x y)."; - pp " Proof."; - pp " intros x; case x; clear x; unfold same_level0."; - for i = 0 to size do - pp " intros x."; - if i == 0 then - begin - pp " generalize (spec_w0_eq0 x); case w0_eq0; intros H."; - pp " intros y; rewrite H; apply Pf0t."; - pp " clear H."; - end; - pp " intros y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y."; - if j == 0 then - begin - pp " generalize (spec_w0_eq0 y); case w0_eq0; intros H."; - pp " rewrite H; apply Pft0."; - pp " clear H."; - end; - pp " rewrite spec_extend%in%i; apply Pf%i." j i i; - done; - pp " intros y; apply Pf%i." i; - for j = i + 1 to size do - pp " intros y; rewrite spec_extend%in%i; apply Pf%i." i j j; - done; - if i == size then - pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else - pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; - done; - pp " intros n x y; case y; clear y."; + pr " Definition iter_t {A:Type}(f : forall n, dom_t n -> A) : t -> A :="; for i = 0 to size do - pp " intros y."; - if i = 0 then - begin - pp " generalize (spec_w0_eq0 y); case w0_eq0; intros H."; - pp " rewrite H; apply Pft0."; - pp " clear H."; - end; - if i == size then - pp " rewrite (spec_extend%in n); apply Pfnn." size - else - pp " rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; + pr " let f%i := f %i in" i i; done; - pp " intros m y; rewrite <- (spec_cast_l n m x);"; - pp " rewrite <- (spec_cast_r n m y); apply Pfnn."; - pp " Qed."; - pp ""; - - pr " (* We iter the smaller argument with the bigger *)"; - pr " Definition iter (x y: t_): res :="; - pr0 " Eval lazy zeta beta iota delta ["; + pr " let fn n := f (SizePlus (S n)) in"; + pr " fun x => match x with"; for i = 0 to size do - pr0 "extend%i " i; + pr " | N%i wx => f%i wx" i i; done; - pr ""; - pr " DoubleBase.extend DoubleBase.extend_aux"; - pr " ] in"; - pr " match x, y with"; - for i = 0 to size do - for j = 0 to i - 1 do - pr " | %s%i wx, %s%i wy => fn%i %i wx wy" c i c j j (i - j - 1); - done; - pr " | %s%i wx, %s%i wy => f%i wx wy" c i c i i; - for j = i + 1 to size do - pr " | %s%i wx, %s%i wy => f%in %i wx wy" c i c j i (j - i - 1); - done; - if i == size then - pr " | %s%i wx, %sn m wy => f%in m wx wy" c size c size - else - pr " | %s%i wx, %sn m wy => f%in m (extend%i %i wx) wy" c i c size i (size - i - 1); - done; - for i = 0 to size do - if i == size then - pr " | %sn n wx, %s%i wy => fn%i n wx wy" c c size size - else - pr " | %sn n wx, %s%i wy => fn%i n wx (extend%i %i wy)" c c i size i (size - i - 1); - done; - pr " | %sn n wx, %sn m wy => fnm n m wx wy" c c; + pr " | Nn n wx => fn n wx"; pr " end."; pr ""; - pp " Ltac zg_tac := try"; - pp " (red; simpl Zcompare; auto;"; - pp " let t := fresh \"H\" in (intros t; discriminate t))."; - pp ""; - pp " Lemma spec_iter: forall x y, P [x] [y] (iter x y)."; - pp " Proof."; - pp " intros x; case x; clear x; unfold iter."; - for i = 0 to size do - pp " intros x y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y; rewrite spec_eval%in%i; apply (Pfn%i %i); zg_tac." j (i - j) j (i - j - 1); - done; - pp " intros y; apply Pf%i." i; - for j = i + 1 to size do - pp " intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac." i (j - i) i (j - i - 1); - done; - if i == size then - pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else - pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; - done; - pp " intros n x y; case y; clear y."; - for i = 0 to size do - if i == size then - pp " intros y; rewrite spec_eval%in; apply Pfn%i." size size - else - pp " intros y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; - done; - pp " intros m y; apply Pfnm."; - pp " Qed."; - pp ""; - - - pr " (* We iter the smaller argument with the bigger (zero case) *)"; - pr " Definition iter0 (x y: t_): res :="; - pr0 " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - pr0 "extend%i " i; - done; - pr ""; - pr " DoubleBase.extend DoubleBase.extend_aux"; - pr " ] in"; - pr " match x with"; - for i = 0 to size do - pr " | %s%i wx =>" c i; - if i == 0 then - pr " if w0_eq0 wx then f0t y else"; - pr " match y with"; - for j = 0 to i - 1 do - pr " | %s%i wy =>" c j; - if j == 0 then - pr " if w0_eq0 wy then ft0 x else"; - pr " fn%i %i wx wy" j (i - j - 1); - done; - pr " | %s%i wy => f%i wx wy" c i i; - for j = i + 1 to size do - pr " | %s%i wy => f%in %i wx wy" c j i (j - i - 1); - done; - if i == size then - pr " | %sn m wy => f%in m wx wy" c size - else - pr " | %sn m wy => f%in m (extend%i %i wx) wy" c size i (size - i - 1); - pr " end"; - done; - pr " | %sn n wx =>" c; - pr " match y with"; + pr " Definition mk_t (n:nat) : dom_t n -> t :="; + pr " match n as n' return dom_t n' -> t with"; for i = 0 to size do - pr " | %s%i wy =>" c i; - if i == 0 then - pr " if w0_eq0 wy then ft0 x else"; - if i == size then - pr " fn%i n wx wy" size - else - pr " fn%i n wx (extend%i %i wy)" size i (size - i - 1); + pr " | %i => N%i" i i; done; - pr " | %sn m wy => fnm n m wx wy" c; - pr " end"; + pr " | %s(S n) => Nn n" (if size=0 then "" else "SizePlus "); pr " end."; pr ""; - pp " Lemma spec_iter0: forall x y, P [x] [y] (iter0 x y)."; - pp " Proof."; - pp " intros x; case x; clear x; unfold iter0."; - for i = 0 to size do - pp " intros x."; - if i == 0 then - begin - pp " generalize (spec_w0_eq0 x); case w0_eq0; intros H."; - pp " intros y; rewrite H; apply Pf0t."; - pp " clear H."; - end; - pp " intros y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y."; - if j == 0 then - begin - pp " generalize (spec_w0_eq0 y); case w0_eq0; intros H."; - pp " rewrite H; apply Pft0."; - pp " clear H."; - end; - pp " rewrite spec_eval%in%i; apply (Pfn%i %i); zg_tac." j (i - j) j (i - j - 1); - done; - pp " intros y; apply Pf%i." i; - for j = i + 1 to size do - pp " intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac." i (j - i) i (j - i - 1); - done; - if i == size then - pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else - pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; - done; - pp " intros n x y; case y; clear y."; - for i = 0 to size do - pp " intros y."; - if i = 0 then - begin - pp " generalize (spec_w0_eq0 y); case w0_eq0; intros H."; - pp " rewrite H; apply Pft0."; - pp " clear H."; - end; - if i == size then - pp " rewrite spec_eval%in; apply Pfn%i." size size - else - pp " rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; - done; - pp " intros m y; apply Pfnm."; - pp " Qed."; - pp ""; - - - pr " End LevelAndIter."; - pr ""; +pr +" Definition level := iter_t (fun n _ => n). + Inductive View_t : t -> Prop := + Mk_t : forall n (x : dom_t n), View_t (mk_t n x). + + Lemma destr_t : forall x, View_t x. + Proof. + intros x. generalize (Mk_t (level x)). destruct x; simpl; auto. + Defined. + + Lemma iter_mk_t : forall A (f:forall n, dom_t n -> A), + forall n x, iter_t f (mk_t n x) = f n x. + Proof. + do_size (destruct n; try reflexivity). + Qed. + + (** * Projection to ZArith *) + + Definition to_Z : t -> Z := + Eval lazy beta iota delta [iter_t dom_t dom_op] in + iter_t (fun _ x => ZnZ.to_Z x). + + Notation \"[ x ]\" := (to_Z x). + + Theorem spec_mk_t : forall n (x:dom_t n), [mk_t n x] = ZnZ.to_Z x. + Proof. + intros. change to_Z with (iter_t (fun _ x => ZnZ.to_Z x)). + rewrite iter_mk_t; auto. + Qed. + + (** * Regular make op, without memoization or karatsuba + + This will normally never be used for actual computations, + but only for specification purpose when using + [word (dom_t n) m] intermediate values. *) + + Fixpoint nmake_op (ww:Type) (ww_op: ZnZ.Ops ww) (n: nat) : + ZnZ.Ops (word ww n) := + match n return ZnZ.Ops (word ww n) with + O => ww_op + | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1) + end. + + Let eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m). + + Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x, + nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x). + Proof. + auto. + Qed. + + Theorem digits_nmake_S :forall n ww (w_op: ZnZ.Ops ww), + ZnZ.digits (nmake_op _ w_op (S n)) = + xO (ZnZ.digits (nmake_op _ w_op n)). + Proof. + auto. + Qed. + + Theorem digits_nmake : forall n ww (w_op: ZnZ.Ops ww), + ZnZ.digits (nmake_op _ w_op n) = Pos.shiftl_nat (ZnZ.digits w_op) n. + Proof. + induction n. auto. + intros ww ww_op. rewrite Pshiftl_nat_S, <- IHn; auto. + Qed. + + Theorem nmake_double: forall n ww (w_op: ZnZ.Ops ww), + ZnZ.to_Z (Ops:=nmake_op _ w_op n) = + @DoubleBase.double_to_Z _ (ZnZ.digits w_op) (ZnZ.to_Z (Ops:=w_op)) n. + Proof. + intros n; elim n; auto; clear n. + intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z. + rewrite <- Hrec; auto. + unfold DoubleBase.double_wB; rewrite <- digits_nmake; auto. + Qed. + + Theorem nmake_WW: forall ww ww_op n xh xl, + (ZnZ.to_Z (Ops:=nmake_op ww ww_op (S n)) (WW xh xl) = + ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xh * + base (ZnZ.digits (nmake_op ww ww_op n)) + + ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xl)%%Z. + Proof. + auto. + Qed. + + (** * The specification proofs for the word operators *) +"; + + if size <> 0 then + pr " Typeclasses Opaque %s." (iter_name 1 size "w" ""); + pr ""; + + pr " Instance w0_spec: ZnZ.Specs w0_op := W0.specs."; + for i = 1 to min 3 size do + pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs w%i_spec." i i (i-1) + done; + for i = 4 to size do + pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." i i (i-1) + done; + pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." (size+1) (size+1) size; + + +pr " + Instance wn_spec (n:nat) : ZnZ.Specs (make_op n). + Proof. + induction n. + rewrite make_op_omake; simpl; auto with *. + rewrite make_op_S. exact (mk_zn2z_specs_karatsuba IHn). + Qed. + + Instance dom_spec n : ZnZ.Specs (dom_op n) | 10. + Proof. + do_size (destruct n; auto with *). apply wn_spec. + Qed. + + Let make_op_WW : forall n x y, + (ZnZ.to_Z (Ops:=make_op (S n)) (WW x y) = + ZnZ.to_Z (Ops:=make_op n) x * base (ZnZ.digits (make_op n)) + + ZnZ.to_Z (Ops:=make_op n) y)%%Z. + Proof. + intros n x y; rewrite make_op_S; auto. + Qed. + + (** * Zero *) + + Definition zero0 : w0 := ZnZ.zero. + + Definition zeron n : dom_t n := + match n with + | O => zero0 + | SizePlus (S n) => W0 + | _ => W0 + end. + + Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. + Proof. + do_size (destruct n; [exact ZnZ.spec_0|]). + destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0. + Qed. + + (** * Digits *) + + Lemma digits_make_op_0 : forall n, + ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op Size)) (S n). + Proof. + induction n. + auto. + replace (ZnZ.digits (make_op (S n))) with (xO (ZnZ.digits (make_op n))). + rewrite IHn; auto. + rewrite make_op_S; auto. + Qed. + + Lemma digits_make_op : forall n, + ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) (SizePlus (S n)). + Proof. + intros. rewrite digits_make_op_0. + replace (SizePlus (S n)) with (S n + Size) by (rewrite <- plus_comm; auto). + rewrite Pshiftl_nat_plus. auto. + Qed. + + Lemma digits_dom_op : forall n, + ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) n. + Proof. + do_size (destruct n; try reflexivity). + exact (digits_make_op n). + Qed. + + Lemma digits_dom_op_nmake : forall n m, + ZnZ.digits (dom_op (m+n)) = ZnZ.digits (nmake_op _ (dom_op n) m). + Proof. + intros. rewrite digits_nmake, 2 digits_dom_op. apply Pshiftl_nat_plus. + Qed. + + (** * Conversion between [zn2z (dom_t n)] and [dom_t (S n)]. + + These two types are provably equal, but not convertible, + hence we need some work. We now avoid using generic casts + (i.e. rewrite via proof of equalities in types), since + proving things with them is a mess. + *) + + Definition succ_t n : zn2z (dom_t n) -> dom_t (S n) := + match n with + | SizePlus (S _) => fun x => x + | _ => fun x => x + end. + + Lemma spec_succ_t : forall n x, + ZnZ.to_Z (succ_t n x) = + zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. + Proof. + do_size (destruct n ; [reflexivity|]). + intros. simpl. rewrite make_op_S. simpl. auto. + Qed. + + Definition pred_t n : dom_t (S n) -> zn2z (dom_t n) := + match n with + | SizePlus (S _) => fun x => x + | _ => fun x => x + end. + + Lemma succ_pred_t : forall n x, succ_t n (pred_t n x) = x. + Proof. + do_size (destruct n ; [reflexivity|]). reflexivity. + Qed. + + (** We can hence project from [zn2z (dom_t n)] to [t] : *) + + Definition mk_t_S n (x : zn2z (dom_t n)) : t := + mk_t (S n) (succ_t n x). + + Lemma spec_mk_t_S : forall n x, + [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. + Proof. + intros. unfold mk_t_S. rewrite spec_mk_t. apply spec_succ_t. + Qed. + + Lemma mk_t_S_level : forall n x, level (mk_t_S n x) = S n. + Proof. + intros. unfold mk_t_S, level. rewrite iter_mk_t; auto. + Qed. + + (** * Conversion from [word (dom_t n) m] to [dom_t (m+n)]. + + Things are more complex here. We start with a naive version + that breaks zn2z-trees and reconstruct them. Doing this is + quite unfortunate, but I don't know how to fully avoid that. + (cast someday ?). Then we build an optimized version where + all basic cases (n<=6 or m<=7) are nicely handled. + *) + + Definition zn2z_map {A} {B} (f:A->B) (x:zn2z A) : zn2z B := + match x with + | W0 => W0 + | WW h l => WW (f h) (f l) + end. + + Lemma zn2z_map_id : forall A f (x:zn2z A), (forall u, f u = u) -> + zn2z_map f x = x. + Proof. + destruct x; auto; intros. + simpl; f_equal; auto. + Qed. + + (** The naive version *) + + Fixpoint plus_t n m : word (dom_t n) m -> dom_t (m+n) := + match m as m' return word (dom_t n) m' -> dom_t (m'+n) with + | O => fun x => x + | S m => fun x => succ_t _ (zn2z_map (plus_t n m) x) + end. + + Theorem spec_plus_t : forall n m (x:word (dom_t n) m), + ZnZ.to_Z (plus_t n m x) = eval n m x. + Proof. + unfold eval. + induction m. + simpl; auto. + intros. + simpl plus_t; simpl plus. rewrite spec_succ_t. + destruct x. + simpl; auto. + fold word in w, w0. + simpl. rewrite 2 IHm. f_equal. f_equal. f_equal. + apply digits_dom_op_nmake. + Qed. + + Definition mk_t_w n m (x:word (dom_t n) m) : t := + mk_t (m+n) (plus_t n m x). + + Theorem spec_mk_t_w : forall n m (x:word (dom_t n) m), + [mk_t_w n m x] = eval n m x. + Proof. + intros. unfold mk_t_w. rewrite spec_mk_t. apply spec_plus_t. + Qed. + + (** The optimized version. + + NB: the last particular case for m could depend on n, + but it's simplier to just expand everywhere up to m=7 + (cf [mk_t_w'] later). + *) + + Definition plus_t' n : forall m, word (dom_t n) m -> dom_t (m+n) := + match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with + | SizePlus (S n') as n => plus_t n + | _ as n => + fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with + | SizePlus (S (S m')) as m => plus_t n m + | _ => fun x => x + end + end. + + Lemma plus_t_equiv : forall n m x, + plus_t' n m x = plus_t n m x. + Proof. + (do_size try destruct n); try reflexivity; + (do_size try destruct m); try destruct m; try reflexivity; + simpl; symmetry; repeat (intros; apply zn2z_map_id; trivial). + Qed. + + Lemma spec_plus_t' : forall n m x, + ZnZ.to_Z (plus_t' n m x) = eval n m x. + Proof. + intros; rewrite plus_t_equiv. apply spec_plus_t. + Qed. + + (** Particular cases [Nk x] = eval i j x with specific k,i,j + can be solved by the following tactic *) + + Ltac solve_eval := + intros; rewrite <- spec_plus_t'; unfold to_Z; simpl dom_op; reflexivity. + + (** The last particular case that remains useful *) + + Lemma spec_eval_size : forall n x, [Nn n x] = eval Size (S n) x. + Proof. + induction n. + solve_eval. + destruct x as [ | xh xl ]. + simpl. unfold eval. rewrite make_op_S. rewrite nmake_op_S. auto. + simpl word in xh, xl |- *. + unfold to_Z in *. rewrite make_op_WW. + unfold eval in *. rewrite nmake_WW. + f_equal; auto. + f_equal; auto. + f_equal. + rewrite <- digits_dom_op_nmake. rewrite plus_comm; auto. + Qed. + + (** An optimized [mk_t_w]. + + We could say mk_t_w' := mk_t _ (plus_t' n m x) + (TODO: WHY NOT, BTW ??). + Instead we directly define functions for all intersting [n], + reverting to naive [mk_t_w] at places that should normally + never be used (see [mul] and [div_gt]). + *) +"; + +for i = 0 to size-1 do +let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in +pr +" Let mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in + match m return word w%i (S m) -> t with + | %s as p => mk_t_w %i (S p) + | p => mk_t (%i+p) + end. +" i i pattern i (i+1) +done; + +pr +" Let mk_t_w' n : forall m, word (dom_t n) (S m) -> t := + match n return (forall m, word (dom_t n) (S m) -> t) with"; +for i = 0 to size-1 do pr " | %i => mk_t_%iw" i i done; +pr +" | Size => Nn + | _ as n' => fun m => mk_t_w n' (S m) + end. +"; + +pr +" Ltac solve_spec_mk_t_w' := + rewrite <- spec_plus_t'; + match goal with _ : word (dom_t ?n) ?m |- _ => apply (spec_mk_t (n+m)) end. + + Theorem spec_mk_t_w' : + forall n m x, [mk_t_w' n m x] = eval n (S m) x. + Proof. + intros. + repeat (apply spec_mk_t_w || (destruct n; + [repeat (apply spec_mk_t_w || (destruct m; [solve_spec_mk_t_w'|]))|])). + apply spec_eval_size. + Qed. + + (** * Extend : injecting [dom_t n] into [word (dom_t n) (S m)] *) + + Definition extend n m (x:dom_t n) : word (dom_t n) (S m) := + DoubleBase.extend_aux m (WW (zeron n) x). + + Lemma spec_extend : forall n m x, + [mk_t n x] = eval n (S m) (extend n m x). + Proof. + intros. unfold eval, extend. + rewrite spec_mk_t. + assert (H : forall (x:dom_t n), + (ZnZ.to_Z (zeron n) * base (ZnZ.digits (dom_op n)) + ZnZ.to_Z x = + ZnZ.to_Z x)%%Z). + clear; intros; rewrite spec_zeron; auto. + rewrite <- (@DoubleBase.spec_extend _ + (WW (zeron n)) (ZnZ.digits (dom_op n)) ZnZ.to_Z H m x). + simpl. rewrite digits_nmake, <- nmake_double. auto. + Qed. + + (** A particular case of extend, used in [same_level]: + [extend_size] is [extend Size] *) + + Definition extend_size := DoubleBase.extend (WW (W0:dom_t Size)). + + Lemma spec_extend_size : forall n x, [mk_t Size x] = [Nn n (extend_size n x)]. + Proof. + intros. rewrite spec_eval_size. apply (spec_extend Size n). + Qed. + + (** Misc results about extensions *) + + Let spec_extend_WW : forall n x, + [Nn (S n) (WW W0 x)] = [Nn n x]. + Proof. + intros n x. + set (N:=SizePlus (S n)). + change ([Nn (S n) (extend N 0 x)]=[mk_t N x]). + rewrite (spec_extend N 0). + solve_eval. + Qed. + + Let spec_extend_tr: forall m n w, + [Nn (m + n) (extend_tr w m)] = [Nn n w]. + Proof. + induction m; auto. + intros n x; simpl extend_tr. + simpl plus; rewrite spec_extend_WW; auto. + Qed. + + Let spec_cast_l: forall n m x1, + [Nn n x1] = + [Nn (Max.max n m) (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))]. + Proof. + intros n m x1; case (diff_r n m); simpl castm. + rewrite spec_extend_tr; auto. + Qed. + + Let spec_cast_r: forall n m x1, + [Nn m x1] = + [Nn (Max.max n m) (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))]. + Proof. + intros n m x1; case (diff_l n m); simpl castm. + rewrite spec_extend_tr; auto. + Qed. + + Ltac unfold_lets := + match goal with + | h : _ |- _ => unfold h; clear h; unfold_lets + | _ => idtac + end. + + (** * [same_level] + + Generic binary operator construction, by extending the smaller + argument to the level of the other. + *) + + Section SameLevel. + + Variable res: Type. + Variable P : Z -> Z -> res -> Prop. + Variable f : forall n, dom_t n -> dom_t n -> res. + Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). +"; + +for i = 0 to size do +pr " Let f%i : w%i -> w%i -> res := f %i." i i i i +done; +pr +" Let fn n := f (SizePlus (S n)). + + Let Pf' : + forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). + Proof. + intros. subst. rewrite 2 spec_mk_t. apply Pf. + Qed. +"; + +let ext i j s = + if j <= i then s else Printf.sprintf "(extend %i %i %s)" i (j-i-1) s +in + +pr " Notation same_level_folded := (fun x y => match x, y with"; +for i = 0 to size do + for j = 0 to size do + pr " | N%i wx, N%i wy => f%i %s %s" i j (max i j) (ext i j "wx") (ext j i "wy") + done; + pr " | N%i wx, Nn m wy => fn m (extend_size m %s) wy" i (ext i size "wx") +done; +for i = 0 to size do + pr " | Nn n wx, N%i wy => fn n wx (extend_size n %s)" i (ext i size "wy") +done; +pr +" | Nn n wx, Nn m wy => + let mn := Max.max n m in + let d := diff n m in + fn mn + (castm (diff_r n m) (extend_tr wx (snd d))) + (castm (diff_l n m) (extend_tr wy (fst d))) + end). +"; + +pr +" Definition same_level := Eval lazy beta iota delta + [ DoubleBase.extend DoubleBase.extend_aux extend zeron ] + in same_level_folded. + + Lemma spec_same_level_0: forall x y, P [x] [y] (same_level x y). + Proof. + change same_level with same_level_folded. unfold_lets. + destruct x, y; apply Pf'; simpl mk_t; rewrite <- ?spec_extend_size; + match goal with + | |- context [ extend ?n ?m _ ] => apply (spec_extend n m) + | |- context [ castm _ _ ] => apply spec_cast_l || apply spec_cast_r + | _ => reflexivity + end. + Qed. + + End SameLevel. + + Arguments same_level [res] f x y. + + Theorem spec_same_level_dep : + forall res + (P : nat -> Z -> Z -> res -> Prop) + (Pantimon : forall n m z z' r, n <= m -> P m z z' r -> P n z z' r) + (f : forall n, dom_t n -> dom_t n -> res) + (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), + forall x y, P (level x) [x] [y] (same_level f x y). + Proof. + intros res P Pantimon f Pf. + set (f' := fun n x y => (n, f n x y)). + set (P' := fun z z' r => P (fst r) z z' (snd r)). + assert (FST : forall x y, level x <= fst (same_level f' x y)) + by (destruct x, y; simpl; omega with * ). + assert (SND : forall x y, same_level f x y = snd (same_level f' x y)) + by (destruct x, y; reflexivity). + intros. eapply Pantimon; [eapply FST|]. + rewrite SND. eapply (@spec_same_level_0 _ P' f'); eauto. + Qed. + + (** * [iter] + + Generic binary operator construction, by splitting the larger + argument in blocks and applying the smaller argument to them. + *) + + Section Iter. + + Variable res: Type. + Variable P: Z -> Z -> res -> Prop. + + Variable f : forall n, dom_t n -> dom_t n -> res. + Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). + + Variable fd : forall n m, dom_t n -> word (dom_t n) (S m) -> res. + Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. + Variable Pfd : forall n m x y, P (ZnZ.to_Z x) (eval n (S m) y) (fd n m x y). + Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). + + Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. + Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). + + Let Pf' : + forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). + Proof. + intros. subst. rewrite 2 spec_mk_t. apply Pf. + Qed. + + Let Pfd' : forall n m x y u v, u = [mk_t n x] -> v = eval n (S m) y -> + P u v (fd n m x y). + Proof. + intros. subst. rewrite spec_mk_t. apply Pfd. + Qed. + + Let Pfg' : forall n m x y u v, u = eval n (S m) x -> v = [mk_t n y] -> + P u v (fg n m x y). + Proof. + intros. subst. rewrite spec_mk_t. apply Pfg. + Qed. +"; + +for i = 0 to size do +pr " Let f%i := f %i." i i +done; + +for i = 0 to size do +pr " Let f%in := fd %i." i i; +pr " Let fn%i := fg %i." i i; +done; + +pr " Notation iter_folded := (fun x y => match x, y with"; +for i = 0 to size do + for j = 0 to size do + pr " | N%i wx, N%i wy => f%s wx wy" i j + (if i = j then string_of_int i + else if i < j then string_of_int i ^ "n " ^ string_of_int (j-i-1) + else "n" ^ string_of_int j ^ " " ^ string_of_int (i-j-1)) + done; + pr " | N%i wx, Nn m wy => f%in m %s wy" i size (ext i size "wx") +done; +for i = 0 to size do + pr " | Nn n wx, N%i wy => fn%i n wx %s" i size (ext i size "wy") +done; +pr +" | Nn n wx, Nn m wy => fnm n m wx wy + end). +"; + +pr +" Definition iter := Eval lazy beta iota delta + [extend DoubleBase.extend DoubleBase.extend_aux zeron] + in iter_folded. + + Lemma spec_iter: forall x y, P [x] [y] (iter x y). + Proof. + change iter with iter_folded; unfold_lets. + destruct x; destruct y; apply Pf' || apply Pfd' || apply Pfg' || apply Pfnm; + simpl mk_t; + match goal with + | |- ?x = ?x => reflexivity + | |- [Nn _ _] = _ => apply spec_eval_size + | |- context [extend ?n ?m _] => apply (spec_extend n m) + | _ => idtac + end; + unfold to_Z; rewrite <- spec_plus_t'; simpl dom_op; reflexivity. + Qed. + + End Iter. +"; + +pr +" Definition switch + (P:nat->Type)%s + (fn:forall n, P n) n := + match n return P n with" + (iter_str_gen size (fun i -> Printf.sprintf "(f%i:P %i)" i i)); +for i = 0 to size do pr " | %i => f%i" i i done; +pr +" | n => fn n + end. +"; + +pr +" Lemma spec_switch : forall P (f:forall n, P n) n, + switch P %sf n = f n. + Proof. + repeat (destruct n; try reflexivity). + Qed. +" (iter_str_gen size (fun i -> Printf.sprintf "(f %i) " i)); + +pr +" (** * [iter_sym] + + A variant of [iter] for symmetric functions, or pseudo-symmetric + functions (when f y x can be deduced from f x y). + *) + + Section IterSym. + + Variable res: Type. + Variable P: Z -> Z -> res -> Prop. + + Variable f : forall n, dom_t n -> dom_t n -> res. + Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). + + Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. + Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). + + Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. + Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). + + Variable opp: res -> res. + Variable Popp : forall u v r, P u v r -> P v u (opp r). +"; + +for i = 0 to size do +pr " Let f%i := f %i." i i +done; + +for i = 0 to size do +pr " Let fn%i := fg %i." i i; +done; + +pr " Let f' := switch _ %s f." (iter_name 0 size "f" ""); +pr " Let fg' := switch _ %s fg." (iter_name 0 size "fn" ""); + +pr +" Local Notation iter_sym_folded := + (iter res f' (fun n m x y => opp (fg' n m y x)) fg' fnm). + + Definition iter_sym := + Eval lazy beta zeta iota delta [iter f' fg' switch] in iter_sym_folded. + + Lemma spec_iter_sym: forall x y, P [x] [y] (iter_sym x y). + Proof. + intros. change iter_sym with iter_sym_folded. apply spec_iter; clear x y. + unfold_lets. + intros. rewrite spec_switch. auto. + intros. apply Popp. unfold_lets. rewrite spec_switch; auto. + intros. unfold_lets. rewrite spec_switch; auto. + auto. + Qed. + + End IterSym. + + (** * Reduction + + [reduce] can be used instead of [mk_t], it will choose the + lowest possible level. NB: We only search and remove leftmost + W0's via ZnZ.eq0, any non-W0 block ends the process, even + if its value is 0. + *) + + (** First, a direct version ... *) + + Fixpoint red_t n : dom_t n -> t := + match n return dom_t n -> t with + | O => N0 + | S n => fun x => + let x' := pred_t n x in + reduce_n1 _ _ (N0 zero0) ZnZ.eq0 (red_t n) (mk_t_S n) x' + end. + + Lemma spec_red_t : forall n x, [red_t n x] = [mk_t n x]. + Proof. + induction n. + reflexivity. + intros. + simpl red_t. unfold reduce_n1. + rewrite <- (succ_pred_t n x) at 2. + remember (pred_t n x) as x'. + rewrite spec_mk_t, spec_succ_t. + destruct x' as [ | xh xl]. simpl. apply ZnZ.spec_0. + generalize (ZnZ.spec_eq0 xh); case ZnZ.eq0; intros H. + rewrite IHn, spec_mk_t. simpl. rewrite H; auto. + apply spec_mk_t_S. + Qed. + + (** ... then a specialized one *) +"; + +for i = 0 to size do +pr " Definition eq0%i := @ZnZ.eq0 _ w%i_op." i i; +done; + +pr " + Definition reduce_0 := N0."; +for i = 1 to size do + pr " Definition reduce_%i :=" i; + pr " Eval lazy beta iota delta [reduce_n1] in"; + pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i N%i." (i-1) (i-1) i +done; - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Reduction *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - pr " Definition reduce_0 (x:w) := %s0 x." c; - pr " Definition reduce_1 :="; - pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w0_eq0 %s0 %s1." c c; - for i = 2 to size do - pr " Definition reduce_%i :=" i; - pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." - (i-1) (i-1) c i - done; pr " Definition reduce_%i :=" (size+1); - pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." - size size c; + pr " Eval lazy beta iota delta [reduce_n1] in"; + pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i (Nn 0)." size size; pr " Definition reduce_n n :="; - pr " Eval lazy beta iota delta[reduce_n] in"; - pr " reduce_n _ _ zero reduce_%i %sn n." (size + 1) c; - pr ""; - - pp " Let spec_reduce_0: forall x, [reduce_0 x] = [%s0 x]." c; - pp " Proof."; - pp " intros x; unfold to_Z, reduce_0."; - pp " auto."; - pp " Qed."; - pp ""; - - for i = 1 to size + 1 do - if i == size + 1 then - pp " Let spec_reduce_%i: forall x, [reduce_%i x] = [%sn 0 x]." i i c - else - pp " Let spec_reduce_%i: forall x, [reduce_%i x] = [%s%i x]." i i c i; - pp " Proof."; - pp " intros x; case x; unfold reduce_%i." i; - pp " exact (spec_0 w0_spec)."; - pp " intros x1 y1."; - pp " generalize (spec_w%i_eq0 x1);" (i - 1); - pp " case w%i_eq0; intros H1; auto." (i - 1); - if i <> 1 then - pp " rewrite spec_reduce_%i." (i - 1); - pp " unfold to_Z; rewrite znz_to_Z_%i." i; - pp " unfold to_Z in H1; rewrite H1; auto."; - pp " Qed."; - pp ""; - done; - - pp " Let spec_reduce_n: forall n x, [reduce_n n x] = [%sn n x]." c; - pp " Proof."; - pp " intros n; elim n; simpl reduce_n."; - pp " intros x; rewrite <- spec_reduce_%i; auto." (size + 1); - pp " intros n1 Hrec x; case x."; - pp " unfold to_Z; rewrite make_op_S; auto."; - pp " exact (spec_0 w0_spec)."; - pp " intros x1 y1; case x1; auto."; - pp " rewrite Hrec."; - pp " rewrite spec_extendn0_0; auto."; - pp " Qed."; - pp ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Successor *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_succ_c := w%i_op.(znz_succ_c)." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_succ := w%i_op.(znz_succ)." i i - done; - pr ""; - - pr " Definition succ x :="; - pr " match x with"; - for i = 0 to size-1 do - pr " | %s%i wx =>" c i; - pr " match w%i_succ_c wx with" i; - pr " | C0 r => %s%i r" c i; - pr " | C1 r => %s%i (WW one%i r)" c (i+1) i; - pr " end"; - done; - pr " | %s%i wx =>" c size; - pr " match w%i_succ_c wx with" size; - pr " | C0 r => %s%i r" c size; - pr " | C1 r => %sn 0 (WW one%i r)" c size ; - pr " end"; - pr " | %sn n wx =>" c; - pr " let op := make_op n in"; - pr " match op.(znz_succ_c) wx with"; - pr " | C0 r => %sn n r" c; - pr " | C1 r => %sn (S n) (WW op.(znz_1) r)" c; - pr " end"; - pr " end."; - pr ""; - - pr " Theorem spec_succ: forall n, [succ n] = [n] + 1."; - pa " Admitted."; - pp " Proof."; - pp " intros n; case n; unfold succ, to_Z."; - for i = 0 to size do - pp " intros n1; generalize (spec_succ_c w%i_spec n1);" i; - pp " unfold succ, to_Z, w%i_succ_c; case znz_succ_c; auto." i; - pp " intros ww H; rewrite <- H."; - pp " (rewrite znz_to_Z_%i; unfold interp_carry;" (i + 1); - pp " apply f_equal2 with (f := Zplus); auto;"; - pp " apply f_equal2 with (f := Zmult); auto;"; - pp " exact (spec_1 w%i_spec))." i; - done; - pp " intros k n1; generalize (spec_succ_c (wn_spec k) n1)."; - pp " unfold succ, to_Z; case znz_succ_c; auto."; - pp " intros ww H; rewrite <- H."; - pp " (rewrite (znz_to_Z_n k); unfold interp_carry;"; - pp " apply f_equal2 with (f := Zplus); auto;"; - pp " apply f_equal2 with (f := Zmult); auto;"; - pp " exact (spec_1 (wn_spec k)))."; - pp " Qed."; - pr ""; - - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Adddition *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_add_c := znz_add_c w%i_op." i i; - pr " Definition w%i_add x y :=" i; - pr " match w%i_add_c x y with" i; - pr " | C0 r => %s%i r" c i; - if i == size then - pr " | C1 r => %sn 0 (WW one%i r)" c size - else - pr " | C1 r => %s%i (WW one%i r)" c (i + 1) i; - pr " end."; - pr ""; - done ; - pr " Definition addn n (x y : word w%i (S n)) :=" size; - pr " let op := make_op n in"; - pr " match op.(znz_add_c) x y with"; - pr " | C0 r => %sn n r" c; - pr " | C1 r => %sn (S n) (WW op.(znz_1) r) end." c; - pr ""; - - - for i = 0 to size do - pp " Let spec_w%i_add: forall x y, [w%i_add x y] = [%s%i x] + [%s%i y]." i i c i c i; - pp " Proof."; - pp " intros n m; unfold to_Z, w%i_add, w%i_add_c." i i; - pp " generalize (spec_add_c w%i_spec n m); case znz_add_c; auto." i; - pp " intros ww H; rewrite <- H."; - pp " rewrite znz_to_Z_%i; unfold interp_carry;" (i + 1); - pp " apply f_equal2 with (f := Zplus); auto;"; - pp " apply f_equal2 with (f := Zmult); auto;"; - pp " exact (spec_1 w%i_spec)." i; - pp " Qed."; - pp ""; - done; - pp " Let spec_wn_add: forall n x y, [addn n x y] = [%sn n x] + [%sn n y]." c c; - pp " Proof."; - pp " intros k n m; unfold to_Z, addn."; - pp " generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto."; - pp " intros ww H; rewrite <- H."; - pp " rewrite (znz_to_Z_n k); unfold interp_carry;"; - pp " apply f_equal2 with (f := Zplus); auto;"; - pp " apply f_equal2 with (f := Zmult); auto;"; - pp " exact (spec_1 (wn_spec k))."; - pp " Qed."; - - pr " Definition add := Eval lazy beta delta [same_level] in"; - pr0 " (same_level t_ "; - for i = 0 to size do - pr0 "w%i_add " i; - done; - pr "addn)."; - pr ""; - - pr " Theorem spec_add: forall x y, [add x y] = [x] + [y]."; - pa " Admitted."; - pp " Proof."; - pp " unfold add."; - pp " generalize (spec_same_level t_ (fun x y res => [res] = x + y))."; - pp " unfold same_level; intros HH; apply HH; clear HH."; - for i = 0 to size do - pp " exact spec_w%i_add." i; - done; - pp " exact spec_wn_add."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Predecessor *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_pred_c := w%i_op.(znz_pred_c)." i i - done; - pr ""; - - pr " Definition pred x :="; - pr " match x with"; - for i = 0 to size do - pr " | %s%i wx =>" c i; - pr " match w%i_pred_c wx with" i; - pr " | C0 r => reduce_%i r" i; - pr " | C1 r => zero"; - pr " end"; - done; - pr " | %sn n wx =>" c; - pr " let op := make_op n in"; - pr " match op.(znz_pred_c) wx with"; - pr " | C0 r => reduce_n n r"; - pr " | C1 r => zero"; - pr " end"; - pr " end."; - pr ""; - - pr " Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold pred."; - for i = 0 to size do - pp " intros x1 H1; unfold w%i_pred_c;" i; - pp " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i; - pp " rewrite spec_reduce_%i; auto." i; - pp " unfold interp_carry; unfold to_Z."; - pp " case (spec_to_Z w%i_spec x1); intros HH1 HH2." i; - pp " case (spec_to_Z w%i_spec y1); intros HH3 HH4 HH5." i; - pp " assert (znz_to_Z w%i_op x1 - 1 < 0); auto with zarith." i; - pp " unfold to_Z in H1; auto with zarith."; - done; - pp " intros n x1 H1;"; - pp " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1."; - pp " rewrite spec_reduce_n; auto."; - pp " unfold interp_carry; unfold to_Z."; - pp " case (spec_to_Z (wn_spec n) x1); intros HH1 HH2."; - pp " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4 HH5."; - pp " assert (znz_to_Z (make_op n) x1 - 1 < 0); auto with zarith."; - pp " unfold to_Z in H1; auto with zarith."; - pp " Qed."; - pp ""; - - pp " Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0."; - pp " Proof."; - pp " intros x; case x; unfold pred."; - for i = 0 to size do - pp " intros x1 H1; unfold w%i_pred_c;" i; - pp " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1." i; - pp " unfold interp_carry; unfold to_Z."; - pp " unfold to_Z in H1; auto with zarith."; - pp " case (spec_to_Z w%i_spec y1); intros HH3 HH4; auto with zarith." i; - pp " intros; exact (spec_0 w0_spec)."; - done; - pp " intros n x1 H1;"; - pp " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1."; - pp " unfold interp_carry; unfold to_Z."; - pp " unfold to_Z in H1; auto with zarith."; - pp " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4; auto with zarith."; - pp " intros; exact (spec_0 w0_spec)."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Subtraction *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_sub_c := w%i_op.(znz_sub_c)." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_sub x y :=" i; - pr " match w%i_sub_c x y with" i; - pr " | C0 r => reduce_%i r" i; - pr " | C1 r => zero"; - pr " end." - done; - pr ""; - - pr " Definition subn n (x y : word w%i (S n)) :=" size; - pr " let op := make_op n in"; - pr " match op.(znz_sub_c) x y with"; - pr " | C0 r => %sn n r" c; - pr " | C1 r => N0 w_0"; - pr " end."; - pr ""; - - for i = 0 to size do - pp " Let spec_w%i_sub: forall x y, [%s%i y] <= [%s%i x] -> [w%i_sub x y] = [%s%i x] - [%s%i y]." i c i c i i c i c i; - pp " Proof."; - pp " intros n m; unfold w%i_sub, w%i_sub_c." i i; - pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i; - if i == 0 then - pp " intros x; auto." - else - pp " intros x; try rewrite spec_reduce_%i; auto." i; - pp " unfold interp_carry; unfold zero, w_0, to_Z."; - pp " rewrite (spec_0 w0_spec)."; - pp " case (spec_to_Z w%i_spec x); intros; auto with zarith." i; - pp " Qed."; - pp ""; - done; - - pp " Let spec_wn_sub: forall n x y, [%sn n y] <= [%sn n x] -> [subn n x y] = [%sn n x] - [%sn n y]." c c c c; - pp " Proof."; - pp " intros k n m; unfold subn."; - pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;"; - pp " intros x; auto."; - pp " unfold interp_carry, to_Z."; - pp " case (spec_to_Z (wn_spec k) x); intros; auto with zarith."; - pp " Qed."; - pp ""; - - pr " Definition sub := Eval lazy beta delta [same_level] in"; - pr0 " (same_level t_ "; - for i = 0 to size do - pr0 "w%i_sub " i; - done; - pr "subn)."; - pr ""; - - pr " Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y]."; - pa " Admitted."; - pp " Proof."; - pp " unfold sub."; - pp " generalize (spec_same_level t_ (fun x y res => y <= x -> [res] = x - y))."; - pp " unfold same_level; intros HH; apply HH; clear HH."; - for i = 0 to size do - pp " exact spec_w%i_sub." i; - done; - pp " exact spec_wn_sub."; - pp " Qed."; - pr ""; - - for i = 0 to size do - pp " Let spec_w%i_sub0: forall x y, [%s%i x] < [%s%i y] -> [w%i_sub x y] = 0." i c i c i i; - pp " Proof."; - pp " intros n m; unfold w%i_sub, w%i_sub_c." i i; - pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c;" i; - pp " intros x; unfold interp_carry."; - pp " unfold to_Z; case (spec_to_Z w%i_spec x); intros; auto with zarith." i; - pp " intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto."; - pp " Qed."; - pp ""; - done; - - pp " Let spec_wn_sub0: forall n x y, [%sn n x] < [%sn n y] -> [subn n x y] = 0." c c; - pp " Proof."; - pp " intros k n m; unfold subn."; - pp " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c;"; - pp " intros x; unfold interp_carry."; - pp " unfold to_Z; case (spec_to_Z (wn_spec k) x); intros; auto with zarith."; - pp " intros; unfold to_Z, w_0; rewrite (spec_0 (w0_spec)); auto."; - pp " Qed."; - pp ""; - - pr " Theorem spec_sub0: forall x y, [x] < [y] -> [sub x y] = 0."; - pa " Admitted."; - pp " Proof."; - pp " unfold sub."; - pp " generalize (spec_same_level t_ (fun x y res => x < y -> [res] = 0))."; - pp " unfold same_level; intros HH; apply HH; clear HH."; - for i = 0 to size do - pp " exact spec_w%i_sub0." i; - done; - pp " exact spec_wn_sub0."; - pp " Qed."; - pr ""; - - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Comparison *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition compare_%i := w%i_op.(znz_compare)." i i; - pr " Definition comparen_%i :=" i; - pr " compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i." i i (pz i) i i (pz i) i - done; - pr ""; - - pr " Definition comparenm n m wx wy :="; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " let op := make_op mn in"; - pr " op.(znz_compare)"; - pr " (castm (diff_r n m) (extend_tr wx (snd d)))"; - pr " (castm (diff_l n m) (extend_tr wy (fst d)))."; - pr ""; - - pr " Definition compare := Eval lazy beta delta [iter] in"; - pr " (iter _"; - for i = 0 to size do - pr " compare_%i" i; - pr " (fun n x y => CompOpp (comparen_%i (S n) y x))" i; - pr " (fun n => comparen_%i (S n))" i; - done; - pr " comparenm)."; - pr ""; - - for i = 0 to size do - pp " Let spec_compare_%i: forall x y," i; - pp " match compare_%i x y with" i; - pp " Eq => [%s%i x] = [%s%i y]" c i c i; - pp " | Lt => [%s%i x] < [%s%i y]" c i c i; - pp " | Gt => [%s%i x] > [%s%i y]" c i c i; - pp " end."; - pp " Proof."; - pp " unfold compare_%i, to_Z; exact (spec_compare w%i_spec)." i i; - pp " Qed."; - pp ""; - - pp " Let spec_comparen_%i:" i; - pp " forall (n : nat) (x : word w%i n) (y : w%i)," i i; - pp " match comparen_%i n x y with" i; - pp " | Eq => eval%in n x = [%s%i y]" i c i; - pp " | Lt => eval%in n x < [%s%i y]" i c i; - pp " | Gt => eval%in n x > [%s%i y]" i c i; - pp " end."; - pp " intros n x y."; - pp " unfold comparen_%i, to_Z; rewrite spec_double_eval%in." i i; - pp " apply spec_compare_mn_1."; - pp " exact (spec_0 w%i_spec)." i; - pp " intros x1; exact (spec_compare w%i_spec %s x1)." i (pz i); - pp " exact (spec_to_Z w%i_spec)." i; - pp " exact (spec_compare w%i_spec)." i; - pp " exact (spec_compare w%i_spec)." i; - pp " exact (spec_to_Z w%i_spec)." i; - pp " Qed."; - pp ""; - done; - - pp " Let spec_opp_compare: forall c (u v: Z),"; - pp " match c with Eq => u = v | Lt => u < v | Gt => u > v end ->"; - pp " match CompOpp c with Eq => v = u | Lt => v < u | Gt => v > u end."; - pp " Proof."; - pp " intros c u v; case c; unfold CompOpp; auto with zarith."; - pp " Qed."; - pp ""; - - - pr " Theorem spec_compare_aux: forall x y,"; - pr " match compare x y with"; - pr " Eq => [x] = [y]"; - pr " | Lt => [x] < [y]"; - pr " | Gt => [x] > [y]"; - pr " end."; - pa " Admitted."; - pp " Proof."; - pp " refine (spec_iter _ (fun x y res =>"; - pp " match res with"; - pp " Eq => x = y"; - pp " | Lt => x < y"; - pp " | Gt => x > y"; - pp " end)"; - for i = 0 to size do - pp " compare_%i" i; - pp " (fun n x y => CompOpp (comparen_%i (S n) y x))" i; - pp " (fun n => comparen_%i (S n)) _ _ _" i; - done; - pp " comparenm _)."; - - for i = 0 to size - 1 do - pp " exact spec_compare_%i." i; - pp " intros n x y H;apply spec_opp_compare; apply spec_comparen_%i." i; - pp " intros n x y H; exact (spec_comparen_%i (S n) x y)." i; - done; - pp " exact spec_compare_%i." size; - pp " intros n x y;apply spec_opp_compare; apply spec_comparen_%i." size; - pp " intros n; exact (spec_comparen_%i (S n))." size; - pp " intros n m x y; unfold comparenm."; - pp " rewrite <- (spec_cast_l n m x); rewrite <- (spec_cast_r n m y)."; - pp " unfold to_Z; apply (spec_compare (wn_spec (Max.max n m)))."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Multiplication *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_mul_c := w%i_op.(znz_mul_c)." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_mul_add :=" i; - pr " Eval lazy beta delta [w_mul_add] in"; - pr " @w_mul_add w%i %s w%i_succ w%i_add_c w%i_mul_c." i (pz i) i i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_0W := znz_0W w%i_op." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_WW := znz_WW w%i_op." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_mul_add_n1 :=" i; - pr " @double_mul_add_n1 w%i %s w%i_WW w%i_0W w%i_mul_add." i (pz i) i i i - done; - pr ""; - - for i = 0 to size - 1 do - pr " Let to_Z%i n :=" i; - pr " match n return word w%i (S n) -> t_ with" i; - for j = 0 to size - i do - if (i + j) == size then - begin - pr " | %i%s => fun x => %sn 0 x" j "%nat" c; - pr " | %i%s => fun x => %sn 1 x" (j + 1) "%nat" c - end - else - pr " | %i%s => fun x => %s%i x" j "%nat" c (i + j + 1) - done; - pr " | _ => fun _ => N0 w_0"; - pr " end."; - pr ""; - done; - - - for i = 0 to size - 1 do - pp "Theorem to_Z%i_spec:" i; - pp " forall n x, Z_of_nat n <= %i -> [to_Z%i n x] = znz_to_Z (nmake_op _ w%i_op (S n)) x." (size + 1 - i) i i; - for j = 1 to size + 2 - i do - pp " intros n; case n; clear n."; - pp " unfold to_Z%i." i; - pp " intros x H; rewrite spec_eval%in%i; auto." i j; - done; - pp " intros n x."; - pp " repeat rewrite inj_S; unfold Zsucc; auto with zarith."; - pp " Qed."; - pp ""; - done; - - - for i = 0 to size do - pr " Definition w%i_mul n x y :=" i; - pr " let (w,r) := w%i_mul_add_n1 (S n) x y %s in" i (pz i); - if i == size then - begin - pr " if w%i_eq0 w then %sn n r" i c; - pr " else %sn (S n) (WW (extend%i n w) r)." c i; - end - else - begin - pr " if w%i_eq0 w then to_Z%i n r" i i; - pr " else to_Z%i (S n) (WW (extend%i n w) r)." i i; - end; - pr ""; - done; - - pr " Definition mulnm n m x y :="; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " let op := make_op mn in"; - pr " reduce_n (S mn) (op.(znz_mul_c)"; - pr " (castm (diff_r n m) (extend_tr x (snd d)))"; - pr " (castm (diff_l n m) (extend_tr y (fst d))))."; - pr ""; - - pr " Definition mul := Eval lazy beta delta [iter0] in"; - pr " (iter0 t_"; - for i = 0 to size do - pr " (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i; - pr " (fun n x y => w%i_mul n y x)" i; - pr " w%i_mul" i; - done; - pr " mulnm"; - pr " (fun _ => N0 w_0)"; - pr " (fun _ => N0 w_0)"; - pr " )."; - pr ""; - for i = 0 to size do - pp " Let spec_w%i_mul_add: forall x y z," i; - pp " let (q,r) := w%i_mul_add x y z in" i; - pp " znz_to_Z w%i_op q * (base (znz_digits w%i_op)) + znz_to_Z w%i_op r =" i i i; - pp " znz_to_Z w%i_op x * znz_to_Z w%i_op y + znz_to_Z w%i_op z :=" i i i ; - pp " (spec_mul_add w%i_spec)." i; - pp ""; - done; - - for i = 0 to size do - pp " Theorem spec_w%i_mul_add_n1: forall n x y z," i; - pp " let (q,r) := w%i_mul_add_n1 n x y z in" i; - pp " znz_to_Z w%i_op q * (base (znz_digits (nmake_op _ w%i_op n))) +" i i; - pp " znz_to_Z (nmake_op _ w%i_op n) r =" i; - pp " znz_to_Z (nmake_op _ w%i_op n) x * znz_to_Z w%i_op y +" i i; - pp " znz_to_Z w%i_op z." i; - pp " Proof."; - pp " intros n x y z; unfold w%i_mul_add_n1." i; - pp " rewrite nmake_double."; - pp " rewrite digits_doubled."; - pp " change (base (DoubleBase.double_digits (znz_digits w%i_op) n)) with" i; - pp " (DoubleBase.double_wB (znz_digits w%i_op) n)." i; - pp " apply spec_double_mul_add_n1; auto."; - if i == 0 then pp " exact (spec_0 w%i_spec)." i; - pp " exact (spec_WW w%i_spec)." i; - pp " exact (spec_0W w%i_spec)." i; - pp " exact (spec_mul_add w%i_spec)." i; - pp " Qed."; - pp ""; - done; - - pp " Lemma nmake_op_WW: forall ww ww1 n x y,"; - pp " znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) ="; - pp " znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) +"; - pp " znz_to_Z (nmake_op ww ww1 n) y."; - pp " auto."; - pp " Qed."; - pp ""; - - for i = 0 to size do - pp " Lemma extend%in_spec: forall n x1," i; - pp " znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) =" i i; - pp " znz_to_Z w%i_op x1." i; - pp " Proof."; - pp " intros n1 x2; rewrite nmake_double."; - pp " unfold extend%i." i; - pp " rewrite DoubleBase.spec_extend; auto."; - if i == 0 then - pp " intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring."; - pp " Qed."; - pp ""; - done; - - pp " Lemma spec_muln:"; - pp " forall n (x: word _ (S n)) y,"; - pp " [%sn (S n) (znz_mul_c (make_op n) x y)] = [%sn n x] * [%sn n y]." c c c; - pp " Proof."; - pp " intros n x y; unfold to_Z."; - pp " rewrite <- (spec_mul_c (wn_spec n))."; - pp " rewrite make_op_S."; - pp " case znz_mul_c; auto."; - pp " Qed."; - pr ""; - - pr " Theorem spec_mul: forall x y, [mul x y] = [x] * [y]."; - pa " Admitted."; - pp " Proof."; - for i = 0 to size do - pp " assert(F%i:" i; - pp " forall n x y,"; - if i <> size then - pp0 " Z_of_nat n <= %i -> " (size - i); - pp " [w%i_mul n x y] = eval%in (S n) x * [%s%i y])." i i c i; - if i == size then - pp " intros n x y; unfold w%i_mul." i - else - pp " intros n x y H; unfold w%i_mul." i; - pp " generalize (spec_w%i_mul_add_n1 (S n) x y %s)." i (pz i); - pp " case w%i_mul_add_n1; intros x1 y1." i; - pp " change (znz_to_Z (nmake_op _ w%i_op (S n)) x) with (eval%in (S n) x)." i i; - pp " change (znz_to_Z w%i_op y) with ([%s%i y])." i c i; - if i == 0 then - pp " unfold w_0; rewrite (spec_0 w0_spec); rewrite Zplus_0_r." - else - pp " change (znz_to_Z w%i_op W0) with 0; rewrite Zplus_0_r." i; - pp " intros H1; rewrite <- H1; clear H1."; - pp " generalize (spec_w%i_eq0 x1); case w%i_eq0; intros HH." i i; - pp " unfold to_Z in HH; rewrite HH."; - if i == size then - begin - pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i; auto." i i i; - pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i." i i i - end - else - begin - pp " rewrite to_Z%i_spec; auto with zarith." i; - pp " rewrite to_Z%i_spec; try (rewrite inj_S; auto with zarith)." i - end; - pp " rewrite nmake_op_WW; rewrite extend%in_spec; auto." i; - done; - pp " refine (spec_iter0 t_ (fun x y res => [res] = x * y)"; - for i = 0 to size do - pp " (fun x y => reduce_%i (w%i_mul_c x y))" (i + 1) i; - pp " (fun n x y => w%i_mul n y x)" i; - pp " w%i_mul _ _ _" i; - done; - pp " mulnm _"; - pp " (fun _ => N0 w_0) _"; - pp " (fun _ => N0 w_0) _"; - pp " )."; - for i = 0 to size do - pp " intros x y; rewrite spec_reduce_%i." (i + 1); - pp " unfold w%i_mul_c, to_Z." i; - pp " generalize (spec_mul_c w%i_spec x y)." i; - pp " intros HH; rewrite <- HH; clear HH; auto."; - if i == size then - begin - pp " intros n x y; rewrite F%i; auto with zarith." i; - pp " intros n x y; rewrite F%i; auto with zarith." i; - end - else - begin - pp " intros n x y H; rewrite F%i; auto with zarith." i; - pp " intros n x y H; rewrite F%i; auto with zarith." i; - end; - done; - pp " intros n m x y; unfold mulnm."; - pp " rewrite spec_reduce_n."; - pp " rewrite <- (spec_cast_l n m x)."; - pp " rewrite <- (spec_cast_r n m y)."; - pp " rewrite spec_muln; rewrite spec_cast_l; rewrite spec_cast_r; auto."; - pp " intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring."; - pp " intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Square *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_square_c := w%i_op.(znz_square_c)." i i - done; - pr ""; - - pr " Definition square x :="; - pr " match x with"; - pr " | %s0 wx => reduce_1 (w0_square_c wx)" c; - for i = 1 to size - 1 do - pr " | %s%i wx => %s%i (w%i_square_c wx)" c i c (i+1) i - done; - pr " | %s%i wx => %sn 0 (w%i_square_c wx)" c size c size; - pr " | %sn n wx =>" c; - pr " let op := make_op n in"; - pr " %sn (S n) (op.(znz_square_c) wx)" c; - pr " end."; - pr ""; - - pr " Theorem spec_square: forall x, [square x] = [x] * [x]."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold square; clear x."; - pp " intros x; rewrite spec_reduce_1; unfold to_Z."; - pp " exact (spec_square_c w%i_spec x)." 0; - for i = 1 to size do - pp " intros x; unfold to_Z."; - pp " exact (spec_square_c w%i_spec x)." i; - done; - pp " intros n x; unfold to_Z."; - pp " rewrite make_op_S."; - pp " exact (spec_square_c (wn_spec n) x)."; - pp "Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Square root *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_sqrt := w%i_op.(znz_sqrt)." i i - done; - pr ""; - - pr " Definition sqrt x :="; - pr " match x with"; - for i = 0 to size do - pr " | %s%i wx => reduce_%i (w%i_sqrt wx)" c i i i; - done; - pr " | %sn n wx =>" c; - pr " let op := make_op n in"; - pr " reduce_n n (op.(znz_sqrt) wx)"; - pr " end."; - pr ""; - - pr " Theorem spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2."; - pa " Admitted."; - pp " Proof."; - pp " intros x; unfold sqrt; case x; clear x."; - for i = 0 to size do - pp " intros x; rewrite spec_reduce_%i; exact (spec_sqrt w%i_spec x)." i i; - done; - pp " intros n x; rewrite spec_reduce_n; exact (spec_sqrt (wn_spec n) x)."; - pp " Qed."; - pr ""; - - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Division *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_div_gt := w%i_op.(znz_div_gt)." i i - done; - pr ""; - - pp " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :="; - pp " (spec_double_divn1"; - pp " ww_op.(znz_zdigits) ww_op.(znz_0)"; - pp " (znz_WW ww_op) ww_op.(znz_head0)"; - pp " ww_op.(znz_add_mul_div) ww_op.(znz_div21)"; - pp " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)"; - pp " (spec_to_Z ww_spec)"; - pp " (spec_zdigits ww_spec)"; - pp " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)"; - pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec)"; - pp " (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec))."; - pp ""; - - for i = 0 to size do - pr " Definition w%i_divn1 n x y :=" i; - pr " let (u, v) :="; - pr " double_divn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)" i i; - pr " (znz_WW w%i_op) w%i_op.(znz_head0)" i i; - pr " w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)" i i; - pr " w%i_op.(znz_compare) w%i_op.(znz_sub) (S n) x y in" i i; - if i == size then - pr " (%sn _ u, %s%i v)." c c i - else - pr " (to_Z%i _ u, %s%i v)." i c i; - done; - pr ""; - - for i = 0 to size do - pp " Lemma spec_get_end%i: forall n x y," i; - pp " eval%in n x <= [%s%i y] ->" i c i; - pp " [%s%i (DoubleBase.get_low %s n x)] = eval%in n x." c i (pz i) i; - pp " Proof."; - pp " intros n x y H."; - pp " rewrite spec_double_eval%in; unfold to_Z." i; - pp " apply DoubleBase.spec_get_low."; - pp " exact (spec_0 w%i_spec)." i; - pp " exact (spec_to_Z w%i_spec)." i; - pp " apply Zle_lt_trans with [%s%i y]; auto." c i; - pp " rewrite <- spec_double_eval%in; auto." i; - pp " unfold to_Z; case (spec_to_Z w%i_spec y); auto." i; - pp " Qed."; - pp ""; - done; - - for i = 0 to size do - pr " Let div_gt%i x y := let (u,v) := (w%i_div_gt x y) in (reduce_%i u, reduce_%i v)." i i i i; - done; - pr ""; - - - pr " Let div_gtnm n m wx wy :="; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " let op := make_op mn in"; - pr " let (q, r):= op.(znz_div_gt)"; - pr " (castm (diff_r n m) (extend_tr wx (snd d)))"; - pr " (castm (diff_l n m) (extend_tr wy (fst d))) in"; - pr " (reduce_n mn q, reduce_n mn r)."; - pr ""; - - pr " Definition div_gt := Eval lazy beta delta [iter] in"; - pr " (iter _"; - for i = 0 to size do - pr " div_gt%i" i; - pr " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); - pr " w%i_divn1" i; - done; - pr " div_gtnm)."; - pr ""; - - pr " Theorem spec_div_gt: forall x y,"; - pr " [x] > [y] -> 0 < [y] ->"; - pr " let (q,r) := div_gt x y in"; - pr " [q] = [x] / [y] /\\ [r] = [x] mod [y]."; - pa " Admitted."; - pp " Proof."; - pp " assert (FO:"; - pp " forall x y, [x] > [y] -> 0 < [y] ->"; - pp " let (q,r) := div_gt x y in"; - pp " [x] = [q] * [y] + [r] /\\ 0 <= [r] < [y])."; - pp " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->"; - pp " let (q,r) := res in"; - pp " x = [q] * y + [r] /\\ 0 <= [r] < y)"; - for i = 0 to size do - pp " div_gt%i" i; - pp " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); - pp " w%i_divn1 _ _ _" i; - done; - pp " div_gtnm _)."; - for i = 0 to size do - pp " intros x y H1 H2; unfold div_gt%i, w%i_div_gt." i i; - pp " generalize (spec_div_gt w%i_spec x y H1 H2); case znz_div_gt." i; - pp " intros xx yy; repeat rewrite spec_reduce_%i; auto." i; - if i == size then - pp " intros n x y H2 H3; unfold div_gt%i, w%i_div_gt." i i - else - pp " intros n x y H1 H2 H3; unfold div_gt%i, w%i_div_gt." i i; - pp " generalize (spec_div_gt w%i_spec x" i; - pp " (DoubleBase.get_low %s (S n) y))." (pz i); - pp0 ""; - for j = 0 to i do - pp0 "unfold w%i; " (i-j); - done; - pp "case znz_div_gt."; - pp " intros xx yy H4; repeat rewrite spec_reduce_%i." i; - pp " generalize (spec_get_end%i (S n) y x); unfold to_Z; intros H5." i; - pp " unfold to_Z in H2; rewrite H5 in H4; auto with zarith."; - if i == size then - pp " intros n x y H2 H3." - else - pp " intros n x y H1 H2 H3."; - pp " generalize"; - pp " (spec_divn1 w%i w%i_op w%i_spec (S n) x y H3)." i i i; - pp0 " unfold w%i_divn1; " i; - for j = 0 to i do - pp0 "unfold w%i; " (i-j); - done; - pp "case double_divn1."; - pp " intros xx yy H4."; - if i == size then - begin - pp " repeat rewrite <- spec_double_eval%in in H4; auto." i; - pp " rewrite spec_eval%in; auto." i; - end - else - begin - pp " rewrite to_Z%i_spec; auto with zarith." i; - pp " repeat rewrite <- spec_double_eval%in in H4; auto." i; - end; - done; - pp " intros n m x y H1 H2; unfold div_gtnm."; - pp " generalize (spec_div_gt (wn_spec (Max.max n m))"; - pp " (castm (diff_r n m)"; - pp " (extend_tr x (snd (diff n m))))"; - pp " (castm (diff_l n m)"; - pp " (extend_tr y (fst (diff n m)))))."; - pp " case znz_div_gt."; - pp " intros xx yy HH."; - pp " repeat rewrite spec_reduce_n."; - pp " rewrite <- (spec_cast_l n m x)."; - pp " rewrite <- (spec_cast_r n m y)."; - pp " unfold to_Z; apply HH."; - pp " rewrite <- (spec_cast_l n m x) in H1; auto."; - pp " rewrite <- (spec_cast_r n m y) in H1; auto."; - pp " rewrite <- (spec_cast_r n m y) in H2; auto."; - pp " intros x y H1 H2; generalize (FO x y H1 H2); case div_gt."; - pp " intros q r (H3, H4); split."; - pp " apply (Zdiv_unique [x] [y] [q] [r]); auto."; - pp " rewrite Zmult_comm; auto."; - pp " apply (Zmod_unique [x] [y] [q] [r]); auto."; - pp " rewrite Zmult_comm; auto."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Modulo *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - for i = 0 to size do - pr " Definition w%i_mod_gt := w%i_op.(znz_mod_gt)." i i - done; - pr ""; - - for i = 0 to size do - pr " Definition w%i_modn1 :=" i; - pr " double_modn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)" i i; - pr " w%i_op.(znz_head0) w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)" i i i; - pr " w%i_op.(znz_compare) w%i_op.(znz_sub)." i i; - done; - pr ""; - - pr " Let mod_gtnm n m wx wy :="; - pr " let mn := Max.max n m in"; - pr " let d := diff n m in"; - pr " let op := make_op mn in"; - pr " reduce_n mn (op.(znz_mod_gt)"; - pr " (castm (diff_r n m) (extend_tr wx (snd d)))"; - pr " (castm (diff_l n m) (extend_tr wy (fst d))))."; - pr ""; - - pr " Definition mod_gt := Eval lazy beta delta[iter] in"; - pr " (iter _"; - for i = 0 to size do - pr " (fun x y => reduce_%i (w%i_mod_gt x y))" i i; - pr " (fun n x y => reduce_%i (w%i_mod_gt x (DoubleBase.get_low %s (S n) y)))" i i (pz i); - pr " (fun n x y => reduce_%i (w%i_modn1 (S n) x y))" i i; - done; - pr " mod_gtnm)."; - pr ""; - - pp " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) :="; - pp " (spec_double_modn1"; - pp " ww_op.(znz_zdigits) ww_op.(znz_0)"; - pp " (znz_WW ww_op) ww_op.(znz_head0)"; - pp " ww_op.(znz_add_mul_div) ww_op.(znz_div21)"; - pp " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)"; - pp " (spec_to_Z ww_spec)"; - pp " (spec_zdigits ww_spec)"; - pp " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)"; - pp " (spec_add_mul_div ww_spec) (spec_div21 ww_spec)"; - pp " (CyclicAxioms.spec_compare ww_spec) (CyclicAxioms.spec_sub ww_spec))."; - pp ""; - - pr " Theorem spec_mod_gt:"; - pr " forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y]."; - pa " Admitted."; - pp " Proof."; - pp " refine (spec_iter _ (fun x y res => x > y -> 0 < y ->"; - pp " [res] = x mod y)"; - for i = 0 to size do - pp " (fun x y => reduce_%i (w%i_mod_gt x y))" i i; - pp " (fun n x y => reduce_%i (w%i_mod_gt x (DoubleBase.get_low %s (S n) y)))" i i (pz i); - pp " (fun n x y => reduce_%i (w%i_modn1 (S n) x y)) _ _ _" i i; - done; - pp " mod_gtnm _)."; - for i = 0 to size do - pp " intros x y H1 H2; rewrite spec_reduce_%i." i; - pp " exact (spec_mod_gt w%i_spec x y H1 H2)." i; - if i == size then - pp " intros n x y H2 H3; rewrite spec_reduce_%i." i - else - pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i; - pp " unfold w%i_mod_gt." i; - pp " rewrite <- (spec_get_end%i (S n) y x); auto with zarith." i; - pp " unfold to_Z; apply (spec_mod_gt w%i_spec); auto." i; - pp " rewrite <- (spec_get_end%i (S n) y x) in H2; auto with zarith." i; - pp " rewrite <- (spec_get_end%i (S n) y x) in H3; auto with zarith." i; - if i == size then - pp " intros n x y H2 H3; rewrite spec_reduce_%i." i - else - pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i; - pp " unfold w%i_modn1, to_Z; rewrite spec_double_eval%in." i i; - pp " apply (spec_modn1 _ _ w%i_spec); auto." i; - done; - pp " intros n m x y H1 H2; unfold mod_gtnm."; - pp " repeat rewrite spec_reduce_n."; - pp " rewrite <- (spec_cast_l n m x)."; - pp " rewrite <- (spec_cast_r n m y)."; - pp " unfold to_Z; apply (spec_mod_gt (wn_spec (Max.max n m)))."; - pp " rewrite <- (spec_cast_l n m x) in H1; auto."; - pp " rewrite <- (spec_cast_r n m y) in H1; auto."; - pp " rewrite <- (spec_cast_r n m y) in H2; auto."; - pp " Qed."; - pr ""; - - pr " (** digits: a measure for gcd *)"; - pr ""; - - pr " Definition digits x :="; - pr " match x with"; - for i = 0 to size do - pr " | %s%i _ => w%i_op.(znz_digits)" c i i; - done; - pr " | %sn n _ => (make_op n).(znz_digits)" c; - pr " end."; - pr ""; - - pr " Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; clear x."; - for i = 0 to size do - pp " intros x; unfold to_Z, digits;"; - pp " generalize (spec_to_Z w%i_spec x); unfold base; intros H; exact H." i; - done; - pp " intros n x; unfold to_Z, digits;"; - pp " generalize (spec_to_Z (wn_spec n) x); unfold base; intros H; exact H."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Conversion *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - pr " Definition pheight p :="; - pr " Peano.pred (nat_of_P (get_height w0_op.(znz_digits) (plength p)))."; - pr ""; - - pr " Theorem pheight_correct: forall p,"; - pr " Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p)))."; - pr " Proof."; - pr " intros p; unfold pheight."; - pr " assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1)."; - pr " intros x."; - pr " assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith."; - pr " rewrite <- inj_S."; - pr " rewrite <- (fun x => S_pred x 0); auto with zarith."; - pr " rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto."; - pr " apply lt_le_trans with 1%snat; auto with zarith." "%"; - pr " exact (le_Pmult_nat x 1)."; - pr " rewrite F1; clear F1."; - pr " assert (F2:= (get_height_correct (znz_digits w0_op) (plength p)))."; - pr " apply Zlt_le_trans with (Zpos (Psucc p))."; - pr " rewrite Zpos_succ_morphism; auto with zarith."; - pr " apply Zle_trans with (1 := plength_pred_correct (Psucc p))."; - pr " rewrite Ppred_succ."; - pr " apply Zpower_le_monotone; auto with zarith."; - pr " Qed."; - pr ""; - - pr " Definition of_pos x :="; - pr " let h := pheight x in"; - pr " match h with"; - for i = 0 to size do - pr " | %i%snat => reduce_%i (snd (w%i_op.(znz_of_pos) x))" i "%" i i; - done; - pr " | _ =>"; - pr " let n := minus h %i in" (size + 1); - pr " reduce_n n (snd ((make_op n).(znz_of_pos) x))"; - pr " end."; - pr ""; - - pr " Theorem spec_of_pos: forall x,"; - pr " [of_pos x] = Zpos x."; - pa " Admitted."; - pp " Proof."; - pp " assert (F := spec_more_than_1_digit w0_spec)."; - pp " intros x; unfold of_pos; case_eq (pheight x)."; - for i = 0 to size do - if i <> 0 then - pp " intros n; case n; clear n."; - pp " intros H1; rewrite spec_reduce_%i; unfold to_Z." i; - pp " apply (znz_of_pos_correct w%i_spec)." i; - pp " apply Zlt_le_trans with (1 := pheight_correct x)."; - pp " rewrite H1; simpl Z_of_nat; change (2^%i) with (%s)." i (gen2 i); - pp " unfold base."; - pp " apply Zpower_le_monotone; split; auto with zarith."; - if i <> 0 then - begin - pp " rewrite Zmult_comm; repeat rewrite <- Zmult_assoc."; - pp " repeat rewrite <- Zpos_xO."; - pp " refine (Zle_refl _)."; - end; - done; - pp " intros n."; - pp " intros H1; rewrite spec_reduce_n; unfold to_Z."; - pp " simpl minus; rewrite <- minus_n_O."; - pp " apply (znz_of_pos_correct (wn_spec n))."; - pp " apply Zlt_le_trans with (1 := pheight_correct x)."; - pp " unfold base."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " split; auto with zarith."; - pp " rewrite H1."; - pp " elim n; clear n H1."; - pp " simpl Z_of_nat; change (2^%i) with (%s)." (size + 1) (gen2 (size + 1)); - pp " rewrite Zmult_comm; repeat rewrite <- Zmult_assoc."; - pp " repeat rewrite <- Zpos_xO."; - pp " refine (Zle_refl _)."; - pp " intros n Hrec."; - pp " rewrite make_op_S."; - pp " change (@znz_digits (word _ (S (S n))) (mk_zn2z_op_karatsuba (make_op n))) with"; - pp " (xO (znz_digits (make_op n)))."; - pp " rewrite (fun x y => (Zpos_xO (@znz_digits x y)))."; - pp " rewrite inj_S; unfold Zsucc."; - pp " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith."; - pp " rewrite Zpower_1_r."; - pp " assert (tmp: forall x y z, x * (y * z) = y * (x * z));"; - pp " [intros; ring | rewrite tmp; clear tmp]."; - pp " apply Zmult_le_compat_l; auto with zarith."; - pp " Qed."; - pr ""; - - pr " (***************************************************************)"; - pr " (* *)"; - pr " (** * Shift *)"; - pr " (* *)"; - pr " (***************************************************************)"; - pr ""; - - (* Head0 *) - pr " Definition head0 w := match w with"; - for i = 0 to size do - pr " | %s%i w=> reduce_%i (w%i_op.(znz_head0) w)" c i i i; - done; - pr " | %sn n w=> reduce_n n ((make_op n).(znz_head0) w)" c; - pr " end."; - pr ""; - - pr " Theorem spec_head00: forall x, [x] = 0 ->[head0 x] = Zpos (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold head0; clear x."; - for i = 0 to size do - pp " intros x; rewrite spec_reduce_%i; exact (spec_head00 w%i_spec x)." i i; - done; - pp " intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x)."; - pp " Qed."; - pr ""; - - pr " Theorem spec_head0: forall x, 0 < [x] ->"; - pr " 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " assert (F0: forall x, (x - 1) + 1 = x)."; - pp " intros; ring."; - pp " intros x; case x; unfold digits, head0; clear x."; - for i = 0 to size do - pp " intros x Hx; rewrite spec_reduce_%i." i; - pp " assert (F1:= spec_more_than_1_digit w%i_spec)." i; - pp " generalize (spec_head0 w%i_spec x Hx)." i; - pp " unfold base."; - pp " pattern (Zpos (znz_digits w%i_op)) at 1;" i; - pp " rewrite <- (fun x => (F0 (Zpos x)))."; - pp " rewrite Zpower_exp; auto with zarith."; - pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith."; - done; - pp " intros n x Hx; rewrite spec_reduce_n."; - pp " assert (F1:= spec_more_than_1_digit (wn_spec n))."; - pp " generalize (spec_head0 (wn_spec n) x Hx)."; - pp " unfold base."; - pp " pattern (Zpos (znz_digits (make_op n))) at 1;"; - pp " rewrite <- (fun x => (F0 (Zpos x)))."; - pp " rewrite Zpower_exp; auto with zarith."; - pp " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith."; - pp " Qed."; - pr ""; - - - (* Tail0 *) - pr " Definition tail0 w := match w with"; - for i = 0 to size do - pr " | %s%i w=> reduce_%i (w%i_op.(znz_tail0) w)" c i i i; - done; - pr " | %sn n w=> reduce_n n ((make_op n).(znz_tail0) w)" c; - pr " end."; - pr ""; - - - pr " Theorem spec_tail00: forall x, [x] = 0 ->[tail0 x] = Zpos (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold tail0; clear x."; - for i = 0 to size do - pp " intros x; rewrite spec_reduce_%i; exact (spec_tail00 w%i_spec x)." i i; - done; - pp " intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x)."; - pp " Qed."; - pr ""; - - - pr " Theorem spec_tail0: forall x,"; - pr " 0 < [x] -> exists y, 0 <= y /\\ [x] = (2 * y + 1) * 2 ^ [tail0 x]."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; clear x; unfold tail0."; - for i = 0 to size do - pp " intros x Hx; rewrite spec_reduce_%i; exact (spec_tail0 w%i_spec x Hx)." i i; - done; - pp " intros n x Hx; rewrite spec_reduce_n; exact (spec_tail0 (wn_spec n) x Hx)."; - pp " Qed."; - pr ""; - - - (* Number of digits *) - pr " Definition %sdigits x :=" c; - pr " match x with"; - pr " | %s0 _ => %s0 w0_op.(znz_zdigits)" c c; - for i = 1 to size do - pr " | %s%i _ => reduce_%i w%i_op.(znz_zdigits)" c i i i; - done; - pr " | %sn n _ => reduce_n n (make_op n).(znz_zdigits)" c; - pr " end."; - pr ""; - - pr " Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; clear x; unfold Ndigits, digits."; - for i = 0 to size do - pp " intros _; try rewrite spec_reduce_%i; exact (spec_zdigits w%i_spec)." i i; - done; - pp " intros n _; try rewrite spec_reduce_n; exact (spec_zdigits (wn_spec n))."; - pp " Qed."; - pr ""; - - - (* Shiftr *) - for i = 0 to size do - pr " Definition unsafe_shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x." i i i i i; - done; - pr " Definition unsafe_shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x."; - pr ""; - - pr " Definition unsafe_shiftr := Eval lazy beta delta [same_level] in"; - pr " same_level _ (fun n x => %s0 (unsafe_shiftr0 n x))" c; - for i = 1 to size do - pr " (fun n x => reduce_%i (unsafe_shiftr%i n x))" i i; - done; - pr " (fun n p x => reduce_n n (unsafe_shiftrn n p x))."; - pr ""; - - - pr " Theorem spec_unsafe_shiftr: forall n x,"; - pr " [n] <= [Ndigits x] -> [unsafe_shiftr n x] = [x] / 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " assert (F0: forall x y, x - (x - y) = y)."; - pp " intros; ring."; - pp " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z)."; - pp " intros x y z HH HH1 HH2."; - pp " split; auto with zarith."; - pp " apply Zle_lt_trans with (2 := HH2); auto with zarith."; - pp " apply Zdiv_le_upper_bound; auto with zarith."; - pp " pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith."; - pp " apply Zmult_le_compat_l; auto."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " rewrite Zpower_0_r; ring."; - pp " assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x)."; - pp " intros xx y HH HH1."; - pp " split; auto with zarith."; - pp " apply Zle_lt_trans with xx; auto with zarith."; - pp " apply Zpower2_lt_lin; auto with zarith."; - pp " assert (F4: forall ww ww1 ww2"; - pp " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)"; - pp " xx yy xx1 yy1,"; - pp " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_zdigits ww1_op) ->"; - pp " znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->"; - pp " znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->"; - pp " znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->"; - pp " znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->"; - pp " znz_to_Z ww_op"; - pp " (znz_add_mul_div ww_op (znz_sub ww_op (znz_zdigits ww_op) yy1)"; - pp " (znz_0 ww_op) xx1) = znz_to_Z ww1_op xx / 2 ^ znz_to_Z ww2_op yy)."; - pp " intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy."; - pp " case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2."; - pp " case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4."; - pp " rewrite <- Hx."; - pp " rewrite <- Hy."; - pp " generalize (spec_add_mul_div Hw"; - pp " (znz_0 ww_op) xx1"; - pp " (znz_sub ww_op (znz_zdigits ww_op)"; - pp " yy1)"; - pp " )."; - pp " rewrite (spec_0 Hw)."; - pp " rewrite Zmult_0_l; rewrite Zplus_0_l."; - pp " rewrite (CyclicAxioms.spec_sub Hw)."; - pp " rewrite Zmod_small; auto with zarith."; - pp " rewrite (spec_zdigits Hw)."; - pp " rewrite F0."; - pp " rewrite Zmod_small; auto with zarith."; - pp " unfold base; rewrite (spec_zdigits Hw) in Hl1 |- *;"; - pp " auto with zarith."; - pp " assert (F5: forall n m, (n <= m)%snat ->" "%"; - pp " Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m)))."; - pp " intros n m HH; elim HH; clear m HH; auto with zarith."; - pp " intros m HH Hrec; apply Zle_trans with (1 := Hrec)."; - pp " rewrite make_op_S."; - pp " match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end."; - pp " rewrite Zpos_xO."; - pp " assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith."; - pp " assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n)))." size; - pp " intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0)))."; - pp " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size; - pp " rewrite Zpos_xO."; - pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size; - pp " apply F5; auto with arith."; - pp " intros x; case x; clear x; unfold unsafe_shiftr, same_level."; - for i = 0 to size do - pp " intros x y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y; unfold unsafe_shiftr%i, Ndigits." i; - pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i; - pp " rewrite (spec_zdigits w%i_spec)." i; - pp " rewrite (spec_zdigits w%i_spec)." j; - pp " change (znz_digits w%i_op) with %s." i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)")); - pp " repeat rewrite (fun x => Zpos_xO (xO x))."; - pp " repeat rewrite (fun x y => Zpos_xO (@znz_digits x y))."; - pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." j; - pp " try (apply sym_equal; exact (spec_extend%in%i y))." j i; - - done; - pp " intros y; unfold unsafe_shiftr%i, Ndigits." i; - pp " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i; - for j = i + 1 to size do - pp " intros y; unfold unsafe_shiftr%i, Ndigits." j; - pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i; - pp " try (apply sym_equal; exact (spec_extend%in%i x))." i j; - done; - if i == size then - begin - pp " intros m y; unfold unsafe_shiftrn, Ndigits."; - pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; - pp " try (apply sym_equal; exact (spec_extend%in m x))." size; - end - else - begin - pp " intros m y; unfold unsafe_shiftrn, Ndigits."; - pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i; - pp " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i; - pp " rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto." size i size; - end - done; - pp " intros n x y; case y; clear y;"; - pp " intros y; unfold unsafe_shiftrn, Ndigits; try rewrite spec_reduce_n."; - for i = 0 to size do - pp " try rewrite spec_reduce_%i; unfold to_Z; intros H1." i; - pp " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i; - pp " rewrite (spec_zdigits w%i_spec)." i; - pp " rewrite (spec_zdigits (wn_spec n))."; - pp " apply Zle_trans with (2 := F6 n)."; - pp " change (znz_digits w%i_op) with %s." size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)")); - pp " repeat rewrite (fun x => Zpos_xO (xO x))."; - pp " repeat rewrite (fun x y => Zpos_xO (@znz_digits x y))."; - pp " assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith." i; - if i == size then - pp " change ([Nn n (extend%i n y)] = [N%i y])." size i - else - pp " change ([Nn n (extend%i n (extend%i %i y))] = [N%i y])." size i (size - i - 1) i; - pp " rewrite <- (spec_extend%in n); auto." size; - if i <> size then - pp " try (rewrite <- spec_extend%in%i; auto)." i size; - done; - pp " generalize y; clear y; intros m y."; - pp " rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith."; - pp " rewrite (spec_zdigits (wn_spec m))."; - pp " rewrite (spec_zdigits (wn_spec (Max.max n m)))."; - pp " apply F5; auto with arith."; - pp " exact (spec_cast_r n m y)."; - pp " exact (spec_cast_l n m x)."; - pp " Qed."; - pr ""; - - (* Unsafe_Shiftl *) - for i = 0 to size do - pr " Definition unsafe_shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i - done; - pr " Definition unsafe_shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0)."; - pr " Definition unsafe_shiftl := Eval lazy beta delta [same_level] in"; - pr " same_level _ (fun n x => %s0 (unsafe_shiftl0 n x))" c; - for i = 1 to size do - pr " (fun n x => reduce_%i (unsafe_shiftl%i n x))" i i; - done; - pr " (fun n p x => reduce_n n (unsafe_shiftln n p x))."; - pr ""; - pr ""; - - - pr " Theorem spec_unsafe_shiftl: forall n x,"; - pr " [n] <= [head0 x] -> [unsafe_shiftl n x] = [x] * 2 ^ [n]."; - pa " Admitted."; - pp " Proof."; - pp " assert (F0: forall x y, x - (x - y) = y)."; - pp " intros; ring."; - pp " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z)."; - pp " intros x y z HH HH1 HH2."; - pp " split; auto with zarith."; - pp " apply Zle_lt_trans with (2 := HH2); auto with zarith."; - pp " apply Zdiv_le_upper_bound; auto with zarith."; - pp " pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith."; - pp " apply Zmult_le_compat_l; auto."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " rewrite Zpower_0_r; ring."; - pp " assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x)."; - pp " intros xx y HH HH1."; - pp " split; auto with zarith."; - pp " apply Zle_lt_trans with xx; auto with zarith."; - pp " apply Zpower2_lt_lin; auto with zarith."; - pp " assert (F4: forall ww ww1 ww2"; - pp " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)"; - pp " xx yy xx1 yy1,"; - pp " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_head0 ww1_op xx) ->"; - pp " znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->"; - pp " znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->"; - pp " znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->"; - pp " znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->"; - pp " znz_to_Z ww_op"; - pp " (znz_add_mul_div ww_op yy1"; - pp " xx1 (znz_0 ww_op)) = znz_to_Z ww1_op xx * 2 ^ znz_to_Z ww2_op yy)."; - pp " intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy."; - pp " case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2."; - pp " case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4."; - pp " rewrite <- Hx."; - pp " rewrite <- Hy."; - pp " generalize (spec_add_mul_div Hw xx1 (znz_0 ww_op) yy1)."; - pp " rewrite (spec_0 Hw)."; - pp " assert (F1: znz_to_Z ww1_op (znz_head0 ww1_op xx) <= Zpos (znz_digits ww1_op))."; - pp " case (Zle_lt_or_eq _ _ HH1); intros HH5."; - pp " apply Zlt_le_weak."; - pp " case (CyclicAxioms.spec_head0 Hw1 xx)."; - pp " rewrite <- Hx; auto."; - pp " intros _ Hu; unfold base in Hu."; - pp " case (Zle_or_lt (Zpos (znz_digits ww1_op))"; - pp " (znz_to_Z ww1_op (znz_head0 ww1_op xx))); auto; intros H1."; - pp " absurd (2 ^ (Zpos (znz_digits ww1_op)) <= 2 ^ (znz_to_Z ww1_op (znz_head0 ww1_op xx)))."; - pp " apply Zlt_not_le."; - pp " case (spec_to_Z Hw1 xx); intros HHx3 HHx4."; - pp " rewrite <- (Zmult_1_r (2 ^ znz_to_Z ww1_op (znz_head0 ww1_op xx)))."; - pp " apply Zle_lt_trans with (2 := Hu)."; - pp " apply Zmult_le_compat_l; auto with zarith."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " rewrite (CyclicAxioms.spec_head00 Hw1 xx); auto with zarith."; - pp " rewrite Zdiv_0_l; auto with zarith."; - pp " rewrite Zplus_0_r."; - pp " case (Zle_lt_or_eq _ _ HH1); intros HH5."; - pp " rewrite Zmod_small; auto with zarith."; - pp " intros HH; apply HH."; - pp " rewrite Hy; apply Zle_trans with (1:= Hl)."; - pp " rewrite <- (spec_zdigits Hw)."; - pp " apply Zle_trans with (2 := Hl1); auto."; - pp " rewrite (spec_zdigits Hw1); auto with zarith."; - pp " split; auto with zarith ."; - pp " apply Zlt_le_trans with (base (znz_digits ww1_op))."; - pp " rewrite Hx."; - pp " case (CyclicAxioms.spec_head0 Hw1 xx); auto."; - pp " rewrite <- Hx; auto."; - pp " intros _ Hu; rewrite Zmult_comm in Hu."; - pp " apply Zle_lt_trans with (2 := Hu)."; - pp " apply Zmult_le_compat_l; auto with zarith."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " unfold base; apply Zpower_le_monotone; auto with zarith."; - pp " split; auto with zarith."; - pp " rewrite <- (spec_zdigits Hw); auto with zarith."; - pp " rewrite <- (spec_zdigits Hw1); auto with zarith."; - pp " rewrite <- HH5."; - pp " rewrite Zmult_0_l."; - pp " rewrite Zmod_small; auto with zarith."; - pp " intros HH; apply HH."; - pp " rewrite Hy; apply Zle_trans with (1 := Hl)."; - pp " rewrite (CyclicAxioms.spec_head00 Hw1 xx); auto with zarith."; - pp " rewrite <- (spec_zdigits Hw); auto with zarith."; - pp " rewrite <- (spec_zdigits Hw1); auto with zarith."; - pp " assert (F5: forall n m, (n <= m)%snat ->" "%"; - pp " Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m)))."; - pp " intros n m HH; elim HH; clear m HH; auto with zarith."; - pp " intros m HH Hrec; apply Zle_trans with (1 := Hrec)."; - pp " rewrite make_op_S."; - pp " match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end."; - pp " rewrite Zpos_xO."; - pp " assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith."; - pp " assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n)))." size; - pp " intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0)))."; - pp " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op))." size; - pp " rewrite Zpos_xO."; - pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." size; - pp " apply F5; auto with arith."; - pp " intros x; case x; clear x; unfold unsafe_shiftl, same_level."; - for i = 0 to size do - pp " intros x y; case y; clear y."; - for j = 0 to i - 1 do - pp " intros y; unfold unsafe_shiftl%i, head0." i; - pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i j i; - pp " rewrite (spec_zdigits w%i_spec)." i; - pp " rewrite (spec_zdigits w%i_spec)." j; - pp " change (znz_digits w%i_op) with %s." i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)")); - pp " repeat rewrite (fun x => Zpos_xO (xO x))."; - pp " repeat rewrite (fun x y => Zpos_xO (@znz_digits x y))."; - pp " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith." j; - pp " try (apply sym_equal; exact (spec_extend%in%i y))." j i; - done; - pp " intros y; unfold unsafe_shiftl%i, head0." i; - pp " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." i i i; - for j = i + 1 to size do - pp " intros y; unfold unsafe_shiftl%i, head0." j; - pp " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1." i j; - pp " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith." j j i; - pp " try (apply sym_equal; exact (spec_extend%in%i x))." i j; - done; - if i == size then - begin - pp " intros m y; unfold unsafe_shiftln, head0."; - pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; - pp " try (apply sym_equal; exact (spec_extend%in m x))." size; - end - else - begin - pp " intros m y; unfold unsafe_shiftln, head0."; - pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." i; - pp " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x])." size i (size - i - 1) i; - pp " rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto." size i size; - end - done; - pp " intros n x y; case y; clear y;"; - pp " intros y; unfold unsafe_shiftln, head0; try rewrite spec_reduce_n."; - for i = 0 to size do - pp " try rewrite spec_reduce_%i; unfold to_Z; intros H1." i; - pp " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith." i; - pp " rewrite (spec_zdigits w%i_spec)." i; - pp " rewrite (spec_zdigits (wn_spec n))."; - pp " apply Zle_trans with (2 := F6 n)."; - pp " change (znz_digits w%i_op) with %s." size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)")); - pp " repeat rewrite (fun x => Zpos_xO (xO x))."; - pp " repeat rewrite (fun x y => Zpos_xO (@znz_digits x y))."; - pp " assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith." i; - if i == size then - pp " change ([Nn n (extend%i n y)] = [N%i y])." size i - else - pp " change ([Nn n (extend%i n (extend%i %i y))] = [N%i y])." size i (size - i - 1) i; - pp " rewrite <- (spec_extend%in n); auto." size; - if i <> size then - pp " try (rewrite <- spec_extend%in%i; auto)." i size; - done; - pp " generalize y; clear y; intros m y."; - pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; - pp " apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith."; - pp " rewrite (spec_zdigits (wn_spec m))."; - pp " rewrite (spec_zdigits (wn_spec (Max.max n m)))."; - pp " apply F5; auto with arith."; - pp " exact (spec_cast_r n m y)."; - pp " exact (spec_cast_l n m x)."; - pp " Qed."; - pr ""; - - (* Double size *) - pr " Definition double_size w := match w with"; - for i = 0 to size-1 do - pr " | %s%i x => %s%i (WW (znz_0 w%i_op) x)" c i c (i + 1) i; - done; - pr " | %s%i x => %sn 0 (WW (znz_0 w%i_op) x)" c size c size; - pr " | %sn n x => %sn (S n) (WW (znz_0 (make_op n)) x)" c c; - pr " end."; - pr ""; - - pr " Theorem spec_double_size_digits:"; - pr " forall x, digits (double_size x) = xO (digits x)."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold double_size, digits; clear x; auto."; - pp " intros n x; rewrite make_op_S; auto."; - pp " Qed."; - pr ""; - - - pr " Theorem spec_double_size: forall x, [double_size x] = [x]."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold double_size; clear x."; - for i = 0 to size do - pp " intros x; unfold to_Z, make_op;"; - pp " rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto with zarith." (i + 1) i; - done; - pp " intros n x; unfold to_Z;"; - pp " generalize (znz_to_Z_n n); simpl word."; - pp " intros HH; rewrite HH; clear HH."; - pp " generalize (spec_0 (wn_spec n)); simpl word."; - pp " intros HH; rewrite HH; clear HH; auto with zarith."; - pp " Qed."; - pr ""; - - - pr " Theorem spec_double_size_head0:"; - pr " forall x, 2 * [head0 x] <= [head0 (double_size x)]."; - pa " Admitted."; - pp " Proof."; - pp " intros x."; - pp " assert (F1:= spec_pos (head0 x))."; - pp " assert (F2: 0 < Zpos (digits x))."; - pp " red; auto."; - pp " case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH."; - pp " generalize HH; rewrite <- (spec_double_size x); intros HH1."; - pp " case (spec_head0 x HH); intros _ HH2."; - pp " case (spec_head0 _ HH1)."; - pp " rewrite (spec_double_size x); rewrite (spec_double_size_digits x)."; - pp " intros HH3 _."; - pp " case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4."; - pp " absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto."; - pp " apply Zle_not_lt."; - pp " apply Zmult_le_compat_r; auto with zarith."; - pp " apply Zpower_le_monotone; auto; auto with zarith."; - pp " generalize (spec_pos (head0 (double_size x))); auto with zarith."; - pp " assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1))."; - pp " case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5."; - pp " apply Zmult_le_reg_r with (2 ^ 1); auto with zarith."; - pp " rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith."; - pp " assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp]."; - pp " apply Zle_trans with (2 := Zlt_le_weak _ _ HH2)."; - pp " apply Zmult_le_compat_l; auto with zarith."; - pp " rewrite Zpower_1_r; auto with zarith."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " split; auto with zarith."; - pp " case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6."; - pp " absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith."; - pp " rewrite <- HH5; rewrite Zmult_1_r."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " rewrite (Zmult_comm 2)."; - pp " rewrite Zpower_mult; auto with zarith."; - pp " rewrite Zpower_2."; - pp " apply Zlt_le_trans with (2 := HH3)."; - pp " rewrite <- Zmult_assoc."; - pp " replace (Zpos (xO (digits x)) - 1) with"; - pp " ((Zpos (digits x) - 1) + (Zpos (digits x)))."; - pp " rewrite Zpower_exp; auto with zarith."; - pp " apply Zmult_lt_compat2; auto with zarith."; - pp " split; auto with zarith."; - pp " apply Zmult_lt_0_compat; auto with zarith."; - pp " rewrite Zpos_xO; ring."; - pp " apply Zlt_le_weak; auto."; - pp " repeat rewrite spec_head00; auto."; - pp " rewrite spec_double_size_digits."; - pp " rewrite Zpos_xO; auto with zarith."; - pp " rewrite spec_double_size; auto."; - pp " Qed."; - pr ""; - - pr " Theorem spec_double_size_head0_pos:"; - pr " forall x, 0 < [head0 (double_size x)]."; - pa " Admitted."; - pp " Proof."; - pp " intros x."; - pp " assert (F: 0 < Zpos (digits x))."; - pp " red; auto."; - pp " case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0."; - pp " case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1."; - pp " apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith."; - pp " case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3."; - pp " generalize F3; rewrite <- (spec_double_size x); intros F4."; - pp " absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x)))."; - pp " apply Zle_not_lt."; - pp " apply Zpower_le_monotone; auto with zarith."; - pp " split; auto with zarith."; - pp " rewrite Zpos_xO; auto with zarith."; - pp " case (spec_head0 x F3)."; - pp " rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH."; - pp " apply Zle_lt_trans with (2 := HH)."; - pp " case (spec_head0 _ F4)."; - pp " rewrite (spec_double_size x); rewrite (spec_double_size_digits x)."; - pp " rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto."; - pp " generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith."; - pp " Qed."; - pr ""; - - (* even *) - pr " Definition is_even x :="; - pr " match x with"; - for i = 0 to size do - pr " | %s%i wx => w%i_op.(znz_is_even) wx" c i i - done; - pr " | %sn n wx => (make_op n).(znz_is_even) wx" c; - pr " end."; - pr ""; - - - pr " Theorem spec_is_even: forall x,"; - pr " if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1."; - pa " Admitted."; - pp " Proof."; - pp " intros x; case x; unfold is_even, to_Z; clear x."; - for i = 0 to size do - pp " intros x; exact (spec_is_even w%i_spec x)." i; - done; - pp " intros n x; exact (spec_is_even (wn_spec n) x)."; - pp " Qed."; - pr ""; - - pr "End Make."; - pr ""; - + pr " Eval lazy beta iota delta [reduce_n] in"; + pr " reduce_n _ _ (N0 zero0) reduce_%i Nn n." (size + 1); + pr ""; + +pr " Definition reduce n : dom_t n -> t :="; +pr " match n with"; +for i = 0 to size do +pr " | %i => reduce_%i" i i; +done; +pr " | %s(S n) => reduce_n n" (if size=0 then "" else "SizePlus "); +pr " end."; +pr ""; + +pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ","); + +pr " + Ltac solve_red := + let H := fresh in let G := fresh in + match goal with + | |- ?P (S ?n) => assert (H:P n) by solve_red + | _ => idtac + end; + intros n G x; destruct (le_lt_eq_dec _ _ G) as [LT|EQ]; + solve [ + apply (H _ (lt_n_Sm_le _ _ LT)) | + inversion LT | + subst; change (reduce 0 x = red_t 0 x); reflexivity | + specialize (H (pred n)); subst; destruct x; + [|unfold_red; rewrite H; auto]; reflexivity + ]. + + Lemma reduce_equiv : forall n x, n <= Size -> reduce n x = red_t n x. + Proof. + set (P N := forall n, n <= N -> forall x, reduce n x = red_t n x). + intros n x H. revert n H x. change (P Size). solve_red. + Qed. + + Lemma spec_reduce_n : forall n x, [reduce_n n x] = [Nn n x]. + Proof. + assert (H : forall x, reduce_%i x = red_t (SizePlus 1) x). + destruct x; [|unfold reduce_%i; rewrite (reduce_equiv Size)]; auto. + induction n. + intros. rewrite H. apply spec_red_t. + destruct x as [|xh xl]. + simpl. rewrite make_op_S. exact ZnZ.spec_0. + fold word in *. + destruct xh; auto. + simpl reduce_n. + rewrite IHn. + rewrite spec_extend_WW; auto. + Qed. +" (size+1) (size+1); + +pr +" Lemma spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. + Proof. + do_size (destruct n; + [intros; rewrite reduce_equiv;[apply spec_red_t|auto with arith]|]). + apply spec_reduce_n. + Qed. + +End Make. +"; diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index cdd41647..4717d0b2 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,9 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: Nbasic.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZArith. +Require Import ZArith Ndigits. Require Import BigNumPrelude. Require Import Max. Require Import DoubleType. @@ -18,6 +16,26 @@ Require Import DoubleBase. Require Import CyclicAxioms. Require Import DoubleCyclic. +Arguments mk_zn2z_ops [t] ops. +Arguments mk_zn2z_ops_karatsuba [t] ops. +Arguments mk_zn2z_specs [t ops] specs. +Arguments mk_zn2z_specs_karatsuba [t ops] specs. +Arguments ZnZ.digits [t] Ops. +Arguments ZnZ.zdigits [t] Ops. + +Lemma Pshiftl_nat_Zpower : forall n p, + Zpos (Pos.shiftl_nat p n) = Zpos p * 2 ^ Z.of_nat n. +Proof. + intros. + rewrite Z.mul_comm. + induction n. simpl; auto. + transitivity (2 * (2 ^ Z.of_nat n * Zpos p)). + rewrite <- IHn. auto. + rewrite Z.mul_assoc. + rewrite inj_S. + rewrite <- Z.pow_succ_r; auto with zarith. +Qed. + (* To compute the necessary height *) Fixpoint plength (p: positive) : positive := @@ -212,8 +230,8 @@ Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) := End ExtendMax. -Implicit Arguments extend_tr[w m]. -Implicit Arguments castm[w m n]. +Arguments extend_tr [w m] v n. +Arguments castm [w m n] H x. @@ -287,11 +305,7 @@ Section CompareRec. Variable w_to_Z: w -> Z. Variable w_to_Z_0: w_to_Z w_0 = 0. Variable spec_compare0_m: forall x, - match compare0_m x with - Eq => w_to_Z w_0 = wm_to_Z x - | Lt => w_to_Z w_0 < wm_to_Z x - | Gt => w_to_Z w_0 > wm_to_Z x - end. + compare0_m x = (w_to_Z w_0 ?= wm_to_Z x). Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base. Let double_to_Z := double_to_Z wm_base wm_to_Z. @@ -308,29 +322,25 @@ Section CompareRec. Lemma spec_compare0_mn: forall n x, - match compare0_mn n x with - Eq => 0 = double_to_Z n x - | Lt => 0 < double_to_Z n x - | Gt => 0 > double_to_Z n x - end. - Proof. + compare0_mn n x = (0 ?= double_to_Z n x). + Proof. intros n; elim n; clear n; auto. - intros x; generalize (spec_compare0_m x); rewrite w_to_Z_0; auto. + intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto. intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto. + fold word in *. intros xh xl. - generalize (Hrec xh); case compare0_mn; auto. - generalize (Hrec xl); case compare0_mn; auto. - simpl double_to_Z; intros H1 H2; rewrite H1; rewrite <- H2; auto. - simpl double_to_Z; intros H1 H2; rewrite <- H2; auto. - case (double_to_Z_pos n xl); auto with zarith. - intros H1; simpl double_to_Z. - set (u := DoubleBase.double_wB wm_base n). - case (double_to_Z_pos n xl); intros H2 H3. - assert (0 < u); auto with zarith. - unfold u, DoubleBase.double_wB, base; auto with zarith. + rewrite 2 Hrec. + simpl double_to_Z. + set (wB := DoubleBase.double_wB wm_base n). + case Zcompare_spec; intros Cmp. + rewrite <- Cmp. reflexivity. + symmetry. apply Zgt_lt, Zlt_gt. (* ;-) *) + assert (0 < wB). + unfold wB, DoubleBase.double_wB, base; auto with zarith. change 0 with (0 + 0); apply Zplus_lt_le_compat; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - case (double_to_Z_pos n xh); auto with zarith. + case (double_to_Z_pos n xl); auto with zarith. + case (double_to_Z_pos n xh); intros; exfalso; omega. Qed. Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := @@ -348,17 +358,9 @@ Section CompareRec. end. Variable spec_compare: forall x y, - match compare x y with - Eq => w_to_Z x = w_to_Z y - | Lt => w_to_Z x < w_to_Z y - | Gt => w_to_Z x > w_to_Z y - end. + compare x y = Zcompare (w_to_Z x) (w_to_Z y). Variable spec_compare_m: forall x y, - match compare_m x y with - Eq => wm_to_Z x = w_to_Z y - | Lt => wm_to_Z x < w_to_Z y - | Gt => wm_to_Z x > w_to_Z y - end. + compare_m x y = Zcompare (wm_to_Z x) (w_to_Z y). Variable wm_base_lt: forall x, 0 <= w_to_Z x < base (wm_base). @@ -369,8 +371,8 @@ Section CompareRec. intros n (H0, H); split; auto. apply Zlt_le_trans with (1:= H). unfold double_wB, DoubleBase.double_wB; simpl. - rewrite base_xO. - set (u := base (double_digits wm_base n)). + rewrite Pshiftl_nat_S, base_xO. + set (u := base (Pos.shiftl_nat wm_base n)). assert (0 < u). unfold u, base; auto with zarith. replace (u^2) with (u * u); simpl; auto with zarith. @@ -380,26 +382,23 @@ Section CompareRec. Lemma spec_compare_mn_1: forall n x y, - match compare_mn_1 n x y with - Eq => double_to_Z n x = w_to_Z y - | Lt => double_to_Z n x < w_to_Z y - | Gt => double_to_Z n x > w_to_Z y - end. + compare_mn_1 n x y = Zcompare (double_to_Z n x) (w_to_Z y). Proof. intros n; elim n; simpl; auto; clear n. intros n Hrec x; case x; clear x; auto. - intros y; generalize (spec_compare w_0 y); rewrite w_to_Z_0; case compare; auto. - intros xh xl y; simpl; generalize (spec_compare0_mn n xh); case compare0_mn; intros H1b. + intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity. + intros xh xl y; simpl; + rewrite spec_compare0_mn, Hrec. case Zcompare_spec. + intros H1b. rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto. - apply Hrec. - apply Zlt_gt. + symmetry. apply Zlt_gt. case (double_wB_lt n y); intros _ H0. apply Zlt_le_trans with (1:= H0). fold double_wB. case (double_to_Z_pos n xl); intros H1 H2. apply Zle_trans with (double_to_Z n xh * double_wB n); auto with zarith. apply Zle_trans with (1 * double_wB n); auto with zarith. - case (double_to_Z_pos n xh); auto with zarith. + case (double_to_Z_pos n xh); intros; exfalso; omega. Qed. End CompareRec. @@ -433,22 +432,6 @@ Section AddS. End AddS. - - Lemma spec_opp: forall u x y, - match u with - | Eq => y = x - | Lt => y < x - | Gt => y > x - end -> - match CompOpp u with - | Eq => x = y - | Lt => x < y - | Gt => x > y - end. - Proof. - intros u x y; case u; simpl; auto with zarith. - Qed. - Fixpoint length_pos x := match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end. @@ -474,34 +457,112 @@ End AddS. Variable w: Type. - Theorem digits_zop: forall w (x: znz_op w), - znz_digits (mk_zn2z_op x) = xO (znz_digits x). + Theorem digits_zop: forall t (ops : ZnZ.Ops t), + ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops). + Proof. intros ww x; auto. Qed. - Theorem digits_kzop: forall w (x: znz_op w), - znz_digits (mk_zn2z_op_karatsuba x) = xO (znz_digits x). + Theorem digits_kzop: forall t (ops : ZnZ.Ops t), + ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops). + Proof. intros ww x; auto. Qed. - Theorem make_zop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op x) = + Theorem make_zop: forall t (ops : ZnZ.Ops t), + @ZnZ.to_Z _ (mk_zn2z_ops ops) = fun z => match z with - W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) - + znz_to_Z x xl + | W0 => 0 + | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) + + ZnZ.to_Z xl end. + Proof. intros ww x; auto. Qed. - Theorem make_kzop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op_karatsuba x) = + Theorem make_kzop: forall t (ops: ZnZ.Ops t), + @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) = fun z => match z with - W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) - + znz_to_Z x xl + | W0 => 0 + | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) + + ZnZ.to_Z xl end. + Proof. intros ww x; auto. Qed. End SimplOp. + +(** Abstract vision of a datatype of arbitrary-large numbers. + Concrete operations can be derived from these generic + fonctions, in particular from [iter_t] and [same_level]. +*) + +Module Type NAbstract. + +(** The domains: a sequence of [Z/nZ] structures *) + +Parameter dom_t : nat -> Type. +Declare Instance dom_op n : ZnZ.Ops (dom_t n). +Declare Instance dom_spec n : ZnZ.Specs (dom_op n). + +Axiom digits_dom_op : forall n, + ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op 0)) n. + +(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t] + and destructor [destr_t] and iterator [iter_t] *) + +Parameter t : Type. + +Parameter mk_t : forall (n:nat), dom_t n -> t. + +Inductive View_t : t -> Prop := + Mk_t : forall n (x : dom_t n), View_t (mk_t n x). + +Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *) + +Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A. + +Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A), + forall n x, iter_t f (mk_t n x) = f n x. + +(** Conversion to [ZArith] *) + +Parameter to_Z : t -> Z. +Local Notation "[ x ]" := (to_Z x). + +Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x. + +(** [reduce] is like [mk_t], but try to minimise the level of the number *) + +Parameter reduce : forall (n:nat), dom_t n -> t. +Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. + +(** Number of level in the tree representation of a number. + NB: This function isn't a morphism for setoid [eq]. *) + +Definition level := iter_t (fun n _ => n). + +(** [same_level] and its rich specification, indexed by [level] *) + +Parameter same_level : forall {A:Type} + (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A. + +Axiom spec_same_level_dep : + forall res + (P : nat -> Z -> Z -> res -> Prop) + (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r) + (f : forall n, dom_t n -> dom_t n -> res) + (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), + forall x y, P (level x) [x] [y] (same_level f x y). + +(** [mk_t_S] : building a number of the next level *) + +Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t. + +Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)), + [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. + +Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n. + +End NAbstract. diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v index 029fdfca..43ca67dd 100644 --- a/theories/Numbers/Natural/Binary/NBinary.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,150 +8,15 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBinary.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import BinPos. Require Export BinNat. Require Import NAxioms NProperties. Local Open Scope N_scope. -(** * Implementation of [NAxiomsSig] module type via [BinNat.N] *) - -Module NBinaryAxiomsMod <: NAxiomsSig. - -(** Bi-directional induction. *) - -Theorem bi_induction : - forall A : N -> Prop, Proper (eq==>iff) A -> - A N0 -> (forall n, A n <-> A (Nsucc n)) -> forall n : N, A n. -Proof. -intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS. -Qed. - -(** Basic operations. *) - -Definition eq_equiv : Equivalence (@eq N) := eq_equivalence. -Local Obligation Tactic := simpl_relation. -Program Instance succ_wd : Proper (eq==>eq) Nsucc. -Program Instance pred_wd : Proper (eq==>eq) Npred. -Program Instance add_wd : Proper (eq==>eq==>eq) Nplus. -Program Instance sub_wd : Proper (eq==>eq==>eq) Nminus. -Program Instance mul_wd : Proper (eq==>eq==>eq) Nmult. - -Definition pred_succ := Npred_succ. -Definition add_0_l := Nplus_0_l. -Definition add_succ_l := Nplus_succ. -Definition sub_0_r := Nminus_0_r. -Definition sub_succ_r := Nminus_succ_r. -Definition mul_0_l := Nmult_0_l. -Definition mul_succ_l n m := eq_trans (Nmult_Sn_m n m) (Nplus_comm _ _). - -(** Order *) - -Program Instance lt_wd : Proper (eq==>eq==>iff) Nlt. - -Definition lt_eq_cases := Nle_lteq. -Definition lt_irrefl := Nlt_irrefl. - -Theorem lt_succ_r : forall n m, n < (Nsucc m) <-> n <= m. -Proof. -intros n m; unfold Nlt, Nle; destruct n as [| p]; destruct m as [| q]; simpl; -split; intro H; try reflexivity; try discriminate. -destruct p; simpl; intros; discriminate. exfalso; now apply H. -apply -> Pcompare_p_Sq in H. destruct H as [H | H]. -now rewrite H. now rewrite H, Pcompare_refl. -apply <- Pcompare_p_Sq. case_eq ((p ?= q)%positive Eq); intro H1. -right; now apply Pcompare_Eq_eq. now left. exfalso; now apply H. -Qed. - -Theorem min_l : forall n m, n <= m -> Nmin n m = n. -Proof. -unfold Nmin, Nle; intros n m H. -destruct (n ?= m); try reflexivity. now elim H. -Qed. - -Theorem min_r : forall n m, m <= n -> Nmin n m = m. -Proof. -unfold Nmin, Nle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -now apply -> Ncompare_eq_correct. -rewrite <- Ncompare_antisym, H1 in H; elim H; auto. -Qed. - -Theorem max_l : forall n m, m <= n -> Nmax n m = n. -Proof. -unfold Nmax, Nle; intros n m H. -case_eq (n ?= m); intro H1; try reflexivity. -symmetry; now apply -> Ncompare_eq_correct. -rewrite <- Ncompare_antisym, H1 in H; elim H; auto. -Qed. - -Theorem max_r : forall n m : N, n <= m -> Nmax n m = m. -Proof. -unfold Nmax, Nle; intros n m H. -destruct (n ?= m); try reflexivity. now elim H. -Qed. - -(** Part specific to natural numbers, not integers. *) - -Theorem pred_0 : Npred 0 = 0. -Proof. -reflexivity. -Qed. - -Definition recursion (A : Type) : A -> (N -> A -> A) -> N -> A := - Nrect (fun _ => A). -Implicit Arguments recursion [A]. - -Instance recursion_wd A (Aeq : relation A) : - Proper (Aeq==>(eq==>Aeq==>Aeq)==>eq==>Aeq) (@recursion A). -Proof. -intros a a' Eaa' f f' Eff'. -intro x; pattern x; apply Nrect. -intros x' H; now rewrite <- H. -clear x. -intros x IH x' H; rewrite <- H. -unfold recursion in *. do 2 rewrite Nrect_step. -now apply Eff'; [| apply IH]. -Qed. - -Theorem recursion_0 : - forall (A : Type) (a : A) (f : N -> A -> A), recursion a f N0 = a. -Proof. -intros A a f; unfold recursion; now rewrite Nrect_base. -Qed. - -Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)). -Proof. -unfold recursion; intros A Aeq a f EAaa f_wd n; pattern n; apply Nrect. -rewrite Nrect_step; rewrite Nrect_base; now apply f_wd. -clear n; intro n; do 2 rewrite Nrect_step; intro IH. apply f_wd; [reflexivity|]. -now rewrite Nrect_step. -Qed. - -(** The instantiation of operations. - Placing them at the very end avoids having indirections in above lemmas. *) - -Definition t := N. -Definition eq := @eq N. -Definition zero := N0. -Definition succ := Nsucc. -Definition pred := Npred. -Definition add := Nplus. -Definition sub := Nminus. -Definition mul := Nmult. -Definition lt := Nlt. -Definition le := Nle. -Definition min := Nmin. -Definition max := Nmax. - -End NBinaryAxiomsMod. +(** * [BinNat.N] already implements [NAxiomSig] *) -Module Export NBinaryPropMod := NPropFunct NBinaryAxiomsMod. +Module N <: NAxiomsSig := N. (* Require Import NDefOps. diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v index fbc63c04..d5df6329 100644 --- a/theories/Numbers/Natural/Peano/NPeano.v +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,13 +8,571 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NPeano.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Import + Bool Peano Peano_dec Compare_dec Plus Mult Minus Le Lt EqNat Div2 Wf_nat + NAxioms NProperties. -Require Import Arith MinMax NAxioms NProperties. +(** Functions not already defined *) + +Fixpoint leb n m := + match n, m with + | O, _ => true + | _, O => false + | S n', S m' => leb n' m' + end. + +Definition ltb n m := leb (S n) m. + +Infix "<=?" := leb (at level 70) : nat_scope. +Infix "<?" := ltb (at level 70) : nat_scope. + +Lemma leb_le n m : (n <=? m) = true <-> n <= m. +Proof. + revert m. + induction n. split; auto with arith. + destruct m; simpl. now split. + rewrite IHn. split; auto with arith. +Qed. + +Lemma ltb_lt n m : (n <? m) = true <-> n < m. +Proof. + unfold ltb, lt. apply leb_le. +Qed. + +Fixpoint pow n m := + match m with + | O => 1 + | S m => n * (pow n m) + end. + +Infix "^" := pow : nat_scope. + +Lemma pow_0_r : forall a, a^0 = 1. +Proof. reflexivity. Qed. + +Lemma pow_succ_r : forall a b, 0<=b -> a^(S b) = a * a^b. +Proof. reflexivity. Qed. + +Definition square n := n * n. + +Lemma square_spec n : square n = n * n. +Proof. reflexivity. Qed. + +Definition Even n := exists m, n = 2*m. +Definition Odd n := exists m, n = 2*m+1. + +Fixpoint even n := + match n with + | O => true + | 1 => false + | S (S n') => even n' + end. + +Definition odd n := negb (even n). + +Lemma even_spec : forall n, even n = true <-> Even n. +Proof. + fix 1. + destruct n as [|[|n]]; simpl; try rewrite even_spec; split. + now exists 0. + trivial. + discriminate. + intros (m,H). destruct m. discriminate. + simpl in H. rewrite <- plus_n_Sm in H. discriminate. + intros (m,H). exists (S m). rewrite H. simpl. now rewrite plus_n_Sm. + intros (m,H). destruct m. discriminate. exists m. + simpl in H. rewrite <- plus_n_Sm in H. inversion H. reflexivity. +Qed. + +Lemma odd_spec : forall n, odd n = true <-> Odd n. +Proof. + unfold odd. + fix 1. + destruct n as [|[|n]]; simpl; try rewrite odd_spec; split. + discriminate. + intros (m,H). rewrite <- plus_n_Sm in H; discriminate. + now exists 0. + trivial. + intros (m,H). exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m). + intros (m,H). destruct m. discriminate. exists m. + simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl. + now rewrite <- !plus_n_Sm, <- !plus_n_O. +Qed. + +Lemma Even_equiv : forall n, Even n <-> Even.even n. +Proof. + split. intros (p,->). apply Even.even_mult_l. do 3 constructor. + intros H. destruct (even_2n n H) as (p,->). + exists p. unfold double. simpl. now rewrite <- plus_n_O. +Qed. + +Lemma Odd_equiv : forall n, Odd n <-> Even.odd n. +Proof. + split. intros (p,->). rewrite <- plus_n_Sm, <- plus_n_O. + apply Even.odd_S. apply Even.even_mult_l. do 3 constructor. + intros H. destruct (odd_S2n n H) as (p,->). + exists p. unfold double. simpl. now rewrite <- plus_n_Sm, <- !plus_n_O. +Qed. + +(* A linear, tail-recursive, division for nat. + + In [divmod], [y] is the predecessor of the actual divisor, + and [u] is [y] minus the real remainder +*) + +Fixpoint divmod x y q u := + match x with + | 0 => (q,u) + | S x' => match u with + | 0 => divmod x' y (S q) y + | S u' => divmod x' y q u' + end + end. + +Definition div x y := + match y with + | 0 => y + | S y' => fst (divmod x y' 0 y') + end. + +Definition modulo x y := + match y with + | 0 => y + | S y' => y' - snd (divmod x y' 0 y') + end. + +Infix "/" := div : nat_scope. +Infix "mod" := modulo (at level 40, no associativity) : nat_scope. + +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. + induction x. simpl. intuition. + intros y q u H. destruct u; simpl divmod. + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u'). + intros (EQ,LE); split; trivial. + rewrite <- EQ, <- minus_n_O, minus_diag, <- plus_n_O. + now rewrite !plus_Sn_m, plus_n_Sm, <- plus_assoc, mult_n_Sm. + generalize (IHx y q u (le_Sn_le _ _ H)). destruct divmod as (q',u'). + intros (EQ,LE); split; trivial. + rewrite <- EQ. + rewrite !plus_Sn_m, plus_n_Sm. f_equal. now apply minus_Sn_m. +Qed. + +Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y. +Proof. + intros x y Hy. + destruct y; [ now elim Hy | clear Hy ]. + 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 <- mult_n_O, minus_diag, <- !plus_n_O in U. +Qed. + +Lemma mod_bound_pos : forall x y, 0<=x -> 0<y -> 0 <= x mod y < y. +Proof. + intros x y Hx Hy. split. auto with arith. + destruct y; [ now elim Hy | clear Hy ]. + unfold modulo. + apply le_n_S, le_minus. +Qed. + +(** Square root *) + +(** The following square root function is linear (and tail-recursive). + With Peano representation, we can't do better. For faster algorithm, + see Psqrt/Zsqrt/Nsqrt... + + We search the square root of n = k + p^2 + (q - r) + with q = 2p and 0<=r<=q. We start with p=q=r=0, hence + looking for the square root of n = k. Then we progressively + decrease k and r. When k = S k' and r=0, it means we can use (S p) + as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2. + When k reaches 0, we have found the biggest p^2 square contained + in n, hence the square root of n is p. +*) + +Fixpoint sqrt_iter k p q r := + match k with + | O => p + | S k' => match r with + | O => sqrt_iter k' (S p) (S (S q)) (S (S q)) + | S r' => sqrt_iter k' p q r' + end + end. + +Definition sqrt n := sqrt_iter n 0 0 0. + +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. + induction k. + (* k = 0 *) + simpl; intros p q r Hq Hr. + split. + apply le_plus_l. + apply le_lt_n_Sm. + rewrite <- mult_n_Sm. + rewrite plus_assoc, (plus_comm p), <- plus_assoc. + apply plus_le_compat; trivial. + rewrite <- Hq. apply le_minus. + (* k = S k' *) + destruct r. + (* r = 0 *) + intros Hq _. + replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). + apply IHk. + simpl. rewrite <- plus_n_Sm. congruence. + auto with arith. + rewrite minus_diag, <- minus_n_O, <- plus_n_O. simpl. + rewrite <- plus_n_Sm; f_equal. rewrite <- plus_assoc; f_equal. + rewrite <- mult_n_Sm, (plus_comm p), <- plus_assoc. congruence. + (* r = S r' *) + intros Hq Hr. + replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)). + apply IHk; auto with arith. + simpl. rewrite plus_n_Sm. f_equal. rewrite minus_Sn_m; auto. +Qed. + +Lemma sqrt_spec : forall n, + (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n). +Proof. + intros. + set (s:=sqrt n). + replace n with (n + 0*0 + (0-0)). + apply sqrt_iter_spec; auto. + simpl. now rewrite <- 2 plus_n_O. +Qed. + +(** A linear tail-recursive base-2 logarithm + + In [log2_iter], we maintain the logarithm [p] of the counter [q], + while [r] is the distance between [q] and the next power of 2, + more precisely [q + S r = 2^(S p)] and [r<2^p]. At each + recursive call, [q] goes up while [r] goes down. When [r] + is 0, we know that [q] has almost reached a power of 2, + and we increase [p] at the next call, while resetting [r] + to [q]. + + Graphically (numbers are [q], stars are [r]) : + +<< + 10 + 9 + 8 + 7 * + 6 * + 5 ... + 4 + 3 * + 2 * + 1 * * +0 * * * +>> + + We stop when [k], the global downward counter reaches 0. + At that moment, [q] is the number we're considering (since + [k+q] is invariant), and [p] its logarithm. +*) + +Fixpoint log2_iter k p q r := + match k with + | O => p + | S k' => match r with + | O => log2_iter k' (S p) (S q) q + | S r' => log2_iter k' p (S q) r' + end + end. + +Definition log2 n := log2_iter (pred n) 0 1 0. + +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. + induction k. + (* k = 0 *) + intros p q r EQ LT. simpl log2_iter. cbv zeta. + split. + rewrite plus_O_n. + apply plus_le_reg_l with (2^p). + simpl pow in EQ. rewrite <- plus_n_O in EQ. rewrite EQ. + rewrite plus_comm. apply plus_le_compat_r. now apply lt_le_S. + rewrite EQ, plus_comm. apply plus_lt_compat_l. apply lt_0_Sn. + (* k = S k' *) + intros p q r EQ LT. destruct r. + (* r = 0 *) + rewrite <- plus_n_Sm, <- plus_n_O in EQ. + rewrite plus_Sn_m, plus_n_Sm. apply IHk. + rewrite <- EQ. remember (S p) as p'; simpl. now rewrite <- plus_n_O. + unfold lt. now rewrite EQ. + (* r = S r' *) + rewrite plus_Sn_m, plus_n_Sm. apply IHk. + now rewrite plus_Sn_m, plus_n_Sm. + unfold lt. + now apply lt_le_weak. +Qed. + +Lemma log2_spec : forall n, 0<n -> + 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 <- plus_n_Sm, <- plus_n_O. + symmetry. now apply S_pred with 0. +Qed. + +Lemma log2_nonpos : forall n, n<=0 -> log2 n = 0. +Proof. + inversion 1; now subst. +Qed. + +(** * Gcd *) + +(** We use Euclid algorithm, which is normally not structural, + but Coq is now clever enough to accept this (behind modulo + there is a subtraction, which now preserves being a subterm) +*) + +Fixpoint gcd a b := + match a with + | O => b + | S a' => gcd (b mod (S a')) (S a') + end. + +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 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 b a') at 2 by discriminate. + destruct H as (u,Hu), H' as (v,Hv). + rewrite mult_comm. + exists ((b/a')*v + u). + rewrite mult_plus_distr_r. + now rewrite <- mult_assoc, <- Hv, <- Hu. +Qed. + +Lemma gcd_divide_l : forall a b, (gcd a b | a). +Proof. + intros. apply gcd_divide. +Qed. + +Lemma gcd_divide_r : forall a b, (gcd a b | b). +Proof. + intros. apply gcd_divide. +Qed. + +Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). +Proof. + fix 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 b a') in H' by discriminate. + destruct H as (u,Hu), H' as (v,Hv). + exists (v - (b/a')*u). + rewrite mult_comm in Hv. + now rewrite mult_minus_distr_r, <- Hv, <-mult_assoc, <-Hu, minus_plus. +Qed. + +(** * Bitwise operations *) + +(** We provide here some bitwise operations for unary numbers. + Some might be really naive, they are just there for fullfiling + the same interface as other for natural representations. As + soon as binary representations such as NArith are available, + it is clearly better to convert to/from them and use their ops. +*) + +Fixpoint testbit a n := + match n with + | O => odd a + | S n => testbit (div2 a) n + end. + +Definition shiftl a n := iter_nat n _ double a. +Definition shiftr a n := iter_nat n _ div2 a. + +Fixpoint bitwise (op:bool->bool->bool) n a b := + match n with + | O => O + | S n' => + (if op (odd a) (odd b) then 1 else 0) + + 2*(bitwise op n' (div2 a) (div2 b)) + end. + +Definition land a b := bitwise andb a a b. +Definition lor a b := bitwise orb (max a b) a b. +Definition ldiff a b := bitwise (fun b b' => b && negb b') a a b. +Definition lxor a b := bitwise xorb (max a b) a b. + +Lemma double_twice : forall n, double n = 2*n. +Proof. + simpl; intros. now rewrite <- plus_n_O. +Qed. + +Lemma testbit_0_l : forall n, testbit 0 n = false. +Proof. + now induction n. +Qed. + +Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. +Proof. + unfold testbit. rewrite odd_spec. now exists a. +Qed. + +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 <- plus_n_Sm, <- plus_n_O. f_equal. + apply div2_double_plus_one. +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_spec : forall a n m, + testbit (shiftr a n) m = testbit a (m+n). +Proof. + induction n; intros m. trivial. + now rewrite <- plus_n_O. + now rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn. +Qed. + +Lemma shiftl_spec_high : forall a n m, n<=m -> + testbit (shiftl a n) m = testbit a (m-n). +Proof. + induction n; intros m H. trivial. + now rewrite <- minus_n_O. + destruct m. inversion H. + simpl. apply le_S_n in H. + change (shiftl a (S n)) with (double (shiftl a n)). + rewrite double_twice, div2_double. now apply IHn. +Qed. + +Lemma shiftl_spec_low : forall a n m, m<n -> + testbit (shiftl a n) m = false. +Proof. + induction n; 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 lt_S_n. +Qed. + +Lemma div2_bitwise : forall op n a b, + div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). +Proof. + intros. unfold bitwise; fold bitwise. + destruct (op (odd a) (odd b)). + now rewrite div2_double_plus_one. + now rewrite plus_O_n, div2_double. +Qed. + +Lemma odd_bitwise : forall op n a b, + odd (bitwise op (S n) a b) = op (odd a) (odd b). +Proof. + intros. unfold bitwise; fold bitwise. + destruct (op (odd a) (odd b)). + apply odd_spec. rewrite plus_comm. eexists; eauto. + unfold odd. apply negb_false_iff. apply even_spec. + rewrite plus_O_n; eexists; eauto. +Qed. + +Lemma div2_decr : forall a n, a <= S n -> div2 a <= n. +Proof. + destruct a; intros. apply le_0_n. + apply le_trans with a. + apply lt_n_Sm_le, lt_div2, lt_0_Sn. now apply le_S_n. +Qed. + +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. + induction n; 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. + +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. + induction n; 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. + +Lemma land_spec : forall a b n, + testbit (land a b) n = testbit a n && testbit b n. +Proof. + intros. unfold land. apply testbit_bitwise_1; trivial. +Qed. + +Lemma ldiff_spec : forall a b n, + testbit (ldiff a b) n = testbit a n && negb (testbit b n). +Proof. + intros. unfold ldiff. apply testbit_bitwise_1; trivial. +Qed. + +Lemma lor_spec : forall a b n, + testbit (lor a b) n = testbit a n || testbit b n. +Proof. + intros. unfold lor. apply testbit_bitwise_2. trivial. + destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. + destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. +Qed. + +Lemma lxor_spec : forall a b n, + testbit (lxor a b) n = xorb (testbit a n) (testbit b n). +Proof. + intros. unfold lxor. apply testbit_bitwise_2. trivial. + destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. + destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l. +Qed. (** * Implementation of [NAxiomsSig] by [nat] *) -Module NPeanoAxiomsMod <: NAxiomsSig. +Module Nat + <: NAxiomsSig <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder. (** Bi-directional induction. *) @@ -40,6 +598,16 @@ Proof. reflexivity. Qed. +Theorem one_succ : 1 = S 0. +Proof. +reflexivity. +Qed. + +Theorem two_succ : 2 = S 1. +Proof. +reflexivity. +Qed. + Theorem add_0_l : forall n : nat, 0 + n = n. Proof. reflexivity. @@ -57,7 +625,7 @@ Qed. Theorem sub_succ_r : forall n m : nat, n - (S m) = pred (n - m). Proof. -intros n m; induction n m using nat_double_ind; simpl; auto. apply sub_0_r. +induction n; destruct m; simpl; auto. apply sub_0_r. Qed. Theorem mul_0_l : forall n : nat, 0 * n = 0. @@ -67,49 +635,32 @@ Qed. Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m. Proof. -intros n m; now rewrite plus_comm. +assert (add_S_r : forall n m, n+S m = S(n+m)) by (induction n; auto). +assert (add_comm : forall n m, n+m = m+n). + induction n; simpl; auto. intros; rewrite add_S_r; auto. +intros n m; now rewrite add_comm. Qed. (** Order on natural numbers *) Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m. -Proof. -intros n m; split. -apply le_lt_or_eq. -intro H; destruct H as [H | H]. -now apply lt_le_weak. rewrite H; apply le_refl. -Qed. - -Theorem lt_irrefl : forall n : nat, ~ (n < n). -Proof. -exact lt_irrefl. -Qed. - Theorem lt_succ_r : forall n m : nat, n < S m <-> n <= m. Proof. -intros n m; split; [apply lt_n_Sm_le | apply le_lt_n_Sm]. +unfold lt; split. apply le_S_n. induction 1; auto. Qed. -Theorem min_l : forall n m : nat, n <= m -> min n m = n. -Proof. -exact min_l. -Qed. - -Theorem min_r : forall n m : nat, m <= n -> min n m = m. -Proof. -exact min_r. -Qed. -Theorem max_l : forall n m : nat, m <= n -> max n m = n. +Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m. Proof. -exact max_l. +split. +inversion 1; auto. rewrite lt_succ_r; auto. +destruct 1; [|subst; auto]. rewrite <- lt_succ_r; auto. Qed. -Theorem max_r : forall n m : nat, n <= m -> max n m = m. +Theorem lt_irrefl : forall n : nat, ~ (n < n). Proof. -exact max_r. +induction n. intro H; inversion H. rewrite lt_succ_r; auto. Qed. (** Facts specific to natural numbers, not integers. *) @@ -119,25 +670,26 @@ Proof. reflexivity. Qed. -Definition recursion (A : Type) : A -> (nat -> A -> A) -> nat -> A := +(** Recursion fonction *) + +Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A := nat_rect (fun _ => A). -Implicit Arguments recursion [A]. -Instance recursion_wd (A : Type) (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). +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' Hn. subst n'. induction n; simpl; auto. apply Hf; auto. Qed. Theorem recursion_0 : - forall (A : Type) (a : A) (f : nat -> A -> A), recursion a f 0 = a. + forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a. Proof. reflexivity. Qed. Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : nat -> A -> A), + 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. @@ -149,7 +701,11 @@ Qed. Definition t := nat. Definition eq := @eq nat. +Definition eqb := beq_nat. +Definition compare := nat_compare. Definition zero := 0. +Definition one := 1. +Definition two := 2. Definition succ := S. Definition pred := pred. Definition add := plus. @@ -157,81 +713,101 @@ Definition sub := minus. Definition mul := mult. Definition lt := lt. Definition le := le. +Definition ltb := ltb. +Definition leb := leb. + Definition min := min. Definition max := max. - -End NPeanoAxiomsMod. - -(** Now we apply the largest property functor *) - -Module Export NPeanoPropMod := NPropFunct NPeanoAxiomsMod. - - - -(** Euclidean Division *) - -Definition divF div x y := if leb y x then S (div (x-y) y) else 0. -Definition modF mod x y := if leb y x then mod (x-y) y else x. -Definition initF (_ _ : nat) := 0. - -Fixpoint loop {A} (F:A->A)(i:A) (n:nat) : A := - match n with - | 0 => i - | S n => F (loop F i n) - end. - -Definition div x y := loop divF initF x x y. -Definition modulo x y := loop modF initF x x y. -Infix "/" := div : nat_scope. -Infix "mod" := modulo (at level 40, no associativity) : nat_scope. - -Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y. -Proof. - cut (forall n x y, y<>0 -> x<=n -> - x = y*(loop divF initF n x y) + (loop modF initF n x y)). - intros H x y Hy. apply H; auto. - induction n. - simpl; unfold initF; simpl. intros. nzsimpl. auto with arith. - simpl; unfold divF at 1, modF at 1. - intros. - destruct (leb y x) as [ ]_eqn:L; - [apply leb_complete in L | apply leb_complete_conv in L]. - rewrite mul_succ_r, <- add_assoc, (add_comm y), add_assoc. - rewrite <- IHn; auto. - symmetry; apply sub_add; auto. - rewrite <- NPeanoAxiomsMod.lt_succ_r. - apply lt_le_trans with x; auto. - apply lt_minus; auto. rewrite <- neq_0_lt_0; auto. - nzsimpl; auto. -Qed. - -Lemma mod_upper_bound : forall x y, y<>0 -> x mod y < y. -Proof. - cut (forall n x y, y<>0 -> x<=n -> loop modF initF n x y < y). - intros H x y Hy. apply H; auto. - induction n. - simpl; unfold initF. intros. rewrite <- neq_0_lt_0; auto. - simpl; unfold modF at 1. - intros. - destruct (leb y x) as [ ]_eqn:L; - [apply leb_complete in L | apply leb_complete_conv in L]; auto. - apply IHn; auto. - rewrite <- NPeanoAxiomsMod.lt_succ_r. - apply lt_le_trans with x; auto. - apply lt_minus; auto. rewrite <- neq_0_lt_0; auto. -Qed. - -Require Import NDiv. - -Module NDivMod <: NDivSig. - Include NPeanoAxiomsMod. - Definition div := div. - Definition modulo := modulo. - Definition div_mod := div_mod. - Definition mod_upper_bound := mod_upper_bound. - Local Obligation Tactic := simpl_relation. - Program Instance div_wd : Proper (eq==>eq==>eq) div. - Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. -End NDivMod. - -Module Export NDivPropMod := NDivPropFunct NDivMod NPeanoPropMod. +Definition max_l := max_l. +Definition max_r := max_r. +Definition min_l := min_l. +Definition min_r := min_r. + +Definition eqb_eq := beq_nat_true_iff. +Definition compare_spec := nat_compare_spec. +Definition eq_dec := eq_nat_dec. +Definition leb_le := leb_le. +Definition ltb_lt := ltb_lt. + +Definition Even := Even. +Definition Odd := Odd. +Definition even := even. +Definition odd := odd. +Definition even_spec := even_spec. +Definition odd_spec := odd_spec. + +Program Instance pow_wd : Proper (eq==>eq==>eq) pow. +Definition pow_0_r := pow_0_r. +Definition pow_succ_r := pow_succ_r. +Lemma pow_neg_r : forall a b, b<0 -> a^b = 0. inversion 1. Qed. +Definition pow := pow. + +Definition square := square. +Definition square_spec := square_spec. + +Definition log2_spec := log2_spec. +Definition log2_nonpos := log2_nonpos. +Definition log2 := log2. + +Definition sqrt_spec a (Ha:0<=a) := sqrt_spec a. +Lemma sqrt_neg : forall a, a<0 -> sqrt a = 0. inversion 1. Qed. +Definition sqrt := sqrt. + +Definition div := div. +Definition modulo := modulo. +Program Instance div_wd : Proper (eq==>eq==>eq) div. +Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. +Definition div_mod := div_mod. +Definition mod_bound_pos := mod_bound_pos. + +Definition divide := divide. +Definition gcd := gcd. +Definition gcd_divide_l := gcd_divide_l. +Definition gcd_divide_r := gcd_divide_r. +Definition gcd_greatest := gcd_greatest. +Lemma gcd_nonneg : forall a b, 0<=gcd a b. +Proof. intros. apply le_O_n. Qed. + +Definition testbit := testbit. +Definition shiftl := shiftl. +Definition shiftr := shiftr. +Definition lxor := lxor. +Definition land := land. +Definition lor := lor. +Definition ldiff := ldiff. +Definition div2 := div2. + +Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. +Definition testbit_odd_0 := testbit_odd_0. +Definition testbit_even_0 := testbit_even_0. +Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ a n. +Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ a n. +Lemma testbit_neg_r a n (H:n<0) : testbit a n = false. +Proof. inversion H. Qed. +Definition shiftl_spec_low := shiftl_spec_low. +Definition shiftl_spec_high a n m (_:0<=m) := shiftl_spec_high a n m. +Definition shiftr_spec a n m (_:0<=m) := shiftr_spec a n m. +Definition lxor_spec := lxor_spec. +Definition land_spec := land_spec. +Definition lor_spec := lor_spec. +Definition ldiff_spec := ldiff_spec. +Definition div2_spec a : div2 a = shiftr a 1 := eq_refl _. + +(** Generic Properties *) + +Include NProp + <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + +End Nat. + +(** [Nat] contains an [order] tactic for natural numbers *) + +(** Note that [Nat.order] is domain-agnostic: it will not prove + [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) + +Section TestOrder. + Let test : forall x y, x<=y -> y<=x -> x=y. + Proof. + Nat.order. + Qed. +End TestOrder. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index 7893a82d..aaf44ca6 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,9 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZArith Znumtheory. +Require Import BinInt. Open Scope Z_scope. @@ -29,60 +27,83 @@ Module Type NType. Parameter spec_pos: forall x, 0 <= [x]. Parameter of_N : N -> t. - Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x. - Definition to_N n := Zabs_N (to_Z n). + Parameter spec_of_N: forall x, to_Z (of_N x) = Z.of_N x. + Definition to_N n := Z.to_N (to_Z n). Definition eq n m := [n] = [m]. Definition lt n m := [n] < [m]. Definition le n m := [n] <= [m]. Parameter compare : t -> t -> comparison. - Parameter eq_bool : t -> t -> bool. + Parameter eqb : t -> t -> bool. + Parameter ltb : t -> t -> bool. + Parameter leb : t -> t -> bool. Parameter max : t -> t -> t. Parameter min : t -> t -> t. Parameter zero : t. Parameter one : t. + Parameter two : t. Parameter succ : t -> t. Parameter pred : t -> t. Parameter add : t -> t -> t. Parameter sub : t -> t -> t. Parameter mul : t -> t -> t. Parameter square : t -> t. - Parameter power_pos : t -> positive -> t. - Parameter power : t -> N -> t. + Parameter pow_pos : t -> positive -> t. + Parameter pow_N : t -> N -> t. + Parameter pow : t -> t -> t. Parameter sqrt : t -> t. + Parameter log2 : t -> t. Parameter div_eucl : t -> t -> t * t. Parameter div : t -> t -> t. Parameter modulo : t -> t -> t. Parameter gcd : t -> t -> t. + Parameter even : t -> bool. + Parameter odd : t -> bool. + Parameter testbit : t -> t -> bool. Parameter shiftr : t -> t -> t. Parameter shiftl : t -> t -> t. - Parameter is_even : t -> bool. + Parameter land : t -> t -> t. + Parameter lor : t -> t -> t. + Parameter ldiff : t -> t -> t. + Parameter lxor : t -> t -> t. + Parameter div2 : t -> t. - Parameter spec_compare: forall x y, compare x y = Zcompare [x] [y]. - Parameter spec_eq_bool: forall x y, eq_bool x y = Zeq_bool [x] [y]. - Parameter spec_max : forall x y, [max x y] = Zmax [x] [y]. - Parameter spec_min : forall x y, [min x y] = Zmin [x] [y]. + Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). + Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). + Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]). + Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]). + Parameter spec_max : forall x y, [max x y] = Z.max [x] [y]. + Parameter spec_min : forall x y, [min x y] = Z.min [x] [y]. Parameter spec_0: [zero] = 0. Parameter spec_1: [one] = 1. + Parameter spec_2: [two] = 2. Parameter spec_succ: forall n, [succ n] = [n] + 1. Parameter spec_add: forall x y, [add x y] = [x] + [y]. - Parameter spec_pred: forall x, [pred x] = Zmax 0 ([x] - 1). - Parameter spec_sub: forall x y, [sub x y] = Zmax 0 ([x] - [y]). + Parameter spec_pred: forall x, [pred x] = Z.max 0 ([x] - 1). + Parameter spec_sub: forall x y, [sub x y] = Z.max 0 ([x] - [y]). Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. - Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. - Parameter spec_power: forall x n, [power x n] = [x] ^ Z_of_N n. - Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + Parameter spec_square: forall x, [square x] = [x] * [x]. + Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. + Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. + Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n]. + Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. + Parameter spec_log2: forall x, [log2 x] = Z.log2 [x]. Parameter spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y]. Parameter spec_div: forall x y, [div x y] = [x] / [y]. Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. - Parameter spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]. - Parameter spec_shiftr: forall p x, [shiftr p x] = [x] / 2^[p]. - Parameter spec_shiftl: forall p x, [shiftl p x] = [x] * 2^[p]. - Parameter spec_is_even: forall x, - if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1. + Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. + Parameter spec_even: forall x, even x = Z.even [x]. + Parameter spec_odd: forall x, odd x = Z.odd [x]. + Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. + Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. + Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. + Parameter spec_land: forall x y, [land x y] = Z.land [x] [y]. + Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. + Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. + Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. + Parameter spec_div2: forall x, [div2 x] = Z.div2 [x]. End NType. @@ -90,9 +111,12 @@ Module Type NType_Notation (Import N:NType). Notation "[ x ]" := (to_Z x). Infix "==" := eq (at level 70). Notation "0" := zero. + Notation "1" := one. + Notation "2" := two. Infix "+" := add. Infix "-" := sub. Infix "*" := mul. + Infix "^" := pow. Infix "<=" := le. Infix "<" := lt. End NType_Notation. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v index a0e096be..2c7884ac 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -1,27 +1,28 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NSigNAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZArith Nnat NAxioms NDiv NSig. +Require Import ZArith OrdersFacts Nnat NAxioms NSig. (** * The interface [NSig.NType] implies the interface [NAxiomsSig] *) -Module NTypeIsNAxioms (Import N : NType'). +Module NTypeIsNAxioms (Import NN : NType'). Hint Rewrite - spec_0 spec_succ spec_add spec_mul spec_pred spec_sub - spec_div spec_modulo spec_gcd spec_compare spec_eq_bool - spec_max spec_min spec_power_pos spec_power + spec_0 spec_1 spec_2 spec_succ spec_add spec_mul spec_pred spec_sub + spec_div spec_modulo spec_gcd spec_compare spec_eqb spec_ltb spec_leb + spec_square spec_sqrt spec_log2 spec_max spec_min spec_pow_pos spec_pow_N + spec_pow spec_even spec_odd spec_testbit spec_shiftl spec_shiftr + spec_land spec_lor spec_ldiff spec_lxor spec_div2 spec_of_N : nsimpl. Ltac nsimpl := autorewrite with nsimpl. -Ltac ncongruence := unfold eq; repeat red; intros; nsimpl; congruence. -Ltac zify := unfold eq, lt, le in *; nsimpl. +Ltac ncongruence := unfold eq, to_N; repeat red; intros; nsimpl; congruence. +Ltac zify := unfold eq, lt, le, to_N in *; nsimpl. +Ltac omega_pos n := generalize (spec_pos n); omega with *. Local Obligation Tactic := ncongruence. @@ -36,14 +37,29 @@ Program Instance mul_wd : Proper (eq==>eq==>eq) mul. Theorem pred_succ : forall n, pred (succ n) == n. Proof. -intros. zify. generalize (spec_pos n); omega with *. +intros. zify. omega_pos n. Qed. -Definition N_of_Z z := of_N (Zabs_N z). +Theorem one_succ : 1 == succ 0. +Proof. +now zify. +Qed. + +Theorem two_succ : 2 == succ 1. +Proof. +now zify. +Qed. + +Definition N_of_Z z := of_N (Z.to_N z). + +Lemma spec_N_of_Z z : (0<=z)%Z -> [N_of_Z z] = z. +Proof. + unfold N_of_Z. zify. apply Z2N.id. +Qed. Section Induction. -Variable A : N.t -> Prop. +Variable A : NN.t -> Prop. Hypothesis A_wd : Proper (eq==>iff) A. Hypothesis A0 : A 0. Hypothesis AS : forall n, A n <-> A (succ n). @@ -62,9 +78,7 @@ Proof. intros z H1 H2. unfold B in *. apply -> AS in H2. setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto. -unfold eq. rewrite spec_succ. -unfold N_of_Z. -rewrite 2 spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith. +unfold eq. rewrite spec_succ, 2 spec_N_of_Z; auto with zarith. Qed. Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z. @@ -76,9 +90,7 @@ Theorem bi_induction : forall n, A n. Proof. intro n. setoid_replace n with (N_of_Z (to_Z n)). apply B_holds. apply spec_pos. -red; unfold N_of_Z. -rewrite spec_of_N, Z_of_N_abs, Zabs_eq; auto. -apply spec_pos. +red. now rewrite spec_N_of_Z by apply spec_pos. Qed. End Induction. @@ -95,7 +107,7 @@ Qed. Theorem sub_0_r : forall n, n - 0 == n. Proof. -intros. zify. generalize (spec_pos n); omega with *. +intros. zify. omega_pos n. Qed. Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). @@ -115,39 +127,69 @@ Qed. (** Order *) -Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Lemma eqb_eq x y : eqb x y = true <-> x == y. +Proof. + zify. apply Z.eqb_eq. +Qed. + +Lemma leb_le x y : leb x y = true <-> x <= y. +Proof. + zify. apply Z.leb_le. +Qed. + +Lemma ltb_lt x y : ltb x y = true <-> x < y. +Proof. + zify. apply Z.ltb_lt. +Qed. + +Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. Proof. - intros. zify. destruct (Zcompare_spec [x] [y]); auto. + intros. zify. apply Z.compare_eq_iff. Qed. -Definition eqb := eq_bool. +Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. +Proof. + intros. zify. reflexivity. +Qed. -Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y. +Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. Proof. - intros. zify. symmetry. apply Zeq_is_eq_bool. + intros. zify. reflexivity. Qed. +Lemma compare_antisym n m : compare m n = CompOpp (compare n m). +Proof. + intros. zify. apply Z.compare_antisym. +Qed. + +Include BoolOrderFacts NN NN NN [no inline]. + Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. Proof. -intros x x' Hx y y' Hy. rewrite 2 spec_compare, Hx, Hy; intuition. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. +Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Theorem lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. Proof. -intros. zify. omega. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Theorem lt_irrefl : forall n, ~ n < n. +Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. Proof. -intros. zify. omega. +intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. Qed. -Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. +Instance lt_wd : Proper (eq ==> eq ==> iff) lt. +Proof. +intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. +Qed. + +Theorem lt_succ_r : forall n m, n < succ m <-> n <= m. Proof. intros. zify. omega. Qed. @@ -179,6 +221,98 @@ Proof. zify. auto. Qed. +(** Power *) + +Program Instance pow_wd : Proper (eq==>eq==>eq) pow. + +Lemma pow_0_r : forall a, a^0 == 1. +Proof. + intros. now zify. +Qed. + +Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. +Proof. + intros a b. zify. intros. now Z.nzsimpl. +Qed. + +Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. +Proof. + intros a b. zify. intro Hb. exfalso. omega_pos b. +Qed. + +Lemma pow_pow_N : forall a b, a^b == pow_N a (to_N b). +Proof. + intros. zify. f_equal. + now rewrite Z2N.id by apply spec_pos. +Qed. + +Lemma pow_N_pow : forall a b, pow_N a b == a^(of_N b). +Proof. + intros. now zify. +Qed. + +Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). +Proof. + intros. now zify. +Qed. + +(** Square *) + +Lemma square_spec n : square n == n * n. +Proof. + now zify. +Qed. + +(** Sqrt *) + +Lemma sqrt_spec : forall n, 0<=n -> + (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). +Proof. + intros n. zify. apply Z.sqrt_spec. +Qed. + +Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. +Proof. + intros n. zify. intro H. exfalso. omega_pos n. +Qed. + +(** Log2 *) + +Lemma log2_spec : forall n, 0<n -> + 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). +Proof. + intros n. zify. change (Z.log2 [n]+1)%Z with (Z.succ (Z.log2 [n])). + apply Z.log2_spec. +Qed. + +Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. +Proof. + intros n. zify. apply Z.log2_nonpos. +Qed. + +(** Even / Odd *) + +Definition Even n := exists m, n == 2*m. +Definition Odd n := exists m, n == 2*m+1. + +Lemma even_spec n : even n = true <-> Even n. +Proof. + unfold Even. zify. rewrite Z.even_spec. + split; intros (m,Hm). + - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. + - exists [m]. revert Hm; now zify. +Qed. + +Lemma odd_spec n : odd n = true <-> Odd n. +Proof. + unfold Odd. zify. rewrite Z.odd_spec. + split; intros (m,Hm). + - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. + - exists [m]. revert Hm; now zify. +Qed. + +(** Div / Mod *) + Program Instance div_wd : Proper (eq==>eq==>eq) div. Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. @@ -187,16 +321,131 @@ Proof. intros a b. zify. intros. apply Z_div_mod_eq_full; auto. Qed. -Theorem mod_upper_bound : forall a b, ~b==0 -> modulo a b < b. +Theorem mod_bound_pos : forall a b, 0<=a -> 0<b -> + 0 <= modulo a b /\ modulo a b < b. +Proof. +intros a b. zify. apply Z.mod_bound_pos. +Qed. + +(** Gcd *) + +Definition divide n m := exists p, m == p*n. +Local Notation "( x | y )" := (divide x y) (at level 0). + +Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. +Proof. + intros n m. split. + - intros (p,H). exists [p]. revert H; now zify. + - intros (z,H). exists (of_N (Z.abs_N z)). zify. + rewrite N2Z.inj_abs_N. + rewrite <- (Z.abs_eq [m]), <- (Z.abs_eq [n]) by apply spec_pos. + now rewrite H, Z.abs_mul. +Qed. + +Lemma gcd_divide_l : forall n m, (gcd n m | n). Proof. -intros a b. zify. intros. -destruct (Z_mod_lt [a] [b]); auto. -generalize (spec_pos b); auto with zarith. + intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. Qed. -Definition recursion (A : Type) (a : A) (f : N.t -> A -> A) (n : N.t) := - Nrect (fun _ => A) a (fun n a => f (N.of_N n) a) (N.to_N n). -Implicit Arguments recursion [A]. +Lemma gcd_divide_r : forall n m, (gcd n m | m). +Proof. + intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. +Qed. + +Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). +Proof. + intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. +Qed. + +Lemma gcd_nonneg : forall n m, 0 <= gcd n m. +Proof. + intros. zify. apply Z.gcd_nonneg. +Qed. + +(** Bitwise operations *) + +Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. + +Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. +Proof. + intros. zify. apply Z.testbit_odd_0. +Qed. + +Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. +Proof. + intros. zify. apply Z.testbit_even_0. +Qed. + +Lemma testbit_odd_succ : forall a n, 0<=n -> + testbit (2*a+1) (succ n) = testbit a n. +Proof. + intros a n. zify. apply Z.testbit_odd_succ. +Qed. + +Lemma testbit_even_succ : forall a n, 0<=n -> + testbit (2*a) (succ n) = testbit a n. +Proof. + intros a n. zify. apply Z.testbit_even_succ. +Qed. + +Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. +Proof. + intros a n. zify. apply Z.testbit_neg_r. +Qed. + +Lemma shiftr_spec : forall a n m, 0<=m -> + testbit (shiftr a n) m = testbit a (m+n). +Proof. + intros a n m. zify. apply Z.shiftr_spec. +Qed. + +Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> + testbit (shiftl a n) m = testbit a (m-n). +Proof. + intros a n m. zify. intros Hn H. rewrite Z.max_r by auto with zarith. + now apply Z.shiftl_spec_high. +Qed. + +Lemma shiftl_spec_low : forall a n m, m<n -> + testbit (shiftl a n) m = false. +Proof. + intros a n m. zify. intros H. now apply Z.shiftl_spec_low. +Qed. + +Lemma land_spec : forall a b n, + testbit (land a b) n = testbit a n && testbit b n. +Proof. + intros a n m. zify. now apply Z.land_spec. +Qed. + +Lemma lor_spec : forall a b n, + testbit (lor a b) n = testbit a n || testbit b n. +Proof. + intros a n m. zify. now apply Z.lor_spec. +Qed. + +Lemma ldiff_spec : forall a b n, + testbit (ldiff a b) n = testbit a n && negb (testbit b n). +Proof. + intros a n m. zify. now apply Z.ldiff_spec. +Qed. + +Lemma lxor_spec : forall a b n, + testbit (lxor a b) n = xorb (testbit a n) (testbit b n). +Proof. + intros a n m. zify. now apply Z.lxor_spec. +Qed. + +Lemma div2_spec : forall a, div2 a == shiftr a 1. +Proof. + intros a. zify. now apply Z.div2_spec. +Qed. + +(** Recursion *) + +Definition recursion (A : Type) (a : A) (f : NN.t -> A -> A) (n : NN.t) := + Nrect (fun _ => A) a (fun n a => f (NN.of_N n) a) (NN.to_N n). +Arguments recursion [A] a f n. Instance recursion_wd (A : Type) (Aeq : relation A) : Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). @@ -204,53 +453,35 @@ Proof. unfold eq. intros a a' Eaa' f f' Eff' x x' Exx'. unfold recursion. -unfold N.to_N. +unfold NN.to_N. rewrite <- Exx'; clear x' Exx'. -replace (Zabs_N [x]) with (N_of_nat (Zabs_nat [x])). -induction (Zabs_nat [x]). +induction (Z.to_N [x]) using N.peano_ind. simpl; auto. -rewrite N_of_S, 2 Nrect_step; auto. apply Eff'; auto. -destruct [x]; simpl; auto. -change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N. -change (nat_of_P p) with (nat_of_N (Npos p)); apply N_of_nat_of_N. +rewrite 2 Nrect_step. now apply Eff'. Qed. Theorem recursion_0 : - forall (A : Type) (a : A) (f : N.t -> A -> A), recursion a f 0 = a. + forall (A : Type) (a : A) (f : NN.t -> A -> A), recursion a f 0 = a. Proof. -intros A a f; unfold recursion, N.to_N; rewrite N.spec_0; simpl; auto. +intros A a f; unfold recursion, NN.to_N; rewrite NN.spec_0; simpl; auto. Qed. Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : N.t -> A -> A), + forall (A : Type) (Aeq : relation A) (a : A) (f : NN.t -> A -> A), Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)). Proof. -unfold N.eq, recursion; intros A Aeq a f EAaa f_wd n. -replace (N.to_N (succ n)) with (Nsucc (N.to_N n)). +unfold eq, recursion; intros A Aeq a f EAaa f_wd n. +replace (to_N (succ n)) with (N.succ (to_N n)) by + (zify; now rewrite <- Z2N.inj_succ by apply spec_pos). rewrite Nrect_step. apply f_wd; auto. -unfold N.to_N. -rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto. - apply N.spec_pos. - -fold (recursion a f n). -apply recursion_wd; auto. -red; auto. -unfold N.to_N. - -rewrite N.spec_succ. -change ([n]+1)%Z with (Zsucc [n]). -apply Z_of_N_eq_rev. -rewrite Z_of_N_succ. -rewrite 2 Z_of_N_abs. -rewrite 2 Zabs_eq; auto. -generalize (spec_pos n); auto with zarith. -apply spec_pos; auto. +zify. now rewrite Z2N.id by apply spec_pos. +fold (recursion a f n). apply recursion_wd; auto. red; auto. Qed. End NTypeIsNAxioms. -Module NType_NAxioms (N : NType) - <: NAxiomsSig <: NDivSig <: HasCompare N <: HasEqBool N <: HasMinMax N - := N <+ NTypeIsNAxioms. +Module NType_NAxioms (NN : NType) + <: NAxiomsSig <: OrderFunctions NN <: HasMinMax NN + := NN <+ NTypeIsNAxioms. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index 124faba1..ba7859ee 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,132 +8,17 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NumPrelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Export Setoid Morphisms. +Require Export Setoid Morphisms Morphisms_Prop. Set Implicit Arguments. -(* -Contents: -- Coercion from bool to Prop -- Extension of the tactics stepl and stepr -- Extentional properties of predicates, relations and functions - (well-definedness and equality) -- Relations on cartesian product -- Miscellaneous -*) - -(** Coercion from bool to Prop *) - -(*Definition eq_bool := (@eq bool).*) - -(*Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.*) -(* This has been added to theories/Datatypes.v *) -(*Coercion eq_true : bool >-> Sortclass.*) - -(*Theorem eq_true_unfold_pos : forall b : bool, b <-> b = true. -Proof. -intro b; split; intro H. now inversion H. now rewrite H. -Qed. - -Theorem eq_true_unfold_neg : forall b : bool, ~ b <-> b = false. -Proof. -intros b; destruct b; simpl; rewrite eq_true_unfold_pos. -split; intro H; [elim (H (refl_equal true)) | discriminate H]. -split; intro H; [reflexivity | discriminate]. -Qed. - -Theorem eq_true_or : forall b1 b2 : bool, b1 || b2 <-> b1 \/ b2. -Proof. -destruct b1; destruct b2; simpl; tauto. -Qed. - -Theorem eq_true_and : forall b1 b2 : bool, b1 && b2 <-> b1 /\ b2. -Proof. -destruct b1; destruct b2; simpl; tauto. -Qed. - -Theorem eq_true_neg : forall b : bool, negb b <-> ~ b. -Proof. -destruct b; simpl; rewrite eq_true_unfold_pos; rewrite eq_true_unfold_neg; -split; now intro. -Qed. - -Theorem eq_true_iff : forall b1 b2 : bool, b1 = b2 <-> (b1 <-> b2). -Proof. -intros b1 b2; split; intro H. -now rewrite H. -destruct b1; destruct b2; simpl; try reflexivity. -apply -> eq_true_unfold_neg. rewrite H. now intro. -symmetry; apply -> eq_true_unfold_neg. rewrite <- H; now intro. -Qed.*) - -(** Extension of the tactics stepl and stepr to make them -applicable to hypotheses *) - -Tactic Notation "stepl" constr(t1') "in" hyp(H) := -match (type of H) with -| ?R ?t1 ?t2 => - let H1 := fresh in - cut (R t1' t2); [clear H; intro H | stepl t1; [assumption |]] -| _ => fail 1 ": the hypothesis" H "does not have the form (R t1 t2)" -end. - -Tactic Notation "stepl" constr(t1') "in" hyp(H) "by" tactic(r) := stepl t1' in H; [| r]. - -Tactic Notation "stepr" constr(t2') "in" hyp(H) := -match (type of H) with -| ?R ?t1 ?t2 => - let H1 := fresh in - cut (R t1 t2'); [clear H; intro H | stepr t2; [assumption |]] -| _ => fail 1 ": the hypothesis" H "does not have the form (R t1 t2)" -end. - -Tactic Notation "stepr" constr(t2') "in" hyp(H) "by" tactic(r) := stepr t2' in H; [| r]. - -(** Predicates, relations, functions *) - -Definition predicate (A : Type) := A -> Prop. - -Instance well_founded_wd A : - Proper (@relation_equivalence A ==> iff) (@well_founded A). -Proof. -intros R1 R2 H. -split; intros WF a; induction (WF a) as [x _ WF']; constructor; -intros y Ryx; apply WF'; destruct (H y x); auto. -Qed. - -(** [solve_predicate_wd] solves the goal [Proper (?==>iff) P] - for P consisting of morphisms and quantifiers *) - -Ltac solve_predicate_wd := -let x := fresh "x" in -let y := fresh "y" in -let H := fresh "H" in - intros x y H; setoid_rewrite H; reflexivity. - -(** [solve_relation_wd] solves the goal [Proper (?==>?==>iff) R] - for R consisting of morphisms and quantifiers *) - -Ltac solve_relation_wd := -let x1 := fresh "x" in -let y1 := fresh "y" in -let H1 := fresh "H" in -let x2 := fresh "x" in -let y2 := fresh "y" in -let H2 := fresh "H" in - intros x1 y1 H1 x2 y2 H2; - rewrite H1; setoid_rewrite H2; reflexivity. -(* The following tactic uses solve_predicate_wd to solve the goals -relating to well-defidedness that are produced by applying induction. +(* The following tactic uses solve_proper to solve the goals +relating to well-definedness that are produced by applying induction. We declare it to take the tactic that applies the induction theorem and not the induction theorem itself because the tactic may, for example, supply additional arguments, as does NZinduct_center in NZBase.v *) Ltac induction_maker n t := - try intros until n; - pattern n; t; clear n; - [solve_predicate_wd | ..]. + try intros until n; pattern n; t; clear n; [solve_proper | ..]. diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index 82190f94..424db5b7 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,47 +35,21 @@ End BigN_BigZ. (** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *) -Module BigQ <: QType <: OrderedTypeFull <: TotalOrder := - QMake.Make BigN BigZ BigN_BigZ <+ !QProperties <+ HasEqBool2Dec - <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. +Delimit Scope bigQ_scope with bigQ. -(** Notations about [BigQ] *) +Module BigQ <: QType <: OrderedTypeFull <: TotalOrder. + Include QMake.Make BigN BigZ BigN_BigZ [scope abstract_scope to bigQ_scope]. + Bind Scope bigQ_scope with t t_. + Include !QProperties <+ HasEqBool2Dec + <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. +End BigQ. -Notation bigQ := BigQ.t. +(** Notations about [BigQ] *) -Delimit Scope bigQ_scope with bigQ. -Bind Scope bigQ_scope with bigQ. -Bind Scope bigQ_scope with BigQ.t. -Bind Scope bigQ_scope with BigQ.t_. -(* Bind Scope has no retroactive effect, let's declare scopes by hand. *) -Arguments Scope BigQ.Qz [bigZ_scope]. -Arguments Scope BigQ.Qq [bigZ_scope bigN_scope]. -Arguments Scope BigQ.to_Q [bigQ_scope]. -Arguments Scope BigQ.red [bigQ_scope]. -Arguments Scope BigQ.opp [bigQ_scope]. -Arguments Scope BigQ.inv [bigQ_scope]. -Arguments Scope BigQ.square [bigQ_scope]. -Arguments Scope BigQ.add [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.sub [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.mul [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.div [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.eq [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.lt [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.le [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.eq [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.compare [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.min [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.max [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.eq_bool [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.power_pos [bigQ_scope positive_scope]. -Arguments Scope BigQ.power [bigQ_scope Z_scope]. -Arguments Scope BigQ.inv_norm [bigQ_scope]. -Arguments Scope BigQ.add_norm [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.sub_norm [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.mul_norm [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.div_norm [bigQ_scope bigQ_scope]. -Arguments Scope BigQ.power_norm [bigQ_scope bigQ_scope]. +Local Open Scope bigQ_scope. +Notation bigQ := BigQ.t. +Bind Scope bigQ_scope with bigQ BigQ.t BigQ.t_. (** As in QArith, we use [#] to denote fractions *) Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope. Local Notation "0" := BigQ.zero : bigQ_scope. @@ -88,19 +62,17 @@ Infix "/" := BigQ.div : bigQ_scope. Infix "^" := BigQ.power : bigQ_scope. Infix "?=" := BigQ.compare : bigQ_scope. Infix "==" := BigQ.eq : bigQ_scope. -Notation "x != y" := (~x==y)%bigQ (at level 70, no associativity) : bigQ_scope. +Notation "x != y" := (~x==y) (at level 70, no associativity) : bigQ_scope. Infix "<" := BigQ.lt : bigQ_scope. Infix "<=" := BigQ.le : bigQ_scope. -Notation "x > y" := (BigQ.lt y x)(only parsing) : bigQ_scope. -Notation "x >= y" := (BigQ.le y x)(only parsing) : bigQ_scope. -Notation "x < y < z" := (x<y /\ y<z)%bigQ : bigQ_scope. -Notation "x < y <= z" := (x<y /\ y<=z)%bigQ : bigQ_scope. -Notation "x <= y < z" := (x<=y /\ y<z)%bigQ : bigQ_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z)%bigQ : bigQ_scope. +Notation "x > y" := (BigQ.lt y x) (only parsing) : bigQ_scope. +Notation "x >= y" := (BigQ.le y x) (only parsing) : bigQ_scope. +Notation "x < y < z" := (x<y /\ y<z) : bigQ_scope. +Notation "x < y <= z" := (x<y /\ y<=z) : bigQ_scope. +Notation "x <= y < z" := (x<=y /\ y<z) : bigQ_scope. +Notation "x <= y <= z" := (x<=y /\ y<=z) : bigQ_scope. Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope. -Local Open Scope bigQ_scope. - (** [BigQ] is a field *) Lemma BigQfieldth : diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 49e9d075..995fbb9e 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -39,6 +39,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Definition t := t_. + Bind Scope abstract_scope with t t_. + (** Specification with respect to [QArith] *) Local Open Scope Q_scope. @@ -55,7 +57,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Definition to_Q (q: t) := match q with | Qz x => Z.to_Z x # 1 - | Qq x y => if N.eq_bool y N.zero then 0 + | Qq x y => if N.eqb y N.zero then 0 else Z.to_Z x # Z2P (N.to_Z y) end. @@ -66,26 +68,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros x; rewrite N.spec_0; generalize (N.spec_pos x). romega. Qed. -(* - Lemma if_fun_commut : forall A B (f:A->B)(b:bool) a a', - f (if b then a else a') = if b then f a else f a'. - Proof. now destruct b. Qed. - Lemma if_fun_commut' : forall A B C D (f:A->B)(b:{C}+{D}) a a', - f (if b then a else a') = if b then f a else f a'. - Proof. now destruct b. Qed. -*) + Ltac destr_zcompare := case Z.compare_spec; intros ?H. + Ltac destr_eqb := match goal with - | |- context [Z.eq_bool ?x ?y] => - rewrite (Z.spec_eq_bool x y); - generalize (Zeq_bool_if (Z.to_Z x) (Z.to_Z y)); - case (Zeq_bool (Z.to_Z x) (Z.to_Z y)); + | |- context [Z.eqb ?x ?y] => + rewrite (Z.spec_eqb x y); + case (Z.eqb_spec (Z.to_Z x) (Z.to_Z y)); destr_eqb - | |- context [N.eq_bool ?x ?y] => - rewrite (N.spec_eq_bool x y); - generalize (Zeq_bool_if (N.to_Z x) (N.to_Z y)); - case (Zeq_bool (N.to_Z x) (N.to_Z y)); + | |- context [N.eqb ?x ?y] => + rewrite (N.spec_eqb x y); + case (Z.eqb_spec (N.to_Z x) (N.to_Z y)); [ | let H:=fresh "H" in try (intro H;generalize (N_to_Z_pos _ H); clear H)]; destr_eqb @@ -100,6 +94,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1 spec_Z_of_N spec_Zabs_N : nz. + Ltac nzsimpl := autorewrite with nz in *. Ltac qsimpl := try red; unfold to_Q; simpl; intros; @@ -143,13 +138,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. match x, y with | Qz zx, Qz zy => Z.compare zx zy | Qz zx, Qq ny dy => - if N.eq_bool dy N.zero then Z.compare zx Z.zero + if N.eqb dy N.zero then Z.compare zx Z.zero else Z.compare (Z.mul zx (Z_of_N dy)) ny | Qq nx dx, Qz zy => - if N.eq_bool dx N.zero then Z.compare Z.zero zy + if N.eqb dx N.zero then Z.compare Z.zero zy else Z.compare nx (Z.mul zy (Z_of_N dx)) | Qq nx dx, Qq ny dy => - match N.eq_bool dx N.zero, N.eq_bool dy N.zero with + match N.eqb dx N.zero, N.eqb dy N.zero with | true, true => Eq | true, false => Z.compare Z.zero ny | false, true => Z.compare nx Z.zero @@ -299,15 +294,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. match y with | Qz zy => Qz (Z.add zx zy) | Qq ny dy => - if N.eq_bool dy N.zero then x + if N.eqb dy N.zero then x else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eqb dx N.zero then y else match y with | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => - if N.eq_bool dy N.zero then x + if N.eqb dy N.zero then x else let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in let d := N.mul dx dy in @@ -331,15 +326,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. match y with | Qz zy => Qz (Z.add zx zy) | Qq ny dy => - if N.eq_bool dy N.zero then x + if N.eqb dy N.zero then x else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eqb dx N.zero then y else match y with | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => - if N.eq_bool dy N.zero then x + if N.eqb dy N.zero then x else let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in let d := N.mul dx dy in @@ -376,8 +371,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros [z | x y]; simpl. rewrite Z.spec_opp; auto. - match goal with |- context[N.eq_bool ?X ?Y] => - generalize (N.spec_eq_bool X Y); case N.eq_bool + match goal with |- context[N.eqb ?X ?Y] => + generalize (N.spec_eqb X Y); case N.eqb end; auto; rewrite N.spec_0. rewrite Z.spec_opp; auto. Qed. @@ -427,26 +422,29 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy) end. + Ltac nsubst := + match goal with E : N.to_Z _ = _ |- _ => rewrite E in * end. + Theorem spec_mul : forall x y, [mul x y] == [x] * [y]. Proof. intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl. rewrite Pmult_1_r, Z2P_correct; auto. destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition. - rewrite H0 in H1; auto with zarith. - rewrite H0 in H1; auto with zarith. - rewrite H in H1; nzsimpl; auto with zarith. + nsubst; auto with zarith. + nsubst; auto with zarith. + nsubst; nzsimpl; auto with zarith. rewrite Zpos_mult_morphism, 2 Z2P_correct; auto. Qed. Definition norm_denum n d := - if N.eq_bool d N.one then Qz n else Qq n d. + if N.eqb d N.one then Qz n else Qq n d. Lemma spec_norm_denum : forall n d, [norm_denum n d] == [Qq n d]. Proof. unfold norm_denum; intros; simpl; qsimpl. congruence. - rewrite H0 in *; auto with zarith. + nsubst; auto with zarith. Qed. Definition irred n d := @@ -526,7 +524,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Qed. Definition mul_norm_Qz_Qq z n d := - if Z.eq_bool z Z.zero then zero + if Z.eqb z Z.zero then zero else let gcd := N.gcd (Zabs_N z) d in match N.compare gcd N.one with @@ -554,12 +552,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. destr_eqb; nzsimpl; intros Hz. qsimpl; rewrite Hz; auto. - destruct Z_le_gt_dec; intros. + destruct Z_le_gt_dec as [LE|GT]. qsimpl. rewrite spec_norm_denum. qsimpl. - rewrite Zdiv_gcd_zero in z0; auto with zarith. - rewrite H in *. rewrite Zdiv_0_l in *; discriminate. + rewrite Zdiv_gcd_zero in GT; auto with zarith. + nsubst. rewrite Zdiv_0_l in *; discriminate. rewrite <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc. rewrite Zgcd_div_swap0; try romega. ring. @@ -635,13 +633,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_norm_denum. qsimpl. - destruct (Zmult_integral _ _ H0) as [Eq|Eq]. + match goal with E : (_ * _ = 0)%Z |- _ => + destruct (Zmult_integral _ _ E) as [Eq|Eq] end. rewrite Eq in *; simpl in *. rewrite <- Hg2' in *; auto with zarith. rewrite Eq in *; simpl in *. rewrite <- Hg2 in *; auto with zarith. - destruct (Zmult_integral _ _ H) as [Eq|Eq]. + match goal with E : (_ * _ = 0)%Z |- _ => + destruct (Zmult_integral _ _ E) as [Eq|Eq] end. rewrite Hz' in Eq; rewrite Eq in *; auto with zarith. rewrite Hz in Eq; rewrite Eq in *; auto with zarith. @@ -689,13 +689,13 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite Zgcd_1_rel_prime in *. apply bezout_rel_prime. - destruct (rel_prime_bezout _ _ H4) as [u v Huv]. + destruct (rel_prime_bezout (Z.to_Z ny) (N.to_Z dy)) as [u v Huv]; trivial. apply Bezout_intro with (u*g')%Z (v*g)%Z. rewrite <- Huv, <- Hg1', <- Hg2. ring. rewrite Zgcd_1_rel_prime in *. apply bezout_rel_prime. - destruct (rel_prime_bezout _ _ H3) as [u v Huv]. + destruct (rel_prime_bezout (Z.to_Z nx) (N.to_Z dx)) as [u v Huv]; trivial. apply Bezout_intro with (u*g)%Z (v*g')%Z. rewrite <- Huv, <- Hg2', <- Hg1. ring. Qed. @@ -753,10 +753,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destr_eqb; nzsimpl; intros. intros; rewrite Zabs_eq in *; romega. intros; rewrite Zabs_eq in *; romega. - clear H1. - rewrite H0. - compute; auto. - clear H1. + nsubst; compute; auto. set (n':=Z.to_Z n) in *; clearbody n'. rewrite Zabs_eq by romega. red; simpl. @@ -768,9 +765,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destr_eqb; nzsimpl; intros. intros; rewrite Zabs_non_eq in *; romega. intros; rewrite Zabs_non_eq in *; romega. - clear H1. - red; nzsimpl; rewrite H0; compute; auto. - clear H1. + nsubst; compute; auto. set (n':=Z.to_Z n) in *; clearbody n'. red; simpl; nzsimpl. rewrite Zabs_non_eq by romega. @@ -789,7 +784,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Gt => Qq Z.minus_one (Zabs_N z) end | Qq n d => - if N.eq_bool d N.zero then zero else + if N.eqb d N.zero then zero else match Z.compare Z.zero n with | Eq => zero | Lt => @@ -926,9 +921,9 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destr_eqb; nzsimpl; intros. apply Qeq_refl. rewrite N.spec_square in *; nzsimpl. - elim (Zmult_integral _ _ H0); romega. - rewrite N.spec_square in *; nzsimpl. - rewrite H in H0; romega. + match goal with E : (_ * _ = 0)%Z |- _ => + elim (Zmult_integral _ _ E); romega end. + rewrite N.spec_square in *; nzsimpl; nsubst; romega. rewrite Z.spec_square, N.spec_square. red; simpl. rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto. @@ -937,8 +932,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Definition power_pos (x : t) p : t := match x with - | Qz zx => Qz (Z.power_pos zx p) - | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) + | Qz zx => Qz (Z.pow_pos zx p) + | Qq nx dx => Qq (Z.pow_pos nx p) (N.pow_pos dx p) end. Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. @@ -946,25 +941,26 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. intros [ z | n d ] p; unfold power_pos. (* Qz *) simpl. - rewrite Z.spec_power_pos. + rewrite Z.spec_pow_pos. rewrite Qpower_decomp. red; simpl; f_equal. rewrite Zpower_pos_1_l; auto. (* Qq *) simpl. - rewrite Z.spec_power_pos. + rewrite Z.spec_pow_pos. destr_eqb; nzsimpl; intros. apply Qeq_sym; apply Qpower_positive_0. - rewrite N.spec_power_pos in *. + rewrite N.spec_pow_pos in *. assert (0 < N.to_Z d ^ ' p)%Z by (apply Zpower_gt_0; auto with zarith). romega. - rewrite N.spec_power_pos, H in *. - rewrite Zpower_0_l in H0; [romega|discriminate]. + exfalso. + rewrite N.spec_pow_pos in *. nsubst. + rewrite Zpower_0_l in *; [romega|discriminate]. rewrite Qpower_decomp. red; simpl; do 3 f_equal. rewrite Z2P_correct by (generalize (N.spec_pos d); romega). - rewrite N.spec_power_pos. auto. + rewrite N.spec_pow_pos. auto. Qed. Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p). @@ -979,10 +975,11 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. revert H. unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl. destr_eqb; nzsimpl; simpl; intros. - rewrite N.spec_power_pos in H0. - rewrite H, Zpower_0_l in *; [romega|discriminate]. + exfalso. + rewrite N.spec_pow_pos in *. nsubst. + rewrite Zpower_0_l in *; [romega|discriminate]. rewrite Z2P_correct in *; auto. - rewrite N.spec_power_pos, Z.spec_power_pos; auto. + rewrite N.spec_pow_pos, Z.spec_pow_pos; auto. rewrite Zgcd_1_rel_prime in *. apply rel_prime_Zpower; auto with zarith. Qed. @@ -1274,7 +1271,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qred_complete; apply spec_power_pos; auto. induction p using Pind. simpl; ring. - rewrite nat_of_P_succ_morphism; simpl Qcpower. + rewrite Psucc_S; simpl Qcpower. rewrite <- IHp; clear IHp. unfold Qcmult, Q2Qc. apply Qc_decomp; intros _ _; unfold this. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v index 0fea26df..29e1e795 100644 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QSig.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax. Open Scope Q_scope. @@ -117,7 +115,7 @@ Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy. Local Obligation Tactic := solve_wd2 || solve_wd1. Instance : Measure to_Q. -Instance eq_equiv : Equivalence eq. +Instance eq_equiv : Equivalence eq := {}. Program Instance lt_wd : Proper (eq==>eq==>iff) lt. Program Instance le_wd : Proper (eq==>eq==>iff) le. @@ -137,13 +135,13 @@ Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power. (** Let's implement [HasCompare] *) -Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). +Lemma compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y). Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed. (** Let's implement [TotalOrder] *) Definition lt_compat := lt_wd. -Instance lt_strorder : StrictOrder lt. +Instance lt_strorder : StrictOrder lt := {}. Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y. Proof. intros. qify. apply Qle_lteq. Qed. @@ -222,4 +220,4 @@ End QProperties. Module QTypeExt (Q : QType) <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q - := Q <+ QProperties.
\ No newline at end of file + := Q <+ QProperties. diff --git a/theories/Numbers/vo.itarget b/theories/Numbers/vo.itarget index 175a15e9..c69af03f 100644 --- a/theories/Numbers/vo.itarget +++ b/theories/Numbers/vo.itarget @@ -1,3 +1,4 @@ +BinNums.vo BigNumPrelude.vo Cyclic/Abstract/CyclicAxioms.vo Cyclic/Abstract/NZCyclic.vo @@ -23,10 +24,16 @@ Integer/Abstract/ZLt.vo Integer/Abstract/ZMulOrder.vo Integer/Abstract/ZMul.vo Integer/Abstract/ZSgnAbs.vo -Integer/Abstract/ZProperties.vo Integer/Abstract/ZDivFloor.vo Integer/Abstract/ZDivTrunc.vo Integer/Abstract/ZDivEucl.vo +Integer/Abstract/ZMaxMin.vo +Integer/Abstract/ZParity.vo +Integer/Abstract/ZPow.vo +Integer/Abstract/ZGcd.vo +Integer/Abstract/ZLcm.vo +Integer/Abstract/ZBits.vo +Integer/Abstract/ZProperties.vo Integer/BigZ/BigZ.vo Integer/BigZ/ZMake.vo Integer/Binary/ZBinary.vo @@ -43,7 +50,13 @@ NatInt/NZMul.vo NatInt/NZOrder.vo NatInt/NZProperties.vo NatInt/NZDomain.vo +NatInt/NZParity.vo NatInt/NZDiv.vo +NatInt/NZPow.vo +NatInt/NZSqrt.vo +NatInt/NZLog.vo +NatInt/NZGcd.vo +NatInt/NZBits.vo Natural/Abstract/NAddOrder.vo Natural/Abstract/NAdd.vo Natural/Abstract/NAxioms.vo @@ -56,6 +69,14 @@ Natural/Abstract/NStrongRec.vo Natural/Abstract/NSub.vo Natural/Abstract/NProperties.vo Natural/Abstract/NDiv.vo +Natural/Abstract/NMaxMin.vo +Natural/Abstract/NParity.vo +Natural/Abstract/NPow.vo +Natural/Abstract/NSqrt.vo +Natural/Abstract/NLog.vo +Natural/Abstract/NGcd.vo +Natural/Abstract/NLcm.vo +Natural/Abstract/NBits.vo Natural/BigN/BigN.vo Natural/BigN/Nbasic.vo Natural/BigN/NMake_gen.vo diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v new file mode 100644 index 00000000..2e4d52a2 --- /dev/null +++ b/theories/PArith/BinPos.v @@ -0,0 +1,2132 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export BinNums. +Require Import Eqdep_dec EqdepFacts RelationClasses Morphisms Setoid + Equalities Orders OrdersFacts GenericMinMax Le Plus. + +Require Export BinPosDef. + +(**********************************************************************) +(** * Binary positive numbers, operations and properties *) +(**********************************************************************) + +(** Initial development by Pierre Crégut, CNET, Lannion, France *) + +(** The type [positive] and its constructors [xI] and [xO] and [xH] + are now defined in [BinNums.v] *) + +Local Open Scope positive_scope. +Local Unset Boolean Equality Schemes. +Local Unset Case Analysis Schemes. + +(** Every definitions and early properties about positive numbers + are placed in a module [Pos] for qualification purpose. *) + +Module Pos + <: UsualOrderedTypeFull + <: UsualDecidableTypeFull + <: TotalOrder. + +(** * Definitions of operations, now in a separate file *) + +Include BinPosDef.Pos. + +(** In functor applications that follow, we only inline t and eq *) + +Set Inline Level 30. + +(** * Logical Predicates *) + +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. + +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; 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; destruct q; simpl; now f_equal. +Qed. + +(** ** Commutativity *) + +Theorem add_comm p q : p + q = q + p. +Proof. + revert q. induction p; 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; 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 with (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 with (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| ]; 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. + +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; trivial. + intros. simpl. now rewrite IHp. +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. + +Definition peano_rec (P:positive->Set) := peano_rect P. + +(** Peano induction *) + +Definition peano_ind (P:positive->Prop) := peano_rect P. + +(** Peano case analysis *) + +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. + +(** Earlier, the Peano-like recursor was built and proved in a way due to + Conor McBride, see "The view from the left" *) + +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. + induction q as [ | p q IHq ]. + apply eq_dep_eq_positive. + cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. 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'. + intro. destruct p; discriminate. + intro. apply succ_inj in H. + generalize q'. rewrite H. intro. + 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 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; assumption. +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 : forall A B (f:A->B)(g:A->A)(h:B->B), + (forall a, f (g a) = h (f a)) -> forall p a, + f (iter p g a) = iter p h (f a). +Proof. + induction p; simpl; intros; now rewrite ?H, ?IHp. +Qed. + +Theorem iter_swap : + forall p (A:Type) (f:A -> A) (x:A), + iter p f (f x) = f (iter p f x). +Proof. + intros. symmetry. now apply iter_swap_gen. +Qed. + +Theorem iter_succ : + forall p (A:Type) (f:A -> A) (x:A), + iter (succ p) f x = f (iter p f x). +Proof. + induction p as [p IHp|p IHp|]; intros; simpl; trivial. + now rewrite !IHp, 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. + induction p using peano_ind; intros. + now rewrite add_1_l, iter_succ. + now rewrite add_succ_l, !iter_succ, IHp. +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 p f x). +Proof. + induction p as [p IHp|p IHp|]; simpl; trivial. + intros A f Inv H x H0. apply H, IHp, IHp; trivial. + intros A f Inv H x H0. apply IHp, IHp; trivial. +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. + - 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; 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| ]; destruct q; simpl; + try reflexivity; try 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; destruct q; simpl; try constructor; trivial. + (* p~1 q~1 *) + destruct (IHp q); subst; try now constructor. + now apply SubIsNeg with r~0. + (* p~1 q~0 *) + destruct (IHp q); 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); 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); 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; 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; destruct q; simpl; rewrite ?IHp; split; congruence. +Qed. + +Theorem ltb_lt p q : (p <? q) = true <-> 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 p q c = switch_Eq c (p ?= q). +Proof. + unfold compare. + revert q c. + induction p; destruct q; simpl; trivial. + intros c. + rewrite 2 IHp. now destruct (compare_cont p q Eq). + intros c. + rewrite 2 IHp. now destruct (compare_cont p q Eq). +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 p q c = Eq -> c = Eq. +Proof. + rewrite compare_cont_spec. now destruct (p ?= q). +Qed. + +Lemma compare_cont_Lt_Gt p q : + compare_cont p q Lt = 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 p q Lt = Lt <-> p <= q. +Proof. + rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'. +Qed. + +Lemma compare_cont_Gt_Lt p q : + compare_cont p q Gt = 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 p q Gt = Gt <-> p >= q. +Proof. + rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'. +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. + +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 p p c = c. +Proof. + now induction p. +Qed. + +Lemma compare_cont_antisym p q c : + CompOpp (compare_cont p q c) = compare_cont q p (CompOpp c). +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; destruct 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<q -> 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. + +Instance lt_strorder : StrictOrder lt. +Proof. split. exact lt_irrefl. exact lt_trans. Qed. + +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. + +Instance le_preorder : PreOrder le. +Proof. split. exact le_refl. exact le_trans. Qed. + +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 p 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<r <-> 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<r <-> 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<q -> r<s -> p+r<q+s. +Proof. + intros. apply lt_trans with (p+s). + now apply add_lt_mono_l. + now apply add_lt_mono_r. +Qed. + +Lemma add_le_mono_l p q r : q<=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; 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<r <-> 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<r <-> 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<q -> r<s -> 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 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<n -> 1<n^p. +Proof. + intros H. induction p using peano_ind. + now rewrite pow_1_r. + rewrite pow_succ_r. + apply lt_trans with (n*1). + now rewrite mul_1_r. + now apply mul_lt_mono_l. +Qed. + +(**********************************************************************) +(** * Properties of subtraction on binary positive numbers *) + +Lemma sub_1_r p : sub p 1 = pred p. +Proof. + now destruct p. +Qed. + +Lemma pred_sub p : pred p = sub p 1. +Proof. + symmetry. apply sub_1_r. +Qed. + +Theorem sub_succ_r p q : p - (succ q) = pred (p - q). +Proof. + unfold sub; rewrite sub_mask_succ_r, sub_mask_carry_spec. + destruct (sub_mask p q) as [|[r|r| ]|]; auto. +Qed. + +(** ** Properties of subtraction without underflow *) + +Lemma sub_mask_pos' p q : + q < p -> 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<q -> 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 -> (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 -> p<r -> 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<p -> r<p -> (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<q -> p<r -> (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<p -> r<q -> 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 -> 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<q -> 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 -> 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 -> 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 -> 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 -> 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<q -> 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<q -> 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<q -> (size_nat p <= size_nat q)%nat. +Proof. + assert (le0 : forall n, (0<=n)%nat) by (induction n; auto). + assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). + revert q. + induction p; destruct q; simpl; intros; 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; 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; 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. +Include !UsualMinMaxDecProperties. + +(** 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. + induction p; simpl; intros; trivial. + rewrite H. apply IHp. +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. 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 1. + destruct 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 _ r). 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; 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. + induction n. + simpl; auto. + 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. + induction n. + simpl; auto. + 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. + induction n. + destruct a, b; simpl; inversion 1. + destruct a, 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 Le.le_trans; [|eapply LE]. + rewrite plus_comm, <- plus_n_Sm, <- plus_Sn_m. + apply plus_le_compat; 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 Le.le_trans; [|eapply LE]. + apply plus_le_compat; 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. + 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. apply le_Sn_le. now rewrite plus_n_Sm. + 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. apply le_Sn_le. now rewrite plus_n_Sm. + 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. 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. + +(** Exportation of notations *) + +Infix "+" := Pos.add : positive_scope. +Infix "-" := Pos.sub : positive_scope. +Infix "*" := Pos.mul : positive_scope. +Infix "^" := Pos.pow : positive_scope. +Infix "?=" := Pos.compare (at level 70, no associativity) : positive_scope. +Infix "=?" := Pos.eqb (at level 70, no associativity) : positive_scope. +Infix "<=?" := Pos.leb (at level 70, no associativity) : positive_scope. +Infix "<?" := Pos.ltb (at level 70, no associativity) : positive_scope. +Infix "<=" := Pos.le : positive_scope. +Infix "<" := Pos.lt : positive_scope. +Infix ">=" := Pos.ge : positive_scope. +Infix ">" := Pos.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. + +Notation "( p | q )" := (Pos.divide p q) (at level 0) : positive_scope. + +(** Compatibility notations *) + +Notation positive := positive (only parsing). +Notation positive_rect := positive_rect (only parsing). +Notation positive_rec := positive_rec (only parsing). +Notation positive_ind := positive_ind (only parsing). +Notation xI := xI (only parsing). +Notation xO := xO (only parsing). +Notation xH := xH (only parsing). + +Notation Psucc := Pos.succ (only parsing). +Notation Pplus := Pos.add (only parsing). +Notation Pplus_carry := Pos.add_carry (only parsing). +Notation Ppred := Pos.pred (only parsing). +Notation Piter_op := Pos.iter_op (only parsing). +Notation Piter_op_succ := Pos.iter_op_succ (only parsing). +Notation Pmult_nat := (Pos.iter_op plus) (only parsing). +Notation nat_of_P := Pos.to_nat (only parsing). +Notation P_of_succ_nat := Pos.of_succ_nat (only parsing). +Notation Pdouble_minus_one := Pos.pred_double (only parsing). +Notation positive_mask := Pos.mask (only parsing). +Notation IsNul := Pos.IsNul (only parsing). +Notation IsPos := Pos.IsPos (only parsing). +Notation IsNeg := Pos.IsNeg (only parsing). +Notation positive_mask_rect := Pos.mask_rect (only parsing). +Notation positive_mask_ind := Pos.mask_ind (only parsing). +Notation positive_mask_rec := Pos.mask_rec (only parsing). +Notation Pdouble_plus_one_mask := Pos.succ_double_mask (only parsing). +Notation Pdouble_mask := Pos.double_mask (only parsing). +Notation Pdouble_minus_two := Pos.double_pred_mask (only parsing). +Notation Pminus_mask := Pos.sub_mask (only parsing). +Notation Pminus_mask_carry := Pos.sub_mask_carry (only parsing). +Notation Pminus := Pos.sub (only parsing). +Notation Pmult := Pos.mul (only parsing). +Notation iter_pos := @Pos.iter (only parsing). +Notation Ppow := Pos.pow (only parsing). +Notation Pdiv2 := Pos.div2 (only parsing). +Notation Pdiv2_up := Pos.div2_up (only parsing). +Notation Psize := Pos.size_nat (only parsing). +Notation Psize_pos := Pos.size (only parsing). +Notation Pcompare := Pos.compare_cont (only parsing). +Notation Plt := Pos.lt (only parsing). +Notation Pgt := Pos.gt (only parsing). +Notation Ple := Pos.le (only parsing). +Notation Pge := Pos.ge (only parsing). +Notation Pmin := Pos.min (only parsing). +Notation Pmax := Pos.max (only parsing). +Notation Peqb := Pos.eqb (only parsing). +Notation positive_eq_dec := Pos.eq_dec (only parsing). +Notation xI_succ_xO := Pos.xI_succ_xO (only parsing). +Notation Psucc_discr := Pos.succ_discr (only parsing). +Notation Psucc_o_double_minus_one_eq_xO := + Pos.succ_pred_double (only parsing). +Notation Pdouble_minus_one_o_succ_eq_xI := + Pos.pred_double_succ (only parsing). +Notation xO_succ_permute := Pos.double_succ (only parsing). +Notation double_moins_un_xO_discr := + Pos.pred_double_xO_discr (only parsing). +Notation Psucc_not_one := Pos.succ_not_1 (only parsing). +Notation Ppred_succ := Pos.pred_succ (only parsing). +Notation Psucc_pred := Pos.succ_pred_or (only parsing). +Notation Psucc_inj := Pos.succ_inj (only parsing). +Notation Pplus_carry_spec := Pos.add_carry_spec (only parsing). +Notation Pplus_comm := Pos.add_comm (only parsing). +Notation Pplus_succ_permute_r := Pos.add_succ_r (only parsing). +Notation Pplus_succ_permute_l := Pos.add_succ_l (only parsing). +Notation Pplus_no_neutral := Pos.add_no_neutral (only parsing). +Notation Pplus_carry_plus := Pos.add_carry_add (only parsing). +Notation Pplus_reg_r := Pos.add_reg_r (only parsing). +Notation Pplus_reg_l := Pos.add_reg_l (only parsing). +Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (only parsing). +Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (only parsing). +Notation Pplus_assoc := Pos.add_assoc (only parsing). +Notation Pplus_xO := Pos.add_xO (only parsing). +Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (only parsing). +Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (only parsing). +Notation Pplus_diag := Pos.add_diag (only parsing). +Notation PeanoView := Pos.PeanoView (only parsing). +Notation PeanoOne := Pos.PeanoOne (only parsing). +Notation PeanoSucc := Pos.PeanoSucc (only parsing). +Notation PeanoView_rect := Pos.PeanoView_rect (only parsing). +Notation PeanoView_ind := Pos.PeanoView_ind (only parsing). +Notation PeanoView_rec := Pos.PeanoView_rec (only parsing). +Notation peanoView_xO := Pos.peanoView_xO (only parsing). +Notation peanoView_xI := Pos.peanoView_xI (only parsing). +Notation peanoView := Pos.peanoView (only parsing). +Notation PeanoView_iter := Pos.PeanoView_iter (only parsing). +Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (only parsing). +Notation PeanoViewUnique := Pos.PeanoViewUnique (only parsing). +Notation Prect := Pos.peano_rect (only parsing). +Notation Prect_succ := Pos.peano_rect_succ (only parsing). +Notation Prect_base := Pos.peano_rect_base (only parsing). +Notation Prec := Pos.peano_rec (only parsing). +Notation Pind := Pos.peano_ind (only parsing). +Notation Pcase := Pos.peano_case (only parsing). +Notation Pmult_1_r := Pos.mul_1_r (only parsing). +Notation Pmult_Sn_m := Pos.mul_succ_l (only parsing). +Notation Pmult_xO_permute_r := Pos.mul_xO_r (only parsing). +Notation Pmult_xI_permute_r := Pos.mul_xI_r (only parsing). +Notation Pmult_comm := Pos.mul_comm (only parsing). +Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (only parsing). +Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (only parsing). +Notation Pmult_assoc := Pos.mul_assoc (only parsing). +Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (only parsing). +Notation Pmult_xO_discr := Pos.mul_xO_discr (only parsing). +Notation Pmult_reg_r := Pos.mul_reg_r (only parsing). +Notation Pmult_reg_l := Pos.mul_reg_l (only parsing). +Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (only parsing). +Notation Psquare_xO := Pos.square_xO (only parsing). +Notation Psquare_xI := Pos.square_xI (only parsing). +Notation iter_pos_swap_gen := Pos.iter_swap_gen (only parsing). +Notation iter_pos_swap := Pos.iter_swap (only parsing). +Notation iter_pos_succ := Pos.iter_succ (only parsing). +Notation iter_pos_plus := Pos.iter_add (only parsing). +Notation iter_pos_invariant := Pos.iter_invariant (only parsing). +Notation Ppow_1_r := Pos.pow_1_r (only parsing). +Notation Ppow_succ_r := Pos.pow_succ_r (only parsing). +Notation Peqb_refl := Pos.eqb_refl (only parsing). +Notation Peqb_eq := Pos.eqb_eq (only parsing). +Notation Pcompare_refl_id := Pos.compare_cont_refl (only parsing). +Notation Pcompare_eq_iff := Pos.compare_eq_iff (only parsing). +Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (only parsing). +Notation Pcompare_eq_Lt := Pos.compare_lt_iff (only parsing). +Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (only parsing). + +Notation Pcompare_antisym := Pos.compare_cont_antisym (only parsing). +Notation ZC1 := Pos.gt_lt (only parsing). +Notation ZC2 := Pos.lt_gt (only parsing). +Notation Pcompare_spec := Pos.compare_spec (only parsing). +Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (only parsing). +Notation Pcompare_succ_succ := Pos.compare_succ_succ (only parsing). +Notation Pcompare_1 := Pos.nlt_1_r (only parsing). +Notation Plt_1 := Pos.nlt_1_r (only parsing). +Notation Plt_1_succ := Pos.lt_1_succ (only parsing). +Notation Plt_lt_succ := Pos.lt_lt_succ (only parsing). +Notation Plt_irrefl := Pos.lt_irrefl (only parsing). +Notation Plt_trans := Pos.lt_trans (only parsing). +Notation Plt_ind := Pos.lt_ind (only parsing). +Notation Ple_lteq := Pos.le_lteq (only parsing). +Notation Ple_refl := Pos.le_refl (only parsing). +Notation Ple_lt_trans := Pos.le_lt_trans (only parsing). +Notation Plt_le_trans := Pos.lt_le_trans (only parsing). +Notation Ple_trans := Pos.le_trans (only parsing). +Notation Plt_succ_r := Pos.lt_succ_r (only parsing). +Notation Ple_succ_l := Pos.le_succ_l (only parsing). +Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (only parsing). +Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (only parsing). +Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (only parsing). +Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (only parsing). +Notation Pplus_lt_mono := Pos.add_lt_mono (only parsing). +Notation Pplus_le_mono_l := Pos.add_le_mono_l (only parsing). +Notation Pplus_le_mono_r := Pos.add_le_mono_r (only parsing). +Notation Pplus_le_mono := Pos.add_le_mono (only parsing). +Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (only parsing). +Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (only parsing). +Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (only parsing). +Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (only parsing). +Notation Pmult_lt_mono := Pos.mul_lt_mono (only parsing). +Notation Pmult_le_mono_l := Pos.mul_le_mono_l (only parsing). +Notation Pmult_le_mono_r := Pos.mul_le_mono_r (only parsing). +Notation Pmult_le_mono := Pos.mul_le_mono (only parsing). +Notation Plt_plus_r := Pos.lt_add_r (only parsing). +Notation Plt_not_plus_l := Pos.lt_not_add_l (only parsing). +Notation Ppow_gt_1 := Pos.pow_gt_1 (only parsing). +Notation Ppred_mask := Pos.pred_mask (only parsing). +Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (only parsing). +Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (only parsing). +Notation Pminus_succ_r := Pos.sub_succ_r (only parsing). +Notation Pminus_mask_diag := Pos.sub_mask_diag (only parsing). + +Notation Pplus_minus_eq := Pos.add_sub (only parsing). +Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (only parsing). +Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (only parsing). +Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (only parsing). +Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (only parsing). +Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (only parsing). +Notation Pminus_decr := Pos.sub_decr (only parsing). +Notation Pminus_xI_xI := Pos.sub_xI_xI (only parsing). +Notation Pplus_minus_assoc := Pos.add_sub_assoc (only parsing). +Notation Pminus_plus_distr := Pos.sub_add_distr (only parsing). +Notation Pminus_minus_distr := Pos.sub_sub_distr (only parsing). +Notation Pminus_mask_Lt := Pos.sub_mask_neg (only parsing). +Notation Pminus_Lt := Pos.sub_lt (only parsing). +Notation Pminus_Eq := Pos.sub_diag (only parsing). +Notation Psize_monotone := Pos.size_nat_monotone (only parsing). +Notation Psize_pos_gt := Pos.size_gt (only parsing). +Notation Psize_pos_le := Pos.size_le (only parsing). + +(** More complex compatibility facts, expressed as lemmas + (to preserve scopes for instance) *) + +Lemma Peqb_true_eq x y : Pos.eqb x y = true -> x=y. +Proof. apply Pos.eqb_eq. Qed. +Lemma Pcompare_eq_Gt p q : (p ?= q) = Gt <-> p > q. +Proof. reflexivity. Qed. +Lemma Pplus_one_succ_r p : Psucc p = p + 1. +Proof (eq_sym (Pos.add_1_r p)). +Lemma Pplus_one_succ_l p : Psucc p = 1 + p. +Proof (eq_sym (Pos.add_1_l p)). +Lemma Pcompare_refl p : Pcompare p p Eq = Eq. +Proof (Pos.compare_cont_refl p Eq). +Lemma Pcompare_Eq_eq : forall p q, Pcompare p q Eq = Eq -> p = q. +Proof Pos.compare_eq. +Lemma ZC4 p q : Pcompare p q Eq = CompOpp (Pcompare q p Eq). +Proof (Pos.compare_antisym q p). +Lemma Ppred_minus p : Ppred p = p - 1. +Proof (eq_sym (Pos.sub_1_r p)). + +Lemma Pminus_mask_Gt p q : + p > q -> + exists h : positive, + Pminus_mask p q = IsPos h /\ + q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred 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. +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. +Qed. + +(** Discontinued results of little interest and little/zero use + in user contributions: + + Pplus_carry_no_neutral + Pplus_carry_pred_eq_plus + Pcompare_not_Eq + Pcompare_Lt_Lt + Pcompare_Lt_eq_Lt + Pcompare_Gt_Gt + Pcompare_Gt_eq_Gt + Psucc_lt_compat + Psucc_le_compat + ZC3 + Pcompare_p_Sq + Pminus_mask_carry_diag + Pminus_mask_IsNeg + ZL10 + ZL11 + double_eq_zero_inversion + double_plus_one_zero_discr + double_plus_one_eq_one_inversion + double_eq_one_discr + + Infix "/" := Pdiv2 : positive_scope. +*) + +(** Old stuff, to remove someday *) + +Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. +Proof. + destruct r; auto. +Qed. + +(** Incompatibilities : + + - [(_ ?= _)%positive] expects no arg now, and designates [Pos.compare] + which is convertible but syntactically distinct to + [Pos.compare_cont .. .. Eq]. + + - [Pmult_nat] cannot be unfolded (unfold [Pos.iter_op] instead). + +*) diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v new file mode 100644 index 00000000..7916511a --- /dev/null +++ b/theories/PArith/BinPosDef.v @@ -0,0 +1,565 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(**********************************************************************) +(** * Binary positive numbers, operations *) +(**********************************************************************) + +(** Initial development by Pierre Crégut, CNET, Lannion, France *) + +(** The type [positive] and its constructors [xI] and [xO] and [xH] + are now defined in [BinNums.v] *) + +Require Export BinNums. + +(** Postfix notation for positive numbers, allowing to mimic + the position of bits in a big-endian representation. + For instance, we can write [1~1~0] instead of [(xO (xI xH))] + for the number 6 (which is 110 in binary notation). +*) + +Notation "p ~ 1" := (xI p) + (at level 7, left associativity, format "p '~' '1'") : positive_scope. +Notation "p ~ 0" := (xO p) + (at level 7, left associativity, format "p '~' '0'") : positive_scope. + +Local Open Scope positive_scope. +Local Unset Boolean Equality Schemes. +Local Unset Case Analysis Schemes. + +Module Pos. + +Definition t := positive. + +(** * Operations over positive numbers *) + +(** ** Successor *) + +Fixpoint succ x := + match x with + | p~1 => (succ p)~0 + | p~0 => p~1 + | 1 => 1~0 + end. + +(** ** Addition *) + +Fixpoint add x y := + match x, y with + | p~1, q~1 => (add_carry p q)~0 + | p~1, q~0 => (add p q)~1 + | p~1, 1 => (succ p)~0 + | p~0, q~1 => (add p q)~1 + | p~0, q~0 => (add p q)~0 + | p~0, 1 => p~1 + | 1, q~1 => (succ q)~0 + | 1, q~0 => q~1 + | 1, 1 => 1~0 + end + +with add_carry x y := + match x, y with + | p~1, q~1 => (add_carry p q)~1 + | p~1, q~0 => (add_carry p q)~0 + | p~1, 1 => (succ p)~1 + | p~0, q~1 => (add_carry p q)~0 + | p~0, q~0 => (add p q)~1 + | p~0, 1 => (succ p)~0 + | 1, q~1 => (succ q)~1 + | 1, q~0 => (succ q)~0 + | 1, 1 => 1~1 + end. + +Infix "+" := add : positive_scope. + +(** ** Operation [x -> 2*x-1] *) + +Fixpoint pred_double x := + match x with + | p~1 => p~0~1 + | p~0 => (pred_double p)~1 + | 1 => 1 + end. + +(** ** Predecessor *) + +Definition pred x := + match x with + | p~1 => p~0 + | p~0 => pred_double p + | 1 => 1 + end. + +(** ** The predecessor of a positive number can be seen as a [N] *) + +Definition pred_N x := + match x with + | p~1 => Npos (p~0) + | p~0 => Npos (pred_double p) + | 1 => N0 + end. + +(** ** An auxiliary type for subtraction *) + +Inductive mask : Set := +| IsNul : mask +| IsPos : positive -> mask +| IsNeg : mask. + +(** ** Operation [x -> 2*x+1] *) + +Definition succ_double_mask (x:mask) : mask := + match x with + | IsNul => IsPos 1 + | IsNeg => IsNeg + | IsPos p => IsPos p~1 + end. + +(** ** Operation [x -> 2*x] *) + +Definition double_mask (x:mask) : mask := + match x with + | IsNul => IsNul + | IsNeg => IsNeg + | IsPos p => IsPos p~0 + end. + +(** ** Operation [x -> 2*x-2] *) + +Definition double_pred_mask x : mask := + match x with + | p~1 => IsPos p~0~0 + | p~0 => IsPos (pred_double p)~0 + | 1 => IsNul + end. + +(** ** 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. + +(** ** Subtraction, result as a mask *) + +Fixpoint sub_mask (x y:positive) {struct y} : mask := + match x, y with + | p~1, q~1 => double_mask (sub_mask p q) + | p~1, q~0 => succ_double_mask (sub_mask p q) + | p~1, 1 => IsPos p~0 + | p~0, q~1 => succ_double_mask (sub_mask_carry p q) + | p~0, q~0 => double_mask (sub_mask p q) + | p~0, 1 => IsPos (pred_double p) + | 1, 1 => IsNul + | 1, _ => IsNeg + end + +with sub_mask_carry (x y:positive) {struct y} : mask := + match x, y with + | p~1, q~1 => succ_double_mask (sub_mask_carry p q) + | p~1, q~0 => double_mask (sub_mask p q) + | p~1, 1 => IsPos (pred_double p) + | p~0, q~1 => double_mask (sub_mask_carry p q) + | p~0, q~0 => succ_double_mask (sub_mask_carry p q) + | p~0, 1 => double_pred_mask p + | 1, _ => IsNeg + end. + +(** ** Subtraction, result as a positive, returning 1 if [x<=y] *) + +Definition sub x y := + match sub_mask x y with + | IsPos z => z + | _ => 1 + end. + +Infix "-" := sub : positive_scope. + +(** ** Multiplication *) + +Fixpoint mul x y := + match x with + | p~1 => y + (mul p y)~0 + | p~0 => (mul p y)~0 + | 1 => y + end. + +Infix "*" := mul : positive_scope. + +(** ** Iteration over a positive number *) + +Fixpoint iter (n:positive) {A} (f:A -> A) (x:A) : A := + match n with + | xH => f x + | xO n' => iter n' f (iter n' f x) + | xI n' => f (iter n' f (iter n' f x)) + end. + +(** ** Power *) + +Definition pow (x y:positive) := iter y (mul x) 1. + +Infix "^" := pow : positive_scope. + +(** ** Square *) + +Fixpoint square p := + match p with + | p~1 => (square p + p)~0~1 + | p~0 => (square p)~0~0 + | 1 => 1 + end. + +(** ** Division by 2 rounded below but for 1 *) + +Definition div2 p := + match p with + | 1 => 1 + | p~0 => p + | p~1 => p + end. + +(** Division by 2 rounded up *) + +Definition div2_up p := + match p with + | 1 => 1 + | p~0 => p + | p~1 => succ p + end. + +(** ** 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. + +(** Same, with positive output *) + +Fixpoint size p := + match p with + | 1 => 1 + | p~1 => succ (size p) + | p~0 => succ (size p) + end. + +(** ** Comparison on binary positive numbers *) + +Fixpoint compare_cont (x y:positive) (r:comparison) {struct y} : comparison := + match x, y with + | p~1, q~1 => compare_cont p q r + | p~1, q~0 => compare_cont p q Gt + | p~1, 1 => Gt + | p~0, q~1 => compare_cont p q Lt + | p~0, q~0 => compare_cont p q r + | p~0, 1 => Gt + | 1, q~1 => Lt + | 1, q~0 => Lt + | 1, 1 => r + end. + +Definition compare x y := compare_cont x y Eq. + +Infix "?=" := compare (at level 70, no associativity) : positive_scope. + +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. + +(** ** Boolean equality and comparisons *) + +(** Nota: this [eqb] is not convertible with the generated [positive_beq], due + to a different guard argument. We keep this version for compatibility. *) + +Fixpoint eqb p q {struct q} := + match p, q with + | p~1, q~1 => eqb p q + | p~0, q~0 => eqb p q + | 1, 1 => true + | _, _ => false + end. + +Definition leb x y := + match x ?= y with Gt => false | _ => true 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 "<?" := ltb (at level 70, no associativity) : positive_scope. + +(** ** A Square Root function for positive numbers *) + +(** We procede by blocks of two digits : if p is written qbb' + then sqrt(p) will be sqrt(q)~0 or sqrt(q)~1. + For deciding easily in which case we are, we store the remainder + (as a mask, since it can be null). + Instead of copy-pasting the following code four times, we + factorize as an auxiliary function, with f and g being either + xO or xI depending of the initial digits. + NB: (sub_mask (g (f 1)) 4) is a hack, morally it's g (f 0). +*) + +Definition sqrtrem_step (f g:positive->positive) p := + match p with + | (s, IsPos r) => + let s' := s~0~1 in + let r' := g (f r) in + if s' <=? r' then (s~1, sub_mask r' s') + else (s~0, IsPos r') + | (s,_) => (s~0, sub_mask (g (f 1)) 4) + end. + +Fixpoint sqrtrem p : positive * mask := + match p with + | 1 => (1,IsNul) + | 2 => (1,IsPos 1) + | 3 => (1,IsPos 2) + | p~0~0 => sqrtrem_step xO xO (sqrtrem p) + | p~0~1 => sqrtrem_step xO xI (sqrtrem p) + | p~1~0 => sqrtrem_step xI xO (sqrtrem p) + | p~1~1 => sqrtrem_step xI xI (sqrtrem p) + end. + +Definition sqrt p := fst (sqrtrem p). + + +(** ** Greatest Common Divisor *) + +Definition divide p q := exists r, q = r*p. +Notation "( p | q )" := (divide p q) (at level 0) : positive_scope. + +(** Instead of the Euclid algorithm, we use here the Stein binary + algorithm, which is faster for this representation. This algorithm + is almost structural, but in the last cases we do some recursive + calls on subtraction, hence the need for a counter. +*) + +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 *) + +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. + +(** Local copies of the not-yet-available [N.double] and [N.succ_double] *) + +Definition Nsucc_double x := + match x with + | N0 => Npos 1 + | Npos p => Npos p~1 + end. + +Definition Ndouble n := + match n with + | N0 => N0 + | Npos p => Npos p~0 + end. + +(** Operation over bits. *) + +(** Logical [or] *) + +Fixpoint lor (p q : positive) : positive := + match p, q with + | 1, q~0 => q~1 + | 1, _ => q + | p~0, 1 => p~1 + | _, 1 => p + | p~0, q~0 => (lor p q)~0 + | p~0, q~1 => (lor p q)~1 + | p~1, q~0 => (lor p q)~1 + | p~1, q~1 => (lor p q)~1 + end. + +(** Logical [and] *) + +Fixpoint land (p q : positive) : N := + match p, q with + | 1, q~0 => N0 + | 1, _ => Npos 1 + | p~0, 1 => N0 + | _, 1 => Npos 1 + | p~0, q~0 => Ndouble (land p q) + | p~0, q~1 => Ndouble (land p q) + | p~1, q~0 => Ndouble (land p q) + | p~1, q~1 => Nsucc_double (land p q) + end. + +(** Logical [diff] *) + +Fixpoint ldiff (p q:positive) : N := + match p, q with + | 1, q~0 => Npos 1 + | 1, _ => N0 + | _~0, 1 => Npos p + | p~1, 1 => Npos (p~0) + | p~0, q~0 => Ndouble (ldiff p q) + | p~0, q~1 => Ndouble (ldiff p q) + | p~1, q~1 => Ndouble (ldiff p q) + | p~1, q~0 => Nsucc_double (ldiff p q) + end. + +(** [xor] *) + +Fixpoint lxor (p q:positive) : N := + match p, q with + | 1, 1 => N0 + | 1, q~0 => Npos (q~1) + | 1, q~1 => Npos (q~0) + | p~0, 1 => Npos (p~1) + | p~0, q~0 => Ndouble (lxor p q) + | p~0, q~1 => Nsucc_double (lxor p q) + | p~1, 1 => Npos (p~0) + | p~1, q~0 => Nsucc_double (lxor p q) + | p~1, q~1 => Ndouble (lxor p q) + end. + +(** Shifts. NB: right shift of 1 stays at 1. *) + +Definition shiftl_nat (p:positive)(n:nat) := nat_iter n xO p. +Definition shiftr_nat (p:positive)(n:nat) := nat_iter n div2 p. + +Definition shiftl (p:positive)(n:N) := + match n with + | N0 => p + | Npos n => iter n xO p + end. + +Definition shiftr (p:positive)(n:N) := + match n with + | N0 => p + | Npos n => iter n div2 p + 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 + | 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 binary positive numbers to Peano natural numbers *) + +Definition iter_op {A}(op:A->A->A) := + fix iter (p:positive)(a:A) : A := + match p with + | 1 => a + | p~0 => iter p (op a a) + | p~1 => op a (iter p (op a a)) + end. + +Definition to_nat (x:positive) : nat := iter_op plus x (S O). + +(** ** 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. + +(* Another version that converts [n] into [n+1] *) + +Fixpoint of_succ_nat (n:nat) : positive := + match n with + | O => 1 + | S x => succ (of_succ_nat x) + end. + +End Pos.
\ No newline at end of file diff --git a/theories/PArith/PArith.v b/theories/PArith/PArith.v new file mode 100644 index 00000000..26b8265b --- /dev/null +++ b/theories/PArith/PArith.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Library for positive natural numbers *) + +Require Export BinNums BinPos Pnat POrderedType. diff --git a/theories/NArith/POrderedType.v b/theories/PArith/POrderedType.v index 0ff03c31..de7b2b82 100644 --- a/theories/NArith/POrderedType.v +++ b/theories/PArith/POrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,39 +12,15 @@ Local Open Scope positive_scope. (** * DecidableType structure for [positive] numbers *) -Module Positive_as_UBE <: UsualBoolEq. - Definition t := positive. - Definition eq := @eq positive. - Definition eqb := Peqb. - Definition eqb_eq := Peqb_eq. -End Positive_as_UBE. - -Module Positive_as_DT <: UsualDecidableTypeFull - := Make_UDTF Positive_as_UBE. +Module Positive_as_DT <: UsualDecidableTypeFull := Pos. (** Note that the last module fulfills by subtyping many other interfaces, such as [DecidableType] or [EqualityType]. *) - (** * OrderedType structure for [positive] numbers *) -Module Positive_as_OT <: OrderedTypeFull. - Include Positive_as_DT. - Definition lt := Plt. - Definition le := Ple. - Definition compare p q := Pcompare p q Eq. - - Instance lt_strorder : StrictOrder Plt. - Proof. split; [ exact Plt_irrefl | exact Plt_trans ]. Qed. - - Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Plt. - Proof. repeat red; intros; subst; auto. Qed. - - Definition le_lteq := Ple_lteq. - Definition compare_spec := Pcompare_spec. - -End Positive_as_OT. +Module Positive_as_OT <: OrderedTypeFull := Pos. (** Note that [Positive_as_OT] can also be seen as a [UsualOrderedType] and a [OrderedType] (and also as a [DecidableType]). *) diff --git a/theories/PArith/Pnat.v b/theories/PArith/Pnat.v new file mode 100644 index 00000000..f9df70bd --- /dev/null +++ b/theories/PArith/Pnat.v @@ -0,0 +1,483 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinPos Le Lt Gt Plus Mult Minus Compare_dec. + +(** Properties of the injection from binary positive numbers + to Peano natural numbers *) + +(** Original development by Pierre Crégut, CNET, Lannion, France *) + +Local Open Scope positive_scope. +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 plus_assoc. +Qed. + +Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q. +Proof. + revert q. induction p using Pind; 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 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 : forall p, exists n, to_nat p = S n. +Proof. + induction p 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,->). auto with arith. +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 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) = nat_compare (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_S. + symmetry. apply nat_compare_lt, 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, 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. +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. +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. +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. +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 plus_reg_l with (to_nat q); rewrite le_plus_minus_r. + now rewrite <- inj_add, add_comm, sub_add. + now apply lt_le_weak, inj_lt. +Qed. + +Theorem inj_sub_max p q : + to_nat (p - q) = Peano.max 1 (to_nat p - to_nat q). +Proof. + destruct (ltb_spec q p). + rewrite <- inj_sub by trivial. + now destruct (is_succ (p - q)) as (m,->). + rewrite sub_le by trivial. + replace (to_nat p - to_nat q) with 0; trivial. + apply le_n_0_eq. + rewrite <- (minus_diag (to_nat p)). + now apply minus_le_compat_l, inj_le. +Qed. + +Theorem inj_pred p : (1 < p)%positive -> + to_nat (pred p) = Peano.pred (to_nat p). +Proof. + intros H. now rewrite <- Pos.sub_1_r, inj_sub, pred_of_minus. +Qed. + +Theorem inj_pred_max p : + to_nat (pred p) = Peano.max 1 (Peano.pred (to_nat p)). +Proof. + rewrite <- Pos.sub_1_r, pred_of_minus. apply inj_sub_max. +Qed. + +(** [Pos.to_nat] and other operations *) + +Lemma inj_min p q : + to_nat (min p q) = Peano.min (to_nat p) (to_nat q). +Proof. + unfold min. rewrite inj_compare. + case nat_compare_spec; intros H; symmetry. + apply Peano.min_l. now rewrite H. + now apply Peano.min_l, lt_le_weak. + now apply Peano.min_r, lt_le_weak. +Qed. + +Lemma inj_max p q : + to_nat (max p q) = Peano.max (to_nat p) (to_nat q). +Proof. + unfold max. rewrite inj_compare. + case nat_compare_spec; intros H; symmetry. + apply Peano.max_r. now rewrite H. + now apply Peano.max_r, lt_le_weak. + now apply Peano.max_l, lt_le_weak. +Qed. + +Theorem inj_iter : + forall p {A} (f:A->A) (x:A), + Pos.iter p f x = nat_iter (to_nat p) f x. +Proof. + induction p using peano_ind. trivial. + intros. rewrite inj_succ, iter_succ. simpl. now f_equal. +Qed. + +End Pos2Nat. + +Module Nat2Pos. + +(** [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. 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_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 mult_is_O in H. destruct H. now elim Hn. now elim Hm. +Qed. + +Lemma inj_compare (n m : nat) : n<>0 -> m<>0 -> + nat_compare n m = (Pos.of_nat n ?= Pos.of_nat m). +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 min_l || apply min_r. + rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak. +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 max_l || apply max_r. + rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak. +Qed. + +End Nat2Pos. + +(**********************************************************************) +(** Properties of the shifted injection from Peano natural numbers + to binary positive numbers *) + +Module Pos2SuccNat. + +(** 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. + +(** 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. + +End Pos2SuccNat. + +Module SuccNat2Pos. + +(** 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 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 *) + +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. + +(** 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. + +(** 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_compare n m : + nat_compare n m = (Pos.of_succ_nat n ?= Pos.of_succ_nat m). +Proof. +rewrite Pos2Nat.inj_compare, !id_succ; trivial. +Qed. + +(** 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] *) + +End SuccNat2Pos. + +(** For compatibility, old names and old-style lemmas *) + +Notation Psucc_S := Pos2Nat.inj_succ (only parsing). +Notation Pplus_plus := Pos2Nat.inj_add (only parsing). +Notation Pmult_mult := Pos2Nat.inj_mul (only parsing). +Notation Pcompare_nat_compare := Pos2Nat.inj_compare (only parsing). +Notation nat_of_P_xH := Pos2Nat.inj_1 (only parsing). +Notation nat_of_P_xO := Pos2Nat.inj_xO (only parsing). +Notation nat_of_P_xI := Pos2Nat.inj_xI (only parsing). +Notation nat_of_P_is_S := Pos2Nat.is_succ (only parsing). +Notation nat_of_P_pos := Pos2Nat.is_pos (only parsing). +Notation nat_of_P_inj_iff := Pos2Nat.inj_iff (only parsing). +Notation nat_of_P_inj := Pos2Nat.inj (only parsing). +Notation Plt_lt := Pos2Nat.inj_lt (only parsing). +Notation Pgt_gt := Pos2Nat.inj_gt (only parsing). +Notation Ple_le := Pos2Nat.inj_le (only parsing). +Notation Pge_ge := Pos2Nat.inj_ge (only parsing). +Notation Pminus_minus := Pos2Nat.inj_sub (only parsing). +Notation iter_nat_of_P := @Pos2Nat.inj_iter (only parsing). + +Notation nat_of_P_of_succ_nat := SuccNat2Pos.id_succ (only parsing). +Notation P_of_succ_nat_of_P := Pos2SuccNat.id_succ (only parsing). + +Notation nat_of_P_succ_morphism := Pos2Nat.inj_succ (only parsing). +Notation nat_of_P_plus_morphism := Pos2Nat.inj_add (only parsing). +Notation nat_of_P_mult_morphism := Pos2Nat.inj_mul (only parsing). +Notation nat_of_P_compare_morphism := Pos2Nat.inj_compare (only parsing). +Notation lt_O_nat_of_P := Pos2Nat.is_pos (only parsing). +Notation ZL4 := Pos2Nat.is_succ (only parsing). +Notation nat_of_P_o_P_of_succ_nat_eq_succ := SuccNat2Pos.id_succ (only parsing). +Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (only parsing). +Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (only parsing). + +Lemma nat_of_P_minus_morphism p q : + Pcompare p q Eq = Gt -> Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q. +Proof (fun H => Pos2Nat.inj_sub p q (ZC1 _ _ H)). + +Lemma nat_of_P_lt_Lt_compare_morphism p q : + Pcompare p q Eq = Lt -> Pos.to_nat p < Pos.to_nat q. +Proof (proj1 (Pos2Nat.inj_lt p q)). + +Lemma nat_of_P_gt_Gt_compare_morphism p q : + Pcompare p q Eq = Gt -> Pos.to_nat p > Pos.to_nat q. +Proof (proj1 (Pos2Nat.inj_gt p q)). + +Lemma nat_of_P_lt_Lt_compare_complement_morphism p q : + Pos.to_nat p < Pos.to_nat q -> Pcompare p q Eq = Lt. +Proof (proj2 (Pos2Nat.inj_lt p q)). + +Definition nat_of_P_gt_Gt_compare_complement_morphism p q : + Pos.to_nat p > Pos.to_nat q -> Pcompare p q Eq = Gt. +Proof (proj2 (Pos2Nat.inj_gt p q)). + +(** Old intermediate results about [Pmult_nat] *) + +Section ObsoletePmultNat. + +Lemma Pmult_nat_mult : forall p n, + Pmult_nat p n = Pos.to_nat p * n. +Proof. + induction p; intros n; unfold Pos.to_nat; simpl. + f_equal. rewrite 2 IHp. rewrite <- mult_assoc. + f_equal. simpl. now rewrite <- plus_n_O. + rewrite 2 IHp. rewrite <- mult_assoc. + f_equal. simpl. now rewrite <- plus_n_O. + simpl. now rewrite <- plus_n_O. +Qed. + +Lemma Pmult_nat_succ_morphism : + forall p n, Pmult_nat (Psucc 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 mult_plus_distr_r. +Qed. + +Theorem Pmult_nat_plus_carry_morphism : + forall p q n, Pmult_nat (Pplus_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 mult_plus_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, mult_comm. simpl. now rewrite <- plus_n_O. +Qed. + +Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. +Proof. + intros. rewrite Pmult_nat_mult. + apply le_trans with (1*n). now rewrite mult_1_l. + apply mult_le_compat_r. apply Pos2Nat.is_pos. +Qed. + +End ObsoletePmultNat. diff --git a/theories/PArith/intro.tex b/theories/PArith/intro.tex new file mode 100644 index 00000000..ffce881e --- /dev/null +++ b/theories/PArith/intro.tex @@ -0,0 +1,4 @@ +\section{Binary positive integers : PArith}\label{PArith} + +Here are defined various arithmetical notions and their properties, +similar to those of {\tt Arith}. diff --git a/theories/PArith/vo.itarget b/theories/PArith/vo.itarget new file mode 100644 index 00000000..73044e2c --- /dev/null +++ b/theories/PArith/vo.itarget @@ -0,0 +1,5 @@ +BinPosDef.vo +BinPos.vo +Pnat.vo +POrderedType.vo +PArith.vo
\ No newline at end of file diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 37c4d94d..7cef5c5a 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -1,13 +1,11 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Basics.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Standard functions and combinators. Proofs about them require functional extensionality and can be found @@ -19,7 +17,7 @@ (** The polymorphic identity function is defined in [Datatypes]. *) -Implicit Arguments id [[A]]. +Arguments id {A} x. (** Function composition. *) @@ -55,5 +53,5 @@ Definition apply {A B} (f : A -> B) (x : A) := f x. (** Curryfication of [prod] is defined in [Logic.Datatypes]. *) -Implicit Arguments prod_curry [[A] [B] [C]]. -Implicit Arguments prod_uncurry [[A] [B] [C]]. +Arguments prod_curry {A B C} f p. +Arguments prod_uncurry {A B C} f x y. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index f446b455..81316ded 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -1,13 +1,11 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Combinators.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** * Proofs about standard combinators, exports functional extensionality. Author: Matthieu Sozeau diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index f63aad43..06ff7cd1 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Equality.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Tactics related to (dependent) equality and proof irrelevance. *) Require Export ProofIrrelevance. @@ -15,9 +13,6 @@ Require Export JMeq. Require Import Coq.Program.Tactics. -Local Notation "'Π' x .. y , P" := (forall x, .. (forall y, P) ..) - (at level 200, x binder, y binder, right associativity) : type_scope. - Ltac is_ground_goal := match goal with |- ?T => is_ground T @@ -33,18 +28,12 @@ Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. Definition block {A : Type} (a : A) := a. Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. -Ltac unblock_goal := unfold block at 1. -Ltac unblock_all := unfold block in *. +Ltac unblock_goal := cbv beta delta [block]. (** Notation for heterogenous equality. *) Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). -(** Notation for the single element of [x = x] and [x ~= x]. *) - -Implicit Arguments eq_refl [[A] [x]] [A]. -Implicit Arguments JMeq_refl [[A] [x]] [A]. - (** Do something on an heterogeneous equality appearing in the context. *) Ltac on_JMeq tac := @@ -177,15 +166,15 @@ Hint Rewrite <- eq_rect_eq : refl_id. [coerce_* t eq_refl = t]. *) Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl. -Proof. intros. apply proof_irrelevance. Qed. +Proof. apply proof_irrelevance. Qed. -Lemma UIP_refl_refl : Π A (x : A), +Lemma UIP_refl_refl A (x : A) : Eqdep.EqdepTheory.UIP_refl A x eq_refl = eq_refl. -Proof. intros. apply UIP_refl. Qed. +Proof. apply UIP_refl. Qed. -Lemma inj_pairT2_refl : Π A (x : A) (P : A -> Type) (p : P x), +Lemma inj_pairT2_refl A (x : A) (P : A -> Type) (p : P x) : Eqdep.EqdepTheory.inj_pairT2 A P x p p eq_refl = eq_refl. -Proof. intros. apply UIP_refl. Qed. +Proof. apply UIP_refl. Qed. Hint Rewrite @JMeq_eq_refl @UIP_refl_refl @inj_pairT2_refl : refl_id. @@ -225,7 +214,7 @@ Ltac simplify_eqs := Ltac simplify_IH_hyps := repeat match goal with - | [ hyp : context [ block _ ] |- _ ] => specialize_eqs hyp ; unfold block in hyp + | [ hyp : _ |- _ ] => specialize_eqs hyp end. (** We split substitution tactics in the two directions depending on which @@ -285,27 +274,31 @@ Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. (** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) -Lemma solution_left : Π A (B : A -> Type) (t : A), B t -> (Π x, x = t -> B x). -Proof. intros; subst. apply X. Defined. +Lemma solution_left A (B : A -> Type) (t : A) : + B t -> (forall x, x = t -> B x). +Proof. intros; subst; assumption. Defined. -Lemma solution_right : Π A (B : A -> Type) (t : A), B t -> (Π x, t = x -> B x). -Proof. intros; subst; apply X. Defined. +Lemma solution_right A (B : A -> Type) (t : A) : + B t -> (forall x, t = x -> B x). +Proof. intros; subst; assumption. Defined. -Lemma deletion : Π A B (t : A), B -> (t = t -> B). +Lemma deletion A B (t : A) : B -> (t = t -> B). Proof. intros; assumption. Defined. -Lemma simplification_heq : Π A B (x y : A), (x = y -> B) -> (JMeq x y -> B). -Proof. intros; apply X; apply (JMeq_eq H). Defined. +Lemma simplification_heq A B (x y : A) : + (x = y -> B) -> (JMeq x y -> B). +Proof. intros H J; apply H; apply (JMeq_eq J). Defined. -Lemma simplification_existT2 : Π A (P : A -> Type) B (p : A) (x y : P p), +Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) : (x = y -> B) -> (existT P p x = existT P p y -> B). -Proof. intros. apply X. apply inj_pair2. exact H. Defined. +Proof. intros H E. apply H. apply inj_pair2. assumption. Defined. -Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P q), +Lemma simplification_existT1 A (P : A -> Type) B (p q : A) (x : P p) (y : P q) : (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B). -Proof. intros. injection H. intros ; auto. Defined. - -Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B eq_refl -> (Π p : x = x, B p). +Proof. injection 2. auto. Defined. + +Lemma simplification_K A (x : A) (B : x = x -> Type) : + B eq_refl -> (forall p : x = x, B p). Proof. intros. rewrite (UIP_refl A). assumption. Defined. (** This hint database and the following tactic can be used with [autounfold] to @@ -320,35 +313,20 @@ Hint Unfold solution_left solution_right deletion simplification_heq constructor forms). Compare with the lemma 16 of the paper. We don't have a [noCycle] procedure yet. *) -Ltac block_equality id := - match type of id with - | @eq ?A ?t ?u => change (block (@eq A t u)) in id - | _ => idtac - end. - -Ltac revert_blocking_until id := - Tactics.on_last_hyp ltac:(fun id' => - match id' with - | id => idtac - | _ => block_equality id' ; revert id' ; revert_blocking_until id - end). - Ltac simplify_one_dep_elim_term c := match c with | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) - | eq (existT _ ?p _) (existT _ ?q _) -> _ => + | eq (existT _ _ _) (existT _ _ _) -> _ => refine (simplification_existT2 _ _ _ _ _ _ _) || - match goal with - | H : p = q |- _ => intro - | _ => refine (simplification_existT1 _ _ _ _ _ _ _ _) - end + refine (simplification_existT1 _ _ _ _ _ _ _ _) | ?x = ?y -> _ => (* variables case *) + (unfold x) || (unfold y) || (let hyp := fresh in intros hyp ; - move hyp before x ; revert_blocking_until hyp ; generalize dependent x ; + move hyp before x ; revert_until hyp ; generalize dependent x ; refine (solution_left _ _ _ _)(* ; intros until 0 *)) || (let hyp := fresh in intros hyp ; - move hyp before y ; revert_blocking_until hyp ; generalize dependent y ; + move hyp before y ; revert_until hyp ; generalize dependent y ; refine (solution_right _ _ _ _)(* ; intros until 0 *)) | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H) | ?t = ?u -> _ => let hyp := fresh in @@ -406,18 +384,18 @@ Tactic Notation "intro_block_id" ident(H) := (is_introduced H ; block_goal ; revert_until H) || (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). -Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_all. +Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. Ltac do_intros H := (try intros until H) ; (intro_block_id H || intro_block H). -Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; block_goal ; tac H ; unblock_goal. +Ltac do_depelim_nosimpl tac H := do_intros H ; generalize_eqs H ; tac H. Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim. Ltac do_depind tac H := - do_intros H ; generalize_eqs_vars H ; block_goal ; tac H ; - unblock_goal ; simplify_dep_elim ; simplify_IH_hyps ; unblock_all. + (try intros until H) ; intro_block H ; + generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. (** To dependent elimination on some hyp. *) @@ -433,26 +411,26 @@ Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id. (** A variant where generalized variables should be given by the user. *) -Ltac do_depelim' tac H := - (try intros until H) ; block_goal ; generalize_eqs H ; block_goal ; tac H ; unblock_goal ; - simplify_dep_elim ; simplify_IH_hyps ; unblock_all. +Ltac do_depelim' rev tac H := + (try intros until H) ; block_goal ; rev H ; generalize_eqs H ; tac H ; simplify_dep_elim ; + simplify_IH_hyps ; unblock_goal. (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. By default, we don't try to generalize the hyp by its variable indices. *) Tactic Notation "dependent" "destruction" ident(H) := - do_depelim' ltac:(fun hyp => do_case hyp) H. + do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := - do_depelim' ltac:(fun hyp => destruct hyp using c) H. + do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => destruct hyp using c) H. (** This tactic also generalizes the goal by the given variables before the elimination. *) Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := - do_depelim' ltac:(fun hyp => revert l ; do_case hyp) H. + do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depelim' ltac:(fun hyp => revert l ; destruct hyp using c) H. + do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before @@ -467,7 +445,7 @@ Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := - do_depelim' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. + do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depelim' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. + do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H. diff --git a/theories/Program/Program.v b/theories/Program/Program.v index 2b6dd864..14a7ffca 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -1,16 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Program.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Coq.Program.Utils. Require Export Coq.Program.Wf. Require Export Coq.Program.Equality. Require Export Coq.Program.Subset. Require Export Coq.Program.Basics. Require Export Coq.Program.Combinators. -Require Export Coq.Program.Syntax.
\ No newline at end of file +Require Export Coq.Program.Syntax. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index d0a76d3f..ca4002d7 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Subset.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Tactics related to subsets and proof irrelevance. *) Require Import Coq.Program.Utils. diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 582bc461..61d389ed 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Syntax.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Custom notations and implicits for Coq prelude definitions. Author: Matthieu Sozeau @@ -20,48 +18,23 @@ Notation " () " := tt. (** Set maximally inserted implicit arguments for standard definitions. *) -Implicit Arguments Some [[A]]. -Implicit Arguments None [[A]]. - -Implicit Arguments inl [[A] [B]] [A]. -Implicit Arguments inr [[A] [B]] [B]. - -Implicit Arguments left [[A] [B]] [A]. -Implicit Arguments right [[A] [B]] [B]. - -Implicit Arguments pair [[A] [B]]. -Implicit Arguments fst [[A] [B]]. -Implicit Arguments snd [[A] [B]]. - -Require Import Coq.Lists.List. +Arguments Some {A} _. +Arguments None {A}. -Implicit Arguments nil [[A]]. -Implicit Arguments cons [[A]]. +Arguments pair {A B} _ _. +Arguments fst {A B} _. +Arguments snd {A B} _. -(** Standard notations for lists. *) +Arguments nil {A}. +Arguments cons {A} _ _. -Notation " [ ] " := nil : list_scope. -Notation " [ x ] " := (cons x nil) : list_scope. -Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. - -(** Implicit arguments for vectors. *) +Require List. +Export List.ListNotations. Require Import Bvector. -Implicit Arguments Vnil [[A]] []. -Implicit Arguments Vcons [[A] [n]] []. - (** Treating n-ary exists *) -Notation " 'exists' x y , p" := (ex (fun x => (ex (fun y => p)))) - (at level 200, x ident, y ident, right associativity) : type_scope. - -Notation " 'exists' x y z , p" := (ex (fun x => (ex (fun y => (ex (fun z => p)))))) - (at level 200, x ident, y ident, z ident, right associativity) : type_scope. - -Notation " 'exists' x y z w , p" := (ex (fun x => (ex (fun y => (ex (fun z => (ex (fun w => p)))))))) - (at level 200, x ident, y ident, z ident, w ident, right associativity) : type_scope. - Tactic Notation "exists" constr(x) := exists x. Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y. Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index f62ff703..9694e3fd 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This module implements various tactics used to simplify the goals produced by Program, which are also generally useful. *) @@ -61,12 +59,20 @@ Ltac destruct_pairs := repeat (destruct_one_pair). Ltac destruct_one_ex := let tac H := let ph := fresh "H" in (destruct H as [H ph]) in + let tac2 H := let ph := fresh "H" in let ph' := fresh "H" in + (destruct H as [H ph ph']) + in let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in + let tacT2 H := let ph := fresh "X" in let ph' := fresh "X" in + (destruct H as [H ph ph']) + in match goal with | [H : (ex _) |- _] => tac H | [H : (sig ?P) |- _ ] => tac H | [H : (sigT ?P) |- _ ] => tacT H - | [H : (ex2 _) |- _] => tac H + | [H : (ex2 _ _) |- _] => tac2 H + | [H : (sig2 ?P _) |- _ ] => tac2 H + | [H : (sigT2 ?P _) |- _ ] => tacT2 H end. (** Repeateadly destruct existentials. *) @@ -304,18 +310,22 @@ Ltac refine_hyp c := possibly using [program_simplify] to use standard goal-cleaning tactics. *) Ltac program_simplify := - simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *); +simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in * ); subst*; autoinjections ; try discriminates ; try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). -(** We only try to solve proposition goals automatically. *) +(** Restrict automation to propositional obligations. *) -Ltac program_solve := +Ltac program_solve_wf := match goal with | |- well_founded _ => auto with * | |- ?T => match type of T with Prop => auto end end. -Ltac program_simpl := program_simplify ; try program_solve. +Create HintDb program discriminated. + +Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; try program_solve_wf. Obligation Tactic := program_simpl. + +Definition obligation (A : Type) {a : A} := a.
\ No newline at end of file diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index 1e57a74b..1885decf 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Utils.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Various syntaxic shortands that are useful with [Program]. *) Require Export Coq.Program.Tactics. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 3afaf5e8..a823aedd 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Wf.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Reformulation of the Wf module using subsets where possible, providing the support for [Program]'s treatment of well-founded definitions. *) diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index 2255cd41..fe8d639c 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export QArith_base. Require Export Qring. Require Export Qreduction. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 18b8823d..94ea4906 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith_base.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export ZArith. Require Export ZArithRing. Require Export Morphisms Setoid Bool. @@ -20,7 +18,7 @@ Record Q : Set := Qmake {Qnum : Z; Qden : positive}. Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. -Arguments Scope Qmake [Z_scope positive_scope]. +Arguments Qmake _%Z _%positive. Open Scope Q_scope. Ltac simpl_mult := repeat rewrite Zpos_mult_morphism. @@ -29,7 +27,7 @@ Ltac simpl_mult := repeat rewrite Zpos_mult_morphism. Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope. Definition inject_Z (x : Z) := Qmake x 1. -Arguments Scope inject_Z [Z_scope]. +Arguments inject_Z x%Z. Notation QDen p := (Zpos (Qden p)). Notation " 0 " := (0#1) : Q_scope. @@ -48,6 +46,13 @@ Notation "x > y" := (Qlt y x)(only parsing) : Q_scope. Notation "x >= y" := (Qle y x)(only parsing) : Q_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. +(** injection from Z is injective. *) + +Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. +Proof. + unfold Qeq. simpl. omega. +Qed. + (** Another approach : using Qcompare for defining order relations. *) Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z. @@ -92,7 +97,7 @@ Proof. unfold "?=". intros. apply Zcompare_antisym. Qed. -Lemma Qcompare_spec : forall x y, CompSpec Qeq Qlt x y (x ?= y). +Lemma Qcompare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (x ?= y). Proof. intros. destruct (x ?= y) as [ ]_eqn:H; constructor; auto. @@ -387,6 +392,26 @@ Proof. red; simpl; intro; ring. Qed. +(** Injectivity of addition (uses theory about Qopp above): *) + +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. +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. +Qed. + (** * Properties of [Qmult] *) @@ -462,6 +487,21 @@ Proof. rewrite <- H0; ring. Qed. + +(** * inject_Z is a ring homomorphism: *) + +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. +Qed. + +Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y. +Proof. reflexivity. Qed. + +Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x. +Proof. reflexivity. Qed. + + (** * Inverse and division. *) Lemma Qinv_involutive : forall q, (/ / q) == q. @@ -500,6 +540,25 @@ Proof. apply Qdiv_mult_l; auto. Qed. +(** Injectivity of Qmult (requires theory about Qinv above): *) + +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. +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. +Qed. + (** * Properties of order upon Q. *) Lemma Qle_refl : forall x, x<=x. @@ -539,6 +598,19 @@ Proof. unfold Qlt, Qeq; auto with zarith. Qed. +Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). +Proof. + unfold Qle. intros. simpl. + do 2 rewrite Zmult_1_r. reflexivity. +Qed. + +Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y). +Proof. + unfold Qlt. intros. simpl. + do 2 rewrite Zmult_1_r. reflexivity. +Qed. + + (** Large = strict or equal *) Lemma Qle_lteq : forall x y, x<=y <-> x<y \/ x==y. @@ -677,6 +749,54 @@ Proof. Close Scope Z_scope. Qed. +Lemma Qplus_lt_le_compat : + forall x y z t, x<y -> z<=t -> x+z < y+t. +Proof. + unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2); + simpl; simpl_mult. + Open Scope Z_scope. + intros. + match goal with |- ?a < ?b => ring_simplify a b end. + rewrite Zplus_comm. + apply Zplus_le_lt_compat. + match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end. + auto with zarith. + match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end. + assert (forall p, 0 < ' p) by reflexivity. + repeat (apply Zmult_lt_compat_r; auto). + Close Scope Z_scope. +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 *. +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. +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 *. +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. +Qed. + Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. @@ -699,6 +819,19 @@ Proof. Close Scope Z_scope. 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. +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. +Qed. + Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. @@ -713,6 +846,30 @@ Proof. Close Scope Z_scope. 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. + replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring. + replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring. + assert (forall p, 0 < ' p) by reflexivity. + split; intros. + apply Zmult_lt_reg_r with (c1*'c2); auto with zarith. + apply Zmult_lt_0_compat; auto with zarith. + apply Zmult_lt_compat_r; auto with zarith. + apply Zmult_lt_0_compat. omega. + compute; auto. + 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. +Qed. + Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b. Proof. intros a b Ha Hb. diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v index be894419..238de6fa 100644 --- a/theories/QArith/QOrderedType.v +++ b/theories/QArith/QOrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index 747c2c3c..557fabc8 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -100,6 +100,13 @@ rewrite Zabs_Zmult. reflexivity. Qed. +Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x). +Proof. + unfold Qminus, Qopp. simpl. + rewrite Pmult_comm, <- Zabs_Zopp. + do 2 f_equal. ring. +Qed. + Lemma Qle_Qabs : forall a, a <= Qabs a. Proof. intros a. @@ -122,3 +129,31 @@ 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. +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. +Qed. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 71a3b474..fea2ba39 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qcanon.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Field. Require Import QArith. Require Import Znumtheory. @@ -20,7 +18,7 @@ Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }. Delimit Scope Qc_scope with Qc. Bind Scope Qc_scope with Qc. -Arguments Scope Qcmake [Q_scope]. +Arguments Qcmake this%Q _. Open Scope Qc_scope. Lemma Qred_identity : @@ -71,7 +69,7 @@ Proof. Qed. Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). -Arguments Scope Q2Qc [Q_scope]. +Arguments Q2Qc q%Q. Notation " !! " := Q2Qc : Qc_scope. Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. @@ -468,18 +466,16 @@ Proof. destruct n; simpl. destruct 1; auto. intros. - apply Qc_is_canon. - simpl. - compute; auto. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. Proof. induction n; simpl; auto with qarith. - intros; compute; intro; discriminate. + easy. intros. apply Qcle_trans with (0*(p^n)). - compute; intro; discriminate. + easy. apply Qcmult_le_compat_r; auto. Qed. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 81d59714..5e27f381 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qfield.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Field. Require Export QArith_base. Require Import NArithRing. diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v index a458fc6e..2da24ee6 100644 --- a/theories/QArith/Qminmax.v +++ b/theories/QArith/Qminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -64,4 +64,4 @@ Proof. apply plus_min_distr_l. Qed. -End Q.
\ No newline at end of file +End Q. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index 9568c796..b05ee649 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -136,9 +136,9 @@ Proof. intros a [|n|n] [|m|m] H; simpl; try ring; try rewrite Qpower_plus_positive; try apply Qinv_mult_distr; try reflexivity; -case_eq ((n ?= m)%positive Eq); intros H0; simpl; +rewrite ?Z.pos_sub_spec; +case Pos.compare_spec; intros H0; simpl; subst; try rewrite Qpower_minus_positive; - try rewrite (Pcompare_Eq_eq _ _ H0); try (field; try split; apply Qpower_not_0_positive); try assumption; apply ZC2; diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 8a0ebcff..24f6d720 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qreals.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Rbase. Require Export QArith_base. @@ -210,4 +208,4 @@ intro; apply H; apply eqR_Qeq. rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real. Qed. -End LegacyQField.
\ No newline at end of file +End LegacyQField. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index eb8c1164..e39eca0c 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qreduction.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Normalisation functions for rational numbers. *) Require Export QArith_base. @@ -43,23 +41,16 @@ Definition Qred (q:Q) := Lemma Qred_correct : forall q, (Qred q) == q. Proof. unfold Qred, Qeq; intros (n,d); simpl. - generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) - (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)). + generalize (Zggcd_gcd n ('d)) (Zgcd_nonneg n ('d)) + (Zggcd_correct_divisors n ('d)). destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl. Open Scope Z_scope. - intuition. - rewrite <- H in H0,H1; clear H. - rewrite H3; rewrite H4. - assert (0 <> g). - intro; subst g; discriminate. - - assert (0 < dd). - apply Zmult_gt_0_lt_0_reg_r with g. - omega. - rewrite Zmult_comm. - rewrite <- H4; compute; auto. - rewrite Z2P_correct; auto. - ring. + intros Hg LE (Hn,Hd). rewrite Hd, Hn. + rewrite <- Hg in LE; clear Hg. + assert (0 <> g) by (intro; subst; discriminate). + rewrite Z2P_correct. ring. + apply Zmult_gt_0_lt_0_reg_r with g; auto with zarith. + now rewrite Zmult_comm, <- Hd. Close Scope Z_scope. Qed. @@ -69,10 +60,10 @@ Proof. unfold Qred, Qeq in *; simpl in *. Open Scope Z_scope. generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) - (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)). + (Zgcd_nonneg a ('b)) (Zggcd_correct_divisors a ('b)). destruct (Zggcd a (Zpos b)) as (g,(aa,bb)). generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) - (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)). + (Zgcd_nonneg c ('d)) (Zggcd_correct_divisors c ('d)). destruct (Zggcd c (Zpos d)) as (g',(cc,dd)). simpl. intro H; rewrite <- H; clear H. @@ -80,10 +71,9 @@ Proof. intro H; rewrite <- H; clear H. intros Hg1 Hg2 (Hg3,Hg4). intros. - assert (g <> 0). - intro; subst g; discriminate. - assert (g' <> 0). - intro; subst g'; discriminate. + assert (g <> 0) by (intro; subst g; discriminate). + assert (g' <> 0) by (intro; subst g'; discriminate). + elim (rel_prime_cross_prod aa bb cc dd). congruence. unfold rel_prime in |- *. @@ -93,14 +83,13 @@ Proof. exists bb; auto with zarith. intros. inversion Hg1. - destruct (H6 (g*x)). + destruct (H6 (g*x)) as (x',Hx). rewrite Hg3. destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring. rewrite Hg4. destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring. - exists q. - apply Zmult_reg_l with g; auto. - pattern g at 1; rewrite H7; ring. + exists x'. + apply Zmult_reg_l with g; auto. rewrite Hx at 1; ring. (* /rel_prime *) unfold rel_prime in |- *. (* rel_prime *) @@ -109,14 +98,13 @@ Proof. exists dd; auto with zarith. intros. inversion Hg'1. - destruct (H6 (g'*x)). + destruct (H6 (g'*x)) as (x',Hx). rewrite Hg'3. destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring. rewrite Hg'4. destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring. - exists q. - apply Zmult_reg_l with g'; auto. - pattern g' at 1; rewrite H7; ring. + exists x'. + apply Zmult_reg_l with g'; auto. rewrite Hx at 1; ring. (* /rel_prime *) assert (0<bb); [|auto with zarith]. apply Zmult_gt_0_lt_0_reg_r with g. diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index 173136b8..c88a8141 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -1,11 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qring.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Qfield. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 01a97870..ce363a33 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -136,4 +136,15 @@ intros x y H. apply Zle_antisym. auto with *. symmetry in H; auto with *. -Qed.
\ No newline at end of file +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 Zdiv_0_r, Zmult_0_r. + now rewrite Zmult_1_r. + rewrite <- Zopp_eq_mult_neg_1. + rewrite <- (Zopp_involutive (Zpos p)). + now rewrite Zdiv_opp_opp. +Qed. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 092eafa3..18612a68 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Alembert.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. @@ -109,7 +107,7 @@ Proof. symmetry in |- *; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity. intro X; elim X; intros. - exists x; apply tech10; + exists x; apply Un_cv_crit_lub; [ unfold Un_growing in |- *; intro; rewrite tech5; pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; apply H @@ -524,7 +522,7 @@ Proof. symmetry in |- *; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity. intro X; elim X; intros. - exists x; apply tech10; + exists x; apply Un_cv_crit_lub; [ unfold Un_growing in |- *; intro; rewrite tech5; pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; apply H diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index cab14704..07a26929 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: AltSeries.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index c378a2e2..620561dc 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: ArithProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rbasic_fun. Require Import Even. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index 55c30aec..412f6442 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Binomial.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import PartSum. diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index 1a2e5eca..a9d5cde3 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Cauchy_prod.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 32480b0b..ec1eeddf 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Cos_plus.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index dec5abd3..73f3c0c6 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cos_rel.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 2cdc121f..144de09e 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DiscrR.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import RIneq. Require Import Omega. Open Local Scope R_scope. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 75ea4755..dd97b865 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Exp_prop.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. @@ -648,7 +646,7 @@ Proof. apply H3. rewrite Rminus_0_r; apply Rabs_right. apply Rle_ge. - unfold Rdiv in |- *; repeat apply Rmult_le_pos. + unfold Rdiv in |- *; apply Rmult_le_pos. apply pow_le. apply Rle_trans with 1. left; apply Rlt_0_1. diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index 3199a4f8..da1742ca 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Integration.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export NewtonInt. Require Export RiemannInt_SF. -Require Export RiemannInt.
\ No newline at end of file +Require Export RiemannInt. diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v index 32b9699d..49a94021 100644 --- a/theories/Reals/LegacyRfield.v +++ b/theories/Reals/LegacyRfield.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: LegacyRfield.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Raxioms. Require Export LegacyField. Import LegacyRing_theory. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index 36bbb405..29ebd46d 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: MVT.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 79060771..a4233021 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NewtonInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index e7182312..aa588e38 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PSeries_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index b2a0e574..3f90f15a 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PartSum.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index f02db3d4..70f4ff0d 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RIneq.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** * Basic lemmas for the classical real numbers *) (*********************************************************) @@ -1603,7 +1601,7 @@ Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (nat_of_P p). Proof. intro; apply lt_0_INR. simpl in |- *; auto with real. - apply lt_O_nat_of_P. + apply nat_of_P_pos. Qed. Hint Resolve pos_INR_nat_of_P: real. @@ -1712,38 +1710,32 @@ Qed. Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z_of_nat n). Proof. simple induction n; auto with real. - intros; simpl in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; + intros; simpl in |- *; rewrite nat_of_P_of_succ_nat; auto with real. Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. - intros. - case (lt_eq_lt_dec (nat_of_P p) (nat_of_P q)). - intros [H| H]; simpl in |- *. - rewrite nat_of_P_lt_Lt_compare_complement_morphism; simpl in |- *; trivial. - rewrite (nat_of_P_minus_morphism q p). - rewrite minus_INR; auto with arith; ring. - apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial. - rewrite (nat_of_P_inj p q); trivial. - rewrite Pcompare_refl; simpl in |- *; auto with real. - intro H; simpl in |- *. - rewrite nat_of_P_gt_Gt_compare_complement_morphism; simpl in |- *; - auto with arith. - rewrite (nat_of_P_minus_morphism p q). - rewrite minus_INR; auto with arith; ring. - apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial. + intros p q; simpl. rewrite Z.pos_sub_spec. + case Pcompare_spec; intros H; simpl. + subst. ring. + rewrite Pminus_minus by trivial. + rewrite minus_INR by (now apply lt_le_weak, Plt_lt). + ring. + rewrite Pminus_minus by trivial. + rewrite minus_INR by (now apply lt_le_weak, Plt_lt). + ring. Qed. (**********) Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. intro z; destruct z; intro t; destruct t; intros; auto with real. - simpl in |- *; intros; rewrite nat_of_P_plus_morphism; auto with real. + simpl; intros; rewrite Pplus_plus; auto with real. apply plus_IZR_NEG_POS. rewrite Zplus_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. - simpl in |- *; intros; rewrite nat_of_P_plus_morphism; rewrite plus_INR; + simpl; intros; rewrite Pplus_plus; rewrite plus_INR; auto with real. Qed. @@ -1751,14 +1743,14 @@ Qed. Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m. Proof. intros z t; case z; case t; simpl in |- *; auto with real. - intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. - intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. + intros t1 z1; rewrite Pmult_mult; auto with real. + intros t1 z1; rewrite Pmult_mult; auto with real. rewrite Rmult_comm. rewrite Ropp_mult_distr_l_reverse; auto with real. apply Ropp_eq_compat; rewrite mult_comm; auto with real. - intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. + intros t1 z1; rewrite Pmult_mult; auto with real. rewrite Ropp_mult_distr_l_reverse; auto with real. - intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. + intros t1 z1; rewrite Pmult_mult; auto with real. rewrite Rmult_opp_opp; auto with real. Qed. @@ -1766,7 +1758,7 @@ Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Zpower z (Z_of_nat n)). Proof. intros z [|n];simpl;trivial. rewrite Zpower_pos_nat. - rewrite nat_of_P_o_P_of_succ_nat_eq_succ. unfold Zpower_nat;simpl. + rewrite nat_of_P_of_succ_nat. unfold Zpower_nat;simpl. rewrite mult_IZR. induction n;simpl;trivial. rewrite mult_IZR;ring[IHn]. diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 4e4fb378..dbd2e52f 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RList.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Open Local Scope R_scope. diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v index 87dc07b8..0a8d89c7 100644 --- a/theories/Reals/ROrderedType.v +++ b/theories/Reals/ROrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -55,7 +55,7 @@ Definition Rcompare x y := | inright _ => Gt end. -Lemma Rcompare_spec : forall x y, CompSpec eq Rlt x y (Rcompare x y). +Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (Rcompare x y). Proof. intros. unfold Rcompare. destruct total_order_T as [[H|H]|H]; auto. diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 8cf36c17..9e04a7da 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_Ifp.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (**********************************************************) (** Complements for the reals.Integer and fractional part *) (* *) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index df2267d1..f23b9f17 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqr.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rbasic_fun. Open Local Scope R_scope. @@ -72,7 +70,7 @@ Proof. rewrite Rinv_mult_distr. repeat rewrite Rmult_assoc. apply Rmult_eq_compat_l. - pattern x at 2 in |- *; rewrite Rmult_comm. + rewrite Rmult_comm. repeat rewrite Rmult_assoc. apply Rmult_eq_compat_l. reflexivity. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 26980c95..2c5ede23 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqrt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rsqrt_def. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 39c2271b..01715cf3 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rtrigo. diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 673dc3c1..3075bee8 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis1.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Export Rlimit. @@ -30,15 +28,15 @@ Definition inv_fct f (x:R) : R := / f x. Delimit Scope Rfun_scope with F. -Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope]. -Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope]. -Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope]. -Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope]. -Arguments Scope inv_fct [Rfun_scope R_scope]. -Arguments Scope opp_fct [Rfun_scope R_scope]. -Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope]. -Arguments Scope div_real_fct [R_scope Rfun_scope R_scope]. -Arguments Scope comp [Rfun_scope Rfun_scope R_scope]. +Arguments plus_fct (f1 f2)%F x%R. +Arguments mult_fct (f1 f2)%F x%R. +Arguments minus_fct (f1 f2)%F x%R. +Arguments div_fct (f1 f2)%F x%R. +Arguments inv_fct f%F x%R. +Arguments opp_fct f%F x%R. +Arguments mult_real_fct a%R f%F x%R. +Arguments div_real_fct a%R f%F x%R. +Arguments comp (f1 f2)%F x%R. Infix "+" := plus_fct : Rfun_scope. Notation "- x" := (opp_fct x) : Rfun_scope. @@ -76,8 +74,8 @@ Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop := Definition continuity_pt f (x0:R) : Prop := continue_in f no_cond x0. Definition continuity f : Prop := forall x:R, continuity_pt f x. -Arguments Scope continuity_pt [Rfun_scope R_scope]. -Arguments Scope continuity [Rfun_scope]. +Arguments continuity_pt f%F x0%R. +Arguments continuity f%F. (**********) Lemma continuity_pt_plus : @@ -276,12 +274,12 @@ Definition derivable f := forall x:R, derivable_pt f x. Definition derive_pt f (x:R) (pr:derivable_pt f x) := proj1_sig pr. Definition derive f (pr:derivable f) (x:R) := derive_pt f x (pr x). -Arguments Scope derivable_pt_lim [Rfun_scope R_scope]. -Arguments Scope derivable_pt_abs [Rfun_scope R_scope R_scope]. -Arguments Scope derivable_pt [Rfun_scope R_scope]. -Arguments Scope derivable [Rfun_scope]. -Arguments Scope derive_pt [Rfun_scope R_scope _]. -Arguments Scope derive [Rfun_scope _]. +Arguments derivable_pt_lim f%F x%R l. +Arguments derivable_pt_abs f%F (x l)%R. +Arguments derivable_pt f%F x%R. +Arguments derivable f%F. +Arguments derive_pt f%F x%R pr. +Arguments derive f%F pr x. Definition antiderivative f (g:R -> R) (a b:R) : Prop := (forall x:R, diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index fcff9a01..ed80ac43 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis2.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index c7d95660..afd4a4ee 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis3.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index a7c5a387..cc658fee 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis4.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index b6286c0d..8f01d7d0 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Raxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** Axiomatisation of the classical reals *) (*********************************************************) @@ -107,13 +105,13 @@ Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. (**********************************************************) (**********) -Boxed Fixpoint INR (n:nat) : R := +Fixpoint INR (n:nat) : R := match n with | O => 0 | S O => 1 | S n => INR n + 1 end. -Arguments Scope INR [nat_scope]. +Arguments INR n%nat. (**********************************************************) @@ -127,7 +125,7 @@ Definition IZR (z:Z) : R := | Zpos n => INR (nat_of_P n) | Zneg n => - INR (nat_of_P n) end. -Arguments Scope IZR [Z_scope]. +Arguments IZR z%Z. (**********************************************************) (** * [R] Archimedean *) diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index 23aae957..dbf9ad71 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbase.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Rdefinitions. Require Export Raxioms. Require Export RIneq. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 15b04807..4bc7fd10 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbasic_fun.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** Complements for the real numbers *) (* *) diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index f6d40631..77cb560c 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rcomplete.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index d06e2d1b..83c6b82d 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rdefinitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** Definitions for the axiomatization *) diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index 701914ac..105d8347 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rderiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** Definition of the derivative,continuity *) (* *) @@ -17,8 +15,6 @@ Require Import Rbase. Require Import Rfunctions. Require Import Rlimit. Require Import Fourier. -Require Import Classical_Prop. -Require Import Classical_Pred_Type. Require Import Omega. Open Local Scope R_scope. @@ -168,13 +164,12 @@ Proof. rewrite eps2 in H10; assumption. unfold Rabs in |- *; case (Rcase_abs 2); auto. intro; cut (0 < 2). - intro; generalize (Rlt_asym 0 2 H7); intro; exfalso; auto. + intro ; elim (Rlt_asym 0 2 H7 r). fourier. apply Rabs_no_R0. discrR. Qed. - (*********) Lemma Dconst : forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0. @@ -344,8 +339,7 @@ Proof. rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2; rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2; rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2; - rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (classic (n0 = 0%nat)); - intro cond. + rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (Peano_dec.eq_nat_dec n0 0) ; intros cond. rewrite cond in H2; rewrite cond; simpl in H2; simpl in |- *; cut (1 + x0 * 1 * 0 = 1 * 1); [ intro A; rewrite A in H2; assumption | ring ]. @@ -391,7 +385,7 @@ Proof. intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0)); intros a b; clear b; unfold Rgt in a; elim (a H12); clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; - clear H12; elim (classic (f x2 = f x0)); intro. + clear H12; elim (Req_dec (f x2) (f x0)); intro. elim H11; clear H11; intros; elim H11; clear H11; intros; generalize (H10 x2 (conj (conj H11 H14) H5)); intro; rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16; diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 9929733f..a15e9949 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Reals.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** The library REALS is divided in 6 parts : - Rbase: basic lemmas on R equalities and inequalities @@ -29,4 +27,4 @@ Require Export Rfunctions. Require Export SeqSeries. Require Export Rtrigo. Require Export Ranalysis. -Require Export Integration.
\ No newline at end of file +Require Export Integration. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index a91cf8ae..c0cd7864 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rfunctions.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*i Some properties about pow and sum have been made with John Harrison i*) (*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*) @@ -36,7 +34,7 @@ Open Local Scope R_scope. (*********) Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0. Proof. - intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n)); + intro; red; intro; apply (not_O_INR (fact n) (fact_neq_0 n)); assumption. Qed. @@ -51,7 +49,7 @@ Lemma simpl_fact : forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n). Proof. intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n)); - unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *; + unfold fact at 1; cbv beta iota; fold fact; rewrite (mult_INR (S n) (fact n)); rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))). rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n))); @@ -75,20 +73,20 @@ Qed. Lemma pow_1 : forall x:R, x ^ 1 = x. Proof. - simpl in |- *; auto with real. + simpl; auto with real. Qed. Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m. Proof. - intros x n; elim n; simpl in |- *; auto with real. + intros x n; elim n; simpl; auto with real. intros n0 H' m; rewrite H'; auto with real. Qed. Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0. Proof. - intro; simple induction n; simpl in |- *. - intro; red in |- *; intro; apply R1_neq_R0; assumption. - intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1). + intro; simple induction n; simpl. + intro; red; intro; apply R1_neq_R0; assumption. + intros; red; intro; elim (Rmult_integral x (x ^ n0) H1). intro; auto. apply H; assumption. Qed. @@ -98,24 +96,24 @@ Hint Resolve pow_O pow_1 pow_add pow_nonzero: real. Lemma pow_RN_plus : forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m. Proof. - intros x n; elim n; simpl in |- *; auto with real. + intros x n; elim n; simpl; auto with real. intros n0 H' m H'0. rewrite Rmult_assoc; rewrite <- H'; auto. Qed. Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n. Proof. - intros x n; elim n; simpl in |- *; auto with real. + intros x n; elim n; simpl; auto with real. intros n0 H' H'0; replace 0 with (x * 0); auto with real. Qed. Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. Proof. - intros x n; elim n; simpl in |- *; auto with real. + intros x n; elim n; simpl; auto with real. intros H' H'0; exfalso; omega. intros n0; case n0. - simpl in |- *; rewrite Rmult_1_r; auto. + simpl; rewrite Rmult_1_r; auto. intros n1 H' H'0 H'1. replace 1 with (1 * 1); auto with real. apply Rlt_trans with (r2 := x * 1); auto with real. @@ -129,7 +127,7 @@ Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m. Proof. intros x n m H' H'0; replace m with (m - n + n)%nat. rewrite pow_add. - pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n); + pattern (x ^ n) at 1; replace (x ^ n) with (1 * x ^ n); auto with real. apply Rminus_lt. repeat rewrite (fun y:R => Rmult_comm y (x ^ n)); @@ -149,14 +147,14 @@ Hint Resolve Rlt_pow: real. (*********) Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n. Proof. - simple induction n; simpl in |- *; trivial. + simple induction n; simpl; trivial. Qed. (*********) Lemma tech_pow_Rplus : forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a. Proof. - intros; pattern (x ^ a) at 1 in |- *; + intros; pattern (x ^ a) at 1; rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1); rewrite (Rmult_comm (INR n) (x ^ a)); rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n)); @@ -167,29 +165,29 @@ Qed. Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n. Proof. intros; elim n. - simpl in |- *; cut (1 + 0 * x = 1). - intro; rewrite H0; unfold Rle in |- *; right; reflexivity. + simpl; cut (1 + 0 * x = 1). + intro; rewrite H0; unfold Rle; right; reflexivity. ring. - intros; unfold pow in |- *; fold pow in |- *; + intros; unfold pow; fold pow; apply (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x)) ((1 + x) * (1 + x) ^ n0)). cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)). - intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *; + intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1; rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1); apply Rplus_le_compat_l; elim n0; intros. - simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto. - unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *; - intro; fold (Rsqr x) in |- *; + simpl; rewrite Rmult_0_l; unfold Rle; right; auto. + unfold Rle; left; generalize Rmult_gt_0_compat; unfold Rgt; + intro; fold (Rsqr x); apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1))); fold (x > 0) in H; apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))). rewrite (S_INR n0); ring. unfold Rle in H0; elim H0; intro. - unfold Rle in |- *; left; apply Rmult_lt_compat_l. + unfold Rle; left; apply Rmult_lt_compat_l. rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)). assumption. - rewrite H1; unfold Rle in |- *; right; trivial. + rewrite H1; unfold Rle; right; trivial. Qed. Lemma Power_monotonic : @@ -197,12 +195,12 @@ Lemma Power_monotonic : Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n). Proof. intros x m n H; induction n as [| n Hrecn]; intros; inversion H0. - unfold Rle in |- *; right; reflexivity. - unfold Rle in |- *; right; reflexivity. + unfold Rle; right; reflexivity. + unfold Rle; right; reflexivity. apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))). apply Hrecn; assumption. - simpl in |- *; rewrite Rabs_mult. - pattern (Rabs (x ^ n)) at 1 in |- *. + simpl; rewrite Rabs_mult. + pattern (Rabs (x ^ n)) at 1. rewrite <- Rmult_1_r. rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))). apply Rmult_le_compat_l. @@ -213,7 +211,7 @@ Qed. Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n). Proof. - intro; simple induction n; simpl in |- *. + intro; simple induction n; simpl. apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1. intros; rewrite H; apply sym_eq; apply Rabs_mult. Qed. @@ -233,16 +231,16 @@ Proof. rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)). intro; rewrite H3; apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b). - apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus; + apply Rle_ge; apply poly; fold (Rabs x - 1 > 0); apply Rgt_minus; assumption. apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b). apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1))); - pattern (INR x0 * (Rabs x - 1)) at 1 in |- *; + pattern (INR x0 * (Rabs x - 1)) at 1; rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1); apply Rplus_lt_compat_l; apply Rlt_0_1. cut (b = b * / (Rabs x - 1) * (Rabs x - 1)). intros; rewrite H4; apply Rmult_ge_compat_r. - apply Rge_minus; unfold Rge in |- *; left; assumption. + apply Rge_minus; unfold Rge; left; assumption. assumption. rewrite Rmult_assoc; rewrite Rinv_l. ring. @@ -254,26 +252,26 @@ Proof. apply (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). rewrite INR_IZR_INZ; apply IZR_ge; omega. - unfold Rge in |- *; left; assumption. + unfold Rge; left; assumption. exists 0%nat; apply (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega. - unfold Rge in |- *; left; assumption. + rewrite INR_IZR_INZ; apply IZR_ge; simpl; omega. + unfold Rge; left; assumption. omega. Qed. Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0. Proof. simple induction n. - simpl in |- *; auto. + simpl; auto. intros; elim H; reflexivity. - intros; simpl in |- *; apply Rmult_0_l. + intros; simpl; apply Rmult_0_l. Qed. Lemma Rinv_pow : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n. Proof. - intros; elim n; simpl in |- *. + intros; elim n; simpl. apply Rinv_1. intro m; intro; rewrite Rinv_mult_distr. rewrite H0; reflexivity; assumption. @@ -307,7 +305,7 @@ Proof. rewrite <- Rabs_Rinv. rewrite Rinv_pow. apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))). - pattern (/ y) at 1 in |- *. + pattern (/ y) at 1. rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1). apply Rplus_lt_compat_l. apply Rlt_0_1. @@ -321,17 +319,17 @@ Proof. apply pow_nonzero. assumption. apply Rlt_dichotomy_converse. - right; unfold Rgt in |- *; assumption. + right; unfold Rgt; assumption. rewrite <- (Rinv_involutive 1). rewrite Rabs_Rinv. - unfold Rgt in |- *; apply Rinv_lt_contravar. + unfold Rgt; apply Rinv_lt_contravar. apply Rmult_lt_0_compat. apply Rabs_pos_lt. assumption. rewrite Rinv_1; apply Rlt_0_1. rewrite Rinv_1; assumption. assumption. - red in |- *; intro; apply R1_neq_R0; assumption. + red; intro; apply R1_neq_R0; assumption. Qed. Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat. @@ -345,7 +343,7 @@ Proof. cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto. absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto. replace (Rabs (/ r) ^ S n0) with 1. - simpl in |- *; apply Rlt_irrefl; auto. + simpl; apply Rlt_irrefl; auto. rewrite Rabs_Rinv; auto. rewrite <- Rinv_pow; auto. rewrite RPow_abs; auto. @@ -356,16 +354,16 @@ Proof. case (Rabs_pos r); auto. intros H'3; case Eq2; auto. rewrite Rmult_1_r; rewrite Rinv_r; auto with real. - red in |- *; intro; absurd (r ^ S n0 = 1); auto. - simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real. + red; intro; absurd (r ^ S n0 = 1); auto. + simpl; rewrite H; rewrite Rmult_0_l; auto with real. generalize H'; case n; auto. intros n0 H'0. cut (r <> 0); [ intros Eq1 | auto with real ]. cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto. absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith. - repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real. - red in |- *; intro; absurd (r ^ S n0 = 1); auto. - simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real. + repeat rewrite RPow_abs; rewrite H'0; simpl; auto with real. + red; intro; absurd (r ^ S n0 = 1); auto. + simpl; rewrite H; rewrite Rmult_0_l; auto with real. Qed. Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n. @@ -375,15 +373,15 @@ Proof. replace (2 * S n)%nat with (S (S (2 * n))). replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)). rewrite Hrecn; reflexivity. - simpl in |- *; ring. + simpl; ring. ring. Qed. Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n. Proof. intros; induction n as [| n Hrecn]. - simpl in |- *; left; apply Rlt_0_1. - simpl in |- *; apply Rmult_le_pos; assumption. + simpl; left; apply Rlt_0_1. + simpl; apply Rmult_le_pos; assumption. Qed. (**********) @@ -392,36 +390,36 @@ Proof. intro; induction n as [| n Hrecn]. reflexivity. replace (2 * S n)%nat with (2 + 2 * n)%nat by ring. - rewrite pow_add; rewrite Hrecn; simpl in |- *; ring. + rewrite pow_add; rewrite Hrecn; simpl; ring. Qed. (**********) Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1. Proof. intro; replace (S (2 * n)) with (2 * n + 1)%nat by ring. - rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring. + rewrite pow_add; rewrite pow_1_even; simpl; ring. Qed. (**********) Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1. Proof. intro; induction n as [| n Hrecn]. - simpl in |- *; apply Rabs_R1. + simpl; apply Rabs_R1. replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ]. rewrite Rabs_mult. - rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r; + rewrite Hrecn; rewrite Rmult_1_l; simpl; rewrite Rmult_1_r; rewrite Rabs_Ropp; apply Rabs_R1. Qed. Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2. Proof. intros; induction n2 as [| n2 Hrecn2]. - simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ]. + simpl; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ]. replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat. replace (S n2) with (n2 + 1)%nat by ring. do 2 rewrite pow_add. rewrite Hrecn2. - simpl in |- *. + simpl. ring. ring. Qed. @@ -431,7 +429,7 @@ Proof. intros. induction n as [| n Hrecn]. right; reflexivity. - simpl in |- *. + simpl. elim H; intros. apply Rle_trans with (y * x ^ n). do 2 rewrite <- (Rmult_comm (x ^ n)). @@ -448,7 +446,7 @@ Proof. intros. induction k as [| k Hreck]. right; reflexivity. - simpl in |- *. + simpl. apply Rle_trans with (x * 1). rewrite Rmult_1_r; assumption. apply Rmult_le_compat_l. @@ -463,33 +461,33 @@ Proof. replace n with (n - m + m)%nat. rewrite pow_add. rewrite Rmult_comm. - pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r. + pattern (x ^ m) at 1; rewrite <- Rmult_1_r. apply Rmult_le_compat_l. apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ]. apply pow_R1_Rle; assumption. rewrite plus_comm. - symmetry in |- *; apply le_plus_minus; assumption. + symmetry ; apply le_plus_minus; assumption. Qed. Lemma pow1 : forall n:nat, 1 ^ n = 1. Proof. intro; induction n as [| n Hrecn]. reflexivity. - simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity. + simpl; rewrite Hrecn; rewrite Rmult_1_r; reflexivity. Qed. Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n. Proof. intros; induction n as [| n Hrecn]. right; reflexivity. - simpl in |- *; case (Rcase_abs x); intro. + simpl; case (Rcase_abs x); intro. apply Rle_trans with (Rabs (x * x ^ n)). apply RRle_abs. rewrite Rabs_mult. apply Rmult_le_compat_l. apply Rabs_pos. - right; symmetry in |- *; apply RPow_abs. - pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r); + right; symmetry ; apply RPow_abs. + pattern (Rabs x) at 1; rewrite (Rabs_right x r); apply Rmult_le_compat_l. apply Rge_le; exact r. apply Hrecn. @@ -502,7 +500,7 @@ Proof. apply pow_Rabs. induction n as [| n Hrecn]. right; reflexivity. - simpl in |- *; apply Rle_trans with (x * Rabs y ^ n). + simpl; apply Rle_trans with (x * Rabs y ^ n). do 2 rewrite <- (Rmult_comm (Rabs y ^ n)). apply Rmult_le_compat_l. apply pow_le; apply Rabs_pos. @@ -519,7 +517,7 @@ Qed. (*i Due to L.Thery i*) Ltac case_eq name := - generalize (refl_equal name); pattern name at -1 in |- *; case name. + generalize (refl_equal name); pattern name at -1; case name. Definition powerRZ (x:R) (n:Z) := match n with @@ -533,7 +531,7 @@ Infix Local "^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 in |- *; simpl in |- *; auto with zarith. + induction n; unfold Zpower_nat; simpl; auto with zarith. Qed. Lemma powerRZ_O : forall x:R, x ^Z 0 = 1. @@ -543,60 +541,47 @@ Qed. Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x. Proof. - simpl in |- *; auto with real. + simpl; auto with real. Qed. Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0. Proof. - destruct z; simpl in |- *; auto with real. + destruct z; simpl; auto with real. Qed. Lemma powerRZ_add : forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m. Proof. - intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *; + intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl; auto with real. (* POS/POS *) - rewrite nat_of_P_plus_morphism; auto with real. + rewrite Pplus_plus; auto with real. (* POS/NEG *) - case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real. - intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real. - intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real. - rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1)); - auto with real. - rewrite plus_comm; rewrite le_plus_minus_r; auto with real. - rewrite Rinv_mult_distr; auto with real. - rewrite Rinv_involutive; auto with real. - apply lt_le_weak. - apply nat_of_P_lt_Lt_compare_morphism; auto. - apply ZC2; auto. - intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real. - rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1)); - auto with real. - rewrite plus_comm; rewrite le_plus_minus_r; auto with real. - apply lt_le_weak. - change (nat_of_P n1 > nat_of_P m1)%nat in |- *. - apply nat_of_P_gt_Gt_compare_morphism; auto. + rewrite Z.pos_sub_spec. + case Pcompare_spec; intros; simpl. + subst; auto with real. + rewrite Pminus_minus by trivial. + rewrite (pow_RN_plus x _ (nat_of_P n1)) by auto with real. + rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt). + rewrite Rinv_mult_distr, Rinv_involutive; auto with real. + rewrite Pminus_minus by trivial. + rewrite (pow_RN_plus x _ (nat_of_P m1)) by auto with real. + rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt). + reflexivity. (* NEG/POS *) - case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real. - intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real. - intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real. - rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1)); - auto with real. - rewrite plus_comm; rewrite le_plus_minus_r; auto with real. - apply lt_le_weak. - apply nat_of_P_lt_Lt_compare_morphism; auto. - apply ZC2; auto. - intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real. - rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1)); - auto with real. - rewrite plus_comm; rewrite le_plus_minus_r; auto with real. - rewrite Rinv_mult_distr; auto with real. - apply lt_le_weak. - change (nat_of_P n1 > nat_of_P m1)%nat in |- *. - apply nat_of_P_gt_Gt_compare_morphism; auto. + rewrite Z.pos_sub_spec. + case Pcompare_spec; intros; simpl. + subst; auto with real. + rewrite Pminus_minus by trivial. + rewrite (pow_RN_plus x _ (nat_of_P m1)) by auto with real. + rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt). + rewrite Rinv_mult_distr, Rinv_involutive; auto with real. + rewrite Pminus_minus by trivial. + rewrite (pow_RN_plus x _ (nat_of_P n1)) by auto with real. + rewrite plus_comm, le_plus_minus_r by (now apply lt_le_weak, Plt_lt). + auto with real. (* NEG/NEG *) - rewrite nat_of_P_plus_morphism; auto with real. + rewrite Pplus_plus; auto with real. intros H'; rewrite pow_add; auto with real. apply Rinv_mult_distr; auto. apply pow_nonzero; auto. @@ -607,16 +592,16 @@ 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 in |- *; auto with real. - intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *. + intros n m; elim m; simpl; auto with real. + intros m1 H'; rewrite nat_of_P_of_succ_nat; 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 in |- *. - rewrite H'; simpl in |- *. - case m1; simpl in |- *; auto with real. - intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto. - unfold Zpower_nat in |- *; auto. + repeat rewrite <- INR_IZR_INZ; simpl. + rewrite H'; simpl. + case m1; simpl; auto with real. + intros m2; rewrite nat_of_P_of_succ_nat; auto. + unfold Zpower_nat; auto. Qed. Lemma Zpower_pos_powerRZ : @@ -633,7 +618,7 @@ Qed. Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. Proof. - intros x z; case z; simpl in |- *; auto with real. + intros x z; case z; simpl; auto with real. Qed. Hint Resolve powerRZ_lt: real. @@ -646,19 +631,19 @@ Hint Resolve powerRZ_le: real. Lemma Zpower_nat_powerRZ_absolu : forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m. Proof. - intros n m; case m; simpl in |- *; auto with zarith. - intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith. - intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith. + intros n m; case m; simpl; auto with zarith. + intros p H'; elim (nat_of_P 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 in |- *; auto. - intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H'; + intros n; case n; simpl; auto. + intros p; elim (nat_of_P p); simpl; auto; intros n0 H'; rewrite H'; ring. - intros p; elim (nat_of_P p); simpl in |- *. + intros p; elim (nat_of_P p); simpl. exact Rinv_1. intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H'; auto with real. @@ -676,7 +661,7 @@ Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z). (** * Sum of n first naturals *) (*******************************) (*********) -Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat := +Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) : nat := match n with | O => f 0%nat | S n' => (sum_nat_f_O f n' + f (S n'))%nat @@ -710,10 +695,10 @@ Lemma GP_finite : forall (x:R) (n:nat), sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1. Proof. - intros; induction n as [| n Hrecn]; simpl in |- *. + intros; induction n as [| n Hrecn]; simpl. ring. rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n). - intro H; rewrite H; simpl in |- *; ring. + intro H; rewrite H; simpl; ring. omega. Qed. @@ -721,8 +706,8 @@ Lemma sum_f_R0_triangle : forall (x:nat -> R) (n:nat), Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n. Proof. - intro; simple induction n; simpl in |- *. - unfold Rle in |- *; right; reflexivity. + intro; simple induction n; simpl. + unfold Rle; right; reflexivity. intro m; intro; apply (Rle_trans (Rabs (sum_f_R0 x m + x (S m))) @@ -744,16 +729,16 @@ Definition R_dist (x y:R) : R := Rabs (x - y). (*********) Lemma R_dist_pos : forall x y:R, R_dist x y >= 0. Proof. - intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y)); + intros; unfold R_dist; unfold Rabs; case (Rcase_abs (x - y)); intro l. - unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l). + unfold Rge; left; apply (Ropp_gt_lt_0_contravar (x - y) l). trivial. Qed. (*********) Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x. Proof. - unfold R_dist in |- *; intros; split_Rabs; try ring. + unfold R_dist; intros; split_Rabs; try ring. generalize (Ropp_gt_lt_0_contravar (y - x) r); intro; rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0); intro; unfold Rgt in H; exfalso; auto. @@ -765,7 +750,7 @@ Qed. (*********) Lemma R_dist_refl : forall x y:R, R_dist x y = 0 <-> x = y. Proof. - unfold R_dist in |- *; intros; split_Rabs; split; intros. + unfold R_dist; intros; split_Rabs; split; intros. rewrite (Ropp_minus_distr x y) in H; apply sym_eq; apply (Rminus_diag_uniq y x H). rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro; @@ -776,13 +761,13 @@ Qed. Lemma R_dist_eq : forall x:R, R_dist x x = 0. Proof. - unfold R_dist in |- *; intros; split_Rabs; intros; ring. + unfold R_dist; intros; split_Rabs; intros; ring. Qed. (***********) Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y. Proof. - intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y)); + intros; unfold R_dist; replace (x - y) with (x - z + (z - y)); [ apply (Rabs_triang (x - z) (z - y)) | ring ]. Qed. @@ -790,7 +775,7 @@ Qed. Lemma R_dist_plus : forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d. Proof. - intros; unfold R_dist in |- *; + intros; unfold R_dist; replace (a + c - (b + d)) with (a - b + (c - d)). exact (Rabs_triang (a - b) (c - d)). ring. diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index 3ab2bc73..bda64e77 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rgeom.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 598f5f31..8acfd75b 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RiemannInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rfunctions. Require Import SeqSeries. Require Import Ranalysis. @@ -2242,7 +2240,7 @@ Proof. unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. eapply StepFun_P17. apply StepFun_P1. - simpl in |- *; apply StepFun_P1. + simpl in |- *; apply StepFun_P1. apply Ropp_eq_compat; eapply StepFun_P17. apply StepFun_P1. simpl in |- *; apply StepFun_P1. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index d0d9519c..d16e7f2c 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RiemannInt_SF.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis. @@ -149,7 +147,7 @@ Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := | existT a b => a end. -Boxed Fixpoint Int_SF (l k:Rlist) : R := +Fixpoint Int_SF (l k:Rlist) : R := match l with | nil => 0 | cons a l' => diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index d2d935b7..5c864de3 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rlimit.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************) (** Definition of the limit *) (* *) @@ -15,7 +13,6 @@ Require Import Rbase. Require Import Rfunctions. -Require Import Classical_Prop. Require Import Fourier. Open Local Scope R_scope. diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index b7ffec2b..2237ea6e 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -41,6 +41,7 @@ Variable P : nat -> Prop. Hypothesis HP : forall n, {P n} + {~P n}. Let ge_fun_sums_ge_lemma : (forall (m n : nat) (f : nat -> R), (lt m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n). +Proof. intros m n f mn fpos. replace (sum_f_R0 f m) with (sum_f_R0 f m + 0) by ring. rewrite (tech2 f m n mn). @@ -52,6 +53,7 @@ apply (Rplus_le_compat _ _ _ _ IHn0 (fpos (S (m + S n0)%nat))). Qed. Let ge_fun_sums_ge : (forall (m n : nat) (f : nat -> R), (le m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n). +Proof. intros m n f mn pos. elim (le_lt_or_eq _ _ mn). intro; apply ge_fun_sums_ge_lemma; assumption. @@ -61,6 +63,7 @@ Qed. Let f:=fun n => (if HP n then (1/2)^n else 0)%R. Lemma cauchy_crit_geometric_dec_fun : Cauchy_crit_series f. +Proof. intros e He. assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R). apply GP_infinite. @@ -233,10 +236,11 @@ fourier. Qed. Lemma sig_forall_dec : {n | ~P n}+{forall n, P n}. +Proof. destruct forall_dec. right; assumption. left. -apply constructive_indefinite_description_nat; auto. +apply constructive_indefinite_ground_description_nat; auto. clear - HP. firstorder. apply Classical_Pred_Type.not_all_ex_not. @@ -255,6 +259,7 @@ principle also derive [up] and its [specification] *) 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 diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v index c9faee0c..8f8207d7 100644 --- a/theories/Reals/Rminmax.v +++ b/theories/Reals/Rminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 4f7a8d22..026153b7 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Rpow_def.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import Rdefinitions. Fixpoint pow (r:R) (n:nat) : R := diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 36db12f9..593e54c6 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rpower.v 14641 2011-11-06 11:59:10Z herbelin $ i*) (*i Due to L.Thery i*) (************************************************************) diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 947dbb11..12258d6b 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rprod.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Compare. Require Import Rbase. Require Import Rfunctions. @@ -17,7 +15,7 @@ Require Import Binomial. Open Local Scope R_scope. (** TT Ak; 0<=k<=N *) -Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R := +Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R := match N with | O => f O | S p => prod_f_R0 f p * f (S p) diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index db0fddad..479d381d 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -1,16 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rseries.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. -Require Import Classical. Require Import Compare. Open Local Scope R_scope. @@ -28,7 +25,7 @@ Section sequence. Variable Un : nat -> R. (*********) - Boxed Fixpoint Rmax_N (N:nat) : R := + Fixpoint Rmax_N (N:nat) : R := match N with | O => Un 0 | S n => Rmax (Un (S n)) (Rmax_N n) @@ -100,47 +97,173 @@ Section sequence. (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3). Qed. +(*********) + Lemma Un_cv_crit_lub : Un_growing -> forall l, is_lub EUn l -> Un_cv l. + Proof. + intros Hug l H eps Heps. + + cut (exists N, Un N > l - eps). + intros (N, H3). + exists N. + intros n H4. + unfold R_dist. + rewrite Rabs_left1, Ropp_minus_distr. + apply Rplus_lt_reg_r with (Un n - eps). + apply Rlt_le_trans with (Un N). + now replace (Un n - eps + (l - Un n)) with (l - eps) by ring. + replace (Un n - eps + eps) with (Un n) by ring. + apply Rge_le. + now apply growing_prop. + apply Rle_minus. + apply (proj1 H). + now exists n. + + assert (Hi2pn: forall n, 0 < (/ 2)^n). + clear. intros n. + apply pow_lt. + apply Rinv_0_lt_compat. + now apply (IZR_lt 0 2). + + pose (test := fun n => match Rle_lt_dec (Un n) (l - eps) with left _ => false | right _ => true end). + pose (sum := let fix aux n := match n with S n' => aux n' + + if test n' then (/ 2)^n else 0 | O => 0 end in aux). + + assert (Hsum': forall m n, sum m <= sum (m + n)%nat <= sum m + (/2)^m - (/2)^(m + n)). + clearbody test. + clear -Hi2pn. + intros m. + induction n. + rewrite<- plus_n_O. + ring_simplify (sum m + (/ 2) ^ m - (/ 2) ^ m). + split ; apply Rle_refl. + rewrite <- plus_n_Sm. + simpl. + split. + apply Rle_trans with (sum (m + n)%nat + 0). + rewrite Rplus_0_r. + apply IHn. + apply Rplus_le_compat_l. + case (test (m + n)%nat). + apply Rlt_le. + exact (Hi2pn (S (m + n))). + apply Rle_refl. + apply Rle_trans with (sum (m + n)%nat + / 2 * (/ 2) ^ (m + n)). + apply Rplus_le_compat_l. + case (test (m + n)%nat). + apply Rle_refl. + apply Rlt_le. + exact (Hi2pn (S (m + n))). + apply Rplus_le_reg_r with (-(/ 2 * (/ 2) ^ (m + n))). + rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r. + apply Rle_trans with (1 := proj2 IHn). + apply Req_le. + field. + + assert (Hsum: forall n, 0 <= sum n <= 1 - (/2)^n). + intros N. + generalize (Hsum' O N). + simpl. + now rewrite Rplus_0_l. + + destruct (completeness (fun x : R => exists n : nat, x = sum n)) as (m, (Hm1, Hm2)). + exists 1. + intros x (n, H1). + rewrite H1. + apply Rle_trans with (1 := proj2 (Hsum n)). + apply Rlt_le. + apply Rplus_lt_reg_r with ((/2)^n - 1). + now ring_simplify. + exists 0. now exists O. + + destruct (Rle_or_lt m 0) as [[Hm|Hm]|Hm]. + elim Rlt_not_le with (1 := Hm). + apply Hm1. + now exists O. + + assert (Hs0: forall n, sum n = 0). + intros n. + specialize (Hm1 (sum n) (ex_intro _ _ (refl_equal _))). + apply Rle_antisym with (2 := proj1 (Hsum n)). + now rewrite <- Hm. + + assert (Hub: forall n, Un n <= l - eps). + intros n. + generalize (refl_equal (sum (S n))). + simpl sum at 1. + rewrite 2!Hs0, Rplus_0_l. + unfold test. + destruct Rle_lt_dec. easy. + intros H'. + elim Rgt_not_eq with (2 := H'). + exact (Hi2pn (S n)). + + clear -Heps H Hub. + destruct H as (_, H). + refine (False_ind _ (Rle_not_lt _ _ (H (l - eps) _) _)). + intros x (n, H1). + now rewrite H1. + apply Rplus_lt_reg_r with (eps - l). + now ring_simplify. + + assert (Rabs (/2) < 1). + rewrite Rabs_pos_eq. + rewrite <- Rinv_1 at 3. + apply Rinv_lt_contravar. + rewrite Rmult_1_l. + now apply (IZR_lt 0 2). + now apply (IZR_lt 1 2). + apply Rlt_le. + apply Rinv_0_lt_compat. + now apply (IZR_lt 0 2). + destruct (pow_lt_1_zero (/2) H0 m Hm) as [N H4]. + exists N. + apply Rnot_le_lt. + intros H5. + apply Rlt_not_le with (1 := H4 _ (le_refl _)). + rewrite Rabs_pos_eq. 2: now apply Rlt_le. + apply Hm2. + intros x (n, H6). + rewrite H6. clear x H6. + + assert (Hs: sum N = 0). + clear H4. + induction N. + easy. + simpl. + assert (H6: Un N <= l - eps). + apply Rle_trans with (2 := H5). + apply Rge_le. + apply growing_prop ; try easy. + apply le_n_Sn. + rewrite (IHN H6), Rplus_0_l. + unfold test. + destruct Rle_lt_dec. + apply refl_equal. + now elim Rlt_not_le with (1 := r). + + destruct (le_or_lt N n) as [Hn|Hn]. + rewrite le_plus_minus with (1 := Hn). + apply Rle_trans with (1 := proj2 (Hsum' N (n - N)%nat)). + rewrite Hs, Rplus_0_l. + set (k := (N + (n - N))%nat). + apply Rlt_le. + apply Rplus_lt_reg_r with ((/2)^k - (/2)^N). + now ring_simplify. + apply Rle_trans with (sum N). + rewrite le_plus_minus with (1 := Hn). + rewrite plus_Snm_nSm. + exact (proj1 (Hsum' _ _)). + rewrite Hs. + now apply Rlt_le. + Qed. -(** classical is needed: [not_all_not_ex] *) (*********) Lemma Un_cv_crit : Un_growing -> bound EUn -> exists l : R, Un_cv l. Proof. - unfold Un_growing, Un_cv in |- *; intros; - generalize (completeness_weak EUn H0 EUn_noempty); - intro; elim H1; clear H1; intros; split with x; intros; - unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1; - elim H0; clear H0; intros; elim H1; clear H1; intros; - generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); - intro. - cut (exists N : nat, x - eps < Un N). - intro; elim H6; clear H6; intros; split with x1. - intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps). - unfold Rgt in H2; - apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2). - fold Un_growing in H; generalize (growing_prop n x1 H H7); intro; - generalize - (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8)); - intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9); - unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps)); - rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *; - rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2); - trivial. - cut (~ (forall N:nat, x - eps >= Un N)). - intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *; - intro; red in H6; elim H6; clear H6; intro; - apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)). - red in |- *; intro; cut (forall N:nat, Un N <= x - eps). - intro; generalize (Un_bound_imp (x - eps) H7); intro; - unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); - intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *; - rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; - rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); - rewrite Ropp_involutive; intro; unfold Rgt in H2; - generalize (Rgt_not_le eps 0 H2); intro; auto. - intro; elim (H6 N); intro; unfold Rle in |- *. - left; unfold Rgt in H7; assumption. - right; auto. - apply (H1 (Un n) (Un_in_EUn n)). + intros Hug Heub. + exists (projT1 (completeness EUn Heub EUn_noempty)). + destruct (completeness EUn Heub EUn_noempty) as (l, H). + now apply Un_cv_crit_lub. Qed. (*********) diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index fad19ed2..0027c274 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsigma.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index f2095982..7c3b4699 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsqrt_def.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Sumbool. Require Import Rbase. Require Import Rfunctions. @@ -15,7 +13,7 @@ Require Import SeqSeries. Require Import Ranalysis1. Open Local Scope R_scope. -Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := +Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := match N with | O => x | S n => @@ -56,7 +54,7 @@ Proof. assumption. unfold Rdiv in |- *; apply Rmult_le_reg_l with 2. prove_sup0. - pattern 2 at 3 in |- *; rewrite Rmult_comm. + rewrite Rmult_comm. rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ]. rewrite Rmult_1_r. rewrite double. @@ -95,7 +93,7 @@ Proof. case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)). unfold Rdiv in |- *; apply Rmult_le_reg_l with 2. prove_sup0. - pattern 2 at 3 in |- *; rewrite Rmult_comm. + rewrite Rmult_comm. rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ]. rewrite Rmult_1_r. rewrite double. @@ -120,7 +118,7 @@ Proof. assumption. unfold Rdiv in |- *; apply Rmult_le_reg_l with 2. prove_sup0. - pattern 2 at 3 in |- *; rewrite Rmult_comm. + rewrite Rmult_comm. rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ]. rewrite double; apply Rplus_le_compat. assumption. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 8e9b2bb3..f1142d24 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtopology.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 3499ea24..e45353b5 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. @@ -18,7 +16,6 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. -Require Import Classical_Prop. Local Open Scope nat_scope. Local Open Scope R_scope. @@ -372,7 +369,11 @@ Qed. Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0. Proof. - intro; apply not_and_or; apply cos_sin_0. + intros x. + destruct (Req_dec (cos x) 0). 2: now left. + right. intros H'. + apply (cos_sin_0 x). + now split. Qed. (*****************************************************************) diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index de984415..3ab7d598 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_alt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index e5263f9c..587c2424 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_calc.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. @@ -56,7 +54,7 @@ Proof with trivial. unfold Rdiv in |- *; repeat rewrite Rmult_assoc... rewrite <- Rinv_l_sym... rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; + rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... ring... Qed. @@ -73,7 +71,7 @@ Proof with trivial. unfold Rdiv in |- *; repeat rewrite Rmult_assoc... rewrite <- Rinv_l_sym... rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym... - pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; + rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r; repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym... ring... Qed. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 417cf13c..c6493135 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -1,18 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_def.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import Rbase. -Require Import Rfunctions. -Require Import SeqSeries. -Require Import Rtrigo_fun. -Require Import Max. +Require Import Rbase Rfunctions SeqSeries Rtrigo_fun Max. Open Local Scope R_scope. (********************************) diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index 2ed86abe..b7720141 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_fun.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 59afec88..100e0818 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 7a1319ea..75c57401 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -1,17 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqProp.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Rseries. -Require Import Classical. Require Import Max. Open Local Scope R_scope. @@ -29,31 +26,10 @@ Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)). Lemma growing_cv : forall Un:nat -> R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }. Proof. - unfold Un_growing, Un_cv in |- *; intros; - destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]]. - exists x; intros eps H1. - unfold is_upper_bound in H2, H3. - assert (H5 : forall n:nat, Un n <= x). - intro n; apply (H2 (Un n) (Un_in_EUn Un n)). - cut (exists N : nat, x - eps < Un N). - intro H6; destruct H6 as [N H6]; exists N. - intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps). - unfold Rgt in H1. - apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1). - fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8. - generalize - (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8)); - intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9); - unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps)); - rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *; - rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2); - trivial. - cut (~ (forall N:nat, Un N <= x - eps)). - intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)). - intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7. - intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8; - unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); - apply Rlt_not_le; apply tech_Rgt_minus; exact H1. + intros Un Hug Heub. + exists (projT1 (completeness (EUn Un) Heub (EUn_noempty Un))). + destruct (completeness _ Heub (EUn_noempty Un)) as (l, H). + now apply Un_cv_crit_lub. Qed. Lemma decreasing_growing : @@ -518,68 +494,77 @@ Lemma approx_maj : forall (Un:nat -> R) (pr:has_ub Un) (eps:R), 0 < eps -> exists k : nat, Rabs (lub Un pr - Un k) < eps. Proof. - intros. - set (P := fun k:nat => Rabs (lub Un pr - Un k) < eps). - unfold P in |- *. - cut - ((exists k : nat, P k) -> - exists k : nat, Rabs (lub Un pr - Un k) < eps). - intros. - apply H0. - apply not_all_not_ex. - red in |- *; intro. - 2: unfold P in |- *; trivial. - unfold P in H1. - cut (forall n:nat, Rabs (lub Un pr - Un n) >= eps). - intro. - cut (is_lub (EUn Un) (lub Un pr)). - intro. - unfold is_lub in H3. - unfold is_upper_bound in H3. - elim H3; intros. - cut (forall n:nat, eps <= lub Un pr - Un n). - intro. - cut (forall n:nat, Un n <= lub Un pr - eps). - intro. - cut (forall x:R, EUn Un x -> x <= lub Un pr - eps). - intro. - assert (H9 := H5 (lub Un pr - eps) H8). - cut (eps <= 0). - intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)). - apply Rplus_le_reg_l with (lub Un pr - eps). - rewrite Rplus_0_r. - replace (lub Un pr - eps + eps) with (lub Un pr); - [ assumption | ring ]. - intros. - unfold EUn in H8. - elim H8; intros. - rewrite H9; apply H7. - intro. - assert (H7 := H6 n). - apply Rplus_le_reg_l with (eps - Un n). - replace (eps - Un n + Un n) with eps. - replace (eps - Un n + (lub Un pr - eps)) with (lub Un pr - Un n). - assumption. - ring. - ring. - intro. - assert (H6 := H2 n). - rewrite Rabs_right in H6. - apply Rge_le. - assumption. - apply Rle_ge. - apply Rplus_le_reg_l with (Un n). - rewrite Rplus_0_r; - replace (Un n + (lub Un pr - Un n)) with (lub Un pr); - [ apply H4 | ring ]. - exists n; reflexivity. - unfold lub in |- *. - case (ub_to_lub Un pr). - trivial. - intro. - assert (H2 := H1 n). - apply not_Rlt; assumption. + intros Un pr. + pose (Vn := fix aux n := match n with S n' => if Rle_lt_dec (aux n') (Un n) then Un n else aux n' | O => Un O end). + pose (In := fix aux n := match n with S n' => if Rle_lt_dec (Vn n) (Un n) then n else aux n' | O => O end). + + assert (VUI: forall n, Vn n = Un (In n)). + induction n. + easy. + simpl. + destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1]. + destruct (Rle_lt_dec (Un (S n)) (Un (S n))) as [H2|H2]. + easy. + elim (Rlt_irrefl _ H2). + destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H2|H2]. + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 H1)). + exact IHn. + + assert (HubV : has_ub Vn). + destruct pr as (ub, Hub). + exists ub. + intros x (n, Hn). + rewrite Hn, VUI. + apply Hub. + now exists (In n). + + assert (HgrV : Un_growing Vn). + intros n. + induction n. + simpl. + destruct (Rle_lt_dec (Un O) (Un 1%nat)) as [H|_]. + exact H. + apply Rle_refl. + simpl. + destruct (Rle_lt_dec (Vn n) (Un (S n))) as [H1|H1]. + destruct (Rle_lt_dec (Un (S n)) (Un (S (S n)))) as [H2|H2]. + exact H2. + apply Rle_refl. + destruct (Rle_lt_dec (Vn n) (Un (S (S n)))) as [H2|H2]. + exact H2. + apply Rle_refl. + + destruct (ub_to_lub Vn HubV) as (l, Hl). + unfold lub. + destruct (ub_to_lub Un pr) as (l', Hl'). + replace l' with l. + intros eps Heps. + destruct (Un_cv_crit_lub Vn HgrV l Hl eps Heps) as (n, Hn). + exists (In n). + rewrite <- VUI. + rewrite Rabs_minus_sym. + apply Hn. + apply le_refl. + + apply Rle_antisym. + apply Hl. + intros n (k, Hk). + rewrite Hk, VUI. + apply Hl'. + now exists (In k). + apply Hl'. + intros n (k, Hk). + rewrite Hk. + apply Rle_trans with (Vn k). + clear. + induction k. + apply Rle_refl. + simpl. + destruct (Rle_lt_dec (Vn k) (Un (S k))) as [H|H]. + apply Rle_refl. + now apply Rlt_le. + apply Hl. + now exists k. Qed. (**********) @@ -587,72 +572,23 @@ Lemma approx_min : forall (Un:nat -> R) (pr:has_lb Un) (eps:R), 0 < eps -> exists k : nat, Rabs (glb Un pr - Un k) < eps. Proof. - intros. - set (P := fun k:nat => Rabs (glb Un pr - Un k) < eps). - unfold P in |- *. - cut - ((exists k : nat, P k) -> - exists k : nat, Rabs (glb Un pr - Un k) < eps). - intros. - apply H0. - apply not_all_not_ex. - red in |- *; intro. - 2: unfold P in |- *; trivial. - unfold P in H1. - cut (forall n:nat, Rabs (glb Un pr - Un n) >= eps). - intro. - cut (is_lub (EUn (opp_seq Un)) (- glb Un pr)). - intro. - unfold is_lub in H3. - unfold is_upper_bound in H3. - elim H3; intros. - cut (forall n:nat, eps <= Un n - glb Un pr). - intro. - cut (forall n:nat, opp_seq Un n <= - glb Un pr - eps). - intro. - cut (forall x:R, EUn (opp_seq Un) x -> x <= - glb Un pr - eps). - intro. - assert (H9 := H5 (- glb Un pr - eps) H8). - cut (eps <= 0). - intro. - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)). - apply Rplus_le_reg_l with (- glb Un pr - eps). - rewrite Rplus_0_r. - replace (- glb Un pr - eps + eps) with (- glb Un pr); - [ assumption | ring ]. - intros. - unfold EUn in H8. - elim H8; intros. - rewrite H9; apply H7. - intro. - assert (H7 := H6 n). - unfold opp_seq in |- *. - apply Rplus_le_reg_l with (eps + Un n). - replace (eps + Un n + - Un n) with eps. - replace (eps + Un n + (- glb Un pr - eps)) with (Un n - glb Un pr). - assumption. - ring. - ring. - intro. - assert (H6 := H2 n). - rewrite Rabs_left1 in H6. - apply Rge_le. - replace (Un n - glb Un pr) with (- (glb Un pr - Un n)); - [ assumption | ring ]. - apply Rplus_le_reg_l with (- glb Un pr). - rewrite Rplus_0_r; - replace (- glb Un pr + (glb Un pr - Un n)) with (- Un n). - apply H4. - exists n; reflexivity. - ring. - unfold glb in |- *. - case (lb_to_glb Un pr); simpl. - intro. - rewrite Ropp_involutive. - trivial. - intro. - assert (H2 := H1 n). - apply not_Rlt; assumption. + intros Un pr. + unfold glb. + destruct lb_to_glb as (lb, Hlb). + intros eps Heps. + destruct (approx_maj _ pr eps Heps) as (n, Hn). + exists n. + unfold Rminus. + rewrite <- Ropp_plus_distr, Rabs_Ropp. + replace lb with (lub (opp_seq Un) pr). + now rewrite <- (Ropp_involutive (Un n)). + unfold lub. + destruct ub_to_lub as (ub, Hub). + apply Rle_antisym. + apply Hub. + apply Hlb. + apply Hlb. + apply Hub. Qed. (** Unicity of limit for convergent sequences *) @@ -910,73 +846,6 @@ Proof. left; assumption. Qed. -Lemma tech10 : - forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x. -Proof. - intros; cut (bound (EUn Un)). - intro; assert (H2 := Un_cv_crit _ H H1). - elim H2; intros. - case (total_order_T x x0); intro. - elim s; intro. - cut (forall n:nat, Un n <= x). - intro; unfold Un_cv in H3; cut (0 < x0 - x). - intro; elim (H3 (x0 - x) H5); intros. - cut (x1 >= x1)%nat. - intro; assert (H8 := H6 x1 H7). - unfold R_dist in H8; rewrite Rabs_left1 in H8. - rewrite Ropp_minus_distr in H8; unfold Rminus in H8. - assert (H9 := Rplus_lt_reg_r x0 _ _ H8). - assert (H10 := Ropp_lt_cancel _ _ H9). - assert (H11 := H4 x1). - elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)). - apply Rle_minus; apply Rle_trans with x. - apply H4. - left; assumption. - unfold ge in |- *; apply le_n. - apply Rgt_minus; assumption. - intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros. - apply H4; unfold EUn in |- *; exists n; reflexivity. - rewrite b; assumption. - cut (forall n:nat, Un n <= x0). - intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros. - cut (forall y:R, EUn Un y -> y <= x0). - intro; assert (H8 := H6 _ H7). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)). - unfold EUn in |- *; intros; elim H7; intros. - rewrite H8; apply H4. - intro; case (Rle_dec (Un n) x0); intro. - assumption. - cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0). - intro; unfold Un_cv in H3; cut (0 < Un n - x0). - intro; elim (H3 (Un n - x0) H5); intros. - cut (max n x1 >= x1)%nat. - intro; assert (H8 := H6 (max n x1) H7). - unfold R_dist in H8. - rewrite Rabs_right in H8. - unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8. - assert (H9 := Rplus_lt_reg_r _ _ _ H8). - cut (Un n <= Un (max n x1)). - intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)). - apply tech9; [ assumption | apply le_max_l ]. - apply Rge_trans with (Un n - x0). - unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0)); - apply Rplus_le_compat_l. - apply tech9; [ assumption | apply le_max_l ]. - left; assumption. - unfold ge in |- *; apply le_max_r. - apply Rplus_lt_reg_r with x0. - rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; - apply H4; apply le_n. - intros; apply Rlt_le_trans with (Un n). - case (Rlt_le_dec x0 (Un n)); intro. - assumption. - elim n0; assumption. - apply tech9; assumption. - unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros; - assumption. -Qed. - Lemma tech13 : forall (An:nat -> R) (k:R), 0 <= k < 1 -> diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 4725fe57..0d876be5 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqSeries.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Max. diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index 67af68d1..819606c4 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitAbsolu.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbasic_fun. Ltac split_case_Rabs := diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index 85a2cdd0..e554913c 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitRmult.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index 79f39892..d00ed178 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sqrt_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 26c8ef59..f7f5512e 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Operators_Properties.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (************************************************************************) (** * Some properties of the operators on relations *) (************************************************************************) @@ -19,17 +17,17 @@ Require Import Relation_Operators. Section Properties. - Implicit Arguments clos_refl_trans [A]. - Implicit Arguments clos_refl_trans_1n [A]. - Implicit Arguments clos_refl_trans_n1 [A]. - Implicit Arguments clos_refl_sym_trans [A]. - Implicit Arguments clos_refl_sym_trans_1n [A]. - Implicit Arguments clos_refl_sym_trans_n1 [A]. - Implicit Arguments clos_trans [A]. - Implicit Arguments clos_trans_1n [A]. - Implicit Arguments clos_trans_n1 [A]. - Implicit Arguments inclusion [A]. - Implicit Arguments preorder [A]. + Arguments clos_refl_trans [A] R x _. + Arguments clos_refl_trans_1n [A] R x _. + Arguments clos_refl_trans_n1 [A] R x _. + Arguments clos_refl_sym_trans [A] R _ _. + Arguments clos_refl_sym_trans_1n [A] R x _. + Arguments clos_refl_sym_trans_n1 [A] R x _. + Arguments clos_trans [A] R x _. + Arguments clos_trans_1n [A] R x _. + Arguments clos_trans_n1 [A] R x _. + Arguments inclusion [A] R1 R2. + Arguments preorder [A] R. Variable A : Type. Variable R : relation A. diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 0d901445..a84c1310 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Definitions.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Section Relation_Definition. Variable A : Type. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 6efebc46..abf23997 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -1,25 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Operators.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (************************************************************************) -(** * Bruno Barras, Cristina Cornes *) +(** * Some operators on relations *) +(************************************************************************) +(** * Initial authors: Bruno Barras, Cristina Cornes *) (** * *) -(** * Some of these definitions were taken from : *) +(** * Some of the initial definitions were taken from : *) (** * Constructing Recursion Operators in Type Theory *) (** * L. Paulson JSC (1986) 2, 325-355 *) +(** * *) +(** * Further extensions by Pierre Castéran *) (************************************************************************) Require Import Relation_Definitions. -(** * Some operators to build relations *) - (** ** Transitive closure *) Section Transitive_Closure. diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 630b2822..f9fb2c44 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relations.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relation_Definitions. Require Export Relation_Operators. Require Export Operators_Properties. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 90362da0..f5677005 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v 14641 2011-11-06 11:59:10Z herbelin $: i*) - Require Export Coq.Classes.SetoidTactics. Export Morphisms.ProperNotations. diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 701d9f8a..f93631c7 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Classical_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Constructive_sets. Require Export Classical_Type. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index d3900446..e6dd8381 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Constructive_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Section Ensembles_facts. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index c7b496cb..d612e71e 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Cpo.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Relations_1. Require Export Partial_Order. @@ -107,4 +105,4 @@ Section Specific_orders. {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. -End Specific_orders.
\ No newline at end of file +End Specific_orders. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index 6c80ad40..58b979dd 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Ensembles.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Section Ensembles. Variable U : Type. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index 09a0a94d..f0843675 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Ensembles. Section Ensembles_finis. diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index a9fe8ffe..350cd783 100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Finite_sets. Require Export Constructive_sets. Require Export Classical_Type. @@ -175,14 +173,14 @@ Section Finite_sets_facts. clear H'2 c2 Y. intros X0 c2 H'2 H'3 x0 H'4 H'5. elim (classic (In U X0 x)). - intro H'6; apply f_equal with nat. + intro H'6; apply f_equal. apply H'0 with (Y := Subtract U (Add U X0 x0) x). elimtype (pred (S c2) = c2); auto with sets. apply card_soustr_1; auto with sets. rewrite <- H'5. apply Sub_Add_new; auto with sets. elim (classic (x = x0)). - intros H'6 H'7; apply f_equal with nat. + intros H'6 H'7; apply f_equal. apply H'0 with (Y := X0); auto with sets. apply Simplify_add with (x := x); auto with sets. pattern x at 2 in |- *; rewrite H'6; auto with sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index e5eae17e..24facb6f 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Image.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Finite_sets. Require Export Constructive_sets. Require Export Classical_Type. @@ -202,4 +200,4 @@ Section Image. End Image. -Hint Resolve Im_def image_empty finite_image: sets v62.
\ No newline at end of file +Hint Resolve Im_def image_empty finite_image: sets v62. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index afb9e0e1..a21fe880 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Infinite_sets.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Finite_sets. Require Export Constructive_sets. Require Export Classical_Type. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index 5d073a0c..2c94a2e1 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Integers.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Finite_sets. Require Export Constructive_sets. Require Export Classical_Type. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 6187c08b..5f21335f 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Multiset.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* G. Huet 1-9-95 *) Require Import Permut Setoid. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index e819cafa..a319b983 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Partial_Order.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Relations_1. @@ -99,4 +97,4 @@ Section Partial_order_facts. apply Strict_Rel_Transitive_with_Rel with (y := y); [ intuition | unfold Strict_Rel_of in H', H'0; intuition ]. Qed. -End Partial_order_facts.
\ No newline at end of file +End Partial_order_facts. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 8699eed3..e28a1264 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permut.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* G. Huet 1-9-95 *) (** We consider a Set [U], given with a commutative-associative operator [op], @@ -86,4 +84,4 @@ Section Axiomatisation. apply cong_left; apply perm_left. Qed. -End Axiomatisation.
\ No newline at end of file +End Axiomatisation. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 372473d6..f8b24e74 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Relations_1. Require Export Relations_1_facts. @@ -187,4 +185,4 @@ Hint Resolve Union_increases_r: sets v62. Hint Resolve Intersection_decreases_l: sets v62. Hint Resolve Intersection_decreases_r: sets v62. Hint Resolve Empty_set_is_Bottom: sets v62. -Hint Resolve Strict_inclusion_is_transitive: sets v62.
\ No newline at end of file +Hint Resolve Strict_inclusion_is_transitive: sets v62. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 66c0c0bb..09fc2094 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_Classical_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Constructive_sets. Require Export Relations_1. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 09edd08a..f756f985 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Ensembles. Require Export Constructive_sets. Require Export Relations_1. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 2818b370..a7fbb53d 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Section Relations_1. Variable U : Type. @@ -64,4 +62,4 @@ End Relations_1. Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets v62. Hint Resolve Definition_of_preorder Definition_of_order - Definition_of_equivalence Definition_of_PER: sets v62.
\ No newline at end of file + Definition_of_equivalence Definition_of_PER: sets v62. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index f002e926..0c8329dd 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relations_1. Definition Complement (U:Type) (R:Relation U) : Relation U := @@ -109,4 +107,4 @@ intros U R R' H' H'0; red in |- *. 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.
\ No newline at end of file +Qed. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index 710bff2b..e7a69c99 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relations_1. Section Relations_2. @@ -53,4 +51,4 @@ End Relations_2. Hint Resolve Rstar_0: sets v62. Hint Resolve Rstar1_0: sets v62. Hint Resolve Rstar1_1: sets v62. -Hint Resolve Rplus_0: sets v62.
\ No newline at end of file +Hint Resolve Rplus_0: sets v62. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 5ccdcb11..89b98c1f 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relations_1. Require Export Relations_1_facts. Require Export Relations_2. @@ -150,4 +148,4 @@ 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.
\ No newline at end of file +Qed. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 1f96a75a..51092f7a 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relations_1. Require Export Relations_2. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 3a69a231..8ac6e7fb 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,8 +24,6 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Relations_1. Require Export Relations_1_facts. Require Export Relations_2. @@ -168,4 +166,4 @@ generalize (H'2 v); intro h; lapply h; red in |- *; (exists z1; split); auto with sets. apply T with y1; auto with sets. apply T with t; auto with sets. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 48789f9a..bf1aaf8d 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Uniset.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Sets as characteristic functions *) (* G. Huet 1-9-95 *) @@ -212,4 +210,4 @@ i*) End defs. -Unset Implicit Arguments.
\ No newline at end of file +Unset Implicit Arguments. diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 76080aa9..60bb50ce 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Heap.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file is deprecated, for a tree on list, use [Mergesort.v]. *) (** A development of Treesort on Heap trees. It has an average diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index cded23ea..7124cd53 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mergesort.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** A modular implementation of mergesort (the complexity is O(n.log n) in the length of the list) *) diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index 00d6e7ce..d4e5fba4 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutEq.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation. Set Implicit Arguments. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 87b0b08d..fa807c15 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutSetoid.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Omega Relations Multiset SetoidList. (** This file is deprecated, use [Permutation.v] instead. @@ -344,8 +342,7 @@ Proof. rewrite if_eqA_refl in H. clear IHl; omega. rewrite IHl; intros. - specialize (H a0); auto with *. - destruct (eqA_dec a a0); simpl; auto with *. + specialize (H a0). omega. Qed. (** Permutation is compatible with InA. *) @@ -396,18 +393,14 @@ Proof. apply permut_length_1. red; red; intros. specialize (P a). simpl in *. - rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. - (** Bug omega: le "set" suivant ne devrait pas etre necessaire *) - set (u:= if eqA_dec a2 a then 1 else 0) in *; omega. + rewrite (@if_eqA_rewrite_l a1 a2 a) in P by auto. omega. 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. - (** Bug omega: idem *) - set (u:= if eqA_dec b2 a then 1 else 0) in *; omega. + rewrite (@if_eqA_rewrite_l a1 b2 a) in P by auto. omega. Qed. (** Permutation is compatible with length. *) @@ -492,7 +485,7 @@ Qed. End Permut_map. -Require Import Permutation TheoryList. +Require Import Permutation. Section Permut_permut. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 7508ccc2..797583d0 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -1,15 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permutation.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*********************************************************************) -(** ** List permutations as a composition of adjacent transpositions *) +(** * List permutations as a composition of adjacent transpositions *) (*********************************************************************) (* Adapted in May 2006 by Jean-Marc Notin from initial contents by @@ -139,32 +137,26 @@ 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. + 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. - induction l' as [|y l']; simpl. - rewrite app_nil_r; trivial. - transitivity (x :: y :: l' ++ l). - constructor; rewrite app_comm_cons; apply IHl. - transitivity (y :: x :: l' ++ l); constructor. - transitivity (x :: l ++ l'); auto. + 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. 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; revert l. - induction l1. - simpl. - intros; apply perm_skip; auto. - simpl; intros. - transitivity (a0::a::l1++l2). - apply perm_skip; auto. - transitivity (a::a0::l1++l2). - apply perm_swap; auto. - apply perm_skip; auto. +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. @@ -173,19 +165,20 @@ Theorem Permutation_middle : forall (l1 l2:list A) a, Proof. auto. Qed. +Local Hint Resolve Permutation_middle. Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. - induction l as [| x l]; simpl; trivial. - apply Permutation_trans with (l' := [x] ++ rev l). - simpl; auto. - apply Permutation_app_comm. + induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. Qed. +Add Parametric Morphism : (@rev A) + with signature @Permutation A ==> @Permutation A as Permutation_rev'. +Proof. intros. now do 2 rewrite <- 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. - apply trans_eq with (y:= (length l')); trivial. + intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l'). Qed. Theorem Permutation_ind_bis : @@ -211,6 +204,12 @@ Ltac break_list l x l' H := destruct l as [|x l']; simpl in *; injection H; intros; subst; clear H. +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. + Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a, Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). Proof. @@ -224,32 +223,27 @@ Proof. (* skip *) intros x l l' H IH; intros. break_list l1 b l1' H0; break_list l3 c l3' H1. - auto. - apply perm_trans with (l3'++c::l4); auto. - apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app. - apply perm_skip. - apply (IH a l1' l2 l3' l4); auto. + auto. + now rewrite H. + now rewrite <- H. + now rewrite (IH a _ _ _ _ eq_refl eq_refl). (* contradict *) intros x y l l' Hp IH; intros. break_list l1 b l1' H; break_list l3 c l3' H0. auto. break_list l3' b l3'' H. - auto. - apply perm_trans with (c::l3''++b::l4); auto. + auto. + rewrite <- Permutation_middle in Hp. now rewrite Hp. break_list l1' c l1'' H1. - auto. - apply perm_trans with (b::l1''++c::l2); auto. + auto. + rewrite <- Permutation_middle in Hp. now rewrite Hp. break_list l3' d l3'' H; break_list l1' e l1'' H1. auto. - apply perm_trans with (e::a::l1''++l2); auto. - apply perm_trans with (e::l1''++a::l2); auto. - apply perm_trans with (d::a::l3''++l4); auto. - apply perm_trans with (d::l3''++a::l4); auto. - apply perm_trans with (e::d::l1''++l2); auto. - apply perm_skip; apply perm_skip. - apply (IH a l1'' l2 l3'' l4); auto. + rewrite <- Permutation_middle in Hp. rewrite perm_swap. auto. + rewrite perm_swap, Permutation_middle. auto. + now rewrite perm_swap, (IH a _ _ _ _ eq_refl eq_refl). (*trans*) - intros. + intros. destruct (In_split a l') as (l'1,(l'2,H6)). apply (Permutation_in a H). subst l. @@ -375,4 +369,4 @@ End Permutation_map. (* begin hide *) Notation Permutation_app_swap := Permutation_app_comm (only parsing). -(* end hide *) +(* end hide *)
\ No newline at end of file diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 2c7c07e5..0e230b77 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sorted.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* Made by Hugo Herbelin *) (** This file defines two notions of sorted list: @@ -27,7 +25,7 @@ Require Import List Relations Relations_1. Set Implicit Arguments. Local Notation "[ ]" := nil (at level 0). Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) (at level 0). -Implicit Arguments Transitive [U]. +Arguments Transitive [U] R. Section defs. diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index bc1fdbcf..22e56592 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sorting.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Sorted. Require Export Mergesort. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 4204456f..1ed9140a 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ascii.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) diff --git a/theories/Strings/String.v b/theories/Strings/String.v index c26b8818..958ecd4f 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: String.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) @@ -252,12 +250,12 @@ case H0; simpl in |- *; auto. case m; simpl in |- *; auto. case (index 0 s1 s2'); intros; discriminate. intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. -intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto. +intros x H H0 H1; apply H; injection H1; auto. intros; discriminate. intros n'; case m; simpl in |- *; 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; intros H2; injection H2; auto. +intros x H H1; apply H; injection H1; auto. intros; discriminate. Qed. @@ -290,7 +288,7 @@ intros x H H0 H1 p; try case p; simpl in |- *; auto. intros H2 H3; red in |- *; intros H4; case H0. intros H5 H6; absurd (false = true); auto with bool. intros n0 H2 H3; apply H; auto. -injection H1; intros H4; injection H4; auto. +injection H1; auto. apply Le.le_O_n. apply Lt.lt_S_n; auto. intros; discriminate. @@ -300,7 +298,7 @@ intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. intros x H H0 p; case p; simpl in |- *; auto. intros H1; inversion H1; auto. intros n0 H1 H2; apply H; auto. -injection H0; intros H3; injection H3; auto. +injection H0; auto. apply Le.le_S_n; auto. apply Lt.lt_S_n; auto. intros; discriminate. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 18153436..79e81771 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableType.v 12641 2010-01-07 15:32:52Z letouzey $ *) - Require Export SetoidList. Require Equalities. diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v index ac1f014b..2c02f8dd 100644 --- a/theories/Structures/DecidableTypeEx.v +++ b/theories/Structures/DecidableTypeEx.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableTypeEx.v 12641 2010-01-07 15:32:52Z letouzey $ *) - Require Import DecidableType OrderedType OrderedTypeEx. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 382511d9..eb537385 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -6,23 +6,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: Equalities.v 13475 2010-09-29 14:33:13Z letouzey $ *) - Require Export RelationClasses. +Require Import Bool Morphisms Setoid. Set Implicit Arguments. Unset Strict Implicit. +(** Structure with nothing inside. + Used to force a module type T into a module via Nop <+ T. (HACK!) *) + +Module Type Nop. +End Nop. + (** * Structure with just a base type [t] *) Module Type Typ. - Parameter Inline t : Type. + Parameter Inline(10) t : Type. End Typ. (** * Structure with an equality relation [eq] *) Module Type HasEq (Import T:Typ). - Parameter Inline eq : t -> t -> Prop. + Parameter Inline(30) eq : t -> t -> Prop. End HasEq. Module Type Eq := Typ <+ HasEq. @@ -61,10 +66,19 @@ End HasEqDec. (** Having [eq_dec] is the same as having a boolean equality plus a correctness proof. *) -Module Type HasEqBool (Import E:Eq'). +Module Type HasEqb (Import T:Typ). Parameter Inline eqb : t -> t -> bool. - Parameter eqb_eq : forall x y, eqb x y = true <-> x==y. -End HasEqBool. +End HasEqb. + +Module Type EqbSpec (T:Typ)(X:HasEq T)(Y:HasEqb T). + Parameter eqb_eq : forall x y, Y.eqb x y = true <-> X.eq x y. +End EqbSpec. + +Module Type EqbNotation (T:Typ)(E:HasEqb T). + Infix "=?" := E.eqb (at level 70, no associativity). +End EqbNotation. + +Module Type HasEqBool (E:Eq) := HasEqb E <+ EqbSpec E E. (** From these basic blocks, we can build many combinations of static standalone module types. *) @@ -102,8 +116,10 @@ Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation. Module Type DecidableType' := DecidableType <+ EqNotation. Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation. Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation. -Module Type BooleanEqualityType' := BooleanEqualityType <+ EqNotation. -Module Type BooleanDecidableType' := BooleanDecidableType <+ EqNotation. +Module Type BooleanEqualityType' := + BooleanEqualityType <+ EqNotation <+ EqbNotation. +Module Type BooleanDecidableType' := + BooleanDecidableType <+ EqNotation <+ EqbNotation. Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation. (** * Compatibility wrapper from/to the old version of @@ -162,6 +178,49 @@ Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType := E <+ HasEqBool2Dec. +(** Some properties of boolean equality *) + +Module BoolEqualityFacts (Import E : BooleanEqualityType'). + +(** [eqb] is compatible with [eq] *) + +Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb. +Proof. +intros x x' Exx' y y' Eyy'. +apply eq_true_iff_eq. +now rewrite 2 eqb_eq, Exx', Eyy'. +Qed. + +(** Alternative specification of [eqb] based on [reflect]. *) + +Lemma eqb_spec x y : reflect (x==y) (x =? y). +Proof. +apply iff_reflect. symmetry. apply eqb_eq. +Defined. + +(** Negated form of [eqb_eq] *) + +Lemma eqb_neq x y : (x =? y) = false <-> x ~= y. +Proof. +now rewrite <- not_true_iff_false, eqb_eq. +Qed. + +(** Basic equality laws for [eqb] *) + +Lemma eqb_refl x : (x =? x) = true. +Proof. +now apply eqb_eq. +Qed. + +Lemma eqb_sym x y : (x =? y) = (y =? x). +Proof. +apply eq_true_iff_eq. now rewrite 2 eqb_eq. +Qed. + +(** Transitivity is a particular case of [eqb_compat] *) + +End BoolEqualityFacts. + (** * UsualDecidableType diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index d9b1d76f..c69885b4 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -8,21 +8,8 @@ Require Import Equalities Bool SetoidList RelationPairs. -(** In a BooleanEqualityType, [eqb] is compatible with [eq] *) - -Module BoolEqualityFacts (Import E : BooleanEqualityType). - -Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb. -Proof. -intros x x' Exx' y y' Eyy'. -apply eq_true_iff_eq. -rewrite 2 eqb_eq, Exx', Eyy'; auto with *. -Qed. - -End BoolEqualityFacts. - - (** * Keys and datas used in FMap *) + Module KeyDecidableType(Import D:DecidableType). Section Elt. @@ -42,9 +29,9 @@ Module KeyDecidableType(Import D:DecidableType). (* eqk, eqke are equalities, ltk is a strict order *) - Global Instance eqk_equiv : Equivalence eqk. + Global Instance eqk_equiv : Equivalence eqk := _. - Global Instance eqke_equiv : Equivalence eqke. + Global Instance eqke_equiv : Equivalence eqke := _. (* Additionnal facts *) @@ -156,7 +143,7 @@ Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. Definition eq := (D1.eq * D2.eq)%signature. - Instance eq_equiv : Equivalence eq. + Instance eq_equiv : Equivalence eq := _. Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. Proof. @@ -172,7 +159,7 @@ End PairDecidableType. Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Definition t := (D1.t * D2.t)%type. Definition eq := @eq t. - Program Instance eq_equiv : Equivalence eq. + Instance eq_equiv : Equivalence eq := _. Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. Proof. intros (x1,x2) (y1,y2); diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 68f20189..5583142f 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -79,7 +79,7 @@ End GenericMinMax. (** ** Consequences of the minimalist interface: facts about [max]. *) Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O). - Module Import T := !MakeOrderTac O. + Module Import Private_Tac := !MakeOrderTac O. (** An alternative caracterisation of [max], equivalent to [max_l /\ max_r] *) @@ -277,8 +277,9 @@ End MaxLogicalProperties. Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). Include MaxLogicalProperties O M. - Import T. + Import Private_Tac. + Module Import Private_Rev. Module ORev := TotalOrderRev O. Module MRev <: HasMax ORev. Definition max x y := M.min y x. @@ -286,6 +287,7 @@ Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). Definition max_r x y := M.min_l y x. End MRev. Module MPRev := MaxLogicalProperties ORev MRev. + End Private_Rev. Instance min_compat : Proper (eq==>eq==>eq) min. Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed. @@ -578,29 +580,29 @@ End UsualMinMaxLogicalProperties. Module UsualMinMaxDecProperties (Import O:UsualOrderedTypeFull')(Import M:HasMinMax O). - Module P := MinMaxDecProperties O M. + Module Import Private_Dec := MinMaxDecProperties O M. Lemma max_case_strong : forall n m (P:t -> Type), (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). - Proof. intros; apply P.max_case_strong; auto. congruence. Defined. + Proof. intros; apply max_case_strong; auto. congruence. Defined. Lemma max_case : forall n m (P:t -> Type), P n -> P m -> P (max n m). Proof. intros; apply max_case_strong; auto. Defined. Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. - Proof. exact P.max_dec. Defined. + Proof. exact max_dec. Defined. Lemma min_case_strong : forall n m (P:O.t -> Type), (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). - Proof. intros; apply P.min_case_strong; auto. congruence. Defined. + Proof. intros; apply min_case_strong; auto. congruence. Defined. Lemma min_case : forall n m (P:O.t -> Type), P n -> P m -> P (min n m). Proof. intros. apply min_case_strong; auto. Defined. Lemma min_dec : forall n m, {min n m = n} + {min n m = m}. - Proof. exact P.min_dec. Defined. + Proof. exact min_dec. Defined. End UsualMinMaxDecProperties. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 57f491d2..f84cdf32 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedType.v 12732 2010-02-10 22:46:59Z letouzey $ *) - Require Export SetoidList Morphisms OrdersTac. Set Implicit Arguments. Unset Strict Implicit. @@ -22,6 +20,10 @@ Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := | EQ : eq x y -> Compare lt eq x y | GT : lt y x -> Compare lt eq x y. +Arguments LT [X lt eq x y] _. +Arguments EQ [X lt eq x y] _. +Arguments GT [X lt eq x y] _. + Module Type MiniOrderedType. Parameter Inline t : Type. @@ -143,7 +145,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma elim_compare_eq : forall x y : t, - eq x y -> exists H : eq x y, compare x y = EQ _ H. + eq x y -> exists H : eq x y, compare x y = EQ H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. @@ -151,7 +153,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma elim_compare_lt : forall x y : t, - lt x y -> exists H : lt x y, compare x y = LT _ H. + lt x y -> exists H : lt x y, compare x y = LT H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. @@ -159,7 +161,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma elim_compare_gt : forall x y : t, - lt y x -> exists H : lt y x, compare x y = GT _ H. + lt y x -> exists H : lt y x, compare x y = GT H. Proof. intros; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. @@ -318,16 +320,13 @@ Module KeyOrderedType(O:OrderedType). Hint Immediate eqk_sym eqke_sym. Global Instance eqk_equiv : Equivalence eqk. - Proof. split; eauto. Qed. + Proof. constructor; eauto. Qed. Global Instance eqke_equiv : Equivalence eqke. Proof. split; eauto. Qed. Global Instance ltk_strorder : StrictOrder ltk. - Proof. - split; eauto. - intros (x,e); compute; apply (StrictOrder_Irreflexive x). - Qed. + Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v index f6c1532b..b054496e 100644 --- a/theories/Structures/OrderedTypeAlt.v +++ b/theories/Structures/OrderedTypeAlt.v @@ -5,8 +5,6 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedTypeAlt.v 12384 2009-10-13 14:39:51Z letouzey $ *) - Require Import OrderedType. (** * An alternative (but equivalent) presentation for an Ordered Type diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 128cd576..adeba9e4 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedTypeEx.v 13297 2010-07-19 23:32:42Z letouzey $ *) - Require Import OrderedType. Require Import ZArith. Require Import Omega. @@ -111,26 +109,18 @@ Module Positive_as_OT <: UsualOrderedType. Definition eq_sym := @sym_eq t. Definition eq_trans := @trans_eq t. - Definition lt p q:= (p ?= q) Eq = Lt. + Definition lt := Plt. - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - unfold lt; intros x y z. - change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z). - omega. - Qed. + Definition lt_trans := Plt_trans. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Proof. - intros; intro. - rewrite H0 in H. - unfold lt in H. - rewrite Pcompare_refl in H; discriminate. + intros x y H. contradict H. rewrite H. apply Plt_irrefl. Qed. Definition compare : forall x y : t, Compare lt eq x y. Proof. - intros x y. destruct ((x ?= y) Eq) as [ | | ]_eqn. + intros x y. destruct (x ?= y) as [ | | ]_eqn. apply EQ; apply Pcompare_Eq_eq; assumption. apply LT; assumption. apply GT; apply ZC1; assumption. @@ -324,10 +314,10 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Lemma eq_dec (x y: positive): {x = y} + {x <> y}. Proof. - intros. case_eq ((x ?= y) Eq); intros. + intros. case_eq (x ?= y); intros. left. apply Pcompare_Eq_eq; auto. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. + right. red. intro. subst y. rewrite (Pos.compare_refl x) in H. discriminate. + right. red. intro. subst y. rewrite (Pos.compare_refl x) in H. discriminate. Qed. End PositiveOrderedTypeBits. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 5567b743..1d025439 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: Orders.v 13276 2010-07-10 14:34:44Z letouzey $ *) - Require Export Relations Morphisms Setoid Equalities. Set Implicit Arguments. Unset Strict Implicit. @@ -67,20 +65,34 @@ Module Type LeIsLtEq (Import E:EqLtLe'). Axiom le_lteq : forall x y, x<=y <-> x<y \/ x==y. End LeIsLtEq. -Module Type HasCompare (Import E:EqLt). +Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder. +Module Type StrOrder' := StrOrder <+ EqLtNotation. + +(** Versions with a decidable ternary comparison *) + +Module Type HasCmp (Import T:Typ). Parameter Inline compare : t -> t -> comparison. - Axiom compare_spec : forall x y, CompSpec eq lt x y (compare x y). -End HasCompare. +End HasCmp. + +Module Type CmpNotation (T:Typ)(C:HasCmp T). + Infix "?=" := C.compare (at level 70, no associativity). +End CmpNotation. + +Module Type CmpSpec (Import E:EqLt')(Import C:HasCmp E). + Axiom compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y). +End CmpSpec. + +Module Type HasCompare (E:EqLt) := HasCmp E <+ CmpSpec E. -Module Type StrOrder := EqualityType <+ HasLt <+ IsStrOrder. Module Type DecStrOrder := StrOrder <+ HasCompare. +Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation <+ CmpNotation. + Module Type OrderedType <: DecidableType := DecStrOrder <+ HasEqDec. -Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq. +Module Type OrderedType' := OrderedType <+ EqLtNotation <+ CmpNotation. -Module Type StrOrder' := StrOrder <+ EqLtNotation. -Module Type DecStrOrder' := DecStrOrder <+ EqLtNotation. -Module Type OrderedType' := OrderedType <+ EqLtNotation. -Module Type OrderedTypeFull' := OrderedTypeFull <+ EqLtLeNotation. +Module Type OrderedTypeFull := OrderedType <+ HasLe <+ LeIsLtEq. +Module Type OrderedTypeFull' := + OrderedTypeFull <+ EqLtLeNotation <+ CmpNotation. (** NB: in [OrderedType], an [eq_dec] could be deduced from [compare]. But adding this redundant field allows to see an [OrderedType] as a @@ -169,50 +181,63 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder Local Coercion is_true : bool >-> Sortclass. Hint Unfold is_true. -Module Type HasLeBool (Import T:Typ). - Parameter Inline leb : t -> t -> bool. -End HasLeBool. - -Module Type HasLtBool (Import T:Typ). - Parameter Inline ltb : t -> t -> bool. -End HasLtBool. +Module Type HasLeb (Import T:Typ). + Parameter Inline leb : t -> t -> bool. +End HasLeb. -Module Type LeBool := Typ <+ HasLeBool. -Module Type LtBool := Typ <+ HasLtBool. +Module Type HasLtb (Import T:Typ). + Parameter Inline ltb : t -> t -> bool. +End HasLtb. -Module Type LeBoolNotation (E:LeBool). - Infix "<=?" := E.leb (at level 35). -End LeBoolNotation. +Module Type LebNotation (T:Typ)(E:HasLeb T). + Infix "<=?" := E.leb (at level 35). +End LebNotation. -Module Type LtBoolNotation (E:LtBool). - Infix "<?" := E.ltb (at level 35). -End LtBoolNotation. +Module Type LtbNotation (T:Typ)(E:HasLtb T). + Infix "<?" := E.ltb (at level 35). +End LtbNotation. -Module Type LeBool' := LeBool <+ LeBoolNotation. -Module Type LtBool' := LtBool <+ LtBoolNotation. +Module Type LebSpec (T:Typ)(X:HasLe T)(Y:HasLeb T). + Parameter leb_le : forall x y, Y.leb x y = true <-> X.le x y. +End LebSpec. -Module Type LeBool_Le (T:Typ)(X:HasLeBool T)(Y:HasLe T). - Parameter leb_le : forall x y, X.leb x y = true <-> Y.le x y. -End LeBool_Le. +Module Type LtbSpec (T:Typ)(X:HasLt T)(Y:HasLtb T). + Parameter ltb_lt : forall x y, Y.ltb x y = true <-> X.lt x y. +End LtbSpec. -Module Type LtBool_Lt (T:Typ)(X:HasLtBool T)(Y:HasLt T). - Parameter ltb_lt : forall x y, X.ltb x y = true <-> Y.lt x y. -End LtBool_Lt. +Module Type LeBool := Typ <+ HasLeb. +Module Type LtBool := Typ <+ HasLtb. +Module Type LeBool' := LeBool <+ LebNotation. +Module Type LtBool' := LtBool <+ LtbNotation. -Module Type LeBoolIsTotal (Import X:LeBool'). +Module Type LebIsTotal (Import X:LeBool'). Axiom leb_total : forall x y, (x <=? y) = true \/ (y <=? x) = true. -End LeBoolIsTotal. +End LebIsTotal. -Module Type TotalLeBool := LeBool <+ LeBoolIsTotal. -Module Type TotalLeBool' := LeBool' <+ LeBoolIsTotal. +Module Type TotalLeBool := LeBool <+ LebIsTotal. +Module Type TotalLeBool' := LeBool' <+ LebIsTotal. -Module Type LeBoolIsTransitive (Import X:LeBool'). +Module Type LebIsTransitive (Import X:LeBool'). Axiom leb_trans : Transitive X.leb. -End LeBoolIsTransitive. +End LebIsTransitive. + +Module Type TotalTransitiveLeBool := TotalLeBool <+ LebIsTransitive. +Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LebIsTransitive. + +(** Grouping all boolean comparison functions *) + +Module Type HasBoolOrdFuns (T:Typ) := HasEqb T <+ HasLtb T <+ HasLeb T. + +Module Type HasBoolOrdFuns' (T:Typ) := + HasBoolOrdFuns T <+ EqbNotation T <+ LtbNotation T <+ LebNotation T. -Module Type TotalTransitiveLeBool := TotalLeBool <+ LeBoolIsTransitive. -Module Type TotalTransitiveLeBool' := TotalLeBool' <+ LeBoolIsTransitive. +Module Type BoolOrdSpecs (O:EqLtLe)(F:HasBoolOrdFuns O) := + EqbSpec O O F <+ LtbSpec O O F <+ LebSpec O O F. +Module Type OrderFunctions (E:EqLtLe) := + HasCompare E <+ HasBoolOrdFuns E <+ BoolOrdSpecs E. +Module Type OrderFunctions' (E:EqLtLe) := + HasCompare E <+ CmpNotation E <+ HasBoolOrdFuns' E <+ BoolOrdSpecs E. (** * From [OrderedTypeFull] to [TotalTransitiveLeBool] *) diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v index 21ef8eb8..85e7fb17 100644 --- a/theories/Structures/OrdersAlt.v +++ b/theories/Structures/OrdersAlt.v @@ -11,8 +11,6 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrdersAlt.v 12754 2010-02-12 16:21:48Z letouzey $ *) - Require Import OrderedType Orders. Set Implicit Arguments. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index 9f83d82b..e071d053 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -11,20 +11,18 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrdersEx.v 12641 2010-01-07 15:32:52Z letouzey $ *) - -Require Import Orders NatOrderedType POrderedType NOrderedType - ZOrderedType RelationPairs EqualitiesFacts. +Require Import Orders NPeano POrderedType NArith + ZArith RelationPairs EqualitiesFacts. (** * Examples of Ordered Type structures. *) (** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *) -Module Nat_as_OT := NatOrderedType.Nat_as_OT. +Module Nat_as_OT := NPeano.Nat. Module Positive_as_OT := POrderedType.Positive_as_OT. -Module N_as_OT := NOrderedType.N_as_OT. -Module Z_as_OT := ZOrderedType.Z_as_OT. +Module N_as_OT := BinNat.N. +Module Z_as_OT := BinInt.Z. (** An OrderedType can now directly be seen as a DecidableType *) diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index a28b7977..2e9c0cf5 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -6,15 +6,76 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -Require Import Basics OrdersTac. +Require Import Bool Basics OrdersTac. Require Export Orders. Set Implicit Arguments. Unset Strict Implicit. -(** * Properties of [OrderedTypeFull] *) +(** * Properties of [compare] *) -Module OrderedTypeFullFacts (Import O:OrderedTypeFull'). +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. + Proof. + case compare_spec; intro H; split; try easy; intro LT; + contradict LT; rewrite H; apply irreflexivity. + Qed. + + Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y<x. + Proof. + case compare_spec; intro H; split; try easy; intro LT; + contradict LT; rewrite H; apply irreflexivity. + Qed. + + Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y). + Proof. + rewrite compare_lt_iff; intuition. + Qed. + + Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y<x). + Proof. + rewrite compare_gt_iff; intuition. + Qed. + + Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. + + Instance compare_compat : Proper (eq==>eq==>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. + + + (** * Properties of [OrderedTypeFull] *) + +Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Module OrderTac := OTF_to_OrderTac O. Ltac order := OrderTac.order. @@ -47,6 +108,18 @@ Module OrderedTypeFullFacts (Import O:OrderedTypeFull'). Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x. Proof. iorder. Qed. + 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_ge_iff x y : compare x y <> Lt <-> y<=x. + Proof. + rewrite le_not_gt_iff. apply compare_nlt_iff. + Qed. + End OrderedTypeFullFacts. @@ -84,50 +157,9 @@ Module OrderedTypeFacts (Import O: OrderedType'). Definition lt_irrefl (x:t) : ~x<x := StrictOrder_Irreflexive x. - (** Some more about [compare] *) - - Lemma compare_eq_iff : forall x y, (x ?= y) = Eq <-> x==y. - Proof. - intros; elim_compare x y; intuition; try discriminate; order. - Qed. - - Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x<y. - Proof. - intros; elim_compare x y; intuition; try discriminate; order. - Qed. - - Lemma compare_gt_iff : forall x y, (x ?= y) = Gt <-> y<x. - Proof. - intros; elim_compare x y; intuition; try discriminate; order. - Qed. - - Lemma compare_ge_iff : forall x y, (x ?= y) <> Lt <-> y<=x. - Proof. - intros; rewrite compare_lt_iff; intuition. - Qed. - - Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y. - Proof. - intros; rewrite compare_gt_iff; intuition. - Qed. - - Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. - - Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. - Proof. - intros x x' Hxx' y y' Hyy'. - elim_compare x' y'; autorewrite with order; order. - Qed. - - Lemma compare_refl : forall x, (x ?= x) = Eq. - Proof. - intros; elim_compare x x; auto; order. - Qed. - - Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). - Proof. - intros; elim_compare x y; simpl; autorewrite with order; order. - Qed. + Include CompareFacts O. + Notation compare_le_iff := compare_ngt_iff (only parsing). + Notation compare_ge_iff := compare_nlt_iff (only parsing). (** For compatibility reasons *) Definition eq_dec := eq_dec. @@ -162,10 +194,6 @@ Module OrderedTypeFacts (Import O: OrderedType'). End OrderedTypeFacts. - - - - (** * Tests of the order tactic Is it at least capable of proving some basic properties ? *) @@ -208,7 +236,7 @@ Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull. Definition t := O.t. Definition eq := O.eq. -Instance eq_equiv : Equivalence eq. +Program Instance eq_equiv : Equivalence eq. Definition eq_dec := O.eq_dec. Definition lt := flip O.lt. @@ -232,3 +260,195 @@ Qed. End OrderedTypeRev. +Unset Implicit Arguments. + +(** * Order relations derived from a [compare] function. + + We factorize here some common properties for ZArith, NArith + and co, where [lt] and [le] are defined in terms of [compare]. + Note that we do not require anything here concerning compatibility + of [compare] w.r.t [eq], nor anything concerning transitivity. +*) + +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). +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<y) (y<x) (x?=y). + Proof. + case_eq (compare x y); intros H; constructor. + now apply compare_eq_iff. + now apply compare_lt_iff. + rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff. + Qed. + + Lemma compare_eq x y : (x ?= y) = Eq -> 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<x. + Proof. + now rewrite <- compare_lt_iff, compare_antisym, CompOpp_iff. + Qed. + + Lemma compare_ge_iff x y : (x ?= 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<x). + Proof. + rewrite compare_gt_iff; intuition. + Qed. + + Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y). + Proof. + rewrite compare_lt_iff; intuition. + Qed. + + Lemma compare_nle_iff x y : (x ?= y) = Gt <-> ~(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<x). + Proof. + now rewrite <- compare_lt_iff, compare_refl. + Qed. + + Lemma lt_eq_cases n m : n <= m <-> 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). + +Include CompareBasedOrderFacts E C O. + +(** 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) (x<=?y). +Proof. + case leb_spec0; constructor; trivial. + now rewrite <- compare_lt_iff, compare_nge_iff. +Qed. + +Lemma ltb_spec0 x y : reflect (x<y) (x<?y). +Proof. + apply iff_reflect. symmetry. apply ltb_lt. +Defined. + +Lemma ltb_spec x y : BoolSpec (x<y) (y<=x) (x<?y). +Proof. + case ltb_spec0; constructor; trivial. + now rewrite <- compare_le_iff, compare_ngt_iff. +Qed. + +(** Negated variants of the specifications *) + +Lemma leb_nle x y : x <=? y = false <-> ~ (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 <? y = false <-> ~ (x < y). +Proof. +now rewrite <- not_true_iff_false, ltb_lt. +Qed. + +Lemma ltb_ge x y : x <? y = false <-> 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 <? y). +Proof. +apply eq_true_iff_eq. now rewrite negb_true_iff, leb_le, ltb_ge. +Qed. + +Lemma ltb_irrefl x : x <? x = false. +Proof. +apply ltb_ge. apply lt_eq_cases. now right. +Qed. + +Lemma ltb_antisym x y : y <? x = negb (x <=? y). +Proof. +apply eq_true_iff_eq. now rewrite negb_true_iff, ltb_lt, leb_gt. +Qed. + +(** Relation bewteen [compare] and the boolean comparisons *) + +Lemma eqb_compare x y : + (x =? y) = match compare x y with Eq => true | _ => false end. +Proof. +apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. +destruct compare; now split. +Qed. + +Lemma ltb_compare x y : + (x <? y) = match compare x y with Lt => true | _ => false end. +Proof. +apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. +destruct compare; now split. +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. +destruct compare; split; try easy. now destruct 1. +Qed. + +End BoolOrderFacts. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 2ed07026..f83b6377 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -86,11 +86,11 @@ Module KeyOrderedType(Import O:OrderedType). (* eqk, eqke are equalities, ltk is a strict order *) - Global Instance eqk_equiv : Equivalence eqk. + Global Instance eqk_equiv : Equivalence eqk := _. - Global Instance eqke_equiv : Equivalence eqke. + Global Instance eqke_equiv : Equivalence eqke := _. - Global Instance ltk_strorder : StrictOrder ltk. + Global Instance ltk_strorder : StrictOrder ltk := _. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. unfold eqk, ltk; auto with *. Qed. diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v index 41a98ef2..86ab4776 100644 --- a/theories/Unicode/Utf8.v +++ b/theories/Unicode/Utf8.v @@ -1,49 +1,13 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Logic *) -Notation "∀ x , P" := (forall x , P) - (at level 200, x ident, right associativity) : type_scope. -Notation "∀ x y , P" := (forall x y , P) - (at level 200, x ident, y ident, right associativity) : type_scope. -Notation "∀ x y z , P" := (forall x y z , P) - (at level 200, x ident, y ident, z ident, right associativity) : type_scope. -Notation "∀ x y z u , P" := (forall x y z u , P) - (at level 200, x ident, y ident, z ident, u ident, right associativity) - : type_scope. -Notation "∀ x : t , P" := (forall x : t , P) - (at level 200, x ident, right associativity) : type_scope. -Notation "∀ x y : t , P" := (forall x y : t , P) - (at level 200, x ident, y ident, right associativity) : type_scope. -Notation "∀ x y z : t , P" := (forall x y z : t , P) - (at level 200, x ident, y ident, z ident, right associativity) : type_scope. -Notation "∀ x y z u : t , P" := (forall x y z u : t , P) - (at level 200, x ident, y ident, z ident, u ident, right associativity) - : type_scope. - -Notation "∃ x , P" := (exists x , P) - (at level 200, x ident, right associativity) : type_scope. -Notation "∃ x : t , P" := (exists x : t, P) - (at level 200, x ident, right associativity) : type_scope. - -Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope. -Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope. -Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope. -Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope. -Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope. -Notation "x ≠ y" := (x <> y) (at level 70) : type_scope. - -(* Abstraction *) -(* Not nice -Notation "'λ' x : T , y" := ([x:T] y) (at level 1, x,T,y at level 10). -Notation "'λ' x := T , y" := ([x:=T] y) (at level 1, x,T,y at level 10). -*) +Require Export Utf8_core. (* Arithmetic *) Notation "x ≤ y" := (le x y) (at level 70, no associativity). @@ -51,10 +15,10 @@ Notation "x ≥ y" := (ge x y) (at level 70, no associativity). (* test *) (* -Goal ∀ x, True -> (∃ y , x ≥ y + 1) ∨ x ≤ 0. +Check ∀ x z, True -> (∃ y v, x + v ≥ y + z) ∨ x ≤ 0. *) (* Integer Arithmetic *) (* TODO: this should come after ZArith -Notation "x ≤ y" := (Zle x y) (at level 1, y at level 10). +Notation "x ≤ y" := (Zle x y) (at level 70, no associativity). *) diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v index ce637413..31724b3c 100644 --- a/theories/Unicode/Utf8_core.v +++ b/theories/Unicode/Utf8_core.v @@ -1,12 +1,14 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) + + (* Logic *) Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v new file mode 100644 index 00000000..28e355fb --- /dev/null +++ b/theories/Vectors/Fin.v @@ -0,0 +1,176 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Arith_base. + +(** [fin n] is a convinient way to represent \[1 .. n\] + +[fin n] can be seen as a n-uplet of unit where [F1] is the first element of +the n-uplet and [FS] set (n-1)-uplet of all the element but the first. + + Author: Pierre Boutillier + Institution: PPS, INRIA 12/2010 +*) + +Inductive t : nat -> Set := +|F1 : forall {n}, t (S n) +|FS : forall {n}, t n -> t (S n). + +Section SCHEMES. +Definition case0 P (p: t 0): P p := + match p as p' in t n return + match n as n' return t n' -> Type + with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p' + with |F1 _ => @id |FS _ _ => @id end. + +Definition caseS (P: forall {n}, t (S n) -> Type) + (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p)) + {n} (p: t (S n)): P p := + match p with + |F1 k => P1 k + |FS k pp => PS pp + end. + +Definition rectS (P: forall {n}, t (S n) -> Type) + (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)): + forall {n} (p: t (S n)), P p := +fix rectS_fix {n} (p: t (S n)): P p:= + match p with + |F1 k => P1 k + |FS 0 pp => case0 (fun f => P (FS f)) pp + |FS (S k) pp => PS pp (rectS_fix pp) + end. + +Definition rect2 (P: forall {n} (a b: t n), Type) + (H0: forall n, @P (S n) F1 F1) + (H1: forall {n} (f: t n), P F1 (FS f)) + (H2: forall {n} (f: t n), P (FS f) F1) + (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)): + forall {n} (a b: t n), P a b := +fix rect2_fix {n} (a: t n): forall (b: t n), P a b := +match a with + |F1 m => fun (b: t (S m)) => match b as b' in t n' + return match n',b' with + |0,_ => @ID + |S n0,b0 => P F1 b0 + end with + |F1 m' => H0 m' + |FS m' b' => H1 b' + end + |FS m a' => fun (b: t (S m)) => match b with + |F1 m' => fun aa: t m' => H2 aa + |FS m' b' => fun aa: t m' => HS aa b' (rect2_fix aa b') + end a' +end. +End SCHEMES. + +(** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *) +Fixpoint to_nat {m} (n : t m) : {i | i < m} := + match n in t k return {i | i< k} with + |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j) + |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end + end. + +(** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of +p >= n else *) +Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } := + match n with + |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p)) + |S n' => match p with + |0 => inleft _ (F1) + |S p' => match of_nat p' n' with + |inleft f => inleft _ (FS f) + |inright arg => inright _ (match arg with |ex_intro m e => + ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end) + end + end + end. + +(** [of_nat_lt p n H] answers the p{^ th} element of [fin n] +it behaves much better than [of_nat p n] on open term *) +Fixpoint of_nat_lt {p n : nat} : p < n -> t n := + match n with + |0 => fun H : p < 0 => False_rect _ (Lt.lt_n_O p H) + |S n' => match p with + |0 => fun _ => @F1 n' + |S p' => fun H => FS (of_nat_lt (Lt.lt_S_n _ _ H)) + end + end. + +Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p. +Proof. +induction p. + reflexivity. + simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique. +Qed. + +(** [weak p f] answers a function witch is the identity for the p{^ th} first +element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))] +with p FSs *) +Fixpoint weak {m}{n} p (f : t m -> t n) : + t (p + m) -> t (p + n) := +match p as p' return t (p' + m) -> t (p' + n) with + |0 => f + |S p' => fun x => match x with + |F1 n' => fun eq : n' = p' + m => F1 + |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq)) + end (eq_refl _) +end. + +(** The p{^ th} element of [fin m] viewed as the p{^ th} element of +[fin (m + n)] *) +Fixpoint L {m} n (p : t m) : t (m + n) := + match p with |F1 _ => F1 |FS _ p' => FS (L n p') end. + +Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p). +Proof. +induction p. + reflexivity. + simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p). +Qed. + +(** The p{^ th} element of [fin m] viewed as the p{^ th} element of +[fin (n + m)] +Really really ineficient !!! *) +Definition L_R {m} n (p : t m) : t (n + m). +induction n. + exact p. + exact ((fix LS k (p: t k) := + match p with + |F1 k' => @F1 (S k') + |FS _ p' => FS (LS _ p') + end) _ IHn). +Defined. + +(** The p{^ th} element of [fin m] viewed as the (n + p){^ th} element of +[fin (n + m)] *) +Fixpoint R {m} n (p : t m) : t (n + m) := + match n with |0 => p |S n' => FS (R n' p) end. + +Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p). +Proof. +induction n. + reflexivity. + simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p). +Qed. + +Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) := +match o with + |F1 m' => L (m' * n) p + |FS m' o' => R n (depair o' p) +end. + +Lemma depair_sanity {m n} (o : t m) (p : t n) : + proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)). +induction o ; simpl. + rewrite L_sanity. now rewrite Mult.mult_0_r. + + rewrite R_sanity. rewrite IHo. + rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r. + now rewrite (Plus.plus_comm n). +Qed. diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v new file mode 100644 index 00000000..f3e5e338 --- /dev/null +++ b/theories/Vectors/Vector.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Vectors. + + Author: Pierre Boutillier + Institution: PPS, INRIA 12/2010 + +Originally from the contribution bit vector by Jean Duprat (ENS Lyon). + +Based on contents from Util/VecUtil of the CoLoR contribution *) + +Require Fin. +Require VectorDef. +Require VectorSpec. +Include VectorDef. +Include VectorSpec. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v new file mode 100644 index 00000000..0fee50ff --- /dev/null +++ b/theories/Vectors/VectorDef.v @@ -0,0 +1,317 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Definitions of Vectors and functions to use them + + Author: Pierre Boutillier + Institution: PPS, INRIA 12/2010 +*) + +(** +Names should be "caml name in list.ml" if exists and order of arguments +have to be the same. complain if you see mistakes ... *) + +Require Import Arith_base. +Require Vectors.Fin. +Import EqNotations. +Open Local Scope nat_scope. + +(** +A vector is a list of size n whose elements belong to a set A. *) + +Inductive t A : nat -> Type := + |nil : t A 0 + |cons : forall (h:A) (n:nat), t A n -> t A (S n). + +Local Notation "[]" := (nil _). +Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity). + +Section SCHEMES. + +(** An induction scheme for non-empty vectors *) + +Definition rectS {A} (P:forall {n}, t A (S n) -> Type) + (bas: forall a: A, P (a :: [])) + (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) := + fix rectS_fix {n} (v: t A (S n)) : P v := + match v with + |nil => @id + |cons a 0 v => + match v as vnn in t _ nn + return + match nn,vnn with + |0,vm => P (a :: vm) + |S _,_ => ID + end + with + |nil => bas a + |_ :: _ => @id + end + |cons a (S nn') v => rect a v (rectS_fix v) + end. + +(** An induction scheme for 2 vectors of same length *) +Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type) + (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 -> + forall a b, P (a :: v1) (b :: v2)) := +fix rect2_fix {n} (v1:t A n): + forall v2 : t B n, P v1 v2 := +match v1 as v1' in t _ n1 + return forall v2 : t B n1, P v1' v2 with + |[] => fun v2 => + match v2 with + |[] => bas + |_ :: _ => @id + end + |h1 :: t1 => fun v2 => + match v2 with + |[] => @id + |h2 :: t2 => fun t1' => + rect (rect2_fix t1' t2) h1 h2 + end t1 +end. + +(** A vector of length [0] is [nil] *) +Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v := +match v with + |[] => H +end. + +(** A vector of length [S _] is [cons] *) +Definition caseS {A} (P : forall n, t A (S n) -> Type) + (H : forall h {n} t, @P n (h :: t)) {n} v : P n v := +match v with + |[] => @id (* Why needed ? *) + |h :: t => H h t +end. +End SCHEMES. + +Section BASES. +(** The first element of a non empty vector *) +Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in +(caseS (fun n v => A) (fun h n t => h) v). + +(** The last element of an non empty vector *) +Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in +(rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v). + +(** Build a vector of n{^ th} [a] *) +Fixpoint const {A} (a:A) (n:nat) := + match n return t A n with + | O => nil A + | S n => a :: (const a n) + end. + +(** The [p]{^ th} element of a vector of length [m]. + +Computational behavior of this function should be the same as +ocaml function. *) +Fixpoint nth {A} {m} (v' : t A m) (p : Fin.t m) {struct p} : A := +match p in Fin.t m' return t A m' -> A with + |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v + |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A) + (fun h n t p0 => nth t p0) v) p' +end v'. + +(** An equivalent definition of [nth]. *) +Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) := +(nth v (Fin.of_nat_lt H)). + +(** Put [a] at the p{^ th} place of [v] *) +Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n := + match p with + |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v' + |Fin.FS k p' => fun v' => + (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p' + end v. + +(** Version of replace with [lt] *) +Definition replace_order {A n} (v: t A n) {p} (H: p < n) := +replace v (Fin.of_nat_lt H). + +(** Remove the first element of a non empty vector *) +Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in +(caseS (fun n v => t A n) (fun h n t => t) v). + +(** Remove last element of a non-empty vector *) +Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n := +Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => []) + (fun h _ _ H => h :: H) v). + +(** Add an element at the end of a vector *) +Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) := +match v with + |[] => a :: [] + |h :: t => h :: (shiftin a t) +end. + +(** Copy last element of a vector *) +Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) := +Eval cbv delta beta in (rectS (fun n _ => t A (S (S n))) + (fun h => h :: h :: []) (fun h _ _ H => h :: H) v). + +(** Remove [p] last elements of a vector *) +Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n + -> t A (n - p). +Proof. + induction p as [| p f]; intros H v. + rewrite <- minus_n_O. + exact v. + + apply shiftout. + + rewrite minus_Sn_m. + apply f. + auto with *. + exact v. + auto with *. +Defined. + +(** Concatenation of two vectors *) +Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n+p) := + match v with + | [] => w + | a :: v' => a :: (append v' w) + end. + +Infix "++" := append. + +(** Two definitions of the tail recursive function that appends two lists but +reverses the first one *) + +(** This one has the exact expected computational behavior *) +Fixpoint rev_append_tail {A n p} (v : t A n) (w: t A p) + : t A (tail_plus n p) := + match v with + | [] => w + | a :: v' => rev_append_tail v' (a :: w) + end. + +Import EqdepFacts. + +(** This one has a better type *) +Definition rev_append {A n p} (v: t A n) (w: t A p) + :t A (n + p) := + rew <- (plus_tail_plus n p) in (rev_append_tail v w). + +(** rev [a₁ ; a₂ ; .. ; an] is [an ; a{n-1} ; .. ; a₁] + +Caution : There is a lot of rewrite garbage in this definition *) +Definition rev {A n} (v : t A n) : t A n := + rew <- (plus_n_O _) in (rev_append v []). + +End BASES. +Local Notation "v [@ p ]" := (nth v p) (at level 1). + +Section ITERATORS. +(** * Here are special non dependent useful instantiation of induction +schemes *) + +(** Uniform application on the arguments of the vector *) +Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n := + fix map_fix {n} (v : t A n) : t B n := match v with + | [] => [] + | a :: v' => (f a) :: (map_fix v') + end. + +(** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *) +Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n) + : t C n := +Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C) + (fun _ _ _ H a b => (g a b) :: H) v1 v2. + +(** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *) +Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B := + fix fold_left_fix (b:B) {n} (v : t A n) : B := match v with + | [] => b + | a :: w => (fold_left_fix (f b a) w) + end. + +(** fold_right f [x1 .. xn] b = f x1 (f x2 .. (f xn b) .. ) *) +Definition fold_right {A B : Type} (f : A->B->B) := + fix fold_right_fix {n} (v : t A n) (b:B) + {struct v} : B := + match v with + | [] => b + | a :: w => f a (fold_right_fix w b) + end. + +(** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *) +Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n) + (w : t B n) (c:C) : C := +Eval cbv delta beta in rect2 (fun _ _ _ => C) c + (fun _ _ _ H a b => g a b H) v w. + +(** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *) +Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) := +fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A := +match v in t _ n0 return t C n0 -> A with + |[] => fun w => match w in t _ n1 + return match n1 with |0 => A |S _ => @ID end with + |[] => a + |_ :: _ => @id end + |cons vh vn vt => fun w => match w in t _ n1 + return match n1 with |0 => @ID |S n => t B n -> A end with + |[] => @id + |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt +end. + +End ITERATORS. + +Section SCANNING. +Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := + |Forall_nil: Forall P [] + |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). +Hint Constructors Forall. + +Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := + |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) + |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). +Hint Constructors Exists. + +Inductive In {A} (a:A): forall {n}, t A n -> Prop := + |In_cons_hd {m} (v: t A m): In a (a::v) + |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). +Hint Constructors In. + +Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := + |Forall2_nil: Forall2 P [] [] + |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> + Forall2 P (x1::v1) (x2::v2). +Hint Constructors Forall2. + +Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := + |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) + |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). +Hint Constructors Exists2. + +End SCANNING. + +Section VECTORLIST. +(** * vector <=> list functions *) + +Fixpoint of_list {A} (l : list A) : t A (length l) := +match l as l' return t A (length l') with + |Datatypes.nil => [] + |(h :: tail)%list => (h :: (of_list tail)) +end. + +Definition to_list {A}{n} (v : t A n) : list A := +Eval cbv delta beta in fold_right (fun h H => Datatypes.cons h H) v Datatypes.nil. +End VECTORLIST. + +Module VectorNotations. +Notation "[]" := [] : vector_scope. +Notation "h :: t" := (h :: t) (at level 60, right associativity) + : vector_scope. +Notation " [ x ] " := (x :: []) : vector_scope. +Notation " [ x ; .. ; y ] " := (cons _ x _ .. (cons _ y _ (nil _)) ..) : vector_scope +. +Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope. +Open Scope vector_scope. +End VectorNotations. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v new file mode 100644 index 00000000..a576315e --- /dev/null +++ b/theories/Vectors/VectorSpec.v @@ -0,0 +1,113 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Proofs of specification for functions defined over Vector + + Author: Pierre Boutillier + Institution: PPS, INRIA 12/2010 +*) + +Require Fin. +Require Import VectorDef. +Import VectorNotations. + +(** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all +is true for the one that use [lt] *) + +Lemma eq_nth_iff A n (v1 v2: t A n): + (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. +Proof. +split. + revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros. + reflexivity. + f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). + apply H. intros p1 p2 H1; + apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)). + intros; now f_equal. +Qed. + +Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), + nth_order v H = last v. +Proof. +unfold nth_order; refine (@rectS _ _ _ _); now simpl. +Qed. + +Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): + nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. +Proof. +subst k2; induction k1. + generalize dependent n. apply caseS ; intros. now simpl. + generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl. +Qed. + +Lemma shiftin_last A a n (v: t A n): last (shiftin a v) = a. +Proof. +induction v ;now simpl. +Qed. + +Lemma shiftrepeat_nth A: forall n k (v: t A (S n)), + nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k. +Proof. +refine (@Fin.rectS _ _ _); intros. + revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. + revert p H. + refine (match v as v' in t _ m return match m as m' return t A m' -> Type with + |S (S n) => fun v => forall p : Fin.t (S n), + (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) -> + (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p] + |_ => fun _ => @ID end v' with + |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl. +Qed. + +Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v. +Proof. +refine (@rectS _ _ _ _); now simpl. +Qed. + +Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a. +Proof. +now induction p. +Qed. + +Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): + (map f v) [@ p1] = f (v [@ p2]). +Proof. +subst p2; induction p1. + revert n v; refine (@caseS _ _ _); now simpl. + revert n v p1 IHp1; refine (@caseS _ _ _); now simpl. +Qed. + +Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n): + p1 = p2 -> p2 = p3 -> (map2 f v w) [@p1] = f (v[@p2]) (w[@p3]). +Proof. +intros; subst p2; subst p3; revert n v w p1. +refine (@rect2 _ _ _ _ _); simpl. + exact (Fin.case0 _). + intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _); + now simpl. +Qed. + +Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} + (assoc: forall a b c, f (f a b) c = f (f a c) b) + {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. +Proof. +assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). + induction v0. + now simpl. + intros; simpl. rewrite<- IHv0. now f_equal. + induction v. + reflexivity. + simpl. intros; now rewrite<- (IHv). +Qed. + +Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. +Proof. +induction l. + reflexivity. + unfold to_list; simpl. now f_equal. +Qed. diff --git a/theories/Vectors/vo.itarget b/theories/Vectors/vo.itarget new file mode 100644 index 00000000..7f00d016 --- /dev/null +++ b/theories/Vectors/vo.itarget @@ -0,0 +1,4 @@ +Fin.vo +VectorDef.vo +VectorSpec.vo +Vector.vo diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index ccfef1e6..f5daa301 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Disjoint_Union.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory L. Paulson JSC (1986) 2, 325-355 *) diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index fad1978e..1c83c481 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inclusion.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Bruno Barras *) Require Import Relation_Definitions. diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index 204cff19..27a1c381 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inverse_Image.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Bruno Barras *) Section Inverse_Image. diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index bc8803ad..6d5b663b 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lexicographic_Exponentiation.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index e0f0cc8f..ce0fee71 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lexicographic_Product.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Authors: Bruno Barras, Cristina Cornes *) Require Import Eqdep. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 59832b1b..e9bc7ccf 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Transitive_Closure.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Bruno Barras *) Require Import Relation_Definitions. diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 84d75754..e3fdc4c5 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Union.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Bruno Barras *) Require Import Relation_Operators. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index cec21555..fc4e2ebc 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Well_Ordering.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Author: Cristina Cornes. From: Constructing Recursion Operators in Type Theory L. Paulson JSC (1986) 2, 325-355 *) diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v index 03b7b210..4dc4d59d 100644 --- a/theories/Wellfounded/Wellfounded.v +++ b/theories/Wellfounded/Wellfounded.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wellfounded.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Export Disjoint_Union. Require Export Inclusion. Require Export Inverse_Image. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index e2b89d84..3a5eb885 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1,1158 +1,1585 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinInt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +Require Export BinNums BinPos Pnat. +Require Import BinNat Bool Plus Mult Equalities GenericMinMax + OrdersFacts ZAxioms ZProperties. +Require BinIntDef. (***********************************************************) -(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) +(** * Binary Integers *) (***********************************************************) -Require Export BinPos. -Require Export Pnat. -Require Import BinNat. -Require Import Plus. -Require Import Mult. +(** Initial author: Pierre Crégut, CNET, Lannion, France *) -Unset Boxed Definitions. +(** The type [Z] and its constructors [Z0] and [Zpos] and [Zneg] + are now defined in [BinNums.v] *) -(*****************************) -(** * Binary integer numbers *) +Local Open Scope Z_scope. -Inductive Z : Set := - | Z0 : Z - | Zpos : positive -> Z - | Zneg : positive -> Z. +(** Every definitions and early properties about binary integers + are placed in a module [Z] for qualification purpose. *) +Module Z + <: ZAxiomsSig + <: UsualOrderedTypeFull + <: UsualDecidableTypeFull + <: TotalOrder. -(** Automatically open scope positive_scope for the constructors of Z *) -Delimit Scope Z_scope with Z. -Bind Scope Z_scope with Z. -Arguments Scope Zpos [positive_scope]. -Arguments Scope Zneg [positive_scope]. - -(** ** Subtraction of positive into Z *) - -Definition Zdouble_plus_one (x:Z) := - match x with - | Z0 => Zpos 1 - | Zpos p => Zpos p~1 - | Zneg p => Zneg (Pdouble_minus_one p) - end. - -Definition Zdouble_minus_one (x:Z) := - match x with - | Z0 => Zneg 1 - | Zneg p => Zneg p~1 - | Zpos p => Zpos (Pdouble_minus_one p) - end. - -Definition Zdouble (x:Z) := - match x with - | Z0 => Z0 - | Zpos p => Zpos p~0 - | Zneg p => Zneg p~0 - end. - -Open Local Scope positive_scope. - -Fixpoint ZPminus (x y:positive) {struct y} : Z := - match x, y with - | p~1, q~1 => Zdouble (ZPminus p q) - | p~1, q~0 => Zdouble_plus_one (ZPminus p q) - | p~1, 1 => Zpos p~0 - | p~0, q~1 => Zdouble_minus_one (ZPminus p q) - | p~0, q~0 => Zdouble (ZPminus p q) - | p~0, 1 => Zpos (Pdouble_minus_one p) - | 1, q~1 => Zneg q~0 - | 1, q~0 => Zneg (Pdouble_minus_one q) - | 1, 1 => Z0 - end. - -Close Local Scope positive_scope. - -(** ** Addition on integers *) - -Definition Zplus (x y:Z) := - match x, y with - | Z0, y => y - | Zpos x', Z0 => Zpos x' - | Zneg x', Z0 => Zneg x' - | Zpos x', Zpos y' => Zpos (x' + y') - | Zpos x', Zneg y' => - match (x' ?= y')%positive Eq with - | Eq => Z0 - | Lt => Zneg (y' - x') - | Gt => Zpos (x' - y') - end - | Zneg x', Zpos y' => - match (x' ?= y')%positive Eq with - | Eq => Z0 - | Lt => Zpos (y' - x') - | Gt => Zneg (x' - y') - end - | Zneg x', Zneg y' => Zneg (x' + y') - end. - -Infix "+" := Zplus : Z_scope. - -(** ** Opposite *) - -Definition Zopp (x:Z) := - match x with - | Z0 => Z0 - | Zpos x => Zneg x - | Zneg x => Zpos x - end. - -Notation "- x" := (Zopp x) : Z_scope. - -(** ** Successor on integers *) - -Definition Zsucc (x:Z) := (x + Zpos 1)%Z. - -(** ** Predecessor on integers *) - -Definition Zpred (x:Z) := (x + Zneg 1)%Z. - -(** ** Subtraction on integers *) - -Definition Zminus (m n:Z) := (m + - n)%Z. - -Infix "-" := Zminus : Z_scope. - -(** ** Multiplication on integers *) - -Definition Zmult (x y:Z) := - match x, y with - | Z0, _ => Z0 - | _, Z0 => Z0 - | Zpos x', Zpos y' => Zpos (x' * y') - | Zpos x', Zneg y' => Zneg (x' * y') - | Zneg x', Zpos y' => Zneg (x' * y') - | Zneg x', Zneg y' => Zpos (x' * y') - end. - -Infix "*" := Zmult : Z_scope. - -(** ** Comparison of integers *) - -Definition Zcompare (x y:Z) := - match x, y with - | Z0, Z0 => Eq - | Z0, Zpos y' => Lt - | Z0, Zneg y' => Gt - | Zpos x', Z0 => Gt - | Zpos x', Zpos y' => (x' ?= y')%positive Eq - | Zpos x', Zneg y' => Gt - | Zneg x', Z0 => Lt - | Zneg x', Zpos y' => Lt - | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq) - end. - -Infix "?=" := Zcompare (at level 70, no associativity) : Z_scope. +(** * Definitions of operations, now in a separate file *) -Ltac elim_compare com1 com2 := - case (Dcompare (com1 ?= com2)%Z); - [ idtac | let x := fresh "H" in - (intro x; case x; clear x) ]. +Include BinIntDef.Z. + +(** When including property functors, only inline t eq zero one two *) -(** ** Sign function *) +Set Inline Level 30. -Definition Zsgn (z:Z) : Z := - match z with - | Z0 => Z0 - | Zpos p => Zpos 1 - | Zneg p => Zneg 1 - end. +(** * Logic Predicates *) + +Definition eq := @Logic.eq Z. +Definition eq_equiv := @eq_equivalence Z. + +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 : Z_scope. +Infix "<" := lt : Z_scope. +Infix ">=" := ge : Z_scope. +Infix ">" := gt : Z_scope. + +Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope. +Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope. +Notation "x < y < z" := (x < y /\ y < z) : Z_scope. +Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope. -(** ** Direct, easier to handle variants of successor and addition *) +Definition divide x y := exists z, y = z*x. +Notation "( x | y )" := (divide x y) (at level 0). -Definition Zsucc' (x:Z) := - match x with - | Z0 => Zpos 1 - | Zpos x' => Zpos (Psucc x') - | Zneg x' => ZPminus 1 x' - end. +Definition Even a := exists b, a = 2*b. +Definition Odd a := exists b, a = 2*b+1. -Definition Zpred' (x:Z) := - match x with - | Z0 => Zneg 1 - | Zpos x' => ZPminus x' 1 - | Zneg x' => Zneg (Psucc x') - end. +(** * Decidability of equality. *) -Definition Zplus' (x y:Z) := - match x, y with - | Z0, y => y - | x, Z0 => x - | Zpos x', Zpos y' => Zpos (x' + y') - | Zpos x', Zneg y' => ZPminus x' y' - | Zneg x', Zpos y' => ZPminus y' x' - | Zneg x', Zneg y' => Zneg (x' + y') - end. +Definition eq_dec (x y : Z) : {x = y} + {x <> y}. +Proof. + decide equality; apply Pos.eq_dec. +Defined. -Open Local Scope Z_scope. +(** * Properties of [pos_sub] *) -(**********************************************************************) -(** ** Inductive specification of Z *) +(** [pos_sub] can be written in term of positive comparison + and subtraction (cf. earlier definition of addition of Z) *) -Theorem Zind : - forall P:Z -> Prop, - P Z0 -> - (forall x:Z, P x -> P (Zsucc' x)) -> - (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n. +Lemma pos_sub_spec p q : + pos_sub p q = + match (p ?= q)%positive with + | Eq => 0 + | Lt => Zneg (q - p) + | Gt => Zpos (p - q) + end. Proof. - intros P H0 Hs Hp z; destruct z. - assumption. - apply Pind with (P := fun p => P (Zpos p)). - change (P (Zsucc' Z0)) in |- *; apply Hs; apply H0. - intro n; exact (Hs (Zpos n)). - apply Pind with (P := fun p => P (Zneg p)). - change (P (Zpred' Z0)) in |- *; apply Hp; apply H0. - intro n; exact (Hp (Zneg n)). + revert q. induction p; destruct q; simpl; trivial; + rewrite ?Pos.compare_xI_xI, ?Pos.compare_xO_xI, + ?Pos.compare_xI_xO, ?Pos.compare_xO_xO, IHp; simpl; + case Pos.compare_spec; intros; simpl; trivial; + (now rewrite Pos.sub_xI_xI) || (now rewrite Pos.sub_xO_xO) || + (now rewrite Pos.sub_xO_xI) || (now rewrite Pos.sub_xI_xO) || + subst; unfold Pos.sub; simpl; now rewrite Pos.sub_mask_diag. Qed. -(**********************************************************************) -(** * Misc properties about binary integer operations *) +(** Particular cases of the previous result *) +Lemma pos_sub_diag p : pos_sub p p = 0. +Proof. + now rewrite pos_sub_spec, Pos.compare_refl. +Qed. -(**********************************************************************) -(** ** Properties of opposite on binary integer numbers *) +Lemma pos_sub_lt p q : (p < q)%positive -> pos_sub p q = Zneg (q - p). +Proof. + intros H. now rewrite pos_sub_spec, H. +Qed. -Theorem Zopp_0 : Zopp Z0 = Z0. +Lemma pos_sub_gt p q : (q < p)%positive -> pos_sub p q = Zpos (p - q). Proof. - reflexivity. + intros H. now rewrite pos_sub_spec, Pos.compare_antisym, H. Qed. -Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p. +(** The opposite of [pos_sub] is [pos_sub] with reversed arguments *) + +Lemma pos_sub_opp p q : - pos_sub p q = pos_sub q p. Proof. - reflexivity. + revert q; induction p; destruct q; simpl; trivial; + rewrite <- IHp; now destruct pos_sub. Qed. -(** [opp] is involutive *) +(** * Results concerning [Zpos] and [Zneg] and the operators *) -Theorem Zopp_involutive : forall n:Z, - - n = n. +Lemma opp_Zneg p : - Zneg p = Zpos p. Proof. - intro x; destruct x; reflexivity. + reflexivity. Qed. -(** Injectivity of the opposite *) +Lemma opp_Zpos p : - Zpos p = Zneg p. +Proof. + reflexivity. +Qed. -Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m. +Lemma succ_Zpos p : succ (Zpos p) = Zpos (Pos.succ p). Proof. - intros x y; case x; case y; simpl in |- *; intros; - [ trivial - | discriminate H - | discriminate H - | discriminate H - | simplify_eq H; intro E; rewrite E; trivial - | discriminate H - | discriminate H - | discriminate H - | simplify_eq H; intro E; rewrite E; trivial ]. + simpl. f_equal. apply Pos.add_1_r. Qed. -(**********************************************************************) -(** ** Other properties of binary integer numbers *) +Lemma add_Zpos p q : Zpos p + Zpos q = Zpos (p+q). +Proof. + reflexivity. +Qed. -Lemma ZL0 : 2%nat = (1 + 1)%nat. +Lemma add_Zneg p q : Zneg p + Zneg q = Zneg (p+q). Proof. - reflexivity. + reflexivity. Qed. -(**********************************************************************) -(** * Properties of the addition on integers *) +Lemma add_Zpos_Zneg p q : Zpos p + Zneg q = pos_sub p q. +Proof. + reflexivity. +Qed. -(** ** Zero is left neutral for addition *) +Lemma add_Zneg_Zpos p q : Zneg p + Zpos q = pos_sub q p. +Proof. + reflexivity. +Qed. -Theorem Zplus_0_l : forall n:Z, Z0 + n = n. +Lemma sub_Zpos n m : (n < m)%positive -> Zpos m - Zpos n = Zpos (m-n). Proof. - intro x; destruct x; reflexivity. + intros H. simpl. now apply pos_sub_gt. Qed. -(** ** Zero is right neutral for addition *) +Lemma mul_Zpos (p q : positive) : Zpos p * Zpos q = Zpos (p*q). +Proof. + reflexivity. +Qed. -Theorem Zplus_0_r : forall n:Z, n + Z0 = n. +Lemma pow_Zpos p q : (Zpos p)^(Zpos q) = Zpos (p^q). Proof. - intro x; destruct x; reflexivity. + unfold Pos.pow, pow, pow_pos. + symmetry. now apply Pos.iter_swap_gen. Qed. -(** ** Addition is commutative *) +Lemma inj_Zpos p q : Zpos p = Zpos q <-> p = q. +Proof. + split; intros H. now injection H. now f_equal. +Qed. -Theorem Zplus_comm : forall n m:Z, n + m = m + n. +Lemma inj_Zneg p q : Zneg p = Zneg q <-> p = q. Proof. - intro x; induction x as [| p| p]; intro y; destruct y as [| q| q]; - simpl in |- *; try reflexivity. - rewrite Pplus_comm; reflexivity. - rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity. - rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity. - rewrite Pplus_comm; reflexivity. + split; intros H. now injection H. now f_equal. Qed. -(** ** Opposite distributes over addition *) +Lemma pos_xI p : Zpos p~1 = 2 * Zpos p + 1. +Proof. + reflexivity. +Qed. -Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m. +Lemma pos_xO p : Zpos p~0 = 2 * Zpos p. Proof. - intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q]; - simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); - reflexivity. + reflexivity. Qed. -Theorem Zopp_succ : forall n:Z, Zopp (Zsucc n) = Zpred (Zopp n). +Lemma neg_xI p : Zneg p~1 = 2 * Zneg p - 1. Proof. -intro; unfold Zsucc; now rewrite Zopp_plus_distr. + reflexivity. Qed. -(** ** Opposite is inverse for addition *) +Lemma neg_xO p : Zneg p~0 = 2 * Zneg p. +Proof. + reflexivity. +Qed. + +(** In the following module, we group results that are needed now + to prove specifications of operations, but will also be provided + later by the generic functor of properties. *) + +Module Import Private_BootStrap. + +(** * Properties of addition *) + +(** ** Zero is neutral for addition *) -Theorem Zplus_opp_r : forall n:Z, n + - n = Z0. +Lemma add_0_r n : n + 0 = n. Proof. - intro x; destruct x as [| p| p]; simpl in |- *; - [ reflexivity - | rewrite (Pcompare_refl p); reflexivity - | rewrite (Pcompare_refl p); reflexivity ]. + now destruct n. Qed. -Theorem Zplus_opp_l : forall n:Z, - n + n = Z0. +(** ** Addition is commutative *) + +Lemma add_comm n m : n + m = m + n. +Proof. + destruct n, m; simpl; trivial; now rewrite Pos.add_comm. +Qed. + +(** ** Opposite distributes over addition *) + +Lemma opp_add_distr n m : - (n + m) = - n + - m. Proof. - intro; rewrite Zplus_comm; apply Zplus_opp_r. + destruct n, m; simpl; trivial using pos_sub_opp. Qed. -Hint Local Resolve Zplus_0_l Zplus_0_r. +(** ** Opposite is injective *) + +Lemma opp_inj n m : -n = -m -> n = m. +Proof. + destruct n, m; simpl; intros H; destr_eq H; now f_equal. +Qed. (** ** Addition is associative *) -Lemma weak_assoc : - forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n. -Proof. - intros x y z'; case z'; - [ auto with arith - | intros z; simpl in |- *; rewrite Pplus_assoc; auto with arith - | intros z; simpl in |- *; ElimPcompare y z; intros E0; rewrite E0; - ElimPcompare (x + y)%positive z; intros E1; rewrite E1; - [ absurd ((x + y ?= z)%positive Eq = Eq); - [ (* Case 1 *) - rewrite nat_of_P_gt_Gt_compare_complement_morphism; - [ discriminate - | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0); - elim (ZL4 x); intros k E2; rewrite E2; - simpl in |- *; unfold gt, lt in |- *; - apply le_n_S; apply le_plus_r ] - | assumption ] - | absurd ((x + y ?= z)%positive Eq = Lt); - [ (* Case 2 *) - rewrite nat_of_P_gt_Gt_compare_complement_morphism; - [ discriminate - | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0); - elim (ZL4 x); intros k E2; rewrite E2; - simpl in |- *; unfold gt, lt in |- *; - apply le_n_S; apply le_plus_r ] - | assumption ] - | rewrite (Pcompare_Eq_eq y z E0); - (* Case 3 *) - elim (Pminus_mask_Gt (x + z) z); - [ intros t H; elim H; intros H1 H2; elim H2; intros H3 H4; - unfold Pminus in |- *; rewrite H1; cut (x = t); - [ intros E; rewrite E; auto with arith - | apply Pplus_reg_r with (r := z); rewrite <- H3; - rewrite Pplus_comm; trivial with arith ] - | pattern z at 1 in |- *; rewrite <- (Pcompare_Eq_eq y z E0); - assumption ] - | elim (Pminus_mask_Gt z y); - [ (* Case 4 *) - intros k H; elim H; intros H1 H2; elim H2; intros H3 H4; - unfold Pminus at 1 in |- *; rewrite H1; cut (x = k); - [ intros E; rewrite E; rewrite (Pcompare_refl k); - trivial with arith - | apply Pplus_reg_r with (r := y); rewrite (Pplus_comm k y); - rewrite H3; apply Pcompare_Eq_eq; assumption ] - | apply ZC2; assumption ] - | elim (Pminus_mask_Gt z y); - [ (* Case 5 *) - intros k H; elim H; intros H1 H2; elim H2; intros H3 H4; - unfold Pminus at 1 3 5 in |- *; rewrite H1; - cut ((x ?= k)%positive Eq = Lt); - [ intros E2; rewrite E2; elim (Pminus_mask_Gt k x); - [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9; - elim (Pminus_mask_Gt z (x + y)); - [ intros j H10; elim H10; intros H11 H12; elim H12; - intros H13 H14; unfold Pminus in |- *; - rewrite H6; rewrite H11; cut (i = j); - [ intros E; rewrite E; auto with arith - | apply (Pplus_reg_l (x + y)); rewrite H13; - rewrite (Pplus_comm x y); rewrite <- Pplus_assoc; - rewrite H8; assumption ] - | apply ZC2; assumption ] - | apply ZC2; assumption ] - | apply nat_of_P_lt_Lt_compare_complement_morphism; - apply plus_lt_reg_l with (p := nat_of_P y); - do 2 rewrite <- nat_of_P_plus_morphism; - apply nat_of_P_lt_Lt_compare_morphism; - rewrite H3; rewrite Pplus_comm; assumption ] - | apply ZC2; assumption ] - | elim (Pminus_mask_Gt z y); - [ (* Case 6 *) - intros k H; elim H; intros H1 H2; elim H2; intros H3 H4; - elim (Pminus_mask_Gt (x + y) z); - [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9; - unfold Pminus in |- *; rewrite H1; rewrite H6; - cut ((x ?= k)%positive Eq = Gt); - [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11; - elim H11; intros H12 H13; elim H13; - intros H14 H15; rewrite H10; rewrite H12; - cut (i = j); - [ intros H16; rewrite H16; auto with arith - | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j); - rewrite H14; rewrite (Pplus_comm z k); - rewrite <- Pplus_assoc; rewrite H8; - rewrite (Pplus_comm x y); rewrite Pplus_assoc; - rewrite (Pplus_comm k y); rewrite H3; - trivial with arith ] - | apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold lt, gt in |- *; - apply plus_lt_reg_l with (p := nat_of_P y); - do 2 rewrite <- nat_of_P_plus_morphism; - apply nat_of_P_lt_Lt_compare_morphism; - rewrite H3; rewrite Pplus_comm; apply ZC1; - assumption ] - | assumption ] - | apply ZC2; assumption ] - | absurd ((x + y ?= z)%positive Eq = Eq); - [ (* Case 7 *) - rewrite nat_of_P_gt_Gt_compare_complement_morphism; - [ discriminate - | rewrite nat_of_P_plus_morphism; unfold gt in |- *; - apply lt_le_trans with (m := nat_of_P y); - [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption - | apply le_plus_r ] ] - | assumption ] - | absurd ((x + y ?= z)%positive Eq = Lt); - [ (* Case 8 *) - rewrite nat_of_P_gt_Gt_compare_complement_morphism; - [ discriminate - | unfold gt in |- *; apply lt_le_trans with (m := nat_of_P y); - [ exact (nat_of_P_gt_Gt_compare_morphism y z E0) - | rewrite nat_of_P_plus_morphism; apply le_plus_r ] ] - | assumption ] - | elim Pminus_mask_Gt with (1 := E0); intros k H1; - (* Case 9 *) - elim Pminus_mask_Gt with (1 := E1); intros i H2; - elim H1; intros H3 H4; elim H4; intros H5 H6; - elim H2; intros H7 H8; elim H8; intros H9 H10; - unfold Pminus in |- *; rewrite H3; rewrite H7; - cut ((x + k)%positive = i); - [ intros E; rewrite E; auto with arith - | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc; - rewrite H5; rewrite H9; rewrite Pplus_comm; - trivial with arith ] ] ]. -Qed. - -Hint Local Resolve weak_assoc. - -Theorem Zplus_assoc : forall n m p:Z, n + (m + p) = n + m + p. -Proof. - intros x y z; case x; case y; case z; auto with arith; intros; - [ rewrite (Zplus_comm (Zneg p0)); rewrite weak_assoc; - rewrite (Zplus_comm (Zpos p1 + Zneg p0)); rewrite weak_assoc; - rewrite (Zplus_comm (Zpos p1)); trivial with arith - | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg; - rewrite Zplus_comm; rewrite <- weak_assoc; - rewrite (Zplus_comm (- Zpos p1)); - rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p); - rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); - trivial with arith - | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p)); - rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0)); - trivial with arith - | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg; - rewrite (Zplus_comm (- Zpos p0)); rewrite weak_assoc; - rewrite (Zplus_comm (Zpos p1 + - Zpos p0)); rewrite weak_assoc; - rewrite (Zplus_comm (Zpos p)); trivial with arith - | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg; - apply weak_assoc - | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg; - apply weak_assoc ]. -Qed. - - -Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p). -Proof. - intros; symmetry in |- *; apply Zplus_assoc. -Qed. - -(** ** Associativity mixed with commutativity *) - -Theorem Zplus_permute : forall n m p:Z, n + (m + p) = m + (n + p). -Proof. - intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc; - rewrite (Zplus_comm p n); trivial with arith. -Qed. - -(** ** Addition simplifies *) - -Theorem Zplus_reg_l : forall n m p:Z, n + m = n + p -> m = p. - intros n m p H; cut (- n + (n + m) = - n + (n + p)); - [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n); - rewrite Zplus_opp_r; simpl in |- *; trivial with arith - | rewrite H; trivial with arith ]. -Qed. - -(** ** Addition and successor permutes *) - -Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m). -Proof. - intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y)); - rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); - trivial with arith. -Qed. - -Lemma Zplus_succ_r_reverse : forall n m:Z, Zsucc (n + m) = n + Zsucc m. -Proof. - intros n m; unfold Zsucc in |- *; rewrite Zplus_assoc; trivial with arith. +Lemma pos_sub_add p q r : + pos_sub (p + q) r = Zpos p + pos_sub q r. +Proof. + simpl. rewrite !pos_sub_spec. + case (Pos.compare_spec q r); intros E0. + - (* q = r *) + subst. + assert (H := Pos.lt_add_r r p). + rewrite Pos.add_comm in H. apply Pos.lt_gt in H. + now rewrite H, Pos.add_sub. + - (* q < r *) + rewrite pos_sub_spec. + assert (Hr : (r = (r-q)+q)%positive) by (now rewrite Pos.sub_add). + rewrite Hr at 1. rewrite Pos.add_compare_mono_r. + case Pos.compare_spec; intros E1; trivial; f_equal. + rewrite Pos.add_comm. apply Pos.sub_add_distr. + rewrite Hr, Pos.add_comm. now apply Pos.add_lt_mono_r. + symmetry. apply Pos.sub_sub_distr; trivial. + - (* r < q *) + assert (LT : (r < p + q)%positive). + { apply Pos.lt_trans with q; trivial. + rewrite Pos.add_comm. apply Pos.lt_add_r. } + apply Pos.lt_gt in LT. rewrite LT. f_equal. + symmetry. now apply Pos.add_sub_assoc. +Qed. + +Lemma add_assoc n m p : n + (m + p) = n + m + p. +Proof. + assert (AUX : forall x y z, Zpos x + (y + z) = Zpos x + y + z). + { intros x [|y|y] [|z|z]; rewrite ?add_0_r; trivial. + - simpl. now rewrite Pos.add_assoc. + - simpl (_ + Zneg _). symmetry. apply pos_sub_add. + - simpl (Zneg _ + _); simpl (_ + Zneg _). + now rewrite (add_comm _ (Zpos _)), <- 2 pos_sub_add, Pos.add_comm. + - apply opp_inj. rewrite !opp_add_distr, opp_Zpos, !opp_Zneg. + simpl (Zneg _ + _); simpl (_ + Zneg _). + rewrite add_comm, Pos.add_comm. apply pos_sub_add. } + destruct n. + - trivial. + - apply AUX. + - apply opp_inj. rewrite !opp_add_distr, opp_Zneg. apply AUX. +Qed. + +(** ** Subtraction and successor *) + +Lemma sub_succ_l n m : succ n - m = succ (n - m). +Proof. + unfold sub, succ. now rewrite <- 2 add_assoc, (add_comm 1). Qed. -Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing). +(** ** Opposite is inverse for addition *) -Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m. +Lemma add_opp_diag_r n : n + - n = 0. Proof. - unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc; - rewrite (Zplus_comm (Zpos 1)); trivial with arith. + destruct n; simpl; trivial; now rewrite pos_sub_diag. Qed. -(** ** Misc properties, usually redundant or non natural *) - -Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0. +Lemma add_opp_diag_l n : - n + n = 0. Proof. - symmetry in |- *; apply Zplus_0_r. + rewrite add_comm. apply add_opp_diag_r. Qed. -Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m. +(** ** Commutativity of multiplication *) + +Lemma mul_comm n m : n * m = m * n. Proof. - intros n m; rewrite Zplus_0_r; intro; assumption. + destruct n, m; simpl; trivial; f_equal; apply Pos.mul_comm. Qed. -Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m. +(** ** Associativity of multiplication *) + +Lemma mul_assoc n m p : n * (m * p) = n * m * p. Proof. - intros n m; rewrite Zplus_0_r; intro; assumption. + destruct n, m, p; simpl; trivial; f_equal; apply Pos.mul_assoc. Qed. -Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q. +(** Multiplication and constants *) + +Lemma mul_1_l n : 1 * n = n. Proof. - intros; rewrite H; rewrite H0; reflexivity. + now destruct n. Qed. -Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m). +Lemma mul_1_r n : n * 1 = n. Proof. - intros x y z. - rewrite <- (Zplus_assoc x). - rewrite (Zplus_assoc (- z)). - rewrite Zplus_opp_l. - reflexivity. + destruct n; simpl; now rewrite ?Pos.mul_1_r. Qed. -(************************************************************************) -(** * Properties of successor and predecessor on binary integer numbers *) +(** ** Multiplication and Opposite *) -Theorem Zsucc_discr : forall n:Z, n <> Zsucc n. +Lemma mul_opp_l n m : - n * m = - (n * m). Proof. - intros n; cut (Z0 <> Zpos 1); - [ unfold not in |- *; intros H1 H2; apply H1; apply (Zplus_reg_l n); - rewrite Zplus_0_r; exact H2 - | discriminate ]. + now destruct n, m. Qed. -Theorem Zpos_succ_morphism : - forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p). +Lemma mul_opp_r n m : n * - m = - (n * m). Proof. - intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *; - trivial with arith. + now destruct n, m. Qed. -(** ** Successor and predecessor are inverse functions *) +Lemma mul_opp_opp n m : - n * - m = n * m. +Proof. + now destruct n, m. +Qed. -Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n). +Lemma mul_opp_comm n m : - n * m = n * - m. Proof. - intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *; - rewrite Zplus_0_r; trivial with arith. + now destruct n, m. Qed. -Hint Immediate Zsucc_pred: zarith. +(** ** Distributivity of multiplication over addition *) + +Lemma mul_add_distr_pos (p:positive) n m : + Zpos p * (n + m) = Zpos p * n + Zpos p * m. +Proof. + destruct n as [|n|n], m as [|m|m]; simpl; trivial; + rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_l; try case Pos.compare_spec; + intros; now rewrite ?Pos.mul_add_distr_l, ?Pos.mul_sub_distr_l. +Qed. -Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n). +Lemma mul_add_distr_l n m p : n * (m + p) = n * m + n * p. Proof. - intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *; - rewrite Zplus_comm; auto with arith. + destruct n as [|n|n]. trivial. + apply mul_add_distr_pos. + rewrite <- opp_Zpos, !mul_opp_l, <- opp_add_distr. f_equal. + apply mul_add_distr_pos. Qed. -Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m. +Lemma mul_add_distr_r n m p : (n + m) * p = n * p + m * p. Proof. - intros n m H. - change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m) in |- *; - do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1)); - unfold Zsucc in H; rewrite H; trivial with arith. + rewrite !(mul_comm _ p). apply mul_add_distr_l. Qed. -(*************************************************************************) -(** ** Properties of the direct definition of successor and predecessor *) +End Private_BootStrap. + +(** * Proofs of specifications *) + +(** ** Specification of constants *) -Theorem Zsucc_succ' : forall n:Z, Zsucc n = Zsucc' n. +Lemma one_succ : 1 = succ 0. Proof. -destruct n as [| p | p]; simpl. reflexivity. -now rewrite Pplus_one_succ_r. -now destruct p as [q | q |]. Qed. -Theorem Zpred_pred' : forall n:Z, Zpred n = Zpred' n. +Lemma two_succ : 2 = succ 1. Proof. -destruct n as [| p | p]; simpl. reflexivity. -now destruct p as [q | q |]. -now rewrite Pplus_one_succ_r. Qed. -Theorem Zsucc'_inj : forall n m:Z, Zsucc' n = Zsucc' m -> n = m. +(** ** Specification of addition *) + +Lemma add_0_l n : 0 + n = n. +Proof. + now destruct n. +Qed. + +Lemma add_succ_l n m : succ n + m = succ (n + m). Proof. -intros n m; do 2 rewrite <- Zsucc_succ'; now apply Zsucc_inj. + unfold succ. now rewrite 2 (add_comm _ 1), add_assoc. Qed. -Theorem Zsucc'_pred' : forall n:Z, Zsucc' (Zpred' n) = n. +(** ** Specification of opposite *) + +Lemma opp_0 : -0 = 0. Proof. -intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'; -symmetry; apply Zsucc_pred. + reflexivity. Qed. -Theorem Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n. +Lemma opp_succ n : -(succ n) = pred (-n). Proof. -intro; apply Zsucc'_inj; now rewrite Zsucc'_pred'. + unfold succ, pred. apply opp_add_distr. Qed. -Theorem Zpred'_inj : forall n m:Z, Zpred' n = Zpred' m -> n = m. +(** ** Specification of successor and predecessor *) + +Lemma succ_pred n : succ (pred n) = n. Proof. -intros n m H. -rewrite <- (Zsucc'_pred' n); rewrite <- (Zsucc'_pred' m); now rewrite H. + unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. -Theorem Zsucc'_discr : forall n:Z, n <> Zsucc' n. +Lemma pred_succ n : pred (succ n) = n. Proof. - intro x; destruct x; simpl in |- *. - discriminate. - injection; apply Psucc_discr. - destruct p; simpl in |- *. - discriminate. - intro H; symmetry in H; injection H; apply double_moins_un_xO_discr. - discriminate. + unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. -(** Misc properties, usually redundant or non natural *) +(** ** Specification of subtraction *) -Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m. +Lemma sub_0_r n : n - 0 = n. Proof. - intros n m H; rewrite H; reflexivity. + apply add_0_r. Qed. -Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m. +Lemma sub_succ_r n m : n - succ m = pred (n - m). Proof. - unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption. + unfold sub, succ, pred. now rewrite opp_add_distr, add_assoc. Qed. -(**********************************************************************) -(** * Properties of subtraction on binary integer numbers *) +(** ** Specification of multiplication *) -(** ** [minus] and [Z0] *) +Lemma mul_0_l n : 0 * n = 0. +Proof. + reflexivity. +Qed. + +Lemma mul_succ_l n m : succ n * m = n * m + m. +Proof. + unfold succ. now rewrite mul_add_distr_r, mul_1_l. +Qed. + +(** ** Specification of comparisons and order *) + +Lemma eqb_eq n m : (n =? m) = true <-> n = m. +Proof. + destruct n, m; simpl; try (now split). + rewrite inj_Zpos. apply Pos.eqb_eq. + rewrite inj_Zneg. apply Pos.eqb_eq. +Qed. + +Lemma ltb_lt n m : (n <? m) = true <-> n < m. +Proof. + unfold ltb, lt. destruct compare; easy'. +Qed. -Lemma Zminus_0_r : forall n:Z, n - Z0 = n. +Lemma leb_le n m : (n <=? m) = true <-> n <= m. Proof. - intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r; - trivial with arith. + unfold leb, le. destruct compare; easy'. Qed. -Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0. +Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. Proof. - intro; symmetry in |- *; apply Zminus_0_r. +destruct n, m; simpl; rewrite ?CompOpp_iff, ?Pos.compare_eq_iff; + split; congruence. Qed. -Lemma Zminus_diag : forall n:Z, n - n = Z0. +Lemma compare_sub n m : (n ?= m) = (n - m ?= 0). Proof. - intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith. + destruct n as [|n|n], m as [|m|m]; simpl; trivial; + rewrite <- ? Pos.compare_antisym, ?pos_sub_spec; + case Pos.compare_spec; trivial. Qed. -Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n. +Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). Proof. - intro; symmetry in |- *; apply Zminus_diag. +destruct n, m; simpl; trivial; now rewrite <- ?Pos.compare_antisym. Qed. +Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. +Proof. reflexivity. Qed. + +Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. +Proof. reflexivity. Qed. + +(** Some more advanced properties of comparison and orders, + including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *) -(** ** Relating [minus] with [plus] and [Zsucc] *) +Include BoolOrderFacts. -Lemma Zminus_plus_distr : forall n m p:Z, n - (m + p) = n - m - p. +(** Remaining specification of [lt] and [le] *) + +Lemma lt_succ_r n m : n < succ m <-> n<=m. Proof. -intros; unfold Zminus; rewrite Zopp_plus_distr; apply Zplus_assoc. + unfold lt, le. rewrite compare_sub, sub_succ_r. + rewrite (compare_sub n m). + destruct (n-m) as [|[ | | ]|]; easy'. Qed. -Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m. +(** ** Specification of minimum and maximum *) + +Lemma max_l n m : m<=n -> max n m = n. Proof. - intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m)); - rewrite <- Zplus_assoc; apply Zplus_comm. + unfold le, max. rewrite (compare_antisym n m). + case compare; intuition. Qed. -Lemma Zminus_succ_r : forall n m:Z, n - (Zsucc m) = Zpred (n - m). +Lemma max_r n m : n<=m -> max n m = m. Proof. -intros; unfold Zsucc; now rewrite Zminus_plus_distr. + unfold le, max. case compare_spec; intuition. Qed. -Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m. +Lemma min_l n m : n<=m -> min n m = n. Proof. - intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m); - rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc; - rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; - trivial with arith. + unfold le, min. case compare_spec; intuition. Qed. -Lemma Zminus_plus : forall n m:Z, n + m - n = m. +Lemma min_r n m : m<=n -> min n m = m. Proof. - intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m); - rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r. + unfold le, min. + rewrite (compare_antisym n m). case compare_spec; intuition. Qed. -Lemma Zplus_minus : forall n m:Z, n + (m - n) = m. +(** ** Specification of absolute value *) + +Lemma abs_eq n : 0 <= n -> abs n = n. Proof. - unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r; - apply Zplus_0_r. + destruct n; trivial. now destruct 1. Qed. -Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m. +Lemma abs_neq n : n <= 0 -> abs n = - n. Proof. - intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr; - rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p); - rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith. + destruct n; trivial. now destruct 1. Qed. -Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m). +(** ** Specification of sign *) + +Lemma sgn_null n : n = 0 -> sgn n = 0. Proof. - intros; symmetry in |- *; apply Zminus_plus_simpl_l. + intros. now subst. Qed. -Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m. +Lemma sgn_pos n : 0 < n -> sgn n = 1. Proof. - intros x y n. - unfold Zminus in |- *. - rewrite Zopp_plus_distr. - rewrite (Zplus_comm (- y) (- n)). - rewrite Zplus_assoc. - rewrite <- (Zplus_assoc x n (- n)). - rewrite (Zplus_opp_r n). - rewrite <- Zplus_0_r_reverse. - reflexivity. + now destruct n. Qed. -Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt -> - Zpos (b-a) = Zpos b - Zpos a. +Lemma sgn_neg n : n < 0 -> sgn n = -1. Proof. - intros. - simpl. - change Eq with (CompOpp Eq). - rewrite <- Pcompare_antisym. - rewrite H; simpl; auto. + now destruct n. Qed. -(** ** Misc redundant properties *) +(** ** Specification of power *) -Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0. +Lemma pow_0_r n : n^0 = 1. Proof. - intros x y H; rewrite H; symmetry in |- *; apply Zminus_diag_reverse. + reflexivity. Qed. -Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m. +Lemma pow_succ_r n m : 0<=m -> n^(succ m) = n * n^m. Proof. - intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r. + destruct m as [|m|m]; (now destruct 1) || (intros _); simpl; trivial. + unfold pow_pos. now rewrite Pos.add_comm, Pos.iter_add. Qed. +Lemma pow_neg_r n m : m<0 -> n^m = 0. +Proof. + now destruct m. +Qed. -(**********************************************************************) -(** * Properties of multiplication on binary integer numbers *) +(** For folding back a [pow_pos] into a [pow] *) -Theorem Zpos_mult_morphism : - forall p q:positive, Zpos (p*q) = Zpos p * Zpos q. +Lemma pow_pos_fold n p : pow_pos n p = n ^ (Zpos p). Proof. - auto. + reflexivity. Qed. -(** ** One is neutral for multiplication *) +(** ** Specification of square *) -Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n. +Lemma square_spec n : square n = n * n. Proof. - intro x; destruct x; reflexivity. + destruct n; trivial; simpl; f_equal; apply Pos.square_spec. Qed. -Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n. +(** ** Specification of square root *) + +Lemma sqrtrem_spec n : 0<=n -> + let (s,r) := sqrtrem n in n = s*s + r /\ 0 <= r <= 2*s. Proof. - intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity. + destruct n. now repeat split. + generalize (Pos.sqrtrem_spec p). simpl. + destruct 1; simpl; subst; now repeat split. + now destruct 1. Qed. -(** ** Zero property of multiplication *) +Lemma sqrt_spec n : 0<=n -> + let s := sqrt n in s*s <= n < (succ s)*(succ s). +Proof. + destruct n. now repeat split. unfold sqrt. + rewrite succ_Zpos. intros _. apply (Pos.sqrt_spec p). + now destruct 1. +Qed. -Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0. +Lemma sqrt_neg n : n<0 -> sqrt n = 0. Proof. - intro x; destruct x; reflexivity. + now destruct n. Qed. -Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0. +Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. Proof. - intro x; destruct x; reflexivity. + destruct n; try reflexivity. + unfold sqrtrem, sqrt, Pos.sqrt. + destruct (Pos.sqrtrem p) as (s,r). now destruct r. Qed. -Hint Local Resolve Zmult_0_l Zmult_0_r. +(** ** Specification of logarithm *) -Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0. +Lemma log2_spec n : 0 < n -> 2^(log2 n) <= n < 2^(succ (log2 n)). Proof. - intro x; destruct x; reflexivity. + destruct n as [|[p|p|]|]; intros Hn; split; try easy; unfold log2; + rewrite ?succ_Zpos, pow_Zpos. + change (2^Pos.size p <= Pos.succ (p~0))%positive. + apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. + apply Pos.size_gt. + apply Pos.size_le. + apply Pos.size_gt. Qed. -(** ** Commutativity of multiplication *) +Lemma log2_nonpos n : n<=0 -> log2 n = 0. +Proof. + destruct n as [|p|p]; trivial; now destruct 1. +Qed. + +(** Specification of parity functions *) -Theorem Zmult_comm : forall n m:Z, n * m = m * n. +Lemma even_spec n : even n = true <-> Even n. Proof. - intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *; - try rewrite (Pmult_comm p q); reflexivity. + split. + exists (div2 n). now destruct n as [|[ | | ]|[ | | ]]. + intros (m,->). now destruct m. Qed. -(** ** Associativity of multiplication *) +Lemma odd_spec n : odd n = true <-> Odd n. +Proof. + split. + exists (div2 n). destruct n as [|[ | | ]|[ | | ]]; simpl; try easy. + now rewrite Pos.pred_double_succ. + intros (m,->). now destruct m as [|[ | | ]|[ | | ]]. +Qed. + +(** ** Multiplication and Doubling *) + +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 pred_double_spec n : pred_double n = 2*n - 1. +Proof. + now destruct n. +Qed. + +(** ** Correctness proofs for Trunc division *) + +Lemma pos_div_eucl_eq a b : 0 < b -> + let (q, r) := pos_div_eucl a b in Zpos a = q * b + r. +Proof. + intros Hb. + induction a; unfold pos_div_eucl; fold pos_div_eucl. + - (* ~1 *) + destruct pos_div_eucl as (q,r). + rewrite pos_xI, IHa, mul_add_distr_l, mul_assoc. + destruct ltb. + now rewrite add_assoc. + rewrite mul_add_distr_r, mul_1_l, <- !add_assoc. f_equal. + unfold sub. now rewrite (add_comm _ (-b)), add_assoc, add_opp_diag_r. + - (* ~0 *) + destruct pos_div_eucl as (q,r). + rewrite (pos_xO a), IHa, mul_add_distr_l, mul_assoc. + destruct ltb. + trivial. + rewrite mul_add_distr_r, mul_1_l, <- !add_assoc. f_equal. + unfold sub. now rewrite (add_comm _ (-b)), add_assoc, add_opp_diag_r. + - (* 1 *) + case leb_spec; trivial. + intros Hb'. + destruct b as [|b|b]; try easy; clear Hb. + replace b with 1%positive; trivial. + apply Pos.le_antisym. apply Pos.le_1_l. now apply Pos.lt_succ_r. +Qed. + +Lemma div_eucl_eq a b : b<>0 -> + let (q, r) := div_eucl a b in a = b * q + r. +Proof. + destruct a as [ |a|a], b as [ |b|b]; unfold div_eucl; trivial; + (now destruct 1) || intros _; + generalize (pos_div_eucl_eq a (Zpos b) (eq_refl _)); + destruct pos_div_eucl as (q,r); rewrite <- ?opp_Zpos, mul_comm; + intros ->. + - (* Zpos Zpos *) + trivial. + - (* Zpos Zneg *) + destruct r as [ |r|r]; rewrite !mul_opp_opp; trivial; + rewrite mul_add_distr_l, mul_1_r, <- add_assoc; f_equal; + now rewrite add_assoc, add_opp_diag_r. + - (* Zneg Zpos *) + rewrite (opp_add_distr _ r), <- mul_opp_r. + destruct r as [ |r|r]; trivial; + rewrite opp_add_distr, mul_add_distr_l, <- add_assoc; f_equal; + unfold sub; now rewrite add_assoc, mul_opp_r, mul_1_r, add_opp_diag_l. + - (* Zneg Zneg *) + now rewrite opp_add_distr, <- mul_opp_l. +Qed. + +Lemma div_mod a b : b<>0 -> a = b*(a/b) + (a mod b). +Proof. + intros Hb. generalize (div_eucl_eq a b Hb). + unfold div, modulo. now destruct div_eucl. +Qed. + +Lemma pos_div_eucl_bound a b : 0<b -> 0 <= snd (pos_div_eucl a b) < b. +Proof. + assert (AUX : forall m p, m < Zpos (p~0) -> m - Zpos p < Zpos p). + intros m p. unfold lt. + rewrite (compare_sub m), (compare_sub _ (Zpos _)). unfold sub. + rewrite <- add_assoc. simpl opp; simpl (Zneg _ + _). + now rewrite Pos.add_diag. + intros Hb. + destruct b as [|b|b]; discriminate Hb || clear Hb. + induction a; unfold pos_div_eucl; fold pos_div_eucl. + (* ~1 *) + destruct pos_div_eucl as (q,r). + simpl in IHa; destruct IHa as (Hr,Hr'). + case ltb_spec; intros H; unfold snd. split; trivial. now destruct r. + split. unfold le. + now rewrite compare_antisym, <- compare_sub, <- compare_antisym. + apply AUX. rewrite <- succ_double_spec. + destruct r; try easy. unfold lt in *; simpl in *. + now rewrite Pos.compare_xI_xO, Hr'. + (* ~0 *) + destruct pos_div_eucl as (q,r). + simpl in IHa; destruct IHa as (Hr,Hr'). + case ltb_spec; intros H; unfold snd. split; trivial. now destruct r. + split. unfold le. + now rewrite compare_antisym, <- compare_sub, <- compare_antisym. + apply AUX. destruct r; try easy. + (* 1 *) + case leb_spec; intros H; simpl; split; try easy. + red; simpl. now apply Pos.le_succ_l. +Qed. -Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p. +Lemma mod_pos_bound a b : 0 < b -> 0 <= a mod b < b. Proof. - intros x y z; destruct x; destruct y; destruct z; simpl in |- *; - try rewrite Pmult_assoc; reflexivity. + destruct b as [|b|b]; try easy; intros _. + destruct a as [|a|a]; unfold modulo, div_eucl. + now split. + now apply pos_div_eucl_bound. + generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)). + destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). + destruct r as [|r|r]; (now destruct Hr) || clear Hr. + now split. + split. unfold le. + now rewrite compare_antisym, <- compare_sub, <- compare_antisym, Hr'. + unfold lt in *; simpl in *. rewrite pos_sub_gt by trivial. + simpl. now apply Pos.sub_decr. Qed. -Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p). +Definition mod_bound_pos a b (_:0<=a) := mod_pos_bound a b. + +Lemma mod_neg_bound a b : b < 0 -> b < a mod b <= 0. Proof. - intros n m p; rewrite Zmult_assoc; trivial with arith. + destruct b as [|b|b]; try easy; intros _. + destruct a as [|a|a]; unfold modulo, div_eucl. + now split. + generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)). + destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). + destruct r as [|r|r]; (now destruct Hr) || clear Hr. + now split. + split. + unfold lt in *; simpl in *. rewrite pos_sub_lt by trivial. + rewrite <- Pos.compare_antisym. now apply Pos.sub_decr. + change (Zneg b - Zneg r <= 0). unfold le, lt in *. + rewrite <- compare_sub. simpl in *. + now rewrite <- Pos.compare_antisym, Hr'. + generalize (pos_div_eucl_bound a (Zpos b) (eq_refl _)). + destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr'). + split; destruct r; try easy. + red; simpl; now rewrite <- Pos.compare_antisym. Qed. -(** ** Associativity mixed with commutativity *) +(** ** Correctness proofs for Floor division *) + +Theorem quotrem_eq a b : let (q,r) := quotrem a b in a = q * b + r. +Proof. + destruct a as [|a|a], b as [|b|b]; simpl; trivial; + generalize (N.pos_div_eucl_spec a (Npos b)); case N.pos_div_eucl; trivial; + intros q r; rewrite <- ?opp_Zpos; + change (Zpos a) with (of_N (Npos a)); intros ->; now destruct q, r. +Qed. -Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p). +Lemma quot_rem' a b : a = b*(a÷b) + rem a b. Proof. - intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x). - apply Zmult_assoc. + rewrite mul_comm. generalize (quotrem_eq a b). + unfold quot, rem. now destruct quotrem. Qed. -(** ** Z is integral *) +Lemma quot_rem a b : b<>0 -> a = b*(a÷b) + rem a b. +Proof. intros _. apply quot_rem'. Qed. -Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0. +Lemma rem_bound_pos a b : 0<=a -> 0<b -> 0 <= rem a b < b. Proof. - intros x y; destruct x as [| p| p]. - intro H; absurd (Z0 = Z0); trivial. - intros _ H; destruct y as [| q| q]; reflexivity || discriminate. - intros _ H; destruct y as [| q| q]; reflexivity || discriminate. + intros Ha Hb. + destruct b as [|b|b]; (now discriminate Hb) || clear Hb; + destruct a as [|a|a]; (now destruct Ha) || clear Ha. + compute. now split. + unfold rem, quotrem. + assert (H := N.pos_div_eucl_remainder a (Npos b)). + destruct N.pos_div_eucl as (q,[|r]); simpl; split; try easy. + now apply H. Qed. +Lemma rem_opp_l' a b : rem (-a) b = - (rem a b). +Proof. + destruct a, b; trivial; unfold rem; simpl; + now destruct N.pos_div_eucl as (q,[|r]). +Qed. -Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0. +Lemma rem_opp_r' a b : rem a (-b) = rem a b. Proof. - intros x y; destruct x; destruct y; auto; simpl in |- *; intro H; - discriminate H. + destruct a, b; trivial; unfold rem; simpl; + now destruct N.pos_div_eucl as (q,[|r]). Qed. +Lemma rem_opp_l a b : b<>0 -> rem (-a) b = - (rem a b). +Proof. intros _. apply rem_opp_l'. Qed. -Lemma Zmult_1_inversion_l : - forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1. +Lemma rem_opp_r a b : b<>0 -> rem a (-b) = rem a b. +Proof. intros _. apply rem_opp_r'. Qed. + +(** ** Basic properties of divisibility *) + +Lemma divide_Zpos p q : (Zpos p|Zpos q) <-> (p|q)%positive. Proof. - intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ]; - (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H; - intro H; rewrite Pmult_1_inversion_l with (1 := H); - reflexivity). + split. + intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto. + intros (r,H). exists (Zpos r); simpl; now f_equal. Qed. -(** ** Multiplication and Doubling *) +Lemma divide_Zpos_Zneg_r n p : (n|Zpos p) <-> (n|Zneg p). +Proof. + split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H. +Qed. -Lemma Zdouble_mult : forall z, Zdouble z = (Zpos 2) * z. +Lemma divide_Zpos_Zneg_l n p : (Zpos p|n) <-> (Zneg p|n). Proof. - reflexivity. + split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r. Qed. -Lemma Zdouble_plus_one_mult : forall z, - Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1). +(** ** Correctness proofs for gcd *) + +Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b. Proof. - destruct z; simpl; auto with zarith. + destruct a as [ |p|p], b as [ |q|q]; simpl; auto; + generalize (Pos.ggcd_gcd p q); destruct Pos.ggcd as (g,(aa,bb)); + simpl; congruence. Qed. -(** ** Multiplication and Opposite *) +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|p], b as [ |q|q]; simpl; rewrite ?Pos.mul_1_r; auto; + generalize (Pos.ggcd_correct_divisors p q); + destruct Pos.ggcd as (g,(aa,bb)); simpl; destruct 1; now subst. +Qed. -Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m. +Lemma gcd_divide_l a b : (gcd a b | a). Proof. - intros x y; destruct x; destruct y; reflexivity. + 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. -Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m. +Lemma gcd_divide_r a b : (gcd a b | b). Proof. - intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l; - apply Zmult_comm. + 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. -Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m). +Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c | gcd a b). Proof. - intros x y; symmetry in |- *; apply Zopp_mult_distr_l. + assert (H : forall p q r, (r|Zpos p) -> (r|Zpos q) -> (r|Zpos (Pos.gcd p q))). + { intros p q [|r|r] H H'. + destruct H; now rewrite mul_comm in *. + apply divide_Zpos, Pos.gcd_greatest; now apply divide_Zpos. + apply divide_Zpos_Zneg_l, divide_Zpos, Pos.gcd_greatest; + now apply divide_Zpos, divide_Zpos_Zneg_l. + } + destruct a, b; simpl; auto; intros; try apply H; trivial; + now apply divide_Zpos_Zneg_r. Qed. -Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m. +Lemma gcd_nonneg a b : 0 <= gcd a b. Proof. - intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r; - trivial with arith. + now destruct a, b. Qed. -Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m. +(** ggcd and opp : an auxiliary result used in QArith *) + +Theorem ggcd_opp a b : + ggcd (-a) b = (let '(g,(aa,bb)) := ggcd a b in (g,(-aa,bb))). Proof. - intros x y; destruct x; destruct y; reflexivity. + destruct a as [|a|a], b as [|b|b]; unfold ggcd, opp; auto; + destruct (Pos.ggcd a b) as (g,(aa,bb)); auto. Qed. -Theorem Zopp_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1. +(** ** Conversions between [Z.testbit] and [N.testbit] *) + +Lemma testbit_of_N a n : + testbit (of_N a) (of_N n) = N.testbit a n. Proof. - intro x; induction x; intros; rewrite Zmult_comm; auto with arith. + destruct a as [|a], n; simpl; trivial. now destruct a. Qed. -(** ** Distributivity of multiplication over addition *) +Lemma testbit_of_N' a n : 0<=n -> + testbit (of_N a) n = N.testbit a (to_N n). +Proof. + intro Hn. rewrite <- testbit_of_N. f_equal. + destruct n; trivial; now destruct Hn. +Qed. -Lemma weak_Zmult_plus_distr_r : - forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m. +Lemma testbit_Zpos a n : 0<=n -> + testbit (Zpos a) n = N.testbit (Npos a) (to_N n). Proof. - intros x y' z'; case y'; case z'; auto with arith; intros y z; - (simpl in |- *; rewrite Pmult_plus_distr_l; trivial with arith) || - (simpl in |- *; ElimPcompare z y; intros E0; rewrite E0; - [ rewrite (Pcompare_Eq_eq z y E0); rewrite (Pcompare_refl (x * y)); - trivial with arith - | cut ((x * z ?= x * y)%positive Eq = Lt); - [ intros E; rewrite E; rewrite Pmult_minus_distr_l; - [ trivial with arith | apply ZC2; assumption ] - | apply nat_of_P_lt_Lt_compare_complement_morphism; - do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); - intros h H1; rewrite H1; apply mult_S_lt_compat_l; - exact (nat_of_P_lt_Lt_compare_morphism z y E0) ] - | cut ((x * z ?= x * y)%positive Eq = Gt); - [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith - | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *; - do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); - intros h H1; rewrite H1; apply mult_S_lt_compat_l; - exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]). + intro Hn. now rewrite <- testbit_of_N'. Qed. -Theorem Zmult_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p. +Lemma testbit_Zneg a n : 0<=n -> + testbit (Zneg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)). Proof. - intros x y z; case x; - [ auto with arith - | intros x'; apply weak_Zmult_plus_distr_r - | intros p; apply Zopp_inj; rewrite Zopp_plus_distr; - do 3 rewrite <- Zopp_mult_distr_l_reverse; rewrite Zopp_neg; - apply weak_Zmult_plus_distr_r ]. + intro Hn. + rewrite <- testbit_of_N' by trivial. + destruct n as [ |n|n]; + [ | simpl; now destruct (Ppred_N a) | now destruct Hn]. + unfold testbit. + now destruct a as [|[ | | ]| ]. Qed. -Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p. +(** ** Proofs of specifications for bitwise operations *) + +Lemma div2_spec a : div2 a = shiftr a 1. Proof. - intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r; - do 2 rewrite (Zmult_comm p); trivial with arith. + reflexivity. Qed. -(** ** Distributivity of multiplication over subtraction *) +Lemma testbit_0_l n : testbit 0 n = false. +Proof. + now destruct n. +Qed. -Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p. +Lemma testbit_neg_r a n : n<0 -> testbit a n = false. Proof. - intros x y z; unfold Zminus in |- *. - rewrite <- Zopp_mult_distr_l_reverse. - apply Zmult_plus_distr_l. + now destruct n. Qed. +Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. +Proof. + now destruct a as [|a|[a|a|]]. +Qed. -Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m. +Lemma testbit_even_0 a : testbit (2*a) 0 = false. Proof. - intros x y z; rewrite (Zmult_comm z (x - y)). - rewrite (Zmult_comm z x). - rewrite (Zmult_comm z y). - apply Zmult_minus_distr_r. + now destruct a. Qed. -(** ** Simplification of multiplication for non-zero integers *) +Lemma testbit_odd_succ a n : 0<=n -> + testbit (2*a+1) (succ n) = testbit a n. +Proof. + destruct n as [|n|n]; (now destruct 1) || intros _. + destruct a as [|[a|a|]|[a|a|]]; simpl; trivial. now destruct a. + unfold testbit. rewrite succ_Zpos. + destruct a as [|a|[a|a|]]; simpl; trivial; + rewrite ?Pos.pred_N_succ; now destruct n. +Qed. -Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m. +Lemma testbit_even_succ a n : 0<=n -> + testbit (2*a) (succ n) = testbit a n. Proof. - intros x y z H H0. - generalize (Zeq_minus _ _ H0). - intro. - apply Zminus_eq. - rewrite <- Zmult_minus_distr_l in H1. - clear H0; destruct (Zmult_integral _ _ H1). - contradiction. - trivial. + destruct n as [|n|n]; (now destruct 1) || intros _. + destruct a as [|[a|a|]|[a|a|]]; simpl; trivial. now destruct a. + unfold testbit. rewrite succ_Zpos. + destruct a as [|a|[a|a|]]; simpl; trivial; + rewrite ?Pos.pred_N_succ; now destruct n. Qed. -Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m. +(** Correctness proofs about [Z.shiftr] and [Z.shiftl] *) + +Lemma shiftr_spec_aux a n m : 0<=n -> 0<=m -> + testbit (shiftr a n) m = testbit a (m+n). Proof. - intros x y z Hz. - rewrite (Zmult_comm x z). - rewrite (Zmult_comm y z). - intro; apply Zmult_reg_l with z; assumption. + intros Hn Hm. unfold shiftr. + destruct n as [ |n|n]; (now destruct Hn) || clear Hn; simpl. + now rewrite add_0_r. + assert (forall p, to_N (m + Zpos p) = (to_N m + Npos p)%N). + destruct m; trivial; now destruct Hm. + assert (forall p, 0 <= m + Zpos p). + destruct m; easy || now destruct Hm. + destruct a as [ |a|a]. + (* a = 0 *) + replace (Pos.iter n div2 0) with 0 + by (apply Pos.iter_invariant; intros; subst; trivial). + now rewrite 2 testbit_0_l. + (* a > 0 *) + change (Zpos a) with (of_N (Npos a)) at 1. + rewrite <- (Pos.iter_swap_gen _ _ _ Ndiv2) by now intros [|[ | | ]]. + rewrite testbit_Zpos, testbit_of_N', H; trivial. + exact (N.shiftr_spec' (Npos a) (Npos n) (to_N m)). + (* a < 0 *) + rewrite <- (Pos.iter_swap_gen _ _ _ Pdiv2_up) by trivial. + rewrite 2 testbit_Zneg, H; trivial. f_equal. + rewrite (Pos.iter_swap_gen _ _ _ _ Ndiv2) by exact N.pred_div2_up. + exact (N.shiftr_spec' (Ppred_N a) (Npos n) (to_N m)). Qed. -(** ** Addition and multiplication by 2 *) +Lemma shiftl_spec_low a n m : m<n -> + testbit (shiftl a n) m = false. +Proof. + intros H. destruct n as [|n|n], m as [|m|m]; try easy; simpl shiftl. + destruct (Pos.succ_pred_or n) as [-> | <-]; + rewrite ?Pos.iter_succ; apply testbit_even_0. + destruct a as [ |a|a]. + (* a = 0 *) + replace (Pos.iter n (mul 2) 0) with 0 + by (apply Pos.iter_invariant; intros; subst; trivial). + apply testbit_0_l. + (* a > 0 *) + rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial. + rewrite testbit_Zpos by easy. + exact (N.shiftl_spec_low (Npos a) (Npos n) (Npos m) H). + (* a < 0 *) + rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial. + rewrite testbit_Zneg by easy. + now rewrite (N.pos_pred_shiftl_low a (Npos n)). +Qed. + +Lemma shiftl_spec_high a n m : 0<=m -> n<=m -> + testbit (shiftl a n) m = testbit a (m-n). +Proof. + intros Hm H. + destruct n as [ |n|n]. simpl. now rewrite sub_0_r. + (* n > 0 *) + destruct m as [ |m|m]; try (now destruct H). + assert (0 <= Zpos m - Zpos n). + red. now rewrite compare_antisym, <- compare_sub, <- compare_antisym. + assert (EQ : to_N (Zpos m - Zpos n) = (Npos m - Npos n)%N). + red in H. simpl in H. simpl to_N. + rewrite pos_sub_spec, Pos.compare_antisym. + destruct (Pos.compare_spec n m) as [H'|H'|H']; try (now destruct H). + subst. now rewrite N.sub_diag. + simpl. destruct (Pos.sub_mask_pos' m n H') as (p & -> & <-). + f_equal. now rewrite Pos.add_comm, Pos.add_sub. + destruct a; unfold shiftl. + (* ... a = 0 *) + replace (Pos.iter n (mul 2) 0) with 0 + by (apply Pos.iter_invariant; intros; subst; trivial). + now rewrite 2 testbit_0_l. + (* ... a > 0 *) + rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial. + rewrite 2 testbit_Zpos, EQ by easy. + exact (N.shiftl_spec_high' (Npos p) (Npos n) (Npos m) H). + (* ... a < 0 *) + rewrite <- (Pos.iter_swap_gen _ _ _ xO) by trivial. + rewrite 2 testbit_Zneg, EQ by easy. f_equal. + simpl to_N. + rewrite <- N.shiftl_spec_high by easy. + now apply (N.pos_pred_shiftl_high p (Npos n)). + (* n < 0 *) + unfold sub. simpl. + now apply (shiftr_spec_aux a (Zpos n) m). +Qed. + +Lemma shiftr_spec a n m : 0<=m -> + testbit (shiftr a n) m = testbit a (m+n). +Proof. + intros Hm. + destruct (leb_spec 0 n). + now apply shiftr_spec_aux. + destruct (leb_spec (-n) m) as [LE|GT]. + unfold shiftr. + rewrite (shiftl_spec_high a (-n) m); trivial. now destruct n. + unfold shiftr. + rewrite (shiftl_spec_low a (-n) m); trivial. + rewrite testbit_neg_r; trivial. + red in GT. rewrite compare_sub in GT. now destruct n. +Qed. + +(** Correctness proofs for bitwise operations *) + +Lemma lor_spec a b n : + testbit (lor a b) n = testbit a n || testbit b n. +Proof. + destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r]. + destruct a as [ |a|a], b as [ |b|b]; + rewrite ?testbit_0_l, ?orb_false_r; trivial; unfold lor; + rewrite ?testbit_Zpos, ?testbit_Zneg, ?N.pos_pred_succ by trivial. + now rewrite <- N.lor_spec. + now rewrite N.ldiff_spec, negb_andb, negb_involutive, orb_comm. + now rewrite N.ldiff_spec, negb_andb, negb_involutive. + now rewrite N.land_spec, negb_andb. +Qed. + +Lemma land_spec a b n : + testbit (land a b) n = testbit a n && testbit b n. +Proof. + destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r]. + destruct a as [ |a|a], b as [ |b|b]; + rewrite ?testbit_0_l, ?andb_false_r; trivial; unfold land; + rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ + by trivial. + now rewrite <- N.land_spec. + now rewrite N.ldiff_spec. + now rewrite N.ldiff_spec, andb_comm. + now rewrite N.lor_spec, negb_orb. +Qed. + +Lemma ldiff_spec a b n : + testbit (ldiff a b) n = testbit a n && negb (testbit b n). +Proof. + destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r]. + destruct a as [ |a|a], b as [ |b|b]; + rewrite ?testbit_0_l, ?andb_true_r; trivial; unfold ldiff; + rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ + by trivial. + now rewrite <- N.ldiff_spec. + now rewrite N.land_spec, negb_involutive. + now rewrite N.lor_spec, negb_orb. + now rewrite N.ldiff_spec, negb_involutive, andb_comm. +Qed. + +Lemma lxor_spec a b n : + testbit (lxor a b) n = xorb (testbit a n) (testbit b n). +Proof. + destruct (leb_spec 0 n) as [Hn|Hn]; [|now rewrite !testbit_neg_r]. + destruct a as [ |a|a], b as [ |b|b]; + rewrite ?testbit_0_l, ?xorb_false_l, ?xorb_false_r; trivial; unfold lxor; + rewrite ?testbit_Zpos, ?testbit_Zneg, ?testbit_of_N', ?N.pos_pred_succ + by trivial. + now rewrite <- N.lxor_spec. + now rewrite N.lxor_spec, negb_xorb_r. + now rewrite N.lxor_spec, negb_xorb_l. + now rewrite N.lxor_spec, xorb_negb_negb. +Qed. + +(** ** Induction principles based on successor / predecessor *) + +Lemma peano_ind (P : Z -> Prop) : + P 0 -> + (forall x, P x -> P (succ x)) -> + (forall x, P x -> P (pred x)) -> + forall z, P z. +Proof. + intros H0 Hs Hp z; destruct z. + assumption. + induction p using Pos.peano_ind. + now apply (Hs 0). + rewrite <- Pos.add_1_r. + now apply (Hs (Zpos p)). + induction p using Pos.peano_ind. + now apply (Hp 0). + rewrite <- Pos.add_1_r. + now apply (Hp (Zneg p)). +Qed. + +Lemma bi_induction (P : Z -> Prop) : + Proper (eq ==> iff) P -> + P 0 -> + (forall x, P x <-> P (succ x)) -> + forall z, P z. +Proof. + intros _ H0 Hs. induction z using peano_ind. + assumption. + now apply -> Hs. + apply Hs. now rewrite succ_pred. +Qed. + + +(** * 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 opp_wd : Proper (eq==>eq) opp := _. +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 quot_wd : Proper (eq==>eq==>eq) quot := _. +Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _. +Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _. +Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _. + +Include ZProp + <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. + +(** Otherwise Z stays associated with abstract_scope : (TODO FIX) *) +Bind Scope Z_scope with Z. + +(** 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 Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2. +Lemma gt_lt_iff n m : n > m <-> m < n. Proof. - intros x; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; reflexivity. + unfold lt, gt. now rewrite compare_antisym, CompOpp_iff. Qed. -(** ** Multiplication and successor *) +Lemma gt_lt n m : n > m -> m < n. +Proof. + apply gt_lt_iff. +Qed. -Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n. +Lemma lt_gt n m : n < m -> m > n. Proof. - intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r; - rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; - trivial with arith. + apply gt_lt_iff. Qed. -Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m. +Lemma ge_le_iff n m : n >= m <-> m <= n. Proof. - intros; symmetry in |- *; apply Zmult_succ_r. + unfold le, ge. now rewrite compare_antisym, CompOpp_iff. Qed. -Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m. +Lemma ge_le n m : n >= m -> m <= n. Proof. - intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l; - rewrite Zmult_1_l; trivial with arith. + apply ge_le_iff. Qed. -Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m. +Lemma le_ge n m : n <= m -> m >= n. Proof. - intros; symmetry in |- *; apply Zmult_succ_l. + apply ge_le_iff. Qed. +(** We provide a tactic converting from one style to the other. *) +Ltac swap_greater := rewrite ?gt_lt_iff in *; rewrite ?ge_le_iff in *. -(** ** Misc redundant properties *) +(** Similarly, the boolean comparisons [ltb] and [leb] are favored + over their dual [gtb] and [geb]. We prove here the equivalence + and a few minimal results. *) -Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0. +Lemma gtb_ltb n m : (n >? m) = (m <? n). Proof. - intros x y H; rewrite H; auto with arith. + unfold gtb, ltb. rewrite compare_antisym. now case compare. Qed. +Lemma geb_leb n m : (n >=? m) = (m <=? n). +Proof. + unfold geb, leb. rewrite compare_antisym. now case compare. +Qed. +Lemma gtb_lt n m : (n >? m) = true <-> m < n. +Proof. + rewrite gtb_ltb. apply ltb_lt. +Qed. -(**********************************************************************) -(** * Relating binary positive numbers and binary integers *) +Lemma geb_le n m : (n >=? m) = true <-> m <= n. +Proof. + rewrite geb_leb. apply leb_le. +Qed. -Lemma Zpos_eq : forall p q:positive, p = q -> Zpos p = Zpos q. +Lemma gtb_spec n m : BoolSpec (m<n) (n<=m) (n >? m). Proof. - intros; f_equal; auto. + rewrite gtb_ltb. apply ltb_spec. Qed. -Lemma Zpos_eq_rev : forall p q:positive, Zpos p = Zpos q -> p = q. +Lemma geb_spec n m : BoolSpec (m<=n) (n<m) (n >=? m). Proof. - inversion 1; auto. + rewrite geb_leb. apply leb_spec. Qed. -Lemma Zpos_eq_iff : forall p q:positive, p = q <-> Zpos p = Zpos q. +(** TODO : to add in Numbers ? *) + +Lemma add_reg_l n m p : n + m = n + p -> m = p. Proof. - split; [apply Zpos_eq|apply Zpos_eq_rev]. + exact (proj1 (add_cancel_l m p n)). Qed. -Lemma Zpos_xI : forall p:positive, Zpos p~1 = Zpos 2 * Zpos p + Zpos 1. +Lemma mul_reg_l n m p : p <> 0 -> p * n = p * m -> n = m. Proof. - intro; apply refl_equal. + exact (fun Hp => proj1 (mul_cancel_l n m p Hp)). Qed. -Lemma Zpos_xO : forall p:positive, Zpos p~0 = Zpos 2 * Zpos p. +Lemma mul_reg_r n m p : p <> 0 -> n * p = m * p -> n = m. Proof. - intro; apply refl_equal. + exact (fun Hp => proj1 (mul_cancel_r n m p Hp)). Qed. -Lemma Zneg_xI : forall p:positive, Zneg p~1 = Zpos 2 * Zneg p - Zpos 1. +Lemma opp_eq_mul_m1 n : - n = n * -1. Proof. - intro; apply refl_equal. + rewrite mul_comm. now destruct n. Qed. -Lemma Zneg_xO : forall p:positive, Zneg p~0 = Zpos 2 * Zneg p. +Lemma add_diag n : n + n = 2 * n. Proof. - reflexivity. + change 2 with (1+1). now rewrite mul_add_distr_r, !mul_1_l. Qed. -Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q. +(** * Comparison and opposite *) + +Lemma compare_opp n m : (- n ?= - m) = (m ?= n). Proof. - intros p p'; destruct p; - [ destruct p' as [p0| p0| ] - | destruct p' as [p0| p0| ] - | destruct p' as [p| p| ] ]; reflexivity. + destruct n, m; simpl; trivial; intros; now rewrite <- Pos.compare_antisym. Qed. -Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q. +(** * Comparison and addition *) + +Lemma add_compare_mono_l n m p : (n + m ?= n + p) = (m ?= p). Proof. - intros p p'; destruct p; - [ destruct p' as [p0| p0| ] - | destruct p' as [p0| p0| ] - | destruct p' as [p| p| ] ]; reflexivity. + rewrite (compare_sub m p), compare_sub. f_equal. + unfold sub. rewrite opp_add_distr, (add_comm n m), add_assoc. + f_equal. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. -(**********************************************************************) -(** * Order relations *) +End Z. + +(** Export Notations *) + +Infix "+" := Z.add : Z_scope. +Notation "- x" := (Z.opp x) : Z_scope. +Infix "-" := Z.sub : Z_scope. +Infix "*" := Z.mul : Z_scope. +Infix "^" := Z.pow : Z_scope. +Infix "/" := Z.div : Z_scope. +Infix "mod" := Z.modulo (at level 40, no associativity) : Z_scope. +Infix "÷" := Z.quot (at level 40, left associativity) : Z_scope. + +(* TODO : transition from Zdivide *) +Notation "( x | y )" := (Z.divide x y) (at level 0). -Definition Zlt (x y:Z) := (x ?= y) = Lt. -Definition Zgt (x y:Z) := (x ?= y) = Gt. -Definition Zle (x y:Z) := (x ?= y) <> Gt. -Definition Zge (x y:Z) := (x ?= y) <> Lt. -Definition Zne (x y:Z) := x <> y. +Infix "?=" := Z.compare (at level 70, no associativity) : Z_scope. -Infix "<=" := Zle : Z_scope. -Infix "<" := Zlt : Z_scope. -Infix ">=" := Zge : Z_scope. -Infix ">" := Zgt : Z_scope. +Infix "<=" := Z.le : Z_scope. +Infix "<" := Z.lt : Z_scope. +Infix ">=" := Z.ge : Z_scope. +Infix ">" := Z.gt : Z_scope. Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope. Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope. Notation "x < y < z" := (x < y /\ y < z) : Z_scope. Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope. -(**********************************************************************) -(** * Absolute value on integers *) - -Definition Zabs_nat (x:Z) : nat := - match x with - | Z0 => 0%nat - | Zpos p => nat_of_P p - | Zneg p => nat_of_P p - end. - -Definition Zabs (z:Z) : Z := - match z with - | Z0 => Z0 - | Zpos p => Zpos p - | Zneg p => Zpos p - end. - -(**********************************************************************) -(** * From [nat] to [Z] *) - -Definition Z_of_nat (x:nat) := - match x with - | O => Z0 - | S y => Zpos (P_of_succ_nat y) - end. - -Require Import BinNat. - -Definition Zabs_N (z:Z) := - match z with - | Z0 => 0%N - | Zpos p => Npos p - | Zneg p => Npos p - end. - -Definition Z_of_N (x:N) := - match x with - | N0 => Z0 - | Npos p => Zpos p - end. +Infix "=?" := Z.eqb (at level 70, no associativity) : Z_scope. +Infix "<=?" := Z.leb (at level 70, no associativity) : Z_scope. +Infix "<?" := Z.ltb (at level 70, no associativity) : Z_scope. +Infix ">=?" := Z.geb (at level 70, no associativity) : Z_scope. +Infix ">?" := Z.gtb (at level 70, no associativity) : Z_scope. + +(** Compatibility Notations *) + +Notation Zdouble_plus_one := Z.succ_double (only parsing). +Notation Zdouble_minus_one := Z.pred_double (only parsing). +Notation Zdouble := Z.double (only parsing). +Notation ZPminus := Z.pos_sub (only parsing). +Notation Zsucc' := Z.succ (only parsing). +Notation Zpred' := Z.pred (only parsing). +Notation Zplus' := Z.add (only parsing). +Notation Zplus := Z.add (only parsing). (* Slightly incompatible *) +Notation Zopp := Z.opp (only parsing). +Notation Zsucc := Z.succ (only parsing). +Notation Zpred := Z.pred (only parsing). +Notation Zminus := Z.sub (only parsing). +Notation Zmult := Z.mul (only parsing). +Notation Zcompare := Z.compare (only parsing). +Notation Zsgn := Z.sgn (only parsing). +Notation Zle := Z.le (only parsing). +Notation Zge := Z.ge (only parsing). +Notation Zlt := Z.lt (only parsing). +Notation Zgt := Z.gt (only parsing). +Notation Zmax := Z.max (only parsing). +Notation Zmin := Z.min (only parsing). +Notation Zabs := Z.abs (only parsing). +Notation Zabs_nat := Z.abs_nat (only parsing). +Notation Zabs_N := Z.abs_N (only parsing). +Notation Z_of_nat := Z.of_nat (only parsing). +Notation Z_of_N := Z.of_N (only parsing). + +Notation Zind := Z.peano_ind (only parsing). +Notation Zopp_0 := Z.opp_0 (only parsing). +Notation Zopp_neg := Z.opp_Zneg (only parsing). +Notation Zopp_involutive := Z.opp_involutive (only parsing). +Notation Zopp_inj := Z.opp_inj (only parsing). +Notation Zplus_0_l := Z.add_0_l (only parsing). +Notation Zplus_0_r := Z.add_0_r (only parsing). +Notation Zplus_comm := Z.add_comm (only parsing). +Notation Zopp_plus_distr := Z.opp_add_distr (only parsing). +Notation Zopp_succ := Z.opp_succ (only parsing). +Notation Zplus_opp_r := Z.add_opp_diag_r (only parsing). +Notation Zplus_opp_l := Z.add_opp_diag_l (only parsing). +Notation Zplus_assoc := Z.add_assoc (only parsing). +Notation Zplus_permute := Z.add_shuffle3 (only parsing). +Notation Zplus_reg_l := Z.add_reg_l (only parsing). +Notation Zplus_succ_l := Z.add_succ_l (only parsing). +Notation Zplus_succ_comm := Z.add_succ_comm (only parsing). +Notation Zsucc_discr := Z.neq_succ_diag_r (only parsing). +Notation Zsucc_inj := Z.succ_inj (only parsing). +Notation Zsucc'_inj := Z.succ_inj (only parsing). +Notation Zsucc'_pred' := Z.succ_pred (only parsing). +Notation Zpred'_succ' := Z.pred_succ (only parsing). +Notation Zpred'_inj := Z.pred_inj (only parsing). +Notation Zsucc'_discr := Z.neq_succ_diag_r (only parsing). +Notation Zminus_0_r := Z.sub_0_r (only parsing). +Notation Zminus_diag := Z.sub_diag (only parsing). +Notation Zminus_plus_distr := Z.sub_add_distr (only parsing). +Notation Zminus_succ_r := Z.sub_succ_r (only parsing). +Notation Zminus_plus := Z.add_simpl_l (only parsing). +Notation Zmult_0_l := Z.mul_0_l (only parsing). +Notation Zmult_0_r := Z.mul_0_r (only parsing). +Notation Zmult_1_l := Z.mul_1_l (only parsing). +Notation Zmult_1_r := Z.mul_1_r (only parsing). +Notation Zmult_comm := Z.mul_comm (only parsing). +Notation Zmult_assoc := Z.mul_assoc (only parsing). +Notation Zmult_permute := Z.mul_shuffle3 (only parsing). +Notation Zmult_1_inversion_l := Z.mul_eq_1 (only parsing). +Notation Zdouble_mult := Z.double_spec (only parsing). +Notation Zdouble_plus_one_mult := Z.succ_double_spec (only parsing). +Notation Zopp_mult_distr_l_reverse := Z.mul_opp_l (only parsing). +Notation Zmult_opp_opp := Z.mul_opp_opp (only parsing). +Notation Zmult_opp_comm := Z.mul_opp_comm (only parsing). +Notation Zopp_eq_mult_neg_1 := Z.opp_eq_mul_m1 (only parsing). +Notation Zmult_plus_distr_r := Z.mul_add_distr_l (only parsing). +Notation Zmult_plus_distr_l := Z.mul_add_distr_r (only parsing). +Notation Zmult_minus_distr_r := Z.mul_sub_distr_r (only parsing). +Notation Zmult_reg_l := Z.mul_reg_l (only parsing). +Notation Zmult_reg_r := Z.mul_reg_r (only parsing). +Notation Zmult_succ_l := Z.mul_succ_l (only parsing). +Notation Zmult_succ_r := Z.mul_succ_r (only parsing). +Notation Zpos_xI := Z.pos_xI (only parsing). +Notation Zpos_xO := Z.pos_xO (only parsing). +Notation Zneg_xI := Z.neg_xI (only parsing). +Notation Zneg_xO := Z.neg_xO (only parsing). + +Notation Z := Z (only parsing). +Notation Z_rect := Z_rect (only parsing). +Notation Z_rec := Z_rec (only parsing). +Notation Z_ind := Z_ind (only parsing). +Notation Z0 := Z0 (only parsing). +Notation Zpos := Zpos (only parsing). +Notation Zneg := Zneg (only parsing). + +(** Compatibility lemmas. These could be notations, + but scope information would be lost. +*) + +Notation SYM1 lem := (fun n => eq_sym (lem n)). +Notation SYM2 lem := (fun n m => eq_sym (lem n m)). +Notation SYM3 lem := (fun n m p => eq_sym (lem n m p)). + +Lemma Zplus_assoc_reverse : forall n m p, n+m+p = n+(m+p). +Proof (SYM3 Z.add_assoc). +Lemma Zplus_succ_r_reverse : forall n m, Z.succ (n+m) = n+Z.succ m. +Proof (SYM2 Z.add_succ_r). +Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing). +Lemma Zplus_0_r_reverse : forall n, n = n + 0. +Proof (SYM1 Z.add_0_r). +Lemma Zplus_eq_compat : forall n m p q, n=m -> p=q -> n+p=m+q. +Proof (f_equal2 Z.add). +Lemma Zpos_succ_morphism : forall p, Zpos (Psucc p) = Zsucc (Zpos p). +Proof (SYM1 Z.succ_Zpos). +Lemma Zsucc_pred : forall n, n = Z.succ (Z.pred n). +Proof (SYM1 Z.succ_pred). +Lemma Zpred_succ : forall n, n = Z.pred (Z.succ n). +Proof (SYM1 Z.pred_succ). +Lemma Zsucc_eq_compat : forall n m, n = m -> Z.succ n = Z.succ m. +Proof (f_equal Z.succ). +Lemma Zminus_0_l_reverse : forall n, n = n - 0. +Proof (SYM1 Z.sub_0_r). +Lemma Zminus_diag_reverse : forall n, 0 = n-n. +Proof (SYM1 Z.sub_diag). +Lemma Zminus_succ_l : forall n m, Z.succ (n - m) = Z.succ n - m. +Proof (SYM2 Z.sub_succ_l). +Lemma Zplus_minus_eq : forall n m p, n = m + p -> p = n - m. +Proof. intros. now apply Z.add_move_l. Qed. +Lemma Zplus_minus : forall n m, n + (m - n) = m. +Proof (fun n m => eq_trans (Z.add_comm n (m-n)) (Z.sub_add n m)). +Lemma Zminus_plus_simpl_l : forall n m p, p + n - (p + m) = n - m. +Proof (fun n m p => Z.add_add_simpl_l_l p n m). +Lemma Zminus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m). +Proof (SYM3 Zminus_plus_simpl_l). +Lemma Zminus_plus_simpl_r : forall n m p, n + p - (m + p) = n - m. +Proof (fun n m p => Z.add_add_simpl_r_r n p m). +Lemma Zpos_minus_morphism : forall a b, + Pcompare a b Eq = Lt -> Zpos (b - a) = Zpos b - Zpos a. +Proof. intros. now rewrite Z.sub_Zpos. Qed. +Lemma Zeq_minus : forall n m, n = m -> n - m = 0. +Proof (fun n m => proj2 (Z.sub_move_0_r n m)). +Lemma Zminus_eq : forall n m, n - m = 0 -> n = m. +Proof (fun n m => proj1 (Z.sub_move_0_r n m)). +Lemma Zpos_mult_morphism : forall p q, Zpos (p * q) = Zpos p * Zpos q. +Proof (SYM2 Z.mul_Zpos). +Lemma Zmult_0_r_reverse : forall n, 0 = n * 0. +Proof (SYM1 Z.mul_0_r). +Lemma Zmult_assoc_reverse : forall n m p, n * m * p = n * (m * p). +Proof (SYM3 Z.mul_assoc). +Lemma Zmult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. +Proof (fun n m => proj1 (Z.mul_eq_0 n m)). +Lemma Zmult_integral_l : forall n m, n <> 0 -> m * n = 0 -> m = 0. +Proof (fun n m H H' => Z.mul_eq_0_l m n H' H). +Lemma Zopp_mult_distr_l : forall n m, - (n * m) = - n * m. +Proof (SYM2 Z.mul_opp_l). +Lemma Zopp_mult_distr_r : forall n m, - (n * m) = n * - m. +Proof (SYM2 Z.mul_opp_r). +Lemma Zmult_minus_distr_l : forall n m p, p * (n - m) = p * n - p * m. +Proof (fun n m p => Z.mul_sub_distr_l p n m). +Lemma Zmult_succ_r_reverse : forall n m, n * m + n = n * Zsucc m. +Proof (SYM2 Z.mul_succ_r). +Lemma Zmult_succ_l_reverse : forall n m, n * m + m = Zsucc n * m. +Proof (SYM2 Z.mul_succ_l). +Lemma Zpos_eq : forall p q, p = q -> Zpos p = Zpos q. +Proof (fun p q => proj2 (Z.inj_Zpos p q)). +Lemma Zpos_eq_rev : forall p q, Zpos p = Zpos q -> p = q. +Proof (fun p q => proj1 (Z.inj_Zpos p q)). +Lemma Zpos_eq_iff : forall p q, p = q <-> Zpos p = Zpos q. +Proof (fun p q => iff_sym (Z.inj_Zpos p q)). +Lemma Zpos_plus_distr : forall p q, Zpos (p + q) = Zpos p + Zpos q. +Proof (SYM2 Z.add_Zpos). +Lemma Zneg_plus_distr : forall p q, Zneg (p + q) = Zneg p + Zneg q. +Proof (SYM2 Z.add_Zneg). + +Hint Immediate Zsucc_pred: zarith. + +(* Not kept : +Zplus_0_simpl_l +Zplus_0_simpl_l_reverse +Zplus_opp_expand +Zsucc_inj_contrapositive +Zsucc_succ' +Zpred_pred' +*) + +(* No compat notation for : +weak_assoc (now Z.add_assoc_pos) +weak_Zmult_plus_distr_r (now Z.mul_add_distr_pos) +*) + +(** Obsolete stuff *) + +Definition Zne (x y:Z) := x <> y. (* TODO : to remove someday ? *) + +Ltac elim_compare com1 com2 := + case (Dcompare (com1 ?= com2)%Z); + [ idtac | let x := fresh "H" in + (intro x; case x; clear x) ]. + +Lemma ZL0 : 2%nat = (1 + 1)%nat. +Proof. + reflexivity. +Qed. + +Lemma Zplus_diag_eq_mult_2 n : n + n = n * 2. +Proof. + rewrite Z.mul_comm. apply Z.add_diag. +Qed. + +Lemma Z_eq_mult n m : m = 0 -> m * n = 0. +Proof. + intros; now subst. +Qed. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v new file mode 100644 index 00000000..d96d20fb --- /dev/null +++ b/theories/ZArith/BinIntDef.v @@ -0,0 +1,610 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export BinNums. +Require Import BinPos BinNat. + +Local Open Scope Z_scope. + +(***********************************************************) +(** * Binary Integers, Definitions of Operations *) +(***********************************************************) + +(** Initial author: Pierre Crégut, CNET, Lannion, France *) + +Module Z. + +Definition t := Z. + +(** ** Constants *) + +Definition zero := 0. +Definition one := 1. +Definition two := 2. + +(** ** Doubling and variants *) + +Definition double x := + match x with + | 0 => 0 + | Zpos p => Zpos p~0 + | Zneg p => Zneg p~0 + end. + +Definition succ_double x := + match x with + | 0 => 1 + | Zpos p => Zpos p~1 + | Zneg p => Zneg (Pos.pred_double p) + end. + +Definition pred_double x := + match x with + | 0 => -1 + | Zneg p => Zneg p~1 + | Zpos p => Zpos (Pos.pred_double p) + end. + +(** ** Subtraction of positive into Z *) + +Fixpoint pos_sub (x y:positive) {struct y} : Z := + match x, y with + | p~1, q~1 => double (pos_sub p q) + | p~1, q~0 => succ_double (pos_sub p q) + | p~1, 1 => Zpos p~0 + | p~0, q~1 => pred_double (pos_sub p q) + | p~0, q~0 => double (pos_sub p q) + | p~0, 1 => Zpos (Pos.pred_double p) + | 1, q~1 => Zneg q~0 + | 1, q~0 => Zneg (Pos.pred_double q) + | 1, 1 => Z0 + end%positive. + +(** ** Addition *) + +Definition add x y := + match x, y with + | 0, y => y + | x, 0 => x + | Zpos x', Zpos y' => Zpos (x' + y') + | Zpos x', Zneg y' => pos_sub x' y' + | Zneg x', Zpos y' => pos_sub y' x' + | Zneg x', Zneg y' => Zneg (x' + y') + end. + +Infix "+" := add : Z_scope. + +(** ** Opposite *) + +Definition opp x := + match x with + | 0 => 0 + | Zpos x => Zneg x + | Zneg x => Zpos x + end. + +Notation "- x" := (opp x) : Z_scope. + +(** ** Successor *) + +Definition succ x := x + 1. + +(** ** Predecessor *) + +Definition pred x := x + -1. + +(** ** Subtraction *) + +Definition sub m n := m + -n. + +Infix "-" := sub : Z_scope. + +(** ** Multiplication *) + +Definition mul x y := + match x, y with + | 0, _ => 0 + | _, 0 => 0 + | Zpos x', Zpos y' => Zpos (x' * y') + | Zpos x', Zneg y' => Zneg (x' * y') + | Zneg x', Zpos y' => Zneg (x' * y') + | Zneg x', Zneg y' => Zpos (x' * y') + end. + +Infix "*" := mul : Z_scope. + +(** ** Power function *) + +Definition pow_pos (z:Z) (n:positive) := Pos.iter n (mul z) 1. + +Definition pow x y := + match y with + | Zpos p => pow_pos x p + | 0 => 1 + | Zneg _ => 0 + end. + +Infix "^" := pow : Z_scope. + +(** ** Square *) + +Definition square x := + match x with + | 0 => 0 + | Zpos p => Zpos (Pos.square p) + | Zneg p => Zpos (Pos.square p) + end. + +(** ** Comparison *) + +Definition compare x y := + match x, y with + | 0, 0 => Eq + | 0, Zpos y' => Lt + | 0, Zneg y' => Gt + | Zpos x', 0 => Gt + | Zpos x', Zpos y' => (x' ?= y')%positive + | Zpos x', Zneg y' => Gt + | Zneg x', 0 => Lt + | Zneg x', Zpos y' => Lt + | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive) + end. + +Infix "?=" := compare (at level 70, no associativity) : Z_scope. + +(** ** Sign function *) + +Definition sgn z := + match z with + | 0 => 0 + | Zpos p => 1 + | Zneg p => -1 + end. + +(** Boolean equality and comparisons *) + +Definition leb x y := + match x ?= y with + | Gt => false + | _ => true + end. + +Definition ltb x y := + match x ?= y with + | Lt => true + | _ => false + end. + +(** Nota: [geb] and [gtb] are provided for compatibility, + but [leb] and [ltb] should rather be used instead, since + more results we be available on them. *) + +Definition geb x y := + match x ?= y with + | Lt => false + | _ => true + end. + +Definition gtb x y := + match x ?= y with + | Gt => true + | _ => false + end. + +(** Nota: this [eqb] is not convertible with the generated [Z_beq], + since the underlying [Pos.eqb] differs from [positive_beq] + (cf BinIntDef). *) + +Fixpoint eqb x y := + match x, y with + | 0, 0 => true + | Zpos p, Zpos q => Pos.eqb p q + | Zneg p, Zneg q => Pos.eqb p q + | _, _ => false + end. + +Infix "=?" := eqb (at level 70, no associativity) : Z_scope. +Infix "<=?" := leb (at level 70, no associativity) : Z_scope. +Infix "<?" := ltb (at level 70, no associativity) : Z_scope. +Infix ">=?" := geb (at level 70, no associativity) : Z_scope. +Infix ">?" := gtb (at level 70, no associativity) : Z_scope. + +(** ** Minimum and maximum *) + +Definition max n m := + match n ?= m with + | Eq | Gt => n + | Lt => m + end. + +Definition min n m := + match n ?= m with + | Eq | Lt => n + | Gt => m + end. + +(** ** Absolute value *) + +Definition abs z := + match z with + | 0 => 0 + | Zpos p => Zpos p + | Zneg p => Zpos p + end. + +(** ** Conversions *) + +(** From [Z] to [nat] via absolute value *) + +Definition abs_nat (z:Z) : nat := + match z with + | 0 => 0%nat + | Zpos p => Pos.to_nat p + | Zneg p => Pos.to_nat p + end. + +(** From [Z] to [N] via absolute value *) + +Definition abs_N (z:Z) : N := + match z with + | Z0 => 0%N + | Zpos p => Npos p + | Zneg p => Npos p + end. + +(** From [Z] to [nat] by rounding negative numbers to 0 *) + +Definition to_nat (z:Z) : nat := + match z with + | Zpos p => Pos.to_nat p + | _ => O + end. + +(** From [Z] to [N] by rounding negative numbers to 0 *) + +Definition to_N (z:Z) : N := + match z with + | Zpos p => Npos p + | _ => 0%N + end. + +(** From [nat] to [Z] *) + +Definition of_nat (n:nat) : Z := + match n with + | O => 0 + | S n => Zpos (Pos.of_succ_nat n) + end. + +(** From [N] to [Z] *) + +Definition of_N (n:N) : Z := + match n with + | N0 => 0 + | Npos p => Zpos p + end. + +(** ** Iteration of a function + + By convention, iterating a negative number of times is identity. +*) + +Definition iter (n:Z) {A} (f:A -> A) (x:A) := + match n with + | Zpos p => Pos.iter p f x + | _ => x + end. + +(** ** Euclidean divisions for binary integers *) + +(** Concerning the many possible variants of integer divisions, + see the headers of the generic files [ZDivFloor], [ZDivTrunc], + [ZDivEucl], and the article by R. Boute mentioned there. + We provide here two flavours, Floor and Trunc, while + the Euclid convention can be found in file Zeuclid.v + For non-zero b, they all satisfy [a = b*(a/b) + (a mod b)] + and [ |a mod b| < |b| ], but the sign of the modulo will differ + when [a<0] and/or [b<0]. +*) + +(** ** Floor division *) + +(** [div_eucl] provides a Truncated-Toward-Bottom (a.k.a Floor) + Euclidean division. Its projections are named [div] (noted "/") + and [modulo] (noted with an infix "mod"). + These functions correspond to the `div` and `mod` of Haskell. + This is the historical convention of Coq. + + The main properties of this convention are : + - we have [sgn (a mod b) = sgn (b)] + - [div a b] is the greatest integer smaller or equal to the exact + fraction [a/b]. + - there is no easy sign rule. + + In addition, note that we arbitrary take [a/0 = 0] and [a mod 0 = 0]. +*) + +(** First, a division for positive numbers. Even if the second + argument is a Z, the answer is arbitrary is it isn't a Zpos. *) + +Fixpoint pos_div_eucl (a:positive) (b:Z) : Z * Z := + match a with + | xH => if 2 <=? b then (0, 1) else (1, 0) + | xO a' => + let (q, r) := pos_div_eucl a' b in + let r' := 2 * r in + if r' <? b then (2 * q, r') else (2 * q + 1, r' - b) + | xI a' => + let (q, r) := pos_div_eucl a' b in + let r' := 2 * r + 1 in + if r' <? b then (2 * q, r') else (2 * q + 1, r' - b) + end. + +(** Then the general euclidean division *) + +Definition div_eucl (a b:Z) : Z * Z := + match a, b with + | 0, _ => (0, 0) + | _, 0 => (0, 0) + | Zpos a', Zpos _ => pos_div_eucl a' b + | Zneg a', Zpos _ => + let (q, r) := pos_div_eucl a' b in + match r with + | 0 => (- q, 0) + | _ => (- (q + 1), b - r) + end + | Zneg a', Zneg b' => + let (q, r) := pos_div_eucl a' (Zpos b') in (q, - r) + | Zpos a', Zneg b' => + let (q, r) := pos_div_eucl a' (Zpos b') in + match r with + | 0 => (- q, 0) + | _ => (- (q + 1), b + r) + end + end. + +Definition div (a b:Z) : Z := let (q, _) := div_eucl a b in q. +Definition modulo (a b:Z) : Z := let (_, r) := div_eucl a b in r. + +Infix "/" := div : Z_scope. +Infix "mod" := modulo (at level 40, no associativity) : Z_scope. + + +(** ** Trunc Division *) + +(** [quotrem] provides a Truncated-Toward-Zero Euclidean division. + Its projections are named [quot] (noted "÷") and [rem]. + These functions correspond to the `quot` and `rem` of Haskell. + This division convention is used in most programming languages, + e.g. Ocaml. + + With this convention: + - we have [sgn(a rem b) = sgn(a)] + - sign rule for division: [quot (-a) b = quot a (-b) = -(quot a b)] + - and for modulo: [a rem (-b) = a rem b] and [(-a) rem b = -(a rem b)] + + Note that we arbitrary take here [quot a 0 = 0] and [a rem 0 = a]. +*) + +Definition quotrem (a b:Z) : Z * Z := + match a, b with + | 0, _ => (0, 0) + | _, 0 => (0, a) + | Zpos a, Zpos b => + let (q, r) := N.pos_div_eucl a (Npos b) in (of_N q, of_N r) + | Zneg a, Zpos b => + let (q, r) := N.pos_div_eucl a (Npos b) in (-of_N q, - of_N r) + | Zpos a, Zneg b => + let (q, r) := N.pos_div_eucl a (Npos b) in (-of_N q, of_N r) + | Zneg a, Zneg b => + let (q, r) := N.pos_div_eucl a (Npos b) in (of_N q, - of_N r) + end. + +Definition quot a b := fst (quotrem a b). +Definition rem a b := snd (quotrem a b). + +Infix "÷" := quot (at level 40, left associativity) : Z_scope. +(** No infix notation for rem, otherwise it becomes a keyword *) + + +(** ** Parity functions *) + +Definition even z := + match z with + | 0 => true + | Zpos (xO _) => true + | Zneg (xO _) => true + | _ => false + end. + +Definition odd z := + match z with + | 0 => false + | Zpos (xO _) => false + | Zneg (xO _) => false + | _ => true + end. + + +(** ** Division by two *) + +(** [div2] performs rounding toward bottom, it is hence a particular + case of [div], and for all relative number [n] we have: + [n = 2 * div2 n + if odd n then 1 else 0]. *) + +Definition div2 z := + match z with + | 0 => 0 + | Zpos 1 => 0 + | Zpos p => Zpos (Pos.div2 p) + | Zneg p => Zneg (Pos.div2_up p) + end. + +(** [quot2] performs rounding toward zero, it is hence a particular + case of [quot], and for all relative number [n] we have: + [n = 2 * quot2 n + if odd n then sgn n else 0]. *) + +Definition quot2 (z:Z) := + match z with + | 0 => 0 + | Zpos 1 => 0 + | Zpos p => Zpos (Pos.div2 p) + | Zneg 1 => 0 + | Zneg p => Zneg (Pos.div2 p) + end. + +(** NB: [Z.quot2] used to be named [Zdiv2] in Coq <= 8.3 *) + + +(** * Base-2 logarithm *) + +Definition log2 z := + match z with + | Zpos (p~1) => Zpos (Pos.size p) + | Zpos (p~0) => Zpos (Pos.size p) + | _ => 0 + end. + + +(** ** Square root *) + +Definition sqrtrem n := + match n with + | 0 => (0, 0) + | Zpos p => + match Pos.sqrtrem p with + | (s, IsPos r) => (Zpos s, Zpos r) + | (s, _) => (Zpos s, 0) + end + | Zneg _ => (0,0) + end. + +Definition sqrt n := + match n with + | Zpos p => Zpos (Pos.sqrt p) + | _ => 0 + end. + + +(** ** Greatest Common Divisor *) + +Definition gcd a b := + match a,b with + | 0, _ => abs b + | _, 0 => abs a + | Zpos a, Zpos b => Zpos (Pos.gcd a b) + | Zpos a, Zneg b => Zpos (Pos.gcd a b) + | Zneg a, Zpos b => Zpos (Pos.gcd a b) + | Zneg a, Zneg b => Zpos (Pos.gcd a b) + end. + +(** A generalized gcd, also computing division of a and b by gcd. *) + +Definition ggcd a b : Z*(Z*Z) := + match a,b with + | 0, _ => (abs b,(0, sgn b)) + | _, 0 => (abs a,(sgn a, 0)) + | Zpos a, Zpos b => + let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zpos aa, Zpos bb)) + | Zpos a, Zneg b => + let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zpos aa, Zneg bb)) + | Zneg a, Zpos b => + let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zneg aa, Zpos bb)) + | Zneg a, Zneg b => + let '(g,(aa,bb)) := Pos.ggcd a b in (Zpos g, (Zneg aa, Zneg bb)) + end. + + +(** ** Bitwise functions *) + +(** When accessing the bits of negative numbers, all functions + below will use the two's complement representation. For instance, + [-1] will correspond to an infinite stream of true bits. If this + isn't what you're looking for, you can use [abs] first and then + access the bits of the absolute value. +*) + +(** [testbit] : accessing the [n]-th bit of a number [a]. + For negative [n], we arbitrarily answer [false]. *) + +Definition testbit a n := + match n with + | 0 => odd a + | Zpos p => + match a with + | 0 => false + | Zpos a => Pos.testbit a (Npos p) + | Zneg a => negb (N.testbit (Pos.pred_N a) (Npos p)) + end + | Zneg _ => false + end. + +(** Shifts + + Nota: a shift to the right by [-n] will be a shift to the left + by [n], and vice-versa. + + For fulfilling the two's complement convention, shifting to + the right a negative number should correspond to a division + by 2 with rounding toward bottom, hence the use of [div2] + instead of [quot2]. +*) + +Definition shiftl a n := + match n with + | 0 => a + | Zpos p => Pos.iter p (mul 2) a + | Zneg p => Pos.iter p div2 a + end. + +Definition shiftr a n := shiftl a (-n). + +(** Bitwise operations [lor] [land] [ldiff] [lxor] *) + +Definition lor a b := + match a, b with + | 0, _ => b + | _, 0 => a + | Zpos a, Zpos b => Zpos (Pos.lor a b) + | Zneg a, Zpos b => Zneg (N.succ_pos (N.ldiff (Pos.pred_N a) (Npos b))) + | Zpos a, Zneg b => Zneg (N.succ_pos (N.ldiff (Pos.pred_N b) (Npos a))) + | Zneg a, Zneg b => Zneg (N.succ_pos (N.land (Pos.pred_N a) (Pos.pred_N b))) + end. + +Definition land a b := + match a, b with + | 0, _ => 0 + | _, 0 => 0 + | Zpos a, Zpos b => of_N (Pos.land a b) + | Zneg a, Zpos b => of_N (N.ldiff (Npos b) (Pos.pred_N a)) + | Zpos a, Zneg b => of_N (N.ldiff (Npos a) (Pos.pred_N b)) + | Zneg a, Zneg b => Zneg (N.succ_pos (N.lor (Pos.pred_N a) (Pos.pred_N b))) + end. + +Definition ldiff a b := + match a, b with + | 0, _ => 0 + | _, 0 => a + | Zpos a, Zpos b => of_N (Pos.ldiff a b) + | Zneg a, Zpos b => Zneg (N.succ_pos (N.lor (Pos.pred_N a) (Npos b))) + | Zpos a, Zneg b => of_N (N.land (Npos a) (Pos.pred_N b)) + | Zneg a, Zneg b => of_N (N.ldiff (Pos.pred_N b) (Pos.pred_N a)) + end. + +Definition lxor a b := + match a, b with + | 0, _ => b + | _, 0 => a + | Zpos a, Zpos b => of_N (Pos.lxor a b) + | Zneg a, Zpos b => Zneg (N.succ_pos (N.lxor (Pos.pred_N a) (Npos b))) + | Zpos a, Zneg b => Zneg (N.succ_pos (N.lxor (Npos a) (Pos.pred_N b))) + | Zneg a, Zneg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) + end. + +End Z.
\ No newline at end of file diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index c0123ca8..bac50fc4 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: Int.v 12363 2009-09-28 15:04:07Z letouzey $ *) - (** * An light axiomatization of integers (used in FSetAVL). *) (** We define a signature for an integer datatype based on [Z]. @@ -29,7 +27,7 @@ Module Type Int. Parameter int : Set. Parameter i2z : int -> Z. - Arguments Scope i2z [ Int_scope ]. + Arguments i2z _%I. Parameter _0 : int. Parameter _1 : int. @@ -222,10 +220,10 @@ Module MoreInt (I:Int). | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey) | (~ ?x) => let ex := p2ep x in constr:(EPneg ex) | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey) - | (?x<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey) - | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey) - | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey) - | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey) + | (?x < ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey) + | (?x <= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey) + | (?x > ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey) + | (?x >= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey) | ?x => constr:(EPraw x) end. diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 0fe6d623..bcccc126 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -1,123 +1,83 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf_Z.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import BinInt. Require Import Zcompare. Require Import Zorder. Require Import Znat. Require Import Zmisc. Require Import Wf_nat. -Open Local Scope Z_scope. +Local Open Scope Z_scope. (** Our purpose is to write an induction shema for {0,1,2,...} similar to the [nat] schema (Theorem [Natlike_rec]). For that the following implications will be used : << - (n:nat)(Q n)==(n:nat)(P (inject_nat n)) ===> (x:Z)`x > 0) -> (P x) + ∀n:nat, Q n == ∀n:nat, P (Z.of_nat n) ===> ∀x:Z, x <= 0 -> P x /\ || || - (Q O) (n:nat)(Q n)->(Q (S n)) <=== (P 0) (x:Z) (P x) -> (P (Zs x)) + (Q O) ∧ (∀n:nat, Q n -> Q (S n)) <=== (P 0) ∧ (∀x:Z, P x -> P (Z.succ x)) - <=== (inject_nat (S n))=(Zs (inject_nat n)) + <=== (Z.of_nat (S n) = Z.succ (Z.of_nat n)) - <=== inject_nat_complete + <=== Z_of_nat_complete >> Then the diagram will be closed and the theorem proved. *) -Lemma Z_of_nat_complete : - forall x:Z, 0 <= x -> exists n : nat, x = Z_of_nat n. -Proof. - intro x; destruct x; intros; - [ exists 0%nat; auto with arith - | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros; - simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); - intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos); - apply nat_of_P_inj; auto with arith - | absurd (0 <= Zneg p); - [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *; - auto with arith - | assumption ] ]. -Qed. - -Lemma ZL4_inf : forall y:positive, {h : nat | nat_of_P y = S h}. +Lemma Z_of_nat_complete (x : Z) : + 0 <= x -> exists n : nat, x = Z.of_nat n. Proof. - intro y; induction y as [p H| p H1| ]; - [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *; - simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism; - unfold nat_of_P in H1; rewrite H1; auto with arith - | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *; - simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism; - unfold nat_of_P in H2; rewrite H2; auto with arith - | exists 0%nat; auto with arith ]. + intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id. Qed. -Lemma Z_of_nat_complete_inf : - forall x:Z, 0 <= x -> {n : nat | x = Z_of_nat n}. +Lemma Z_of_nat_complete_inf (x : Z) : + 0 <= x -> {n : nat | x = Z_of_nat n}. Proof. - intro x; destruct x; intros; - [ exists 0%nat; auto with arith - | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0); - intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0); - intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos); - apply nat_of_P_inj; auto with arith - | absurd (0 <= Zneg p); - [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *; - auto with arith - | assumption ] ]. + intros H. exists (Z.to_nat x). symmetry. now apply Z2Nat.id. Qed. Lemma Z_of_nat_prop : forall P:Z -> Prop, - (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x. + (forall n:nat, P (Z.of_nat n)) -> forall x:Z, 0 <= x -> P x. Proof. - intros P H x H0. - specialize (Z_of_nat_complete x H0). - intros Hn; elim Hn; intros. - rewrite H1; apply H. + intros P H x Hx. now destruct (Z_of_nat_complete x Hx) as (n,->). Qed. Lemma Z_of_nat_set : forall P:Z -> Set, (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x. Proof. - intros P H x H0. - specialize (Z_of_nat_complete_inf x H0). - intros Hn; elim Hn; intros. - rewrite p; apply H. + intros P H x Hx. now destruct (Z_of_nat_complete_inf x Hx) as (n,->). Qed. Lemma natlike_ind : forall P:Z -> Prop, P 0 -> - (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x. + (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) -> + forall x:Z, 0 <= x -> P x. Proof. - intros P H H0 x H1; apply Z_of_nat_prop; - [ simple induction n; - [ simpl in |- *; assumption - | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ] - | assumption ]. + intros P Ho Hrec x Hx; apply Z_of_nat_prop; trivial. + induction n. exact Ho. + rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg. Qed. Lemma natlike_rec : forall P:Z -> Set, P 0 -> - (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x. + (forall x:Z, 0 <= x -> P x -> P (Z.succ x)) -> + forall x:Z, 0 <= x -> P x. Proof. - intros P H H0 x H1; apply Z_of_nat_set; - [ simple induction n; - [ simpl in |- *; assumption - | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ] - | assumption ]. + intros P Ho Hrec x Hx; apply Z_of_nat_set; trivial. + induction n. exact Ho. + rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg. Qed. Section Efficient_Rec. @@ -129,58 +89,44 @@ Section Efficient_Rec. Let R_wf : well_founded R. Proof. - set - (f := - fun z => - match z with - | Zpos p => nat_of_P p - | Z0 => 0%nat - | Zneg _ => 0%nat - end) in *. - apply well_founded_lt_compat with f. - unfold R, f in |- *; clear f R. - intros x y; case x; intros; elim H; clear H. - case y; intros; apply lt_O_nat_of_P || inversion H0. - case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto. - intros; elim H; auto. + apply well_founded_lt_compat with Z.to_nat. + intros x y (Hx,H). apply Z2Nat.inj_lt; Z.order. Qed. Lemma natlike_rec2 : forall P:Z -> Type, P 0 -> - (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z. + (forall z:Z, 0 <= z -> P z -> P (Z.succ z)) -> + forall z:Z, 0 <= z -> P z. Proof. - intros P Ho Hrec z; pattern z in |- *; - apply (well_founded_induction_type R_wf). - intro x; case x. - trivial. - intros. - assert (0 <= Zpred (Zpos p)). - apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial. - rewrite Zsucc_pred. - apply Hrec. - auto. - apply X; auto; unfold R in |- *; intuition; apply Zlt_pred. - intros; elim H; simpl in |- *; trivial. + intros P Ho Hrec. + induction z as [z IH] using (well_founded_induction_type R_wf). + destruct z; intros Hz. + - apply Ho. + - set (y:=Z.pred (Zpos p)). + assert (LE : 0 <= y) by (unfold y; now apply Z.lt_le_pred). + assert (EQ : Zpos p = Z.succ y) by (unfold y; now rewrite Z.succ_pred). + rewrite EQ. apply Hrec, IH; trivial. + split; trivial. unfold y; apply Z.lt_pred_l. + - now destruct Hz. Qed. - (** A variant of the previous using [Zpred] instead of [Zs]. *) + (** A variant of the previous using [Z.pred] instead of [Z.succ]. *) Lemma natlike_rec3 : forall P:Z -> Type, P 0 -> - (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z. + (forall z:Z, 0 < z -> P (Z.pred z) -> P z) -> + forall z:Z, 0 <= z -> P z. Proof. - intros P Ho Hrec z; pattern z in |- *; - apply (well_founded_induction_type R_wf). - intro x; case x. - trivial. - intros; apply Hrec. - unfold Zlt in |- *; trivial. - assert (0 <= Zpred (Zpos p)). - apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial. - apply X; auto; unfold R in |- *; intuition; apply Zlt_pred. - intros; elim H; simpl in |- *; trivial. + intros P Ho Hrec. + induction z as [z IH] using (well_founded_induction_type R_wf). + destruct z; intros Hz. + - apply Ho. + - assert (EQ : 0 <= Z.pred (Zpos p)) by now apply Z.lt_le_pred. + apply Hrec. easy. apply IH; trivial. split; trivial. + apply Z.lt_pred_l. + - now destruct Hz. Qed. (** A more general induction principle on non-negative numbers using [Zlt]. *) @@ -190,15 +136,15 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. Proof. - intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf). - intro x; case x; intros. - apply Hrec; intros. - assert (H2 : 0 < 0). - apply Zle_lt_trans with y; intuition. - inversion H2. - assumption. - firstorder. - unfold Zle, Zcompare in H; elim H; auto. + intros P Hrec. + induction x as [x IH] using (well_founded_induction_type R_wf). + destruct x; intros Hx. + - apply Hrec; trivial. intros y (Hy,Hy'). + assert (0 < 0) by now apply Z.le_lt_trans with y. + discriminate. + - apply Hrec; trivial. intros y (Hy,Hy'). + apply IH; trivial. now split. + - now destruct Hx. Defined. Lemma Zlt_0_ind : @@ -234,22 +180,15 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> forall x:Z, z <= x -> P x. Proof. - intros P z Hrec x. - assert (Hexpand : forall x, x = x - z + z). - intro; unfold Zminus; rewrite <- Zplus_assoc; rewrite Zplus_opp_l; - rewrite Zplus_0_r; trivial. - intro Hz. - rewrite (Hexpand x); pattern (x - z) in |- *; apply Zlt_0_rec. - 2: apply Zplus_le_reg_r with z; rewrite <- Hexpand; assumption. - intros x0 Hlt_x0 H. - apply Hrec. - 2: change z with (0+z); apply Zplus_le_compat_r; assumption. - intro y; rewrite (Hexpand y); intros. - destruct H0. - apply Hlt_x0. - split. - apply Zplus_le_reg_r with z; assumption. - apply Zplus_lt_reg_r with z; assumption. + intros P z Hrec x Hx. + rewrite <- (Z.sub_simpl_r x z). apply Z.le_0_sub in Hx. + pattern (x - z); apply Zlt_0_rec; trivial. + clear x Hx. intros x IH Hx. + apply Hrec. intros y (Hy,Hy'). + rewrite <- (Z.sub_simpl_r y z). apply IH; split. + now rewrite Z.le_0_sub. + now apply Z.lt_sub_lt_add_r. + now rewrite <- (Z.add_le_mono_r 0 x z). Qed. Lemma Zlt_lower_bound_ind : diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index bc79e373..265e62f0 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -1,21 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZArith.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Library for manipulating integers based on binary encoding *) Require Export ZArith_base. +(** Extra definitions *) + +Require Export Zpow_def. + (** Extra modules using [Omega] or [Ring]. *) Require Export Zcomplements. -Require Export Zsqrt. Require Export Zpower. Require Export Zdiv. Require Export Zlogarithm. diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 8cdae80d..8eeca3b9 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -1,17 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZArith_base.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (** Library for manipulating integers based on binary encoding. These are the basic modules, required by [Omega] and [Ring] for instance. The full library is [ZArith]. *) +Require Export BinNums. Require Export BinPos. Require Export BinNat. Require Export BinInt. @@ -29,8 +28,8 @@ Require Export Zbool. Require Export Zmisc. Require Export Wf_Z. -Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l - Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l - Zmult_plus_distr_r: zarith. +Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l + Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_l + Z.mul_add_distr_r: zarith. Require Export Zhints. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index b6766640..76308e60 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZArith_dec.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Sumbool. Require Import BinInt. @@ -38,17 +36,12 @@ Proof. intro; apply Zcompare_rect. Defined. +Notation Z_eq_dec := Z.eq_dec (only parsing). + Section decidability. Variables x y : Z. - (** * Decidability of equality on binary integers *) - - Definition Z_eq_dec : {x = y} + {x <> y}. - Proof. - decide equality; apply positive_eq_dec. - Defined. - (** * Decidability of order on binary integers *) Definition Z_lt_dec : {x < y} + {~ x < y}. diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v deleted file mode 100644 index 70f6866e..00000000 --- a/theories/ZArith/ZOdiv.v +++ /dev/null @@ -1,947 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - - -Require Import BinPos BinNat Nnat ZArith_base ROmega ZArithRing. -Require Export ZOdiv_def. -Require Zdiv. - -Open Scope Z_scope. - -(** This file provides results about the Round-Toward-Zero Euclidean - division [ZOdiv_eucl], whose projections are [ZOdiv] and [ZOmod]. - Definition of this division can be found in file [ZOdiv_def]. - - This division and the one defined in Zdiv agree only on positive - numbers. Otherwise, Zdiv performs Round-Toward-Bottom. - - The current approach is compatible with the division of usual - programming languages such as Ocaml. In addition, it has nicer - properties with respect to opposite and other usual operations. -*) - -(** Since ZOdiv and Zdiv are not meant to be used concurrently, - we reuse the same notation. *) - -Infix "/" := ZOdiv : Z_scope. -Infix "mod" := ZOmod (at level 40, no associativity) : Z_scope. - -Infix "/" := Ndiv : N_scope. -Infix "mod" := Nmod (at level 40, no associativity) : N_scope. - -(** Auxiliary results on the ad-hoc comparison [NPgeb]. *) - -Lemma NPgeb_Zge : forall (n:N)(p:positive), - NPgeb n p = true -> Z_of_N n >= Zpos p. -Proof. - destruct n as [|n]; simpl; intros. - discriminate. - red; simpl; destruct Pcompare; now auto. -Qed. - -Lemma NPgeb_Zlt : forall (n:N)(p:positive), - NPgeb n p = false -> Z_of_N n < Zpos p. -Proof. - destruct n as [|n]; simpl; intros. - red; auto. - red; simpl; destruct Pcompare; now auto. -Qed. - -(** * Relation between division on N and on Z. *) - -Lemma Ndiv_Z0div : forall a b:N, - Z_of_N (a/b) = (Z_of_N a / Z_of_N b). -Proof. - intros. - destruct a; destruct b; simpl; auto. - unfold Ndiv, ZOdiv; simpl; destruct Pdiv_eucl; auto. -Qed. - -Lemma Nmod_Z0mod : forall a b:N, - Z_of_N (a mod b) = (Z_of_N a) mod (Z_of_N b). -Proof. - intros. - destruct a; destruct b; simpl; auto. - unfold Nmod, ZOmod; simpl; destruct Pdiv_eucl; auto. -Qed. - -(** * Characterization of this euclidean division. *) - -(** First, the usual equation [a=q*b+r]. Notice that [a mod 0] - has been chosen to be [a], so this equation holds even for [b=0]. -*) - -Theorem N_div_mod_eq : forall a b, - a = (b * (Ndiv a b) + (Nmod a b))%N. -Proof. - intros; generalize (Ndiv_eucl_correct a b). - unfold Ndiv, Nmod; destruct Ndiv_eucl; simpl. - intro H; rewrite H; rewrite Nmult_comm; auto. -Qed. - -Theorem ZO_div_mod_eq : forall a b, - a = b * (ZOdiv a b) + (ZOmod a b). -Proof. - intros; generalize (ZOdiv_eucl_correct a b). - unfold ZOdiv, ZOmod; destruct ZOdiv_eucl; simpl. - intro H; rewrite H; rewrite Zmult_comm; auto. -Qed. - -(** Then, the inequalities constraining the remainder. *) - -Theorem Pdiv_eucl_remainder : forall a b:positive, - Z_of_N (snd (Pdiv_eucl a b)) < Zpos b. -Proof. - induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta. - intros b; generalize (IHa b); case Pdiv_eucl. - intros q1 r1 Hr1; simpl in Hr1. - case_eq (NPgeb (2*r1+1) b); intros; unfold snd. - romega with *. - apply NPgeb_Zlt; auto. - intros b; generalize (IHa b); case Pdiv_eucl. - intros q1 r1 Hr1; simpl in Hr1. - case_eq (NPgeb (2*r1) b); intros; unfold snd. - romega with *. - apply NPgeb_Zlt; auto. - destruct b; simpl; romega with *. -Qed. - -Theorem Nmod_lt : forall (a b:N), b<>0%N -> - (a mod b < b)%N. -Proof. - destruct b as [ |b]; intro H; try solve [elim H;auto]. - destruct a as [ |a]; try solve [compute;auto]; unfold Nmod, Ndiv_eucl. - generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl. - romega with *. -Qed. - -(** The remainder is bounded by the divisor, in term of absolute values *) - -Theorem ZOmod_lt : forall a b:Z, b<>0 -> - Zabs (a mod b) < Zabs b. -Proof. - destruct b as [ |b|b]; intro H; try solve [elim H;auto]; - destruct a as [ |a|a]; try solve [compute;auto]; unfold ZOmod, ZOdiv_eucl; - generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl; - try rewrite Zabs_Zopp; rewrite Zabs_eq; auto; apply Z_of_N_le_0. -Qed. - -(** The sign of the remainder is the one of [a]. Due to the possible - nullity of [a], a general result is to be stated in the following form: -*) - -Theorem ZOmod_sgn : forall a b:Z, - 0 <= Zsgn (a mod b) * Zsgn a. -Proof. - destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith; - unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; - simpl; destruct n0; simpl; auto with zarith. -Qed. - -(** This can also be said in a simplier way: *) - -Theorem Zsgn_pos_iff : forall z, 0 <= Zsgn z <-> 0 <= z. -Proof. - destruct z; simpl; intuition auto with zarith. -Qed. - -Theorem ZOmod_sgn2 : forall a b:Z, - 0 <= (a mod b) * a. -Proof. - intros; rewrite <-Zsgn_pos_iff, Zsgn_Zmult; apply ZOmod_sgn. -Qed. - -(** Reformulation of [ZOdiv_lt] and [ZOmod_sgn] in 2 - then 4 particular cases. *) - -Theorem ZOmod_lt_pos : forall a b:Z, 0<=a -> b<>0 -> - 0 <= a mod b < Zabs b. -Proof. - intros. - assert (0 <= a mod b). - generalize (ZOmod_sgn a b). - destruct (Zle_lt_or_eq 0 a H). - rewrite <- Zsgn_pos in H1; rewrite H1; romega with *. - subst a; simpl; auto. - generalize (ZOmod_lt a b H0); romega with *. -Qed. - -Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 -> - -Zabs b < a mod b <= 0. -Proof. - intros. - assert (a mod b <= 0). - generalize (ZOmod_sgn a b). - destruct (Zle_lt_or_eq a 0 H). - rewrite <- Zsgn_neg in H1; rewrite H1; romega with *. - subst a; simpl; auto. - generalize (ZOmod_lt a b H0); romega with *. -Qed. - -Theorem ZOmod_lt_pos_pos : forall a b:Z, 0<=a -> 0<b -> 0 <= a mod b < b. -Proof. - intros; generalize (ZOmod_lt_pos a b); romega with *. -Qed. - -Theorem ZOmod_lt_pos_neg : forall a b:Z, 0<=a -> b<0 -> 0 <= a mod b < -b. -Proof. - intros; generalize (ZOmod_lt_pos a b); romega with *. -Qed. - -Theorem ZOmod_lt_neg_pos : forall a b:Z, a<=0 -> 0<b -> -b < a mod b <= 0. -Proof. - intros; generalize (ZOmod_lt_neg a b); romega with *. -Qed. - -Theorem ZOmod_lt_neg_neg : forall a b:Z, a<=0 -> b<0 -> b < a mod b <= 0. -Proof. - intros; generalize (ZOmod_lt_neg a b); romega with *. -Qed. - -(** * Division and Opposite *) - -(* The precise equalities that are invalid with "historic" Zdiv. *) - -Theorem ZOdiv_opp_l : forall a b:Z, (-a)/b = -(a/b). -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -Theorem ZOdiv_opp_r : forall a b:Z, a/(-b) = -(a/b). -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -Theorem ZOmod_opp_l : forall a b:Z, (-a) mod b = -(a mod b). -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -Theorem ZOmod_opp_r : forall a b:Z, a mod (-b) = a mod b. -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -Theorem ZOdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -Theorem ZOmod_opp_opp : forall a b:Z, (-a) mod (-b) = -(a mod b). -Proof. - destruct a; destruct b; simpl; auto; - unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. -Qed. - -(** * Unicity results *) - -Definition Remainder a b r := - (0 <= a /\ 0 <= r < Zabs b) \/ (a <= 0 /\ -Zabs b < r <= 0). - -Definition Remainder_alt a b r := - Zabs r < Zabs b /\ 0 <= r * a. - -Lemma Remainder_equiv : forall a b r, - Remainder a b r <-> Remainder_alt a b r. -Proof. - unfold Remainder, Remainder_alt; intuition. - romega with *. - romega with *. - rewrite <-(Zmult_opp_opp). - apply Zmult_le_0_compat; romega. - assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto). - destruct r; simpl Zsgn in *; romega with *. -Qed. - -Theorem ZOdiv_mod_unique_full: - forall a b q r, Remainder a b r -> - a = b*q + r -> q = a/b /\ r = a mod b. -Proof. - destruct 1 as [(H,H0)|(H,H0)]; intros. - apply Zdiv.Zdiv_mod_unique with b; auto. - apply ZOmod_lt_pos; auto. - romega with *. - rewrite <- H1; apply ZO_div_mod_eq. - - rewrite <- (Zopp_involutive a). - rewrite ZOdiv_opp_l, ZOmod_opp_l. - generalize (Zdiv.Zdiv_mod_unique b (-q) (-a/b) (-r) (-a mod b)). - generalize (ZOmod_lt_pos (-a) b). - rewrite <-ZO_div_mod_eq, <-Zopp_mult_distr_r, <-Zopp_plus_distr, <-H1. - romega with *. -Qed. - -Theorem ZOdiv_unique_full: - forall a b q r, Remainder a b r -> - a = b*q + r -> q = a/b. -Proof. - intros; destruct (ZOdiv_mod_unique_full a b q r); auto. -Qed. - -Theorem ZOdiv_unique: - forall a b q r, 0 <= a -> 0 <= r < b -> - a = b*q + r -> q = a/b. -Proof. - intros; eapply ZOdiv_unique_full; eauto. - red; romega with *. -Qed. - -Theorem ZOmod_unique_full: - forall a b q r, Remainder a b r -> - a = b*q + r -> r = a mod b. -Proof. - intros; destruct (ZOdiv_mod_unique_full a b q r); auto. -Qed. - -Theorem ZOmod_unique: - forall a b q r, 0 <= a -> 0 <= r < b -> - a = b*q + r -> r = a mod b. -Proof. - intros; eapply ZOmod_unique_full; eauto. - red; romega with *. -Qed. - -(** * Basic values of divisions and modulo. *) - -Lemma ZOmod_0_l: forall a, 0 mod a = 0. -Proof. - destruct a; simpl; auto. -Qed. - -Lemma ZOmod_0_r: forall a, a mod 0 = a. -Proof. - destruct a; simpl; auto. -Qed. - -Lemma ZOdiv_0_l: forall a, 0/a = 0. -Proof. - destruct a; simpl; auto. -Qed. - -Lemma ZOdiv_0_r: forall a, a/0 = 0. -Proof. - destruct a; simpl; auto. -Qed. - -Lemma ZOmod_1_r: forall a, a mod 1 = 0. -Proof. - intros; symmetry; apply ZOmod_unique_full with a; auto with zarith. - rewrite Remainder_equiv; red; simpl; auto with zarith. -Qed. - -Lemma ZOdiv_1_r: forall a, a/1 = a. -Proof. - intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith. - rewrite Remainder_equiv; red; simpl; auto with zarith. -Qed. - -Hint Resolve ZOmod_0_l ZOmod_0_r ZOdiv_0_l ZOdiv_0_r ZOdiv_1_r ZOmod_1_r - : zarith. - -Lemma ZOdiv_1_l: forall a, 1 < a -> 1/a = 0. -Proof. - intros; symmetry; apply ZOdiv_unique with 1; auto with zarith. -Qed. - -Lemma ZOmod_1_l: forall a, 1 < a -> 1 mod a = 1. -Proof. - intros; symmetry; apply ZOmod_unique with 0; auto with zarith. -Qed. - -Lemma ZO_div_same : forall a:Z, a<>0 -> a/a = 1. -Proof. - intros; symmetry; apply ZOdiv_unique_full with 0; auto with *. - rewrite Remainder_equiv; red; simpl; romega with *. -Qed. - -Lemma ZO_mod_same : forall a, a mod a = 0. -Proof. - destruct a; intros; symmetry. - compute; auto. - apply ZOmod_unique with 1; auto with *; romega with *. - apply ZOmod_unique_full with 1; auto with *; red; romega with *. -Qed. - -Lemma ZO_mod_mult : forall a b, (a*b) mod b = 0. -Proof. - intros a b; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; simpl; rewrite ZOmod_0_r; auto with zarith. - symmetry; apply ZOmod_unique_full with a; [ red; romega with * | ring ]. -Qed. - -Lemma ZO_div_mult : forall a b:Z, b <> 0 -> (a*b)/b = a. -Proof. - intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith; - [ red; romega with * | ring]. -Qed. - -(** * Order results about ZOmod and ZOdiv *) - -(* Division of positive numbers is positive. *) - -Lemma ZO_div_pos: forall a b, 0 <= a -> 0 <= b -> 0 <= a/b. -Proof. - intros. - destruct (Zle_lt_or_eq 0 b H0). - assert (H2:=ZOmod_lt_pos_pos a b H H1). - rewrite (ZO_div_mod_eq a b) in H. - destruct (Z_lt_le_dec (a/b) 0); auto. - assert (b*(a/b) <= -b). - replace (-b) with (b*-1); [ | ring]. - apply Zmult_le_compat_l; auto with zarith. - romega. - subst b; rewrite ZOdiv_0_r; auto. -Qed. - -(** As soon as the divisor is greater or equal than 2, - the division is strictly decreasing. *) - -Lemma ZO_div_lt : forall a b:Z, 0 < a -> 2 <= b -> a/b < a. -Proof. - intros. - assert (Hb : 0 < b) by romega. - assert (H1 : 0 <= a/b) by (apply ZO_div_pos; auto with zarith). - assert (H2 : 0 <= a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith). - destruct (Zle_lt_or_eq 0 (a/b) H1) as [H3|H3]; [ | rewrite <- H3; auto]. - pattern a at 2; rewrite (ZO_div_mod_eq a b). - apply Zlt_le_trans with (2*(a/b)). - romega. - apply Zle_trans with (b*(a/b)). - apply Zmult_le_compat_r; auto. - romega. -Qed. - -(** A division of a small number by a bigger one yields zero. *) - -Theorem ZOdiv_small: forall a b, 0 <= a < b -> a/b = 0. -Proof. - intros a b H; apply sym_equal; apply ZOdiv_unique with a; auto with zarith. -Qed. - -(** Same situation, in term of modulo: *) - -Theorem ZOmod_small: forall a n, 0 <= a < n -> a mod n = a. -Proof. - intros a b H; apply sym_equal; apply ZOmod_unique with 0; auto with zarith. -Qed. - -(** [Zge] is compatible with a positive division. *) - -Lemma ZO_div_monotone_pos : forall a b c:Z, 0<=c -> 0<=a<=b -> a/c <= b/c. -Proof. - intros. - destruct H0. - destruct (Zle_lt_or_eq 0 c H); - [ clear H | subst c; do 2 rewrite ZOdiv_0_r; auto]. - generalize (ZO_div_mod_eq a c). - generalize (ZOmod_lt_pos_pos a c H0 H2). - generalize (ZO_div_mod_eq b c). - generalize (ZOmod_lt_pos_pos b c (Zle_trans _ _ _ H0 H1) H2). - intros. - elim (Z_le_gt_dec (a / c) (b / c)); auto with zarith. - intro. - absurd (a - b >= 1). - omega. - replace (a-b) with (c * (a/c-b/c) + a mod c - b mod c) by - (symmetry; pattern a at 1; rewrite H5; pattern b at 1; rewrite H3; ring). - assert (c * (a / c - b / c) >= c * 1). - apply Zmult_ge_compat_l. - omega. - omega. - assert (c * 1 = c). - ring. - omega. -Qed. - -Lemma ZO_div_monotone : forall a b c, 0<=c -> a<=b -> a/c <= b/c. -Proof. - intros. - destruct (Z_le_gt_dec 0 a). - apply ZO_div_monotone_pos; auto with zarith. - destruct (Z_le_gt_dec 0 b). - apply Zle_trans with 0. - apply Zle_left_rev. - simpl. - rewrite <- ZOdiv_opp_l. - apply ZO_div_pos; auto with zarith. - apply ZO_div_pos; auto with zarith. - rewrite <-(Zopp_involutive a), (ZOdiv_opp_l (-a)). - rewrite <-(Zopp_involutive b), (ZOdiv_opp_l (-b)). - generalize (ZO_div_monotone_pos (-b) (-a) c H). - romega. -Qed. - -(** With our choice of division, rounding of (a/b) is always done toward zero: *) - -Lemma ZO_mult_div_le : forall a b:Z, 0 <= a -> 0 <= b*(a/b) <= a. -Proof. - intros a b Ha. - destruct b as [ |b|b]. - simpl; auto with zarith. - split. - apply Zmult_le_0_compat; auto with zarith. - apply ZO_div_pos; auto with zarith. - generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_pos_pos a (Zpos b) Ha); romega with *. - change (Zneg b) with (-Zpos b); rewrite ZOdiv_opp_r, Zmult_opp_opp. - split. - apply Zmult_le_0_compat; auto with zarith. - apply ZO_div_pos; auto with zarith. - generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_pos_pos a (Zpos b) Ha); romega with *. -Qed. - -Lemma ZO_mult_div_ge : forall a b:Z, a <= 0 -> a <= b*(a/b) <= 0. -Proof. - intros a b Ha. - destruct b as [ |b|b]. - simpl; auto with zarith. - split. - generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_neg_pos a (Zpos b) Ha); romega with *. - apply Zle_left_rev; unfold Zplus. - rewrite Zopp_mult_distr_r, <-ZOdiv_opp_l. - apply Zmult_le_0_compat; auto with zarith. - apply ZO_div_pos; auto with zarith. - change (Zneg b) with (-Zpos b); rewrite ZOdiv_opp_r, Zmult_opp_opp. - split. - generalize (ZO_div_mod_eq a (Zpos b)) (ZOmod_lt_neg_pos a (Zpos b) Ha); romega with *. - apply Zle_left_rev; unfold Zplus. - rewrite Zopp_mult_distr_r, <-ZOdiv_opp_l. - apply Zmult_le_0_compat; auto with zarith. - apply ZO_div_pos; auto with zarith. -Qed. - -(** The previous inequalities between [b*(a/b)] and [a] are exact - iff the modulo is zero. *) - -Lemma ZO_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0. -Proof. - intros; generalize (ZO_div_mod_eq a b); romega. -Qed. - -Lemma ZO_div_exact_full_2 : forall a b:Z, a mod b = 0 -> a = b*(a/b). -Proof. - intros; generalize (ZO_div_mod_eq a b); romega. -Qed. - -(** A modulo cannot grow beyond its starting point. *) - -Theorem ZOmod_le: forall a b, 0 <= a -> 0 <= b -> a mod b <= a. -Proof. - intros a b H1 H2. - destruct (Zle_lt_or_eq _ _ H2). - case (Zle_or_lt b a); intros H3. - case (ZOmod_lt_pos_pos a b); auto with zarith. - rewrite ZOmod_small; auto with zarith. - subst; rewrite ZOmod_0_r; auto with zarith. -Qed. - -(** Some additionnal inequalities about Zdiv. *) - -Theorem ZOdiv_le_upper_bound: - forall a b q, 0 < b -> a <= q*b -> a/b <= q. -Proof. - intros. - rewrite <- (ZO_div_mult q b); auto with zarith. - apply ZO_div_monotone; auto with zarith. -Qed. - -Theorem ZOdiv_lt_upper_bound: - forall a b q, 0 <= a -> 0 < b -> a < q*b -> a/b < q. -Proof. - intros a b q H1 H2 H3. - apply Zmult_lt_reg_r with b; auto with zarith. - apply Zle_lt_trans with (2 := H3). - pattern a at 2; rewrite (ZO_div_mod_eq a b); auto with zarith. - rewrite (Zmult_comm b); case (ZOmod_lt_pos_pos a b); auto with zarith. -Qed. - -Theorem ZOdiv_le_lower_bound: - forall a b q, 0 < b -> q*b <= a -> q <= a/b. -Proof. - intros. - rewrite <- (ZO_div_mult q b); auto with zarith. - apply ZO_div_monotone; auto with zarith. -Qed. - -Theorem ZOdiv_sgn: forall a b, - 0 <= Zsgn (a/b) * Zsgn a * Zsgn b. -Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; - unfold ZOdiv; simpl; destruct Pdiv_eucl; simpl; destruct n; simpl; auto with zarith. -Qed. - -(** * Relations between usual operations and Zmod and Zdiv *) - -(** First, a result that used to be always valid with Zdiv, - but must be restricted here. - For instance, now (9+(-5)*2) mod 2 = -1 <> 1 = 9 mod 2 *) - -Lemma ZO_mod_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> - (a + b * c) mod c = a mod c. -Proof. - intros; destruct (Z_eq_dec a 0) as [Ha|Ha]. - subst; simpl; rewrite ZOmod_0_l; apply ZO_mod_mult. - intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. - subst; do 2 rewrite ZOmod_0_r; romega. - symmetry; apply ZOmod_unique_full with (a/c+b); auto with zarith. - rewrite Remainder_equiv; split. - apply ZOmod_lt; auto. - apply Zmult_le_0_reg_r with (a*a); eauto. - destruct a; simpl; auto with zarith. - replace ((a mod c)*(a+b*c)*(a*a)) with (((a mod c)*a)*((a+b*c)*a)) by ring. - apply Zmult_le_0_compat; auto. - apply ZOmod_sgn2. - rewrite Zmult_plus_distr_r, Zmult_comm. - generalize (ZO_div_mod_eq a c); romega. -Qed. - -Lemma ZO_div_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> c<>0 -> - (a + b * c) / c = a / c + b. -Proof. - intros; destruct (Z_eq_dec a 0) as [Ha|Ha]. - subst; simpl; apply ZO_div_mult; auto. - symmetry. - apply ZOdiv_unique_full with (a mod c); auto with zarith. - rewrite Remainder_equiv; split. - apply ZOmod_lt; auto. - apply Zmult_le_0_reg_r with (a*a); eauto. - destruct a; simpl; auto with zarith. - replace ((a mod c)*(a+b*c)*(a*a)) with (((a mod c)*a)*((a+b*c)*a)) by ring. - apply Zmult_le_0_compat; auto. - apply ZOmod_sgn2. - rewrite Zmult_plus_distr_r, Zmult_comm. - generalize (ZO_div_mod_eq a c); romega. -Qed. - -Theorem ZO_div_plus_l: forall a b c : Z, - 0 <= (a*b+c)*c -> b<>0 -> - b<>0 -> (a * b + c) / b = a + c / b. -Proof. - intros a b c; rewrite Zplus_comm; intros; rewrite ZO_div_plus; - try apply Zplus_comm; auto with zarith. -Qed. - -(** Cancellations. *) - -Lemma ZOdiv_mult_cancel_r : forall a b c:Z, - c<>0 -> (a*c)/(b*c) = a/b. -Proof. - intros a b c Hc. - destruct (Z_eq_dec b 0). - subst; simpl; do 2 rewrite ZOdiv_0_r; auto. - symmetry. - apply ZOdiv_unique_full with ((a mod b)*c); auto with zarith. - rewrite Remainder_equiv. - split. - do 2 rewrite Zabs_Zmult. - apply Zmult_lt_compat_r. - romega with *. - apply ZOmod_lt; auto. - replace ((a mod b)*c*(a*c)) with (((a mod b)*a)*(c*c)) by ring. - apply Zmult_le_0_compat. - apply ZOmod_sgn2. - destruct c; simpl; auto with zarith. - pattern a at 1; rewrite (ZO_div_mod_eq a b); ring. -Qed. - -Lemma ZOdiv_mult_cancel_l : forall a b c:Z, - c<>0 -> (c*a)/(c*b) = a/b. -Proof. - intros. - rewrite (Zmult_comm c a); rewrite (Zmult_comm c b). - apply ZOdiv_mult_cancel_r; auto. -Qed. - -Lemma ZOmult_mod_distr_l: forall a b c, - (c*a) mod (c*b) = c * (a mod b). -Proof. - intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. - subst; simpl; rewrite ZOmod_0_r; auto. - destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; repeat rewrite Zmult_0_r || rewrite ZOmod_0_r; auto. - assert (c*b <> 0). - contradict Hc; eapply Zmult_integral_l; eauto. - rewrite (Zplus_minus_eq _ _ _ (ZO_div_mod_eq (c*a) (c*b))). - rewrite (Zplus_minus_eq _ _ _ (ZO_div_mod_eq a b)). - rewrite ZOdiv_mult_cancel_l; auto with zarith. - ring. -Qed. - -Lemma ZOmult_mod_distr_r: forall a b c, - (a*c) mod (b*c) = (a mod b) * c. -Proof. - intros; repeat rewrite (fun x => (Zmult_comm x c)). - apply ZOmult_mod_distr_l; auto. -Qed. - -(** Operations modulo. *) - -Theorem ZOmod_mod: forall a n, (a mod n) mod n = a mod n. -Proof. - intros. - generalize (ZOmod_sgn2 a n). - pattern a at 2 4; rewrite (ZO_div_mod_eq a n); auto with zarith. - rewrite Zplus_comm; rewrite (Zmult_comm n). - intros. - apply sym_equal; apply ZO_mod_plus; auto with zarith. - rewrite Zmult_comm; auto. -Qed. - -Theorem ZOmult_mod: forall a b n, - (a * b) mod n = ((a mod n) * (b mod n)) mod n. -Proof. - intros. - generalize (Zmult_le_0_compat _ _ (ZOmod_sgn2 a n) (ZOmod_sgn2 b n)). - pattern a at 2 3; rewrite (ZO_div_mod_eq a n); auto with zarith. - pattern b at 2 3; rewrite (ZO_div_mod_eq b n); auto with zarith. - set (A:=a mod n); set (B:=b mod n); set (A':=a/n); set (B':=b/n). - replace (A*(n*A'+A)*(B*(n*B'+B))) with (((n*A' + A) * (n*B' + B))*(A*B)) - by ring. - replace ((n*A' + A) * (n*B' + B)) - with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring. - intros. - apply ZO_mod_plus; auto with zarith. -Qed. - -(** addition and modulo - - Generally speaking, unlike with Zdiv, we don't have - (a+b) mod n = (a mod n + b mod n) mod n - for any a and b. - For instance, take (8 + (-10)) mod 3 = -2 whereas - (8 mod 3 + (-10 mod 3)) mod 3 = 1. *) - -Theorem ZOplus_mod: forall a b n, - 0 <= a * b -> - (a + b) mod n = (a mod n + b mod n) mod n. -Proof. - assert (forall a b n, 0<a -> 0<b -> - (a + b) mod n = (a mod n + b mod n) mod n). - intros a b n Ha Hb. - assert (H : 0<=a+b) by (romega with * ); revert H. - pattern a at 1 2; rewrite (ZO_div_mod_eq a n); auto with zarith. - pattern b at 1 2; rewrite (ZO_div_mod_eq b n); auto with zarith. - replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n)) - with ((a mod n + b mod n) + (a / n + b / n) * n) by ring. - intros. - apply ZO_mod_plus; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. - apply Zplus_le_0_compat. - apply Zmult_le_reg_r with a; auto with zarith. - simpl; apply ZOmod_sgn2; auto. - apply Zmult_le_reg_r with b; auto with zarith. - simpl; apply ZOmod_sgn2; auto. - (* general situation *) - intros a b n Hab. - destruct (Z_eq_dec a 0). - subst; simpl; symmetry; apply ZOmod_mod. - destruct (Z_eq_dec b 0). - subst; simpl; do 2 rewrite Zplus_0_r; symmetry; apply ZOmod_mod. - assert (0<a /\ 0<b \/ a<0 /\ b<0). - destruct a; destruct b; simpl in *; intuition; romega with *. - destruct H0. - apply H; intuition. - rewrite <-(Zopp_involutive a), <-(Zopp_involutive b). - rewrite <- Zopp_plus_distr; rewrite ZOmod_opp_l. - rewrite (ZOmod_opp_l (-a)),(ZOmod_opp_l (-b)). - match goal with |- _ = (-?x+-?y) mod n => - rewrite <-(Zopp_plus_distr x y), ZOmod_opp_l end. - f_equal; apply H; auto with zarith. -Qed. - -Lemma ZOplus_mod_idemp_l: forall a b n, - 0 <= a * b -> - (a mod n + b) mod n = (a + b) mod n. -Proof. - intros. - rewrite ZOplus_mod. - rewrite ZOmod_mod. - symmetry. - apply ZOplus_mod; auto. - destruct (Z_eq_dec a 0). - subst; rewrite ZOmod_0_l; auto. - destruct (Z_eq_dec b 0). - subst; rewrite Zmult_0_r; auto with zarith. - apply Zmult_le_reg_r with (a*b). - assert (a*b <> 0). - intro Hab. - rewrite (Zmult_integral_l _ _ n1 Hab) in n0; auto with zarith. - auto with zarith. - simpl. - replace (a mod n * b * (a*b)) with ((a mod n * a)*(b*b)) by ring. - apply Zmult_le_0_compat. - apply ZOmod_sgn2. - destruct b; simpl; auto with zarith. -Qed. - -Lemma ZOplus_mod_idemp_r: forall a b n, - 0 <= a*b -> - (b + a mod n) mod n = (b + a) mod n. -Proof. - intros. - rewrite Zplus_comm, (Zplus_comm b a). - apply ZOplus_mod_idemp_l; auto. -Qed. - -Lemma ZOmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n. -Proof. - intros; rewrite ZOmult_mod, ZOmod_mod, <- ZOmult_mod; auto. -Qed. - -Lemma ZOmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n. -Proof. - intros; rewrite ZOmult_mod, ZOmod_mod, <- ZOmult_mod; auto. -Qed. - -(** Unlike with Zdiv, the following result is true without restrictions. *) - -Lemma ZOdiv_ZOdiv : forall a b c, (a/b)/c = a/(b*c). -Proof. - (* particular case: a, b, c positive *) - assert (forall a b c, a>0 -> b>0 -> c>0 -> (a/b)/c = a/(b*c)). - intros a b c H H0 H1. - pattern a at 2;rewrite (ZO_div_mod_eq a b). - pattern (a/b) at 2;rewrite (ZO_div_mod_eq (a/b) c). - replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with - ((a / b / c)*(b * c) + (b * ((a / b) mod c) + a mod b)) by ring. - assert (b*c<>0). - intro H2; - assert (H3: c <> 0) by auto with zarith; - rewrite (Zmult_integral_l _ _ H3 H2) in H0; auto with zarith. - assert (0<=a/b) by (apply (ZO_div_pos a b); auto with zarith). - assert (0<=a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith). - assert (0<=(a/b) mod c < c) by - (apply ZOmod_lt_pos_pos; auto with zarith). - rewrite ZO_div_plus_l; auto with zarith. - rewrite (ZOdiv_small (b * ((a / b) mod c) + a mod b)). - ring. - split. - apply Zplus_le_0_compat;auto with zarith. - apply Zle_lt_trans with (b * ((a / b) mod c) + (b-1)). - apply Zplus_le_compat;auto with zarith. - apply Zle_lt_trans with (b * (c-1) + (b - 1)). - apply Zplus_le_compat;auto with zarith. - replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith. - repeat (apply Zmult_le_0_compat || apply Zplus_le_0_compat); auto with zarith. - apply (ZO_div_pos (a/b) c); auto with zarith. - (* b c positive, a general *) - assert (forall a b c, b>0 -> c>0 -> (a/b)/c = a/(b*c)). - intros; destruct a as [ |a|a]; try reflexivity. - apply H; auto with zarith. - change (Zneg a) with (-Zpos a); repeat rewrite ZOdiv_opp_l. - f_equal; apply H; auto with zarith. - (* c positive, a b general *) - assert (forall a b c, c>0 -> (a/b)/c = a/(b*c)). - intros; destruct b as [ |b|b]. - repeat rewrite ZOdiv_0_r; reflexivity. - apply H0; auto with zarith. - change (Zneg b) with (-Zpos b); - repeat (rewrite ZOdiv_opp_r || rewrite ZOdiv_opp_l || rewrite <- Zopp_mult_distr_l). - f_equal; apply H0; auto with zarith. - (* a b c general *) - intros; destruct c as [ |c|c]. - rewrite Zmult_0_r; repeat rewrite ZOdiv_0_r; reflexivity. - apply H1; auto with zarith. - change (Zneg c) with (-Zpos c); - rewrite <- Zopp_mult_distr_r; do 2 rewrite ZOdiv_opp_r. - f_equal; apply H1; auto with zarith. -Qed. - -(** A last inequality: *) - -Theorem ZOdiv_mult_le: - forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. -Proof. - intros a b c Ha Hb Hc. - destruct (Zle_lt_or_eq _ _ Ha); - [ | subst; rewrite ZOdiv_0_l, Zmult_0_r, ZOdiv_0_l; auto]. - destruct (Zle_lt_or_eq _ _ Hb); - [ | subst; rewrite ZOdiv_0_r, ZOdiv_0_r, Zmult_0_r; auto]. - destruct (Zle_lt_or_eq _ _ Hc); - [ | subst; rewrite ZOdiv_0_l; auto]. - case (ZOmod_lt_pos_pos a b); auto with zarith; intros Hu1 Hu2. - case (ZOmod_lt_pos_pos c b); auto with zarith; intros Hv1 Hv2. - apply Zmult_le_reg_r with b; auto with zarith. - rewrite <- Zmult_assoc. - replace (a / b * b) with (a - a mod b). - replace (c * a / b * b) with (c * a - (c * a) mod b). - rewrite Zmult_minus_distr_l. - unfold Zminus; apply Zplus_le_compat_l. - match goal with |- - ?X <= -?Y => assert (Y <= X); auto with zarith end. - apply Zle_trans with ((c mod b) * (a mod b)); auto with zarith. - rewrite ZOmult_mod; auto with zarith. - apply (ZOmod_le ((c mod b) * (a mod b)) b); auto with zarith. - apply Zmult_le_compat_r; auto with zarith. - apply (ZOmod_le c b); auto. - pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; - auto with zarith. - pattern a at 1; rewrite (ZO_div_mod_eq a b); try ring; auto with zarith. -Qed. - -(** ZOmod is related to divisibility (see more in Znumtheory) *) - -Lemma ZOmod_divides : forall a b, - a mod b = 0 <-> exists c, a = b*c. -Proof. - split; intros. - exists (a/b). - pattern a at 1; rewrite (ZO_div_mod_eq a b). - rewrite H; auto with zarith. - destruct H as [c Hc]. - destruct (Z_eq_dec b 0). - subst b; simpl in *; subst a; auto. - symmetry. - apply ZOmod_unique_full with c; auto with zarith. - red; romega with *. -Qed. - -(** * Interaction with "historic" Zdiv *) - -(** They agree at least on positive numbers: *) - -Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> - a/b = Zdiv.Zdiv a b /\ a mod b = Zdiv.Zmod a b. -Proof. - intros. - apply Zdiv.Zdiv_mod_unique with b. - apply ZOmod_lt_pos; auto with zarith. - rewrite Zabs_eq; auto with *; apply Zdiv.Z_mod_lt; auto with *. - rewrite <- Zdiv.Z_div_mod_eq; auto with *. - symmetry; apply ZO_div_mod_eq; auto with *. -Qed. - -Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> - a/b = Zdiv.Zdiv a b. -Proof. - intros a b Ha Hb. - destruct (Zle_lt_or_eq _ _ Hb). - generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha H); intuition. - subst; rewrite ZOdiv_0_r, Zdiv.Zdiv_0_r; reflexivity. -Qed. - -Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> - a mod b = Zdiv.Zmod a b. -Proof. - intros a b Ha Hb; generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha Hb); - intuition. -Qed. - -(** Modulos are null at the same places *) - -Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> - (a mod b = 0 <-> Zdiv.Zmod a b = 0). -Proof. - intros. - rewrite ZOmod_divides, Zdiv.Zmod_divides; intuition. -Qed. diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v deleted file mode 100644 index 71d6cad4..00000000 --- a/theories/ZArith/ZOdiv_def.v +++ /dev/null @@ -1,136 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - - -Require Import BinPos BinNat Nnat ZArith_base. - -Open Scope Z_scope. - -Definition NPgeb (a:N)(b:positive) := - match a with - | N0 => false - | Npos na => match Pcompare na b Eq with Lt => false | _ => true end - end. - -Fixpoint Pdiv_eucl (a b:positive) : N * N := - match a with - | xH => - match b with xH => (1, 0)%N | _ => (0, 1)%N end - | xO a' => - let (q, r) := Pdiv_eucl a' b in - let r' := (2 * r)%N in - if (NPgeb r' b) then (2 * q + 1, (Nminus r' (Npos b)))%N - else (2 * q, r')%N - | xI a' => - let (q, r) := Pdiv_eucl a' b in - let r' := (2 * r + 1)%N in - if (NPgeb r' b) then (2 * q + 1, (Nminus r' (Npos b)))%N - else (2 * q, r')%N - end. - -Definition ZOdiv_eucl (a b:Z) : Z * Z := - match a, b with - | Z0, _ => (Z0, Z0) - | _, Z0 => (Z0, a) - | Zpos na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in - (Z_of_N nq, Z_of_N nr) - | Zneg na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in - (Zopp (Z_of_N nq), Zopp (Z_of_N nr)) - | Zpos na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in - (Zopp (Z_of_N nq), Z_of_N nr) - | Zneg na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in - (Z_of_N nq, Zopp (Z_of_N nr)) - end. - -Definition ZOdiv a b := fst (ZOdiv_eucl a b). -Definition ZOmod a b := snd (ZOdiv_eucl a b). - - -Definition Ndiv_eucl (a b:N) : N * N := - match a, b with - | N0, _ => (N0, N0) - | _, N0 => (N0, a) - | Npos na, Npos nb => Pdiv_eucl na nb - end. - -Definition Ndiv a b := fst (Ndiv_eucl a b). -Definition Nmod a b := snd (Ndiv_eucl a b). - - -(* Proofs of specifications for these euclidean divisions. *) - -Theorem NPgeb_correct: forall (a:N)(b:positive), - if NPgeb a b then a = (Nminus a (Npos b) + Npos b)%N else True. -Proof. - destruct a; intros; simpl; auto. - generalize (Pcompare_Eq_eq p b). - case_eq (Pcompare p b Eq); intros; auto. - rewrite H0; auto. - now rewrite Pminus_mask_diag. - destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]]. - rewrite H2. rewrite <- H3. - simpl; f_equal; apply Pplus_comm. -Qed. - -Hint Rewrite Z_of_N_plus Z_of_N_mult Z_of_N_minus Zmult_1_l Zmult_assoc - Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. -Hint Rewrite <- Zplus_assoc : zdiv. - -Theorem Pdiv_eucl_correct: forall a b, - let (q,r) := Pdiv_eucl a b in - Zpos a = Z_of_N q * Zpos b + Z_of_N r. -Proof. - induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta. - intros b; generalize (IHa b); case Pdiv_eucl. - intros q1 r1 Hq1. - generalize (NPgeb_correct (2 * r1 + 1) b); case NPgeb; intros H. - set (u := Nminus (2 * r1 + 1) (Npos b)) in * |- *. - assert (HH: Z_of_N u = (Z_of_N (2 * r1 + 1) - Zpos b)%Z). - rewrite H; autorewrite with zdiv; simpl. - rewrite Zplus_comm, Zminus_plus; trivial. - rewrite HH; autorewrite with zdiv; simpl Z_of_N. - rewrite Zpos_xI, Hq1. - autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial. - rewrite Zpos_xI, Hq1; autorewrite with zdiv; auto. - intros b; generalize (IHa b); case Pdiv_eucl. - intros q1 r1 Hq1. - generalize (NPgeb_correct (2 * r1) b); case NPgeb; intros H. - set (u := Nminus (2 * r1) (Npos b)) in * |- *. - assert (HH: Z_of_N u = (Z_of_N (2 * r1) - Zpos b)%Z). - rewrite H; autorewrite with zdiv; simpl. - rewrite Zplus_comm, Zminus_plus; trivial. - rewrite HH; autorewrite with zdiv; simpl Z_of_N. - rewrite Zpos_xO, Hq1. - autorewrite with zdiv; f_equal; rewrite Zplus_minus; trivial. - rewrite Zpos_xO, Hq1; autorewrite with zdiv; auto. - destruct b; auto. -Qed. - -Theorem ZOdiv_eucl_correct: forall a b, - let (q,r) := ZOdiv_eucl a b in a = q * b + r. -Proof. - destruct a; destruct b; simpl; auto; - generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros; - try change (Zneg p) with (Zopp (Zpos p)); rewrite H. - destruct n; auto. - repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_l); trivial. - repeat (rewrite Zopp_plus_distr || rewrite Zopp_mult_distr_r); trivial. -Qed. - -Theorem Ndiv_eucl_correct: forall a b, - let (q,r) := Ndiv_eucl a b in a = (q * b + r)%N. -Proof. - destruct a; destruct b; simpl; auto; - generalize (Pdiv_eucl_correct p p0); case Pdiv_eucl; auto; intros; - destruct n; destruct n0; simpl; simpl in H; try discriminate; - injection H; intros; subst; trivial. -Qed. diff --git a/theories/ZArith/ZOrderedType.v b/theories/ZArith/ZOrderedType.v deleted file mode 100644 index de4e4e98..00000000 --- a/theories/ZArith/ZOrderedType.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import BinInt Zcompare Zorder Zbool ZArith_dec - Equalities Orders OrdersTac. - -Local Open Scope Z_scope. - -(** * DecidableType structure for binary integers *) - -Module Z_as_UBE <: UsualBoolEq. - Definition t := Z. - Definition eq := @eq Z. - Definition eqb := Zeq_bool. - Definition eqb_eq x y := iff_sym (Zeq_is_eq_bool x y). -End Z_as_UBE. - -Module Z_as_DT <: UsualDecidableTypeFull := Make_UDTF Z_as_UBE. - -(** Note that the last module fulfills by subtyping many other - interfaces, such as [DecidableType] or [EqualityType]. *) - - -(** * OrderedType structure for binary integers *) - -Module Z_as_OT <: OrderedTypeFull. - Include Z_as_DT. - Definition lt := Zlt. - Definition le := Zle. - Definition compare := Zcompare. - - Instance lt_strorder : StrictOrder Zlt. - Proof. split; [ exact Zlt_irrefl | exact Zlt_trans ]. Qed. - - Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Zlt. - Proof. repeat red; intros; subst; auto. Qed. - - Definition le_lteq := Zle_lt_or_eq_iff. - Definition compare_spec := Zcompare_spec. - -End Z_as_OT. - -(** Note that [Z_as_OT] can also be seen as a [UsualOrderedType] - and a [OrderedType] (and also as a [DecidableType]). *) - - - -(** * An [order] tactic for integers *) - -Module ZOrder := OTF_to_OrderTac Z_as_OT. -Ltac z_order := ZOrder.order. - -(** Note that [z_order] is domain-agnostic: it will not prove - [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *) - diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 0f6e62b7..23473e93 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -1,226 +1,106 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zabs.v 14641 2011-11-06 11:59:10Z herbelin $ i*) -(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) +(** Binary Integers : properties of absolute value *) +(** Initial author : Pierre Crégut (CNET, Lannion, France) *) + +(** THIS FILE IS DEPRECATED. + It is now almost entirely made of compatibility formulations + for results already present in BinInt.Z. *) Require Import Arith_base. Require Import BinPos. Require Import BinInt. +Require Import Zcompare. Require Import Zorder. -Require Import Zmax. Require Import Znat. Require Import ZArith_dec. -Open Local Scope Z_scope. +Local Open Scope Z_scope. (**********************************************************************) (** * Properties of absolute value *) -Lemma Zabs_eq : forall n:Z, 0 <= n -> Zabs n = n. -Proof. - intro x; destruct x; auto with arith. - compute in |- *; intros; absurd (Gt = Gt); trivial with arith. -Qed. - -Lemma Zabs_non_eq : forall n:Z, n <= 0 -> Zabs n = - n. -Proof. - intro x; destruct x; auto with arith. - compute in |- *; intros; absurd (Gt = Gt); trivial with arith. -Qed. - -Theorem Zabs_Zopp : forall n:Z, Zabs (- n) = Zabs n. -Proof. - intros z; case z; simpl in |- *; auto. -Qed. +Notation Zabs_eq := Z.abs_eq (only parsing). +Notation Zabs_non_eq := Z.abs_neq (only parsing). +Notation Zabs_Zopp := Z.abs_opp (only parsing). +Notation Zabs_pos := Z.abs_nonneg (only parsing). +Notation Zabs_involutive := Z.abs_involutive (only parsing). +Notation Zabs_eq_case := Z.abs_eq_cases (only parsing). +Notation Zabs_triangle := Z.abs_triangle (only parsing). +Notation Zsgn_Zabs := Z.sgn_abs (only parsing). +Notation Zabs_Zsgn := Z.abs_sgn (only parsing). +Notation Zabs_Zmult := Z.abs_mul (only parsing). +Notation Zabs_square := Z.abs_square (only parsing). (** * Proving a property of the absolute value by cases *) Lemma Zabs_ind : forall (P:Z -> Prop) (n:Z), - (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Zabs n). + (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Z.abs n). Proof. - intros P x H H0; elim (Z_lt_ge_dec x 0); intro. - assert (x <= 0). apply Zlt_le_weak; assumption. - rewrite Zabs_non_eq. apply H0. assumption. assumption. - rewrite Zabs_eq. apply H; assumption. apply Zge_le. assumption. + intros. apply Z.abs_case_strong; Z.swap_greater; trivial. + intros x y Hx; now subst. Qed. -Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Zabs n). +Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Z.abs n). Proof. - intros P z; case z; simpl in |- *; auto. + now destruct n. Qed. -Definition Zabs_dec : forall x:Z, {x = Zabs x} + {x = - Zabs x}. +Definition Zabs_dec : forall x:Z, {x = Z.abs x} + {x = - Z.abs x}. Proof. - intro x; destruct x; auto with arith. + destruct x; auto. Defined. -Lemma Zabs_pos : forall n:Z, 0 <= Zabs n. - intro x; destruct x; auto with arith; compute in |- *; intros H; inversion H. -Qed. - -Lemma Zabs_involutive : forall x:Z, Zabs (Zabs x) = Zabs x. -Proof. - intros; apply Zabs_eq; apply Zabs_pos. -Qed. - -Theorem Zabs_eq_case : forall n m:Z, Zabs n = Zabs m -> n = m \/ n = - m. -Proof. - intros z1 z2; case z1; case z2; simpl in |- *; auto; - try (intros; discriminate); intros p1 p2 H1; injection H1; - (intros H2; rewrite H2); auto. -Qed. - -Lemma Zabs_spec : forall x:Z, - 0 <= x /\ Zabs x = x \/ - 0 > x /\ Zabs x = -x. -Proof. - intros; unfold Zabs, Zle, Zgt; destruct x; simpl; intuition discriminate. -Qed. - -(** * Triangular inequality *) - -Hint Local Resolve Zle_neg_pos: zarith. - -Theorem Zabs_triangle : forall n m:Z, Zabs (n + m) <= Zabs n + Zabs m. -Proof. - intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail). - intros p1 p2; - apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1)); - try rewrite Zopp_plus_distr; auto with zarith. - apply Zplus_le_compat; simpl in |- *; auto with zarith. - apply Zplus_le_compat; simpl in |- *; auto with zarith. - intros p1 p2; - apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1)); - try rewrite Zopp_plus_distr; auto with zarith. - apply Zplus_le_compat; simpl in |- *; auto with zarith. - apply Zplus_le_compat; simpl in |- *; auto with zarith. -Qed. - -(** * Absolute value and multiplication *) - -Lemma Zsgn_Zabs : forall n:Z, n * Zsgn n = Zabs n. -Proof. - intro x; destruct x; rewrite Zmult_comm; auto with arith. -Qed. - -Lemma Zabs_Zsgn : forall n:Z, Zabs n * Zsgn n = n. -Proof. - intro x; destruct x; rewrite Zmult_comm; auto with arith. -Qed. - -Theorem Zabs_Zmult : forall n m:Z, Zabs (n * m) = Zabs n * Zabs m. -Proof. - intros z1 z2; case z1; case z2; simpl in |- *; auto. -Qed. - -Theorem Zabs_square : forall a, Zabs a * Zabs a = a * a. +Lemma Zabs_spec x : + 0 <= x /\ Z.abs x = x \/ + 0 > x /\ Z.abs x = -x. Proof. - destruct a; simpl; auto. -Qed. - -(** * Results about absolute value in nat. *) - -Theorem inj_Zabs_nat : forall z:Z, Z_of_nat (Zabs_nat z) = Zabs z. -Proof. - destruct z; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P. -Qed. - -Theorem Zabs_nat_Z_of_nat: forall n, Zabs_nat (Z_of_nat n) = n. -Proof. - destruct n; simpl; auto. - apply nat_of_P_o_P_of_succ_nat_eq_succ. -Qed. - -Lemma Zabs_nat_mult: forall n m:Z, Zabs_nat (n*m) = (Zabs_nat n * Zabs_nat m)%nat. -Proof. - intros; apply inj_eq_rev. - rewrite inj_mult; repeat rewrite inj_Zabs_nat; apply Zabs_Zmult. -Qed. - -Lemma Zabs_nat_Zsucc: - forall p, 0 <= p -> Zabs_nat (Zsucc p) = S (Zabs_nat p). -Proof. - intros; apply inj_eq_rev. - rewrite inj_S; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. -Qed. - -Lemma Zabs_nat_Zplus: - forall x y, 0<=x -> 0<=y -> Zabs_nat (x+y) = (Zabs_nat x + Zabs_nat y)%nat. -Proof. - intros; apply inj_eq_rev. - rewrite inj_plus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. - apply Zplus_le_0_compat; auto. -Qed. - -Lemma Zabs_nat_Zminus: - forall x y, 0 <= x <= y -> Zabs_nat (y - x) = (Zabs_nat y - Zabs_nat x)%nat. -Proof. - intros x y (H,H'). - assert (0 <= y) by (apply Zle_trans with x; auto). - assert (0 <= y-x) by (apply Zle_minus_le_0; auto). - apply inj_eq_rev. - rewrite inj_minus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto. - rewrite Zmax_right; auto. -Qed. - -Lemma Zabs_nat_le : - forall n m:Z, 0 <= n <= m -> (Zabs_nat n <= Zabs_nat m)%nat. -Proof. - intros n m (H,H'); apply inj_le_rev. - repeat rewrite inj_Zabs_nat, Zabs_eq; auto. - apply Zle_trans with n; auto. -Qed. - -Lemma Zabs_nat_lt : - forall n m:Z, 0 <= n < m -> (Zabs_nat n < Zabs_nat m)%nat. -Proof. - intros n m (H,H'); apply inj_lt_rev. - repeat rewrite inj_Zabs_nat, Zabs_eq; auto. - apply Zlt_le_weak; apply Zle_lt_trans with n; auto. + Z.swap_greater. apply Z.abs_spec. Qed. (** * Some results about the sign function. *) -Lemma Zsgn_Zmult : forall a b, Zsgn (a*b) = Zsgn a * Zsgn b. -Proof. - destruct a; destruct b; simpl; auto. -Qed. - -Lemma Zsgn_Zopp : forall a, Zsgn (-a) = - Zsgn a. -Proof. - destruct a; simpl; auto. -Qed. +Notation Zsgn_Zmult := Z.sgn_mul (only parsing). +Notation Zsgn_Zopp := Z.sgn_opp (only parsing). +Notation Zsgn_pos := Z.sgn_pos_iff (only parsing). +Notation Zsgn_neg := Z.sgn_neg_iff (only parsing). +Notation Zsgn_null := Z.sgn_null_iff (only parsing). (** A characterization of the sign function: *) -Lemma Zsgn_spec : forall x:Z, +Lemma Zsgn_spec x : 0 < x /\ Zsgn x = 1 \/ 0 = x /\ Zsgn x = 0 \/ 0 > x /\ Zsgn x = -1. Proof. - intros; unfold Zsgn, Zle, Zgt; destruct x; compute; intuition. + intros. Z.swap_greater. apply Z.sgn_spec. Qed. -Lemma Zsgn_pos : forall x:Z, Zsgn x = 1 <-> 0 < x. -Proof. - destruct x; now intuition. -Qed. +(** Compatibility *) -Lemma Zsgn_neg : forall x:Z, Zsgn x = -1 <-> x < 0. +Notation inj_Zabs_nat := Zabs2Nat.id_abs (only parsing). +Notation Zabs_nat_Z_of_nat := Zabs2Nat.id (only parsing). +Notation Zabs_nat_mult := Zabs2Nat.inj_mul (only parsing). +Notation Zabs_nat_Zsucc := Zabs2Nat.inj_succ (only parsing). +Notation Zabs_nat_Zplus := Zabs2Nat.inj_add (only parsing). +Notation Zabs_nat_Zminus := (fun n m => Zabs2Nat.inj_sub m n) (only parsing). +Notation Zabs_nat_compare := Zabs2Nat.inj_compare (only parsing). + +Lemma Zabs_nat_le n m : 0 <= n <= m -> (Z.abs_nat n <= Z.abs_nat m)%nat. Proof. - destruct x; now intuition. + intros (H,H'). apply Zabs2Nat.inj_le; trivial. now transitivity n. Qed. -Lemma Zsgn_null : forall x:Z, Zsgn x = 0 <-> x = 0. +Lemma Zabs_nat_lt n m : 0 <= n < m -> (Zabs_nat n < Zabs_nat m)%nat. Proof. - destruct x; now intuition. + intros (H,H'). apply Zabs2Nat.inj_lt; trivial. + transitivity n; trivial. now apply Z.lt_le_incl. Qed. - diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index a4eebfb2..d0901282 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zbool.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import BinInt. Require Import Zeven. Require Import Zorder. @@ -15,7 +13,6 @@ Require Import Zcompare. Require Import ZArith_dec. Require Import Sumbool. -Unset Boxed Definitions. Open Local Scope Z_scope. (** * Boolean operations from decidability of order *) @@ -36,29 +33,13 @@ Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x). (**********************************************************************) (** * Boolean comparisons of binary integers *) -Definition Zle_bool (x y:Z) := - match x ?= y with - | Gt => false - | _ => true - end. +Notation Zle_bool := Z.leb (only parsing). +Notation Zge_bool := Z.geb (only parsing). +Notation Zlt_bool := Z.ltb (only parsing). +Notation Zgt_bool := Z.gtb (only parsing). -Definition Zge_bool (x y:Z) := - match x ?= y with - | Lt => false - | _ => true - end. - -Definition Zlt_bool (x y:Z) := - match x ?= y with - | Lt => true - | _ => false - end. - -Definition Zgt_bool (x y:Z) := - match x ?= y with - | Gt => true - | _ => false - end. +(** We now provide a direct [Z.eqb] that doesn't refer to [Z.compare]. + The old [Zeq_bool] is kept for compatibility. *) Definition Zeq_bool (x y:Z) := match x ?= y with @@ -74,162 +55,130 @@ Definition Zneq_bool (x y:Z) := (** Properties in term of [if ... then ... else ...] *) -Lemma Zle_cases : - forall n m:Z, if Zle_bool n m then (n <= m) else (n > m). +Lemma Zle_cases n m : if n <=? m then n <= m else n > m. Proof. - intros x y; unfold Zle_bool, Zle, Zgt in |- *. - case (x ?= y); auto; discriminate. + case Z.leb_spec; now Z.swap_greater. Qed. -Lemma Zlt_cases : - forall n m:Z, if Zlt_bool n m then (n < m) else (n >= m). +Lemma Zlt_cases n m : if n <? m then n < m else n >= m. Proof. - intros x y; unfold Zlt_bool, Zlt, Zge in |- *. - case (x ?= y); auto; discriminate. + case Z.ltb_spec; now Z.swap_greater. Qed. -Lemma Zge_cases : - forall n m:Z, if Zge_bool n m then (n >= m) else (n < m). +Lemma Zge_cases n m : if n >=? m then n >= m else n < m. Proof. - intros x y; unfold Zge_bool, Zge, Zlt in |- *. - case (x ?= y); auto; discriminate. + rewrite Z.geb_leb. case Z.leb_spec; now Z.swap_greater. Qed. -Lemma Zgt_cases : - forall n m:Z, if Zgt_bool n m then (n > m) else (n <= m). +Lemma Zgt_cases n m : if n >? m then n > m else n <= m. Proof. - intros x y; unfold Zgt_bool, Zgt, Zle in |- *. - case (x ?= y); auto; discriminate. + rewrite Z.gtb_ltb. case Z.ltb_spec; now Z.swap_greater. Qed. -(** Lemmas on [Zle_bool] used in contrib/graphs *) +(** Lemmas on [Z.leb] used in contrib/graphs *) -Lemma Zle_bool_imp_le : forall n m:Z, Zle_bool n m = true -> (n <= m). +Lemma Zle_bool_imp_le n m : (n <=? m) = true -> (n <= m). Proof. - unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *. - case (x ?= y); intros; discriminate. + apply Z.leb_le. Qed. -Lemma Zle_imp_le_bool : forall n m:Z, (n <= m) -> Zle_bool n m = true. +Lemma Zle_imp_le_bool n m : (n <= m) -> (n <=? m) = true. Proof. - unfold Zle, Zle_bool in |- *. intros x y. case (x ?= y); trivial. intro. elim (H (refl_equal _)). + apply Z.leb_le. Qed. -Lemma Zle_bool_refl : forall n:Z, Zle_bool n n = true. -Proof. - intro. apply Zle_imp_le_bool. apply Zeq_le. reflexivity. -Qed. +Notation Zle_bool_refl := Z.leb_refl (only parsing). -Lemma Zle_bool_antisym : - forall n m:Z, Zle_bool n m = true -> Zle_bool m n = true -> n = m. +Lemma Zle_bool_antisym n m : + (n <=? m) = true -> (m <=? n) = true -> n = m. Proof. - intros. apply Zle_antisym. apply Zle_bool_imp_le. assumption. - apply Zle_bool_imp_le. assumption. + rewrite !Z.leb_le. apply Z.le_antisymm. Qed. -Lemma Zle_bool_trans : - forall n m p:Z, - Zle_bool n m = true -> Zle_bool m p = true -> Zle_bool n p = true. +Lemma Zle_bool_trans n m p : + (n <=? m) = true -> (m <=? p) = true -> (n <=? p) = true. Proof. - intros x y z; intros. apply Zle_imp_le_bool. apply Zle_trans with (m := y). apply Zle_bool_imp_le. assumption. - apply Zle_bool_imp_le. assumption. + rewrite !Z.leb_le. apply Z.le_trans. Qed. -Definition Zle_bool_total : - forall x y:Z, {Zle_bool x y = true} + {Zle_bool y x = true}. +Definition Zle_bool_total x y : + { x <=? y = true } + { y <=? x = true }. Proof. - intros x y; intros. unfold Zle_bool in |- *. cut ((x ?= y) = Gt <-> (y ?= x) = Lt). - case (x ?= y). left. reflexivity. - left. reflexivity. - right. rewrite (proj1 H (refl_equal _)). reflexivity. - apply Zcompare_Gt_Lt_antisym. + case_eq (x <=? y); intros H. + - left; trivial. + - right. apply Z.leb_gt in H. now apply Z.leb_le, Z.lt_le_incl. Defined. -Lemma Zle_bool_plus_mono : - forall n m p q:Z, - Zle_bool n m = true -> - Zle_bool p q = true -> Zle_bool (n + p) (m + q) = true. +Lemma Zle_bool_plus_mono n m p q : + (n <=? m) = true -> + (p <=? q) = true -> + (n + p <=? m + q) = true. Proof. - intros. apply Zle_imp_le_bool. apply Zplus_le_compat. apply Zle_bool_imp_le. assumption. - apply Zle_bool_imp_le. assumption. + rewrite !Z.leb_le. apply Z.add_le_mono. Qed. -Lemma Zone_pos : Zle_bool 1 0 = false. +Lemma Zone_pos : 1 <=? 0 = false. Proof. - reflexivity. + reflexivity. Qed. -Lemma Zone_min_pos : forall n:Z, Zle_bool n 0 = false -> Zle_bool 1 n = true. +Lemma Zone_min_pos n : (n <=? 0) = false -> (1 <=? n) = true. Proof. - intros x; intros. apply Zle_imp_le_bool. change (Zsucc 0 <= x) in |- *. apply Zgt_le_succ. generalize H. - unfold Zle_bool, Zgt in |- *. case (x ?= 0). intro H0. discriminate H0. - intro H0. discriminate H0. - reflexivity. + rewrite Z.leb_le, Z.leb_gt. apply Z.le_succ_l. Qed. (** Properties in term of [iff] *) -Lemma Zle_is_le_bool : forall n m:Z, (n <= m) <-> Zle_bool n m = true. +Lemma Zle_is_le_bool n m : (n <= m) <-> (n <=? m) = true. Proof. - intros. split. intro. apply Zle_imp_le_bool. assumption. - intro. apply Zle_bool_imp_le. assumption. + symmetry. apply Z.leb_le. Qed. -Lemma Zge_is_le_bool : forall n m:Z, (n >= m) <-> Zle_bool m n = true. +Lemma Zge_is_le_bool n m : (n >= m) <-> (m <=? n) = true. Proof. - intros. split. intro. apply Zle_imp_le_bool. apply Zge_le. assumption. - intro. apply Zle_ge. apply Zle_bool_imp_le. assumption. + Z.swap_greater. symmetry. apply Z.leb_le. Qed. -Lemma Zlt_is_lt_bool : forall n m:Z, (n < m) <-> Zlt_bool n m = true. +Lemma Zlt_is_lt_bool n m : (n < m) <-> (n <? m) = true. Proof. -intros n m; unfold Zlt_bool, Zlt. -destruct (n ?= m); simpl; split; now intro. + symmetry. apply Z.ltb_lt. Qed. -Lemma Zgt_is_gt_bool : forall n m:Z, (n > m) <-> Zgt_bool n m = true. +Lemma Zgt_is_gt_bool n m : (n > m) <-> (n >? m) = true. Proof. -intros n m; unfold Zgt_bool, Zgt. -destruct (n ?= m); simpl; split; now intro. + Z.swap_greater. rewrite Z.gtb_ltb. symmetry. apply Z.ltb_lt. Qed. -Lemma Zlt_is_le_bool : - forall n m:Z, (n < m) <-> Zle_bool n (m - 1) = true. +Lemma Zlt_is_le_bool n m : (n < m) <-> (n <=? m - 1) = true. Proof. - intros x y. split. intro. apply Zle_imp_le_bool. apply Zlt_succ_le. rewrite (Zsucc_pred y) in H. - assumption. - intro. rewrite (Zsucc_pred y). apply Zle_lt_succ. apply Zle_bool_imp_le. assumption. + rewrite Z.leb_le. apply Z.lt_le_pred. Qed. -Lemma Zgt_is_le_bool : - forall n m:Z, (n > m) <-> Zle_bool m (n - 1) = true. +Lemma Zgt_is_le_bool n m : (n > m) <-> (m <=? n - 1) = true. Proof. - intros x y. apply iff_trans with (y < x). split. exact (Zgt_lt x y). - exact (Zlt_gt y x). - exact (Zlt_is_le_bool y x). + Z.swap_greater. rewrite Z.leb_le. apply Z.lt_le_pred. Qed. -Lemma Zeq_is_eq_bool : forall x y, x = y <-> Zeq_bool x y = true. +(** Properties of the deprecated [Zeq_bool] *) + +Lemma Zeq_is_eq_bool x y : x = y <-> Zeq_bool x y = true. Proof. - intros; unfold Zeq_bool. - generalize (Zcompare_Eq_iff_eq x y); destruct Zcompare; intuition; - try discriminate. + unfold Zeq_bool. + rewrite <- Z.compare_eq_iff. destruct Z.compare; now split. Qed. -Lemma Zeq_bool_eq : forall x y, Zeq_bool x y = true -> x = y. +Lemma Zeq_bool_eq x y : Zeq_bool x y = true -> x = y. Proof. - intros x y H; apply <- Zeq_is_eq_bool; auto. + apply Zeq_is_eq_bool. Qed. -Lemma Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y. +Lemma Zeq_bool_neq x y : Zeq_bool x y = false -> x <> y. Proof. - unfold Zeq_bool; red ; intros; subst. - rewrite Zcompare_refl in H. - discriminate. + rewrite Zeq_is_eq_bool; now destruct Zeq_bool. Qed. -Lemma Zeq_bool_if : forall x y, if Zeq_bool x y then x=y else x<>y. +Lemma Zeq_bool_if x y : if Zeq_bool x y then x=y else x<>y. Proof. - intros. generalize (Zeq_bool_eq x y)(Zeq_bool_neq x y). - destruct Zeq_bool; auto. -Qed.
\ No newline at end of file + generalize (Zeq_bool_eq x y) (Zeq_bool_neq x y). + destruct Zeq_bool; auto. +Qed. diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index ae5302ee..20e1b006 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -1,387 +1,91 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $$ i*) +(** Binary Integers : results about Zcompare *) +(** Initial author: Pierre Crégut (CNET, Lannion, France *) -(**********************************************************************) -(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) -(**********************************************************************) +(** THIS FILE IS DEPRECATED. + It is now almost entirely made of compatibility formulations + for results already present in BinInt.Z. *) -Require Export BinPos. -Require Export BinInt. -Require Import Lt. -Require Import Gt. -Require Import Plus. -Require Import Mult. +Require Export BinPos BinInt. +Require Import Lt Gt Plus Mult. (* Useless now, for compatibility only *) -Open Local Scope Z_scope. +Local Open Scope Z_scope. (***************************) (** * Comparison on integers *) -Lemma Zcompare_refl : forall n:Z, (n ?= n) = Eq. -Proof. - intro x; destruct x as [| p| p]; simpl in |- *; - [ reflexivity | apply Pcompare_refl | rewrite Pcompare_refl; reflexivity ]. -Qed. - -Lemma Zcompare_Eq_eq : forall n m:Z, (n ?= m) = Eq -> n = m. -Proof. - intros x y; destruct x as [| x'| x']; destruct y as [| y'| y']; simpl in |- *; - intro H; reflexivity || (try discriminate H); - [ rewrite (Pcompare_Eq_eq x' y' H); reflexivity - | rewrite (Pcompare_Eq_eq x' y'); - [ reflexivity - | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ]. -Qed. - -Ltac destr_zcompare := - match goal with |- context [Zcompare ?x ?y] => - let H := fresh "H" in - case_eq (Zcompare x y); intro H; - [generalize (Zcompare_Eq_eq _ _ H); clear H; intro H | - change (x<y)%Z in H | - change (x>y)%Z in H ] - end. - -Lemma Zcompare_Eq_iff_eq : forall n m:Z, (n ?= m) = Eq <-> n = m. -Proof. - intros x y; split; intro E; - [ apply Zcompare_Eq_eq; assumption | rewrite E; apply Zcompare_refl ]. -Qed. - -Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n). -Proof. - intros x y; destruct x; destruct y; simpl in |- *; - reflexivity || discriminate H || rewrite Pcompare_antisym; - reflexivity. -Qed. - Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt. -Proof. - intros x y. - rewrite <- Zcompare_antisym. change Gt with (CompOpp Lt). - split. - auto using CompOpp_inj. - intros; f_equal; auto. -Qed. - -Lemma Zcompare_spec : forall n m, CompSpec eq Zlt n m (n ?= m). -Proof. - intros. - destruct (n?=m) as [ ]_eqn:H; constructor; auto. - apply Zcompare_Eq_eq; auto. - red; rewrite <- Zcompare_antisym, H; auto. -Qed. +Proof Z.gt_lt_iff. +Lemma Zcompare_antisym n m : CompOpp (n ?= m) = (m ?= n). +Proof eq_sym (Z.compare_antisym n m). (** * Transitivity of comparison *) Lemma Zcompare_Lt_trans : forall n m p:Z, (n ?= m) = Lt -> (m ?= p) = Lt -> (n ?= p) = Lt. -Proof. - intros x y z; case x; case y; case z; simpl; - try discriminate; auto with arith. - intros; eapply Plt_trans; eauto. - intros p q r; rewrite 3 Pcompare_antisym; simpl. - intros; eapply Plt_trans; eauto. -Qed. +Proof Z.lt_trans. Lemma Zcompare_Gt_trans : forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt. Proof. - intros n m p Hnm Hmp. - apply <- Zcompare_Gt_Lt_antisym. - apply -> Zcompare_Gt_Lt_antisym in Hnm. - apply -> Zcompare_Gt_Lt_antisym in Hmp. - eapply Zcompare_Lt_trans; eauto. + intros n m p. change (n > m -> m > p -> n > p). + Z.swap_greater. intros. now transitivity m. Qed. (** * Comparison and opposite *) -Lemma Zcompare_opp : forall n m:Z, (n ?= m) = (- m ?= - n). +Lemma Zcompare_opp n m : (n ?= m) = (- m ?= - n). Proof. - intros x y; case x; case y; simpl in |- *; auto with arith; intros; - rewrite <- ZC4; trivial with arith. + symmetry. apply Z.compare_opp. Qed. -Hint Local Resolve Pcompare_refl. - (** * Comparison first-order specification *) -Lemma Zcompare_Gt_spec : - forall n m:Z, (n ?= m) = Gt -> exists h : positive, n + - m = Zpos h. +Lemma Zcompare_Gt_spec n m : (n ?= m) = Gt -> exists h, n + - m = Zpos h. Proof. - intros x y; case x; case y; - [ simpl in |- *; intros H; discriminate H - | simpl in |- *; intros p H; discriminate H - | intros p H; exists p; simpl in |- *; auto with arith - | intros p H; exists p; simpl in |- *; auto with arith - | intros q p H; exists (p - q)%positive; unfold Zplus, Zopp in |- *; - unfold Zcompare in H; rewrite H; trivial with arith - | intros q p H; exists (p + q)%positive; simpl in |- *; trivial with arith - | simpl in |- *; intros p H; discriminate H - | simpl in |- *; intros q p H; discriminate H - | unfold Zcompare in |- *; intros q p; rewrite <- ZC4; intros H; - exists (q - p)%positive; simpl in |- *; rewrite (ZC1 q p H); - trivial with arith ]. + rewrite Z.compare_sub. unfold Z.sub. + destruct (n+-m) as [|p|p]; try discriminate. now exists p. Qed. (** * Comparison and addition *) -Lemma weaken_Zcompare_Zplus_compatible : - (forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m)) -> - forall n m p:Z, (p + n ?= p + m) = (n ?= m). +Lemma Zcompare_plus_compat n m p : (p + n ?= p + m) = (n ?= m). Proof. - intros H x y z; destruct z; - [ reflexivity - | apply H - | rewrite (Zcompare_opp x y); rewrite Zcompare_opp; - do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; - apply H ]. + apply Z.add_compare_mono_l. Qed. -Hint Local Resolve ZC4. - -Lemma weak_Zcompare_Zplus_compatible : - forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m). -Proof. - intros x y z; case x; case y; simpl in |- *; auto with arith; - [ intros p; apply nat_of_P_lt_Lt_compare_complement_morphism; apply ZL17 - | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith; - apply nat_of_P_gt_Gt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ unfold gt in |- *; apply ZL16 | assumption ] - | intros p; ElimPcompare z p; intros E; auto with arith; - apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; apply ZL17 - | intros p q; ElimPcompare q p; intros E; rewrite E; - [ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl - | apply nat_of_P_lt_Lt_compare_complement_morphism; - do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism with (1 := E) - | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *; - do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l; - exact (nat_of_P_gt_Gt_compare_morphism q p E) ] - | intros p q; ElimPcompare z p; intros E; rewrite E; auto with arith; - apply nat_of_P_gt_Gt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ unfold gt in |- *; apply lt_trans with (m := nat_of_P z); - [ apply ZL16 | apply ZL17 ] - | assumption ] - | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith; - simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; [ apply ZL16 | assumption ] - | intros p q; ElimPcompare z q; intros E; rewrite E; auto with arith; - simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ] - | assumption ] - | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p; - intros E1; rewrite E1; ElimPcompare q p; intros E2; - rewrite E2; auto with arith; - [ absurd ((q ?= p)%positive Eq = Lt); - [ rewrite <- (Pcompare_Eq_eq z q E0); - rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z); - discriminate - | assumption ] - | absurd ((q ?= p)%positive Eq = Gt); - [ rewrite <- (Pcompare_Eq_eq z q E0); - rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z); - discriminate - | assumption ] - | absurd ((z ?= p)%positive Eq = Lt); - [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2); - rewrite (Pcompare_refl q); discriminate - | assumption ] - | absurd ((z ?= p)%positive Eq = Lt); - [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate - | assumption ] - | absurd ((z ?= p)%positive Eq = Gt); - [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2); - rewrite (Pcompare_refl q); discriminate - | assumption ] - | absurd ((z ?= p)%positive Eq = Gt); - [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate - | assumption ] - | absurd ((z ?= q)%positive Eq = Lt); - [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2); - rewrite (Pcompare_refl p); discriminate - | assumption ] - | absurd ((p ?= q)%positive Eq = Gt); - [ rewrite <- (Pcompare_Eq_eq z p E1); rewrite E0; discriminate - | apply ZC2; assumption ] - | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); - rewrite (Pcompare_refl (p - z)); auto with arith - | simpl in |- *; rewrite <- ZC4; - apply nat_of_P_gt_Gt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z); - rewrite le_plus_minus_r; - [ rewrite le_plus_minus_r; - [ apply nat_of_P_lt_Lt_compare_morphism; assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - assumption ] - | apply ZC2; assumption ] - | apply ZC2; assumption ] - | simpl in |- *; rewrite <- ZC4; - apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ apply plus_lt_reg_l with (p := nat_of_P z); - rewrite le_plus_minus_r; - [ rewrite le_plus_minus_r; - [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; - assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - assumption ] - | apply ZC2; assumption ] - | apply ZC2; assumption ] - | absurd ((z ?= q)%positive Eq = Lt); - [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate - | assumption ] - | absurd ((q ?= p)%positive Eq = Lt); - [ cut ((q ?= p)%positive Eq = Gt); - [ intros E; rewrite E; discriminate - | apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; apply lt_trans with (m := nat_of_P z); - [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption - | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ] - | assumption ] - | absurd ((z ?= q)%positive Eq = Gt); - [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2); - rewrite (Pcompare_refl p); discriminate - | assumption ] - | absurd ((z ?= q)%positive Eq = Gt); - [ rewrite (Pcompare_Eq_eq z p E1); rewrite ZC1; - [ discriminate | assumption ] - | assumption ] - | absurd ((z ?= q)%positive Eq = Gt); - [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate - | assumption ] - | absurd ((q ?= p)%positive Eq = Gt); - [ rewrite ZC1; - [ discriminate - | apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; apply lt_trans with (m := nat_of_P z); - [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption - | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ] - | assumption ] - | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); apply Pcompare_refl - | simpl in |- *; apply nat_of_P_gt_Gt_compare_complement_morphism; - unfold gt in |- *; rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ apply plus_lt_reg_l with (p := nat_of_P p); - rewrite le_plus_minus_r; - [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q); - rewrite plus_assoc; rewrite le_plus_minus_r; - [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; - assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | assumption ] - | assumption ] - | simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism; - rewrite nat_of_P_minus_morphism; - [ rewrite nat_of_P_minus_morphism; - [ apply plus_lt_reg_l with (p := nat_of_P q); - rewrite le_plus_minus_r; - [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); - rewrite plus_assoc; rewrite le_plus_minus_r; - [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; - apply ZC1; assumption ] - | assumption ] - | assumption ] ] ]. -Qed. - -Lemma Zcompare_plus_compat : forall n m p:Z, (p + n ?= p + m) = (n ?= m). +Lemma Zplus_compare_compat (r:comparison) (n m p q:Z) : + (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r. Proof. - exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible). + rewrite (Z.compare_sub n), (Z.compare_sub p), (Z.compare_sub (n+p)). + unfold Z.sub. rewrite Z.opp_add_distr. rewrite Z.add_shuffle1. + destruct (n+-m), (p+-q); simpl; intros; now subst. Qed. -Lemma Zplus_compare_compat : - forall (r:comparison) (n m p q:Z), - (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r. +Lemma Zcompare_succ_Gt n : (Z.succ n ?= n) = Gt. Proof. - intros r x y z t; case r; - [ intros H1 H2; elim (Zcompare_Eq_iff_eq x y); elim (Zcompare_Eq_iff_eq z t); - intros H3 H4 H5 H6; rewrite H3; - [ rewrite H5; - [ elim (Zcompare_Eq_iff_eq (y + t) (y + t)); auto with arith - | auto with arith ] - | auto with arith ] - | intros H1 H2; elim (Zcompare_Gt_Lt_antisym (y + t) (x + z)); intros H3 H4; - apply H3; apply Zcompare_Gt_trans with (m := y + z); - [ rewrite Zcompare_plus_compat; elim (Zcompare_Gt_Lt_antisym t z); - auto with arith - | do 2 rewrite <- (Zplus_comm z); rewrite Zcompare_plus_compat; - elim (Zcompare_Gt_Lt_antisym y x); auto with arith ] - | intros H1 H2; apply Zcompare_Gt_trans with (m := x + t); - [ rewrite Zcompare_plus_compat; assumption - | do 2 rewrite <- (Zplus_comm t); rewrite Zcompare_plus_compat; - assumption ] ]. + apply Z.lt_gt. apply Z.lt_succ_diag_r. Qed. -Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt. +Lemma Zcompare_Gt_not_Lt n m : (n ?= m) = Gt <-> (n ?= m+1) <> Lt. Proof. - intro x; unfold Zsucc in |- *; pattern x at 2 in |- *; - rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; - reflexivity. -Qed. - -Lemma Zcompare_Gt_not_Lt : forall n m:Z, (n ?= m) = Gt <-> (n ?= m + 1) <> Lt. -Proof. - intros x y; split; - [ intro H; elim_compare x (y + 1); - [ intro H1; rewrite H1; discriminate - | intros H1; elim Zcompare_Gt_spec with (1 := H); intros h H2; - absurd ((nat_of_P h > 0)%nat /\ (nat_of_P h < 1)%nat); - [ unfold not in |- *; intros H3; elim H3; intros H4 H5; - absurd (nat_of_P h > 0)%nat; - [ unfold gt in |- *; apply le_not_lt; apply le_S_n; exact H5 - | assumption ] - | split; - [ elim (ZL4 h); intros i H3; rewrite H3; apply gt_Sn_O - | change (nat_of_P h < nat_of_P 1)%nat in |- *; - apply nat_of_P_lt_Lt_compare_morphism; - change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2; - rewrite <- (fun m n:Z => Zcompare_plus_compat m n y); - rewrite (Zplus_comm x); rewrite Zplus_assoc; - rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ] - | intros H1; rewrite H1; discriminate ] - | intros H; elim_compare x (y + 1); - [ intros H1; elim (Zcompare_Eq_iff_eq x (y + 1)); intros H2 H3; - rewrite (H2 H1); exact (Zcompare_succ_Gt y) - | intros H1; absurd ((x ?= y + 1) = Lt); assumption - | intros H1; apply Zcompare_Gt_trans with (m := Zsucc y); - [ exact H1 | exact (Zcompare_succ_Gt y) ] ] ]. + change (n > m <-> n >= m+1). Z.swap_greater. symmetry. apply Z.le_succ_l. Qed. (** * Successor and comparison *) -Lemma Zcompare_succ_compat : forall n m:Z, (Zsucc n ?= Zsucc m) = (n ?= m). +Lemma Zcompare_succ_compat n m : (Z.succ n ?= Z.succ m) = (n ?= m). Proof. - intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1); - rewrite Zcompare_plus_compat; auto with arith. + rewrite <- 2 Z.add_1_l. apply Zcompare_plus_compat. Qed. (** * Multiplication and comparison *) @@ -389,28 +93,24 @@ Qed. Lemma Zcompare_mult_compat : forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m). Proof. - intros x; induction x as [p H| p H| ]; - [ intros y z; cut (Zpos (xI p) = Zpos p + Zpos p + 1); - [ intros E; rewrite E; do 4 rewrite Zmult_plus_distr_l; - do 2 rewrite Zmult_1_l; apply Zplus_compare_compat; - [ apply Zplus_compare_compat; apply H | trivial with arith ] - | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ] - | intros y z; cut (Zpos (xO p) = Zpos p + Zpos p); - [ intros E; rewrite E; do 2 rewrite Zmult_plus_distr_l; - apply Zplus_compare_compat; apply H - | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ] - | intros y z; do 2 rewrite Zmult_1_l; trivial with arith ]. + intros p [|n|n] [|m|m]; simpl; trivial; now rewrite Pos.mul_compare_mono_l. Qed. +Lemma Zmult_compare_compat_l n m p: + p > 0 -> (n ?= m) = (p * n ?= p * m). +Proof. + intros; destruct p; try discriminate. + symmetry. apply Zcompare_mult_compat. +Qed. -(** * Reverting [x ?= y] to trichotomy *) - -Lemma rename : - forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x. +Lemma Zmult_compare_compat_r n m p : + p > 0 -> (n ?= m) = (n * p ?= m * p). Proof. - auto with arith. + intros; rewrite 2 (Zmult_comm _ p); now apply Zmult_compare_compat_l. Qed. +(** * Relating [x ?= y] to [=], [<=], [<], [>=] or [>] *) + Lemma Zcompare_elim : forall (c1 c2 c3:Prop) (n m:Z), (n = m -> c1) -> @@ -421,11 +121,7 @@ Lemma Zcompare_elim : | Gt => c3 end. Proof. - intros c1 c2 c3 x y; intros. - apply rename with (x := x ?= y); intro r; elim r; - [ intro; apply H; apply (Zcompare_Eq_eq x y); assumption - | unfold Zlt in H0; assumption - | unfold Zgt in H1; assumption ]. + intros. case Z.compare_spec; trivial. now Z.swap_greater. Qed. Lemma Zcompare_eq_case : @@ -436,26 +132,9 @@ Lemma Zcompare_eq_case : | Gt => c3 end. Proof. - intros c1 c2 c3 x y; intros. - rewrite H0; rewrite Zcompare_refl. - assumption. + intros. subst. now rewrite Z.compare_refl. Qed. -(** * Decompose an egality between two [?=] relations into 3 implications *) - -Lemma Zcompare_egal_dec : - forall n m p q:Z, - (n < m -> p < q) -> - ((n ?= m) = Eq -> (p ?= q) = Eq) -> - (n > m -> p > q) -> (n ?= m) = (p ?= q). -Proof. - intros x1 y1 x2 y2. - unfold Zgt in |- *; unfold Zlt in |- *; case (x1 ?= y1); case (x2 ?= y2); - auto with arith; symmetry in |- *; auto with arith. -Qed. - -(** * Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *) - Lemma Zle_compare : forall n m:Z, n <= m -> match n ?= m with @@ -464,7 +143,7 @@ Lemma Zle_compare : | Gt => False end. Proof. - intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith. + intros. case Z.compare_spec; trivial; Z.order. Qed. Lemma Zlt_compare : @@ -475,8 +154,7 @@ Lemma Zlt_compare : | Gt => False end. Proof. - intros x y; unfold Zlt in |- *; elim (x ?= y); intros; - discriminate || trivial with arith. + intros x y H; now rewrite H. Qed. Lemma Zge_compare : @@ -487,7 +165,7 @@ Lemma Zge_compare : | Gt => True end. Proof. - intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. + intros. now case Z.compare_spec. Qed. Lemma Zgt_compare : @@ -498,26 +176,23 @@ Lemma Zgt_compare : | Gt => True end. Proof. - intros x y; unfold Zgt in |- *; elim (x ?= y); intros; - discriminate || trivial with arith. + intros x y H; now rewrite H. Qed. -(*********************) -(** * Other properties *) +(** Compatibility notations *) -Lemma Zmult_compare_compat_l : - forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m). -Proof. - intros x y z H; destruct z. - discriminate H. - rewrite Zcompare_mult_compat; reflexivity. - discriminate H. -Qed. - -Lemma Zmult_compare_compat_r : - forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p). -Proof. - intros x y z H; rewrite (Zmult_comm x z); rewrite (Zmult_comm y z); - apply Zmult_compare_compat_l; assumption. -Qed. +Notation Zcompare_refl := Z.compare_refl (only parsing). +Notation Zcompare_Eq_eq := Z.compare_eq (only parsing). +Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (only parsing). +Notation Zcompare_spec := Z.compare_spec (only parsing). +Notation Zmin_l := Z.min_l (only parsing). +Notation Zmin_r := Z.min_r (only parsing). +Notation Zmax_l := Z.max_l (only parsing). +Notation Zmax_r := Z.max_r (only parsing). +Notation Zabs_eq := Z.abs_eq (only parsing). +Notation Zabs_non_eq := Z.abs_neq (only parsing). +Notation Zsgn_0 := Z.sgn_null (only parsing). +Notation Zsgn_1 := Z.sgn_pos (only parsing). +Notation Zsgn_m1 := Z.sgn_neg (only parsing). +(** Not kept: Zcompare_egal_dec *) diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index ca72f8a8..5a2c3cc3 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zcomplements.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import ZArithRing. Require Import ZArith_base. Require Export Omega. @@ -18,29 +16,7 @@ Open Local Scope Z_scope. (**********************************************************************) (** About parity *) -Lemma two_or_two_plus_one : - forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. -Proof. - intro x; destruct x. - left; split with 0; reflexivity. - - destruct p. - right; split with (Zpos p); reflexivity. - - left; split with (Zpos p); reflexivity. - - right; split with 0; reflexivity. - - destruct p. - right; split with (Zneg (1 + p)). - rewrite BinInt.Zneg_xI. - rewrite BinInt.Zneg_plus_distr. - omega. - - left; split with (Zneg p); reflexivity. - - right; split with (-1); reflexivity. -Qed. +Notation two_or_two_plus_one := Z_modulo_2 (only parsing). (**********************************************************************) (** The biggest power of 2 that is stricly less than [a] @@ -58,31 +34,14 @@ Fixpoint floor_pos (a:positive) : positive := Definition floor (a:positive) := Zpos (floor_pos a). Lemma floor_gt0 : forall p:positive, floor p > 0. -Proof. - intro. - compute in |- *. - trivial. -Qed. +Proof. reflexivity. Qed. Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. - unfold floor in |- *. - intro a; induction a as [p| p| ]. - - simpl in |- *. - repeat rewrite BinInt.Zpos_xI. - rewrite (BinInt.Zpos_xO (xO (floor_pos p))). - rewrite (BinInt.Zpos_xO (floor_pos p)). - omega. - - simpl in |- *. - repeat rewrite BinInt.Zpos_xI. - rewrite (BinInt.Zpos_xO (xO (floor_pos p))). - rewrite (BinInt.Zpos_xO (floor_pos p)). - rewrite (BinInt.Zpos_xO p). - omega. - - simpl in |- *; omega. + unfold floor. induction p; simpl. + - rewrite !Z.pos_xI, (Z.pos_xO (xO _)), Z.pos_xO. omega. + - rewrite (Z.pos_xO (xO _)), (Z.pos_xO p), Z.pos_xO. omega. + - omega. Qed. (**********************************************************************) @@ -90,41 +49,39 @@ Qed. Theorem Z_lt_abs_rec : forall P:Z -> Set, - (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) -> + (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) -> forall n:Z, P n. Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z * P (- z)) in *. - cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. + cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ]. elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. unfold Q in |- *; clear Q; intros. - apply pair; apply HP. - rewrite Zabs_eq; auto; intros. - elim (H (Zabs m)); intros; auto with zarith. + split; apply HP. + rewrite Z.abs_eq; auto; intros. + elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. - rewrite Zabs_non_eq; auto with zarith. - rewrite Zopp_involutive; intros. - elim (H (Zabs m)); intros; auto with zarith. + rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. + elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. Theorem Z_lt_abs_induction : forall P:Z -> Prop, - (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) -> + (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) -> forall n:Z, P n. Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *. - cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ]. + cut (Q (Z.abs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ]. elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith. unfold Q in |- *; clear Q; intros. split; apply HP. - rewrite Zabs_eq; auto; intros. - elim (H (Zabs m)); intros; auto with zarith. + rewrite Z.abs_eq; auto; intros. + elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. - rewrite Zabs_non_eq; auto with zarith. - rewrite Zopp_involutive; intros. - elim (H (Zabs m)); intros; auto with zarith. + rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. + elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. @@ -134,25 +91,12 @@ Lemma Zcase_sign : forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P. Proof. intros x P Hzero Hpos Hneg. - induction x as [| p| p]. - apply Hzero; trivial. - apply Hpos; apply Zorder.Zgt_pos_0. - apply Hneg; apply Zorder.Zlt_neg_0. + destruct x; [apply Hzero|apply Hpos|apply Hneg]; easy. Qed. -Lemma sqr_pos : forall n:Z, n * n >= 0. +Lemma sqr_pos n : n * n >= 0. Proof. - intro x. - apply (Zcase_sign x (x * x >= 0)). - intros H; rewrite H; omega. - intros H; replace 0 with (0 * 0). - apply Zmult_ge_compat; omega. - omega. - intros H; replace 0 with (0 * 0). - replace (x * x) with (- x * - x). - apply Zmult_ge_compat; omega. - ring. - omega. + Z.swap_greater. apply Z.square_nonneg. Qed. (**********************************************************************) @@ -167,7 +111,7 @@ Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z := end. Definition Zlength := Zlength_aux 0. -Implicit Arguments Zlength [A]. +Arguments Zlength [A] l. Section Zlength_properties. @@ -175,38 +119,33 @@ Section Zlength_properties. Implicit Type l : list A. - Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l). + Lemma Zlength_correct l : Zlength l = Z.of_nat (length l). Proof. - assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). - simple induction l. - simpl in |- *; auto with zarith. - intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S. - simpl in |- *; rewrite H; auto with zarith. - unfold Zlength in |- *; intros; rewrite H; auto. + assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)). + clear l. induction l. + auto with zarith. + intros. simpl length; simpl Zlength_aux. + rewrite IHl, Nat2Z.inj_succ; auto with zarith. + unfold Zlength. now rewrite H. Qed. Lemma Zlength_nil : Zlength (A:=A) nil = 0. - Proof. - auto. - Qed. + Proof. reflexivity. Qed. - Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l). + Lemma Zlength_cons (x:A) l : Zlength (x :: l) = Z.succ (Zlength l). Proof. - intros; do 2 rewrite Zlength_correct. - simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto. + intros. now rewrite !Zlength_correct, <- Nat2Z.inj_succ. Qed. - Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil. + Lemma Zlength_nil_inv l : Zlength l = 0 -> l = nil. Proof. - intro l; rewrite Zlength_correct. - case l; auto. - intros x l'; simpl (length (x :: l')) in |- *. - rewrite Znat.inj_S. - intros; exfalso; generalize (Zle_0_nat (length l')); omega. + rewrite Zlength_correct. + destruct l as [|x l]; auto. + now rewrite <- Nat2Z.inj_0, Nat2Z.inj_iff. Qed. End Zlength_properties. -Implicit Arguments Zlength_correct [A]. -Implicit Arguments Zlength_cons [A]. -Implicit Arguments Zlength_nil_inv [A]. +Arguments Zlength_correct [A] l. +Arguments Zlength_cons [A] x l. +Arguments Zlength_nil_inv [A] l _. diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v index c43b241d..ff1d96df 100644 --- a/theories/ZArith/Zdigits.v +++ b/theories/ZArith/Zdigits.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zdigits.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Bit vectors interpreted as integers. Contribution by Jean Duprat (ENS Lyon). *) @@ -47,17 +45,17 @@ Section VALUE_OF_BOOLEAN_VECTORS. exact 0%Z. inversion H0. - exact (bit_value a + 2 * H H2)%Z. + exact (bit_value h + 2 * H H2)%Z. Defined. Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z. Proof. simple induction n; intros. inversion H. - exact (- bit_value a)%Z. + exact (- bit_value h)%Z. inversion H0. - exact (bit_value a + 2 * H H2)%Z. + exact (bit_value h + 2 * H H2)%Z. Defined. End VALUE_OF_BOOLEAN_VECTORS. @@ -136,7 +134,7 @@ Section Z_BRIC_A_BRAC. Lemma binary_value_Sn : forall (n:nat) (b:bool) (bv:Bvector n), - binary_value (S n) (Vcons bool b n bv) = + binary_value (S n) ( b :: bv) = (bit_value b + 2 * binary_value n bv)%Z. Proof. intros; auto. @@ -221,7 +219,7 @@ Section Z_BRIC_A_BRAC. destruct (Zeven.Zeven_odd_dec z); intros. rewrite <- Zeven.Zeven_div2; auto. - generalize (Zeven.Zodd_div2 z H z0); omega. + generalize (Zeven.Zodd_div2 z z0); omega. Qed. Lemma Z_to_two_compl_Sn_z : diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index df22371e..314f696a 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -1,200 +1,57 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zdiv.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(** * Euclidean Division *) -(* Contribution by Claude Marché and Xavier Urbain *) - -(** Euclidean Division - - Defines first of function that allows Coq to normalize. - Then only after proves the main required property. -*) +(** Initial Contribution by Claude Marché and Xavier Urbain *) Require Export ZArith_base. -Require Import Zbool. -Require Import Omega. -Require Import ZArithRing. -Require Import Zcomplements. -Require Export Setoid. -Open Local Scope Z_scope. - -(** * Definitions of Euclidian operations *) - -(** Euclidean division of a positive by a integer - (that is supposed to be positive). - - Total function than returns an arbitrary value when - divisor is not positive - -*) - -Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) : Z * Z := - match a with - | xH => if Zge_bool b 2 then (0, 1) else (1, 0) - | xO a' => - let (q, r) := Zdiv_eucl_POS a' b in - let r' := 2 * r in - if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b) - | xI a' => - let (q, r) := Zdiv_eucl_POS a' b in - let r' := 2 * r + 1 in - if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b) - end. - - -(** Euclidean division of integers. - - Total function than returns (0,0) when dividing by 0. -*) - -(** - - The pseudo-code is: - - if b = 0 : (0,0) - - if b <> 0 and a = 0 : (0,0) - - if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in - if r = 0 then (-q,0) else (-(q+1),b-r) - - if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r) - - if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in - if r = 0 then (-q,0) else (-(q+1),b+r) - - In other word, when b is non-zero, q is chosen to be the greatest integer - smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when - r is not null). -*) +Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms. +Local Open Scope Z_scope. -(* Nota: At least two others conventions also exist for euclidean division. - They all satify the equation a=b*q+r, but differ on the choice of (q,r) - on negative numbers. +(** The definition of the division is now in [BinIntDef], the initial + specifications and properties are in [BinInt]. *) - * Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). - Hence (-a) mod b = - (a mod b) - a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). +Notation Zdiv_eucl_POS := Z.pos_div_eucl (only parsing). +Notation Zdiv_eucl := Z.div_eucl (only parsing). +Notation Zdiv := Z.div (only parsing). +Notation Zmod := Z.modulo (only parsing). - * Another solution is to always pick a non-negative remainder: - a=b*q+r with 0 <= r < |b| -*) - -Definition Zdiv_eucl (a b:Z) : Z * Z := - match a, b with - | Z0, _ => (0, 0) - | _, Z0 => (0, 0) - | Zpos a', Zpos _ => Zdiv_eucl_POS a' b - | Zneg a', Zpos _ => - let (q, r) := Zdiv_eucl_POS a' b in - match r with - | Z0 => (- q, 0) - | _ => (- (q + 1), b - r) - end - | Zneg a', Zneg b' => let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r) - | Zpos a', Zneg b' => - let (q, r) := Zdiv_eucl_POS a' (Zpos b') in - match r with - | Z0 => (- q, 0) - | _ => (- (q + 1), b + r) - end - end. - - -(** Division and modulo are projections of [Zdiv_eucl] *) - -Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q. - -Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. - -(** Syntax *) - -Infix "/" := Zdiv : Z_scope. -Infix "mod" := Zmod (at level 40, no associativity) : Z_scope. - -(* Tests: - -Eval compute in (Zdiv_eucl 7 3). - -Eval compute in (Zdiv_eucl (-7) 3). +Notation Zdiv_eucl_eq := Z.div_eucl_eq (only parsing). +Notation Z_div_mod_eq_full := Z.div_mod (only parsing). +Notation Zmod_POS_bound := Z.pos_div_eucl_bound (only parsing). +Notation Zmod_pos_bound := Z.mod_pos_bound (only parsing). +Notation Zmod_neg_bound := Z.mod_neg_bound (only parsing). -Eval compute in (Zdiv_eucl 7 (-3)). +(** * Main division theorems *) -Eval compute in (Zdiv_eucl (-7) (-3)). - -*) - - -(** * Main division theorem *) - -(** First a lemma for two positive arguments *) +(** NB: many things are stated twice for compatibility reasons *) Lemma Z_div_mod_POS : forall b:Z, b > 0 -> forall a:positive, - let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b. + let (q, r) := Z.pos_div_eucl a b in Zpos a = b * q + r /\ 0 <= r < b. Proof. -simple induction a; cbv beta iota delta [Zdiv_eucl_POS] in |- *; - fold Zdiv_eucl_POS in |- *; cbv zeta. - -intro p; case (Zdiv_eucl_POS p b); intros q r [H0 H1]. -generalize (Zgt_cases b (2 * r + 1)). -case (Zgt_bool b (2 * r + 1)); - (rewrite BinInt.Zpos_xI; rewrite H0; split; [ ring | omega ]). - -intros p; case (Zdiv_eucl_POS p b); intros q r [H0 H1]. -generalize (Zgt_cases b (2 * r)). -case (Zgt_bool b (2 * r)); rewrite BinInt.Zpos_xO; - change (Zpos (xO p)) with (2 * Zpos p) in |- *; rewrite H0; - (split; [ ring | omega ]). - -generalize (Zge_cases b 2). -case (Zge_bool b 2); (intros; split; [ try ring | omega ]). -omega. + intros b Hb a. Z.swap_greater. + generalize (Z.pos_div_eucl_eq a b Hb) (Z.pos_div_eucl_bound a b Hb). + destruct Z.pos_div_eucl. rewrite Z.mul_comm. auto. Qed. -(** Then the usual situation of a positive [b] and no restriction on [a] *) - -Theorem Z_div_mod : - forall a b:Z, - b > 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ 0 <= r < b. +Theorem Z_div_mod a b : + b > 0 -> + let (q, r) := Z.div_eucl a b in a = b * q + r /\ 0 <= r < b. Proof. - intros a b; case a; case b; try (simpl in |- *; intros; omega). - unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial. - - intros; discriminate. - - intros. - generalize (Z_div_mod_POS (Zpos p) H p0). - unfold Zdiv_eucl in |- *. - case (Zdiv_eucl_POS p0 (Zpos p)). - intros z z0. - case z0. - - intros [H1 H2]. - split; trivial. - change (Zneg p0) with (- Zpos p0); rewrite H1; ring. - - intros p1 [H1 H2]. - split; trivial. - change (Zneg p0) with (- Zpos p0); rewrite H1; ring. - generalize (Zorder.Zgt_pos_0 p1); omega. - - intros p1 [H1 H2]. - split; trivial. - change (Zneg p0) with (- Zpos p0); rewrite H1; ring. - generalize (Zorder.Zlt_neg_0 p1); omega. - - intros; discriminate. + Z.swap_greater. intros Hb. + assert (Hb' : b<>0) by (now destruct b). + generalize (Z.div_eucl_eq a b Hb') (Z.mod_pos_bound a b Hb). + unfold Z.modulo. destruct Z.div_eucl. auto. Qed. (** For stating the fully general result, let's give a short name @@ -204,7 +61,7 @@ Definition Remainder r b := 0 <= r < b \/ b < r <= 0. (** Another equivalent formulation: *) -Definition Remainder_alt r b := Zabs r < Zabs b /\ Zsgn r <> - Zsgn b. +Definition Remainder_alt r b := Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b. (* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying [ Zsgn r = Zsgn b ], but at least it works even when [r] is null. *) @@ -218,90 +75,44 @@ Hint Unfold Remainder. (** Now comes the fully general result about Euclidean division. *) -Theorem Z_div_mod_full : - forall a b:Z, - b <> 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ Remainder r b. +Theorem Z_div_mod_full a b : + b <> 0 -> + let (q, r) := Z.div_eucl a b in a = b * q + r /\ Remainder r b. Proof. - destruct b as [|b|b]. - (* b = 0 *) - intro H; elim H; auto. - (* b > 0 *) - intros _. - assert (Zpos b > 0) by auto with zarith. - generalize (Z_div_mod a (Zpos b) H). - destruct Zdiv_eucl as (q,r); intuition; simpl; auto. - (* b < 0 *) - intros _. - assert (Zpos b > 0) by auto with zarith. - generalize (Z_div_mod a (Zpos b) H). - unfold Remainder. - destruct a as [|a|a]. - (* a = 0 *) - simpl; intuition. - (* a > 0 *) - unfold Zdiv_eucl; destruct Zdiv_eucl_POS as (q,r). - destruct r as [|r|r]; [ | | omega with *]. - rewrite <- Zmult_opp_comm; simpl Zopp; intuition. - rewrite <- Zmult_opp_comm; simpl Zopp. - rewrite Zmult_plus_distr_r; omega with *. - (* a < 0 *) - unfold Zdiv_eucl. - generalize (Z_div_mod_POS (Zpos b) H a). - destruct Zdiv_eucl_POS as (q,r). - destruct r as [|r|r]; change (Zneg b) with (-Zpos b). - rewrite Zmult_opp_comm; omega with *. - rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; - repeat rewrite Zmult_opp_comm; omega. - rewrite Zmult_opp_comm; omega with *. + intros Hb. + generalize (Z.div_eucl_eq a b Hb) + (Z.mod_pos_bound a b) (Z.mod_neg_bound a b). + unfold Z.modulo. destruct Z.div_eucl as (q,r). + intros EQ POS NEG. + split; auto. + red; destruct b. + now destruct Hb. left; now apply POS. right; now apply NEG. Qed. (** The same results as before, stated separately in terms of Zdiv and Zmod *) -Lemma Z_mod_remainder : forall a b:Z, b<>0 -> Remainder (a mod b) b. -Proof. - unfold Zmod; intros a b Hb; generalize (Z_div_mod_full a b Hb); auto. - destruct Zdiv_eucl; tauto. -Qed. - -Lemma Z_mod_lt : forall a b:Z, b > 0 -> 0 <= a mod b < b. +Lemma Z_mod_remainder a b : b<>0 -> Remainder (a mod b) b. Proof. - unfold Zmod; intros a b Hb; generalize (Z_div_mod a b Hb). - destruct Zdiv_eucl; tauto. + unfold Z.modulo; intros Hb; generalize (Z_div_mod_full a b Hb); auto. + destruct Z.div_eucl; tauto. Qed. -Lemma Z_mod_neg : forall a b:Z, b < 0 -> b < a mod b <= 0. -Proof. - unfold Zmod; intros a b Hb. - assert (Hb' : b<>0) by (auto with zarith). - generalize (Z_div_mod_full a b Hb'). - destruct Zdiv_eucl. - unfold Remainder; intuition. -Qed. +Lemma Z_mod_lt a b : b > 0 -> 0 <= a mod b < b. +Proof (fun Hb => Z.mod_pos_bound a b (Zgt_lt _ _ Hb)). -Lemma Z_div_mod_eq_full : forall a b:Z, b <> 0 -> a = b*(a/b) + (a mod b). -Proof. - unfold Zdiv, Zmod; intros a b Hb; generalize (Z_div_mod_full a b Hb). - destruct Zdiv_eucl; tauto. -Qed. +Lemma Z_mod_neg a b : b < 0 -> b < a mod b <= 0. +Proof (Z.mod_neg_bound a b). -Lemma Z_div_mod_eq : forall a b:Z, b > 0 -> a = b*(a/b) + (a mod b). +Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b). Proof. - intros; apply Z_div_mod_eq_full; auto with zarith. + intros Hb; apply Z.div_mod; auto with zarith. Qed. -Lemma Zmod_eq_full : forall a b:Z, b<>0 -> a mod b = a - (a/b)*b. -Proof. - intros. - rewrite <- Zeq_plus_swap, Zplus_comm, Zmult_comm; symmetry. - apply Z_div_mod_eq_full; auto. -Qed. +Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b. +Proof. intros. rewrite Z.mul_comm. now apply Z.mod_eq. Qed. -Lemma Zmod_eq : forall a b:Z, b>0 -> a mod b = a - (a/b)*b. -Proof. - intros. - rewrite <- Zeq_plus_swap, Zplus_comm, Zmult_comm; symmetry. - apply Z_div_mod_eq; auto. -Qed. +Lemma Zmod_eq a b : b>0 -> a mod b = a - (a/b)*b. +Proof. intros. apply Zmod_eq_full. now destruct b. Qed. (** Existence theorem *) @@ -309,89 +120,51 @@ Theorem Zdiv_eucl_exist : forall (b:Z)(Hb:b>0)(a:Z), {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}. Proof. intros b Hb a. - exists (Zdiv_eucl a b). + exists (Z.div_eucl a b). exact (Z_div_mod a b Hb). Qed. -Implicit Arguments Zdiv_eucl_exist. +Arguments Zdiv_eucl_exist : default implicits. (** Uniqueness theorems *) -Theorem Zdiv_mod_unique : - forall b q1 q2 r1 r2:Z, - 0 <= r1 < Zabs b -> 0 <= r2 < Zabs b -> +Theorem Zdiv_mod_unique b q1 q2 r1 r2 : + 0 <= r1 < Z.abs b -> 0 <= r2 < Z.abs b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. Proof. -intros b q1 q2 r1 r2 Hr1 Hr2 H. -destruct (Z_eq_dec q1 q2) as [Hq|Hq]. +intros Hr1 Hr2 H. rewrite <- (Z.abs_sgn b), <- !Z.mul_assoc in H. +destruct (Z.div_mod_unique (Z.abs b) (Z.sgn b * q1) (Z.sgn b * q2) r1 r2); auto. split; trivial. -rewrite Hq in H; omega. -elim (Zlt_not_le (Zabs (r2 - r1)) (Zabs b)). -omega with *. -replace (r2-r1) with (b*(q1-q2)) by (rewrite Zmult_minus_distr_l; omega). -replace (Zabs b) with ((Zabs b)*1) by ring. -rewrite Zabs_Zmult. -apply Zmult_le_compat_l; auto with *. -omega with *. +apply Z.mul_cancel_l with (Z.sgn b); trivial. +rewrite Z.sgn_null_iff, <- Z.abs_0_iff. destruct Hr1; Z.order. Qed. Theorem Zdiv_mod_unique_2 : forall b q1 q2 r1 r2:Z, Remainder r1 b -> Remainder r2 b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. -Proof. -unfold Remainder. -intros b q1 q2 r1 r2 Hr1 Hr2 H. -destruct (Z_eq_dec q1 q2) as [Hq|Hq]. -split; trivial. -rewrite Hq in H; omega. -elim (Zlt_not_le (Zabs (r2 - r1)) (Zabs b)). -omega with *. -replace (r2-r1) with (b*(q1-q2)) by (rewrite Zmult_minus_distr_l; omega). -replace (Zabs b) with ((Zabs b)*1) by ring. -rewrite Zabs_Zmult. -apply Zmult_le_compat_l; auto with *. -omega with *. -Qed. +Proof Z.div_mod_unique. Theorem Zdiv_unique_full: forall a b q r, Remainder r b -> a = b*q + r -> q = a/b. -Proof. - intros. - assert (b <> 0) by (unfold Remainder in *; omega with *). - generalize (Z_div_mod_full a b H1). - unfold Zdiv; destruct Zdiv_eucl as (q',r'). - intros (H2,H3); rewrite H2 in H0. - destruct (Zdiv_mod_unique_2 b q q' r r'); auto. -Qed. +Proof Z.div_unique. Theorem Zdiv_unique: forall a b q r, 0 <= r < b -> a = b*q + r -> q = a/b. -Proof. - intros; eapply Zdiv_unique_full; eauto. -Qed. +Proof. intros; eapply Zdiv_unique_full; eauto. Qed. Theorem Zmod_unique_full: forall a b q r, Remainder r b -> a = b*q + r -> r = a mod b. -Proof. - intros. - assert (b <> 0) by (unfold Remainder in *; omega with *). - generalize (Z_div_mod_full a b H1). - unfold Zmod; destruct Zdiv_eucl as (q',r'). - intros (H2,H3); rewrite H2 in H0. - destruct (Zdiv_mod_unique_2 b q q' r r'); auto. -Qed. +Proof Z.mod_unique. Theorem Zmod_unique: forall a b q r, 0 <= r < b -> a = b*q + r -> r = a mod b. -Proof. - intros; eapply Zmod_unique_full; eauto. -Qed. +Proof. intros; eapply Zmod_unique_full; eauto. Qed. (** * Basic values of divisions and modulo. *) @@ -415,70 +188,44 @@ Proof. destruct a; simpl; auto. Qed. +Ltac zero_or_not a := + destruct (Z.eq_dec a 0); + [subst; rewrite ?Zmod_0_l, ?Zdiv_0_l, ?Zmod_0_r, ?Zdiv_0_r; + auto with zarith|]. + Lemma Zmod_1_r: forall a, a mod 1 = 0. -Proof. - intros; symmetry; apply Zmod_unique with a; auto with zarith. -Qed. +Proof. intros. zero_or_not a. apply Z.mod_1_r. Qed. Lemma Zdiv_1_r: forall a, a/1 = a. -Proof. - intros; symmetry; apply Zdiv_unique with 0; auto with zarith. -Qed. +Proof. intros. zero_or_not a. apply Z.div_1_r. Qed. Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0. -Proof. - intros; symmetry; apply Zdiv_unique with 1; auto with zarith. -Qed. +Proof Z.div_1_l. Lemma Zmod_1_l: forall a, 1 < a -> 1 mod a = 1. -Proof. - intros; symmetry; apply Zmod_unique with 0; auto with zarith. -Qed. +Proof Z.mod_1_l. Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1. -Proof. - intros; symmetry; apply Zdiv_unique_full with 0; auto with *; red; omega. -Qed. +Proof Z.div_same. Lemma Z_mod_same_full : forall a, a mod a = 0. -Proof. - destruct a; intros; symmetry. - compute; auto. - apply Zmod_unique with 1; auto with *; omega with *. - apply Zmod_unique_full with 1; auto with *; red; omega with *. -Qed. +Proof. intros. zero_or_not a. apply Z.mod_same; auto. Qed. Lemma Z_mod_mult : forall a b, (a*b) mod b = 0. -Proof. - intros a b; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; simpl; rewrite Zmod_0_r; auto. - symmetry; apply Zmod_unique_full with a; [ red; omega | ring ]. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_mul. auto. Qed. Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a. -Proof. - intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; - [ red; omega | ring]. -Qed. +Proof Z.div_mul. (** * Order results about Zmod and Zdiv *) (* Division of positive numbers is positive. *) Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b. -Proof. - intros. - rewrite (Z_div_mod_eq a b H) in H0. - assert (H1:=Z_mod_lt a b H). - destruct (Z_lt_le_dec (a/b) 0); auto. - assert (b*(a/b) <= -b). - replace (-b) with (b*-1); [ | ring]. - apply Zmult_le_compat_l; auto with zarith. - omega. -Qed. +Proof. intros. apply Z.div_pos; auto with zarith. Qed. Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0. Proof. @@ -489,366 +236,165 @@ Qed. the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. -Proof. - intros. cut (b > 0); [ intro Hb | omega ]. - generalize (Z_div_mod a b Hb). - cut (a >= 0); [ intro Ha | omega ]. - generalize (Z_div_ge0 a b Hb Ha). - unfold Zdiv in |- *; case (Zdiv_eucl a b); intros q r H1 [H2 H3]. - cut (a >= 2 * q -> q < a); [ intro h; apply h; clear h | intros; omega ]. - apply Zge_trans with (b * q). - omega. - auto with zarith. -Qed. - +Proof. intros. apply Z.div_lt; auto with zarith. Qed. (** A division of a small number by a bigger one yields zero. *) Theorem Zdiv_small: forall a b, 0 <= a < b -> a/b = 0. -Proof. - intros a b H; apply sym_equal; apply Zdiv_unique with a; auto with zarith. -Qed. +Proof Z.div_small. (** Same situation, in term of modulo: *) Theorem Zmod_small: forall a n, 0 <= a < n -> a mod n = a. -Proof. - intros a b H; apply sym_equal; apply Zmod_unique with 0; auto with zarith. -Qed. +Proof Z.mod_small. (** [Zge] is compatible with a positive division. *) Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c. -Proof. - intros a b c cPos aGeb. - generalize (Z_div_mod_eq a c cPos). - generalize (Z_mod_lt a c cPos). - generalize (Z_div_mod_eq b c cPos). - generalize (Z_mod_lt b c cPos). - intros. - elim (Z_ge_lt_dec (a / c) (b / c)); trivial. - intro. - absurd (b - a >= 1). - omega. - replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by - (symmetry; pattern a at 1; rewrite H2; pattern b at 1; rewrite H0; ring). - assert (c * (b / c - a / c) >= c * 1). - apply Zmult_ge_compat_l. - omega. - omega. - assert (c * 1 = c). - ring. - omega. -Qed. +Proof. intros. apply Zle_ge. apply Z.div_le_mono; auto with zarith. Qed. (** Same, with [Zle]. *) Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c. -Proof. - intros a b c H H0. - apply Zge_le. - apply Z_div_ge; auto with *. -Qed. +Proof. intros. apply Z.div_le_mono; auto with zarith. Qed. (** With our choice of division, rounding of (a/b) is always done toward bottom: *) Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a. -Proof. - intros a b H; generalize (Z_div_mod_eq a b H) (Z_mod_lt a b H); omega. -Qed. +Proof. intros. apply Z.mul_div_le; auto with zarith. Qed. Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a. -Proof. - intros a b H. - generalize (Z_div_mod_eq_full a _ (Zlt_not_eq _ _ H)) (Z_mod_neg a _ H); omega. -Qed. +Proof. intros. apply Zle_ge. apply Z.mul_div_ge; auto with zarith. Qed. (** The previous inequalities are exact iff the modulo is zero. *) Lemma Z_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0. -Proof. - intros; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst b; simpl in *; subst; auto. - generalize (Z_div_mod_eq_full a b Hb); omega. -Qed. +Proof. intros a b. zero_or_not b. rewrite Z.div_exact; auto. Qed. Lemma Z_div_exact_full_2 : forall a b:Z, b <> 0 -> a mod b = 0 -> a = b*(a/b). -Proof. - intros; generalize (Z_div_mod_eq_full a b H); omega. -Qed. +Proof. intros; rewrite Z.div_exact; auto. Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. -Proof. - intros a b H1 H2; case (Zle_or_lt b a); intros H3. - case (Z_mod_lt a b); auto with zarith. - rewrite Zmod_small; auto with zarith. -Qed. +Proof. intros. apply Z.mod_le; auto. Qed. (** Some additionnal inequalities about Zdiv. *) Theorem Zdiv_lt_upper_bound: forall a b q, 0 < b -> a < q*b -> a/b < q. -Proof. - intros a b q H1 H2. - apply Zmult_lt_reg_r with b; auto with zarith. - apply Zle_lt_trans with (2 := H2). - pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith. - rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. -Qed. +Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_lt_upper_bound. Qed. Theorem Zdiv_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a/b <= q. -Proof. - intros. - rewrite <- (Z_div_mult_full q b); auto with zarith. - apply Z_div_le; auto with zarith. -Qed. +Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_upper_bound. Qed. Theorem Zdiv_le_lower_bound: forall a b q, 0 < b -> q*b <= a -> q <= a/b. -Proof. - intros. - rewrite <- (Z_div_mult_full q b); auto with zarith. - apply Z_div_le; auto with zarith. -Qed. +Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed. (** A division of respect opposite monotonicity for the divisor *) Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. -Proof. - intros p q r H H1. - apply Zdiv_le_lower_bound; auto with zarith. - rewrite Zmult_comm. - pattern p at 2; rewrite (Z_div_mod_eq p r); auto with zarith. - apply Zle_trans with (r * (p / r)); auto with zarith. - apply Zmult_le_compat_r; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - case (Z_mod_lt p r); auto with zarith. -Qed. +Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed. Theorem Zdiv_sgn: forall a b, - 0 <= Zsgn (a/b) * Zsgn a * Zsgn b. + 0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b. Proof. destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; - generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; - destruct Zdiv_eucl_POS as (q,r); destruct r; omega with *. + generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl; + destruct Z.pos_div_eucl as (q,r); destruct r; omega with *. Qed. (** * Relations between usual operations and Zmod and Zdiv *) Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c. -Proof. - intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. - subst; do 2 rewrite Zmod_0_r; auto. - symmetry; apply Zmod_unique_full with (a/c+b); auto with zarith. - red; generalize (Z_mod_lt a c)(Z_mod_neg a c); omega. - rewrite Zmult_plus_distr_r, Zmult_comm. - generalize (Z_div_mod_eq_full a c Hc); omega. -Qed. +Proof. intros. zero_or_not c. apply Z.mod_add; auto. Qed. Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b. -Proof. - intro; symmetry. - apply Zdiv_unique_full with (a mod c); auto with zarith. - red; generalize (Z_mod_lt a c)(Z_mod_neg a c); omega. - rewrite Zmult_plus_distr_r, Zmult_comm. - generalize (Z_div_mod_eq_full a c H); omega. -Qed. +Proof Z.div_add. Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. -Proof. - intros a b c H; rewrite Zplus_comm; rewrite Z_div_plus_full; - try apply Zplus_comm; auto with zarith. -Qed. +Proof Z.div_add_l. (** [Zopp] and [Zdiv], [Zmod]. Due to the choice of convention for our Euclidean division, some of the relations about [Zopp] and divisions are rather complex. *) Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. -Proof. - intros [|a|a] [|b|b]; try reflexivity; unfold Zdiv; simpl; - destruct (Zdiv_eucl_POS a (Zpos b)); destruct z0; try reflexivity. -Qed. +Proof. intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed. Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b). -Proof. - intros; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; do 2 rewrite Zmod_0_r; auto. - intros; symmetry. - apply Zmod_unique_full with ((-a)/(-b)); auto. - generalize (Z_mod_remainder a b Hb); destruct 1; [right|left]; omega. - rewrite Zdiv_opp_opp. - pattern a at 1; rewrite (Z_div_mod_eq_full a b Hb); ring. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed. Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0. -Proof. - intros; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; rewrite Zmod_0_r; auto. - rewrite Z_div_exact_full_2 with a b; auto. - replace (- (b * (a / b))) with (0 + - (a / b) * b). - rewrite Z_mod_plus_full; auto. - ring. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed. Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a) mod b = b - (a mod b). -Proof. - intros. - assert (b<>0) by (contradict H; subst; rewrite Zmod_0_r; auto). - symmetry; apply Zmod_unique_full with (-1-a/b); auto. - generalize (Z_mod_remainder a b H0); destruct 1; [left|right]; omega. - rewrite Zmult_minus_distr_l. - pattern a at 1; rewrite (Z_div_mod_eq_full a b H0); ring. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed. Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0. -Proof. - intros. - rewrite <- (Zopp_involutive a). - rewrite Zmod_opp_opp. - rewrite Z_mod_zero_opp_full; auto. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed. Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> a mod (-b) = (a mod b) - b. -Proof. - intros. - pattern a at 1; rewrite <- (Zopp_involutive a). - rewrite Zmod_opp_opp. - rewrite Z_mod_nz_opp_full; auto; omega. -Qed. +Proof. intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed. Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b). -Proof. - intros; destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; do 2 rewrite Zdiv_0_r; auto. - symmetry; apply Zdiv_unique_full with 0; auto. - red; omega. - pattern a at 1; rewrite (Z_div_mod_eq_full a b Hb). - rewrite H; ring. -Qed. +Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. -Proof. - intros. - assert (b<>0) by (contradict H; subst; rewrite Zmod_0_r; auto). - symmetry; apply Zdiv_unique_full with (b-a mod b); auto. - generalize (Z_mod_remainder a b H0); destruct 1; [left|right]; omega. - pattern a at 1; rewrite (Z_div_mod_eq_full a b H0); ring. -Qed. +Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed. Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b). -Proof. - intros. - pattern a at 1; rewrite <- (Zopp_involutive a). - rewrite Zdiv_opp_opp. - rewrite Z_div_zero_opp_full; auto. -Qed. +Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. -Proof. - intros. - pattern a at 1; rewrite <- (Zopp_involutive a). - rewrite Zdiv_opp_opp. - rewrite Z_div_nz_opp_full; auto; omega. -Qed. +Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed. (** Cancellations. *) -Lemma Zdiv_mult_cancel_r : forall a b c:Z, +Lemma Zdiv_mult_cancel_r : forall a b c:Z, c <> 0 -> (a*c)/(b*c) = a/b. -Proof. -assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b). - intros a b c Hb Hc. - symmetry. - apply Zdiv_unique with ((a mod b)*c); auto with zarith. - destruct (Z_mod_lt a b Hb); split. - apply Zmult_le_0_compat; auto with zarith. - apply Zmult_lt_compat_r; auto with zarith. - pattern a at 1; rewrite (Z_div_mod_eq a b Hb); ring. -intros a b c Hc. -destruct (Z_dec b 0) as [Hb|Hb]. -destruct Hb as [Hb|Hb]; destruct (not_Zeq_inf _ _ Hc); auto with *. -rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); - auto with *. -rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, - Zopp_mult_distr_l; auto with *. -rewrite <- Zdiv_opp_opp, Zopp_mult_distr_r, Zopp_mult_distr_r; auto with *. -rewrite Hb; simpl; do 2 rewrite Zdiv_0_r; auto. -Qed. +Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed. Lemma Zdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. - intros. - rewrite (Zmult_comm c a); rewrite (Zmult_comm c b). - apply Zdiv_mult_cancel_r; auto. + intros. rewrite (Zmult_comm c b); zero_or_not b. + rewrite (Zmult_comm b c). apply Z.div_mul_cancel_l; auto. Qed. Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. - intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. - subst; simpl; rewrite Zmod_0_r; auto. - destruct (Z_eq_dec b 0) as [Hb|Hb]. - subst; repeat rewrite Zmult_0_r || rewrite Zmod_0_r; auto. - assert (c*b <> 0). - contradict Hc; eapply Zmult_integral_l; eauto. - rewrite (Zplus_minus_eq _ _ _ (Z_div_mod_eq_full (c*a) (c*b) H)). - rewrite (Zplus_minus_eq _ _ _ (Z_div_mod_eq_full a b Hb)). - rewrite Zdiv_mult_cancel_l; auto with zarith. - ring. + intros. zero_or_not c. rewrite (Zmult_comm c b); zero_or_not b. + rewrite (Zmult_comm b c). apply Z.mul_mod_distr_l; auto. Qed. Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. - intros; repeat rewrite (fun x => (Zmult_comm x c)). - apply Zmult_mod_distr_l; auto. + intros. zero_or_not b. rewrite (Zmult_comm b c); zero_or_not c. + rewrite (Zmult_comm c b). apply Z.mul_mod_distr_r; auto. Qed. (** Operations modulo. *) Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n. -Proof. - intros; destruct (Z_eq_dec n 0) as [Hb|Hb]. - subst; do 2 rewrite Zmod_0_r; auto. - pattern a at 2; rewrite (Z_div_mod_eq_full a n); auto with zarith. - rewrite Zplus_comm; rewrite Zmult_comm. - apply sym_equal; apply Z_mod_plus_full; auto with zarith. -Qed. +Proof. intros. zero_or_not n. apply Z.mod_mod; auto. Qed. Theorem Zmult_mod: forall a b n, (a * b) mod n = ((a mod n) * (b mod n)) mod n. -Proof. - intros; destruct (Z_eq_dec n 0) as [Hb|Hb]. - subst; do 2 rewrite Zmod_0_r; auto. - pattern a at 1; rewrite (Z_div_mod_eq_full a n); auto with zarith. - pattern b at 1; rewrite (Z_div_mod_eq_full b n); auto with zarith. - set (A:=a mod n); set (B:=b mod n); set (A':=a/n); set (B':=b/n). - replace ((n*A' + A) * (n*B' + B)) - with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring. - apply Z_mod_plus_full; auto with zarith. -Qed. +Proof. intros. zero_or_not n. apply Z.mul_mod; auto. Qed. Theorem Zplus_mod: forall a b n, (a + b) mod n = (a mod n + b mod n) mod n. -Proof. - intros; destruct (Z_eq_dec n 0) as [Hb|Hb]. - subst; do 2 rewrite Zmod_0_r; auto. - pattern a at 1; rewrite (Z_div_mod_eq_full a n); auto with zarith. - pattern b at 1; rewrite (Z_div_mod_eq_full b n); auto with zarith. - replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n)) - with ((a mod n + b mod n) + (a / n + b / n) * n) by ring. - apply Z_mod_plus_full; auto with zarith. -Qed. +Proof. intros. zero_or_not n. apply Z.add_mod; auto. Qed. Theorem Zminus_mod: forall a b n, (a - b) mod n = (a mod n - b mod n) mod n. @@ -897,49 +443,48 @@ Qed. (** For a specific number N, equality modulo N is hence a nice setoid equivalence, compatible with [+], [-] and [*]. *) -Definition eqm N a b := (a mod N = b mod N). +Section EqualityModulo. +Variable N:Z. -Lemma eqm_refl N : forall a, (eqm N) a a. +Definition eqm a b := (a mod N = b mod N). +Infix "==" := eqm (at level 70). + +Lemma eqm_refl : forall a, a == a. Proof. unfold eqm; auto. Qed. -Lemma eqm_sym N : forall a b, (eqm N) a b -> (eqm N) b a. +Lemma eqm_sym : forall a b, a == b -> b == a. Proof. unfold eqm; auto. Qed. -Lemma eqm_trans N : forall a b c, - (eqm N) a b -> (eqm N) b c -> (eqm N) a c. +Lemma eqm_trans : forall a b c, + a == b -> b == c -> a == c. Proof. unfold eqm; eauto with *. Qed. -Add Parametric Relation N : Z (eqm N) - reflexivity proved by (eqm_refl N) - symmetry proved by (eqm_sym N) - transitivity proved by (eqm_trans N) as eqm_setoid. +Instance eqm_setoid : Equivalence eqm. +Proof. + constructor; [exact eqm_refl | exact eqm_sym | exact eqm_trans]. +Qed. -Add Parametric Morphism N : Zplus - with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zplus_eqm. +Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Zplus. Proof. - unfold eqm; intros; rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. + unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. Qed. -Add Parametric Morphism N : Zminus - with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zminus_eqm. +Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Zminus. Proof. - unfold eqm; intros; rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. + unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. Qed. -Add Parametric Morphism N : Zmult - with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zmult_eqm. +Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Zmult. Proof. - unfold eqm; intros; rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. + unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. Qed. -Add Parametric Morphism N : Zopp - with signature (eqm N) ==> (eqm N) as Zopp_eqm. +Instance Zopp_eqm : Proper (eqm ==> eqm) Zopp. Proof. - intros; change ((eqm N) (-x) (-y)) with ((eqm N) (0-x) (0-y)). - rewrite H; red; auto. + intros x y H. change ((-x)==(-y)) with ((0-x)==(0-y)). now rewrite H. Qed. -Lemma Zmod_eqm N : forall a, (eqm N) (a mod N) a. +Lemma Zmod_eqm : forall a, (a mod N) == a. Proof. intros; exact (Zmod_mod a N). Qed. @@ -952,32 +497,12 @@ Qed. ~ (1/3 == 1/1) *) +End EqualityModulo. + Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. - intros a b c Hb Hc. - destruct (Zle_lt_or_eq _ _ Hb); [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zdiv_0_l; auto]. - destruct (Zle_lt_or_eq _ _ Hc); [ | subst; rewrite Zmult_0_r, Zdiv_0_r, Zdiv_0_r; auto]. - pattern a at 2;rewrite (Z_div_mod_eq_full a b);auto with zarith. - pattern (a/b) at 2;rewrite (Z_div_mod_eq_full (a/b) c);auto with zarith. - replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with - ((a / b / c)*(b * c) + (b * ((a / b) mod c) + a mod b)) by ring. - rewrite Z_div_plus_full_l; auto with zarith. - rewrite (Zdiv_small (b * ((a / b) mod c) + a mod b)). - ring. - split. - apply Zplus_le_0_compat;auto with zarith. - apply Zmult_le_0_compat;auto with zarith. - destruct (Z_mod_lt (a/b) c);auto with zarith. - destruct (Z_mod_lt a b);auto with zarith. - apply Zle_lt_trans with (b * ((a / b) mod c) + (b-1)). - destruct (Z_mod_lt a b);auto with zarith. - apply Zle_lt_trans with (b * (c-1) + (b - 1)). - apply Zplus_le_compat;auto with zarith. - destruct (Z_mod_lt (a/b) c);auto with zarith. - replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith. - intro H1; - assert (H2: c <> 0) by auto with zarith; - rewrite (Zmult_integral_l _ _ H2 H1) in H; auto with zarith. + intros. zero_or_not b. rewrite Zmult_comm. zero_or_not c. + rewrite Z.mul_comm. apply Z.div_div; auto with zarith. Qed. (** Unfortunately, the previous result isn't always true on negative numbers. @@ -988,40 +513,40 @@ Qed. Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. - intros a b c H1 H2 H3. - destruct (Zle_lt_or_eq _ _ H2); - [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zmult_0_r; auto]. - case (Z_mod_lt a b); auto with zarith; intros Hu1 Hu2. - case (Z_mod_lt c b); auto with zarith; intros Hv1 Hv2. - apply Zmult_le_reg_r with b; auto with zarith. - rewrite <- Zmult_assoc. - replace (a / b * b) with (a - a mod b). - replace (c * a / b * b) with (c * a - (c * a) mod b). - rewrite Zmult_minus_distr_l. - unfold Zminus; apply Zplus_le_compat_l. - match goal with |- - ?X <= -?Y => assert (Y <= X); auto with zarith end. - apply Zle_trans with ((c mod b) * (a mod b)); auto with zarith. - rewrite Zmult_mod; auto with zarith. - apply (Zmod_le ((c mod b) * (a mod b)) b); auto with zarith. - apply Zmult_le_compat_r; auto with zarith. - apply (Zmod_le c b); auto. - pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; - auto with zarith. - pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith. -Qed. + intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed. (** Zmod is related to divisibility (see more in Znumtheory) *) Lemma Zmod_divides : forall a b, b<>0 -> (a mod b = 0 <-> exists c, a = b*c). Proof. - split; intros. - exists (a/b). - pattern a at 1; rewrite (Z_div_mod_eq_full a b); auto with zarith. - destruct H0 as [c Hc]. - symmetry. - apply Zmod_unique_full with c; auto with zarith. - red; omega with *. + intros. rewrite Z.mod_divide; trivial. + split; intros (c,Hc); exists c; subst; auto with zarith. +Qed. + +(** Particular case : dividing by 2 is related with parity *) + +Lemma Zdiv2_div : forall a, Z.div2 a = a/2. +Proof Z.div2_div. + +Lemma Zmod_odd : forall a, a mod 2 = if Z.odd a then 1 else 0. +Proof. + intros a. now rewrite <- Z.bit0_odd, <- Z.bit0_mod. +Qed. + +Lemma Zmod_even : forall a, a mod 2 = if Z.even a then 0 else 1. +Proof. + intros a. rewrite Zmod_odd, Zodd_even_bool. now destruct Zeven_bool. +Qed. + +Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1. +Proof. + intros a. rewrite Zmod_odd. now destruct Zodd_bool. +Qed. + +Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0. +Proof. + intros a. rewrite Zmod_even. now destruct Zeven_bool. Qed. (** * Compatibility *) @@ -1075,12 +600,12 @@ Fixpoint Zmod_POS (a : positive) (b : Z) : Z := | xI a' => let r := Zmod_POS a' b in let r' := (2 * r + 1) in - if Zgt_bool b r' then r' else (r' - b) + if r' <? b then r' else (r' - b) | xO a' => let r := Zmod_POS a' b in let r' := (2 * r) in - if Zgt_bool b r' then r' else (r' - b) - | xH => if Zge_bool b 2 then 1 else 0 + if r' <? b then r' else (r' - b) + | xH => if 2 <=? b then 1 else 0 end. Definition Zmod' a b := @@ -1105,30 +630,28 @@ Definition Zmod' a b := end. -Theorem Zmod_POS_correct: forall a b, Zmod_POS a b = (snd (Zdiv_eucl_POS a b)). +Theorem Zmod_POS_correct a b : Zmod_POS a b = snd (Z.pos_div_eucl a b). Proof. - intros a b; elim a; simpl; auto. - intros p Rec; rewrite Rec. - case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto. - match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto. - intros p Rec; rewrite Rec. - case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto. - match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto. - case (Zge_bool b 2); auto. + induction a as [a IH|a IH| ]; simpl; rewrite ?IH. + destruct (Z.pos_div_eucl a b) as (p,q); simpl; + case Z.ltb_spec; reflexivity. + destruct (Z.pos_div_eucl a b) as (p,q); simpl; + case Z.ltb_spec; reflexivity. + case Z.leb_spec; trivial. Qed. -Theorem Zmod'_correct: forall a b, Zmod' a b = Zmod a b. +Theorem Zmod'_correct: forall a b, Zmod' a b = a mod b. Proof. - intros a b; unfold Zmod; case a; simpl; auto. + intros a b; unfold Z.modulo; case a; simpl; auto. intros p; case b; simpl; auto. intros p1; refine (Zmod_POS_correct _ _); auto. intros p1; rewrite Zmod_POS_correct; auto. - case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. + case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto. intros p; case b; simpl; auto. intros p1; rewrite Zmod_POS_correct; auto. - case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. + case (Z.pos_div_eucl p (Zpos p1)); simpl; intros z1 z2; case z2; auto. intros p1; rewrite Zmod_POS_correct; simpl; auto. - case (Zdiv_eucl_POS p (Zpos p1)); auto. + case (Z.pos_div_eucl p (Zpos p1)); auto. Qed. @@ -1140,12 +663,12 @@ Theorem Zdiv_eucl_extended : forall b:Z, b <> 0 -> forall a:Z, - {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Zabs b}. + {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}. Proof. intros b Hb a. elim (Z_le_gt_dec 0 b); intro Hb'. cut (b > 0); [ intro Hb'' | omega ]. - rewrite Zabs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. + rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. cut (- b > 0); [ intro Hb'' | omega ]. elim (Zdiv_eucl_exist Hb'' a); intros qr. elim qr; intros q r Hqr. @@ -1153,17 +676,33 @@ Proof. elim Hqr; intros. split. rewrite <- Zmult_opp_comm; assumption. - rewrite Zabs_non_eq; [ assumption | omega ]. + rewrite Z.abs_neq; [ assumption | omega ]. Qed. -Implicit Arguments Zdiv_eucl_extended. +Arguments Zdiv_eucl_extended : default implicits. -(** A third convention: Ocaml. +(** * Division and modulo in Z agree with same in nat: *) - See files ZOdiv_def.v and ZOdiv.v. +Require Import NPeano. - Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). - Hence (-a) mod b = - (a mod b) - a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). -*) +Lemma div_Zdiv (n m: nat): m <> O -> + Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m. +Proof. + intros. + apply (Zdiv_unique _ _ _ (Z.of_nat (n mod m))). + split. auto with zarith. + now apply inj_lt, Nat.mod_upper_bound. + rewrite <- inj_mult, <- inj_plus. + now apply inj_eq, Nat.div_mod. +Qed. + +Lemma mod_Zmod (n m: nat): m <> O -> + Z.of_nat (n mod m) = (Z.of_nat n) mod (Z.of_nat m). +Proof. + intros. + apply (Zmod_unique _ _ (Z.of_nat n / Z.of_nat m)). + split. auto with zarith. + now apply inj_lt, Nat.mod_upper_bound. + rewrite <- div_Zdiv, <- inj_mult, <- inj_plus by trivial. + now apply inj_eq, Nat.div_mod. +Qed. diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v new file mode 100644 index 00000000..f1b59749 --- /dev/null +++ b/theories/ZArith/Zeuclid.v @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Morphisms BinInt ZDivEucl. +Local Open Scope Z_scope. + +(** * Definitions of division for binary integers, Euclid convention. *) + +(** In this convention, the remainder is always positive. + For other conventions, see [Z.div] and [Z.quot] in file [BinIntDef]. + To avoid collision with the other divisions, we place this one + under a module. +*) + +Module ZEuclid. + + Definition modulo a b := Z.modulo a (Z.abs b). + Definition div a b := (Z.sgn b) * (Z.div a (Z.abs b)). + + Instance mod_wd : Proper (eq==>eq==>eq) modulo. + Proof. congruence. Qed. + Instance div_wd : Proper (eq==>eq==>eq) div. + Proof. congruence. Qed. + + Theorem div_mod a b : b<>0 -> a = b*(div a b) + modulo a b. + Proof. + intros Hb. unfold div, modulo. + rewrite Z.mul_assoc. rewrite Z.sgn_abs. apply Z.div_mod. + now destruct b. + Qed. + + Lemma mod_always_pos a b : b<>0 -> 0 <= modulo a b < Z.abs b. + Proof. + intros Hb. unfold modulo. + apply Z.mod_pos_bound. + destruct b; compute; trivial. now destruct Hb. + Qed. + + Lemma mod_bound_pos a b : 0<=a -> 0<b -> 0 <= modulo a b < b. + Proof. + intros _ Hb. rewrite <- (Z.abs_eq b) at 3 by Z.order. + apply mod_always_pos. Z.order. + Qed. + + Include ZEuclidProp Z Z Z. + +End ZEuclid. diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 883b7f15..550b66f7 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -1,22 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zeven.v 14641 2011-11-06 11:59:10Z herbelin $ i*) +(** Binary Integers : Parity and Division by Two *) +(** Initial author : Pierre Crégut (CNET, Lannion, France) *) + +(** THIS FILE IS DEPRECATED. + It is now almost entirely made of compatibility formulations + for results already present in BinInt.Z. *) Require Import BinInt. Open Scope Z_scope. -(*******************************************************************) -(** About parity: even and odd predicates on Z, division by 2 on Z *) - -(***************************************************) -(** * [Zeven], [Zodd] and their related properties *) +(** Historical formulation of even and odd predicates, based on + case analysis. We now rather recommend using [Z.Even] and + [Z.Odd], which are based on the exist predicate. *) Definition Zeven (z:Z) := match z with @@ -35,281 +38,253 @@ Definition Zodd (z:Z) := | _ => False end. -Definition Zeven_bool (z:Z) := - match z with - | Z0 => true - | Zpos (xO _) => true - | Zneg (xO _) => true - | _ => false - end. +Lemma Zeven_equiv z : Zeven z <-> Z.Even z. +Proof. + rewrite <- Z.even_spec. + destruct z as [|p|p]; try destruct p; simpl; intuition. +Qed. -Definition Zodd_bool (z:Z) := - match z with - | Z0 => false - | Zpos (xO _) => false - | Zneg (xO _) => false - | _ => true - end. +Lemma Zodd_equiv z : Zodd z <-> Z.Odd z. +Proof. + rewrite <- Z.odd_spec. + destruct z as [|p|p]; try destruct p; simpl; intuition. +Qed. + +Theorem Zeven_ex_iff n : Zeven n <-> exists m, n = 2*m. +Proof (Zeven_equiv n). + +Theorem Zodd_ex_iff n : Zodd n <-> exists m, n = 2*m + 1. +Proof (Zodd_equiv n). + +(** Boolean tests of parity (now in BinInt.Z) *) + +Notation Zeven_bool := Z.even (only parsing). +Notation Zodd_bool := Z.odd (only parsing). + +Lemma Zeven_bool_iff n : Z.even n = true <-> Zeven n. +Proof. + now rewrite Z.even_spec, Zeven_equiv. +Qed. + +Lemma Zodd_bool_iff n : Z.odd n = true <-> Zodd n. +Proof. + now rewrite Z.odd_spec, Zodd_equiv. +Qed. + +Ltac boolify_even_odd := rewrite <- ?Zeven_bool_iff, <- ?Zodd_bool_iff. + +Lemma Zodd_even_bool n : Z.odd n = negb (Z.even n). +Proof. + symmetry. apply Z.negb_even. +Qed. + +Lemma Zeven_odd_bool n : Z.even n = negb (Z.odd n). +Proof. + symmetry. apply Z.negb_odd. +Qed. -Definition Zeven_odd_dec : forall z:Z, {Zeven z} + {Zodd z}. +Definition Zeven_odd_dec n : {Zeven n} + {Zodd n}. Proof. - intro z. case z; - [ left; compute in |- *; trivial - | intro p; case p; intros; - (right; compute in |- *; exact I) || (left; compute in |- *; exact I) - | intro p; case p; intros; - (right; compute in |- *; exact I) || (left; compute in |- *; exact I) ]. + destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right). Defined. -Definition Zeven_dec : forall z:Z, {Zeven z} + {~ Zeven z}. +Definition Zeven_dec n : {Zeven n} + {~ Zeven n}. Proof. - intro z. case z; - [ left; compute in |- *; trivial - | intro p; case p; intros; - (left; compute in |- *; exact I) || (right; compute in |- *; trivial) - | intro p; case p; intros; - (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ]. + destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right). Defined. -Definition Zodd_dec : forall z:Z, {Zodd z} + {~ Zodd z}. +Definition Zodd_dec n : {Zodd n} + {~ Zodd n}. Proof. - intro z. case z; - [ right; compute in |- *; trivial - | intro p; case p; intros; - (left; compute in |- *; exact I) || (right; compute in |- *; trivial) - | intro p; case p; intros; - (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ]. + destruct n as [|p|p]; try destruct p; simpl; (now left) || (now right). Defined. -Lemma Zeven_not_Zodd : forall n:Z, Zeven n -> ~ Zodd n. +Lemma Zeven_not_Zodd n : Zeven n -> ~ Zodd n. Proof. - intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *; - trivial. + boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition. Qed. -Lemma Zodd_not_Zeven : forall n:Z, Zodd n -> ~ Zeven n. +Lemma Zodd_not_Zeven n : Zodd n -> ~ Zeven n. Proof. - intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *; - trivial. + boolify_even_odd. rewrite <- Z.negb_odd. destruct Z.odd; intuition. Qed. -Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n). +Lemma Zeven_Sn n : Zodd n -> Zeven (Z.succ n). Proof. - intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. - unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. + boolify_even_odd. now rewrite Z.even_succ. Qed. -Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n). +Lemma Zodd_Sn n : Zeven n -> Zodd (Z.succ n). Proof. - intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. - unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. + boolify_even_odd. now rewrite Z.odd_succ. Qed. -Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n). +Lemma Zeven_pred n : Zodd n -> Zeven (Z.pred n). Proof. - intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. - unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. + boolify_even_odd. now rewrite Z.even_pred. Qed. -Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n). +Lemma Zodd_pred n : Zeven n -> Zodd (Z.pred n). Proof. - intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. - unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. + boolify_even_odd. now rewrite Z.odd_pred. Qed. Hint Unfold Zeven Zodd: zarith. +Notation Zeven_bool_succ := Z.even_succ (only parsing). +Notation Zeven_bool_pred := Z.even_pred (only parsing). +Notation Zodd_bool_succ := Z.odd_succ (only parsing). +Notation Zodd_bool_pred := Z.odd_pred (only parsing). (******************************************************************) -(** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *) +(** * Definition of [Zquot2], [Zdiv2] and properties wrt [Zeven] + and [Zodd] *) -(** [Zdiv2] is defined on all [Z], but notice that for odd negative - integers it is not the euclidean quotient: in that case we have - [n = 2*(n/2)-1] *) +Notation Zdiv2 := Z.div2 (only parsing). +Notation Zquot2 := Z.quot2 (only parsing). -Definition Zdiv2 (z:Z) := - match z with - | Z0 => 0 - | Zpos xH => 0 - | Zpos p => Zpos (Pdiv2 p) - | Zneg xH => 0 - | Zneg p => Zneg (Pdiv2 p) - end. +(** Properties of [Z.div2] *) -Lemma Zeven_div2 : forall n:Z, Zeven n -> n = 2 * Zdiv2 n. +Lemma Zdiv2_odd_eqn n : n = 2*(Z.div2 n) + if Z.odd n then 1 else 0. +Proof (Z.div2_odd n). + +Lemma Zeven_div2 n : Zeven n -> n = 2 * Z.div2 n. Proof. - intro x; destruct x. - auto with arith. - destruct p; auto with arith. - intros. absurd (Zeven (Zpos (xI p))); red in |- *; auto with arith. - intros. absurd (Zeven 1); red in |- *; auto with arith. - destruct p; auto with arith. - intros. absurd (Zeven (Zneg (xI p))); red in |- *; auto with arith. - intros. absurd (Zeven (-1)); red in |- *; auto with arith. + boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff. + intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn, Z.add_0_r. Qed. -Lemma Zodd_div2 : forall n:Z, n >= 0 -> Zodd n -> n = 2 * Zdiv2 n + 1. +Lemma Zodd_div2 n : Zodd n -> n = 2 * Z.div2 n + 1. Proof. - intro x; destruct x. - intros. absurd (Zodd 0); red in |- *; auto with arith. - destruct p; auto with arith. - intros. absurd (Zodd (Zpos (xO p))); red in |- *; auto with arith. - intros. absurd (Zneg p >= 0); red in |- *; auto with arith. + boolify_even_odd. + intros Hn. rewrite (Zdiv2_odd_eqn n) at 1. now rewrite Hn. Qed. -Lemma Zodd_div2_neg : - forall n:Z, n <= 0 -> Zodd n -> n = 2 * Zdiv2 n - 1. +(** Properties of [Z.quot2] *) + +(** TODO: move to Numbers someday *) + +Lemma Zquot2_odd_eqn n : n = 2*(Z.quot2 n) + if Z.odd n then Z.sgn n else 0. Proof. - intro x; destruct x. - intros. absurd (Zodd 0); red in |- *; auto with arith. - intros. absurd (Zneg p >= 0); red in |- *; auto with arith. - destruct p; auto with arith. - intros. absurd (Zodd (Zneg (xO p))); red in |- *; auto with arith. + now destruct n as [ |[p|p| ]|[p|p| ]]. Qed. -Lemma Z_modulo_2 : - forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. +Lemma Zeven_quot2 n : Zeven n -> n = 2 * Z.quot2 n. Proof. - intros x. - elim (Zeven_odd_dec x); intro. - left. split with (Zdiv2 x). exact (Zeven_div2 x a). - right. generalize b; clear b; case x. - intro b; inversion b. - intro p; split with (Zdiv2 (Zpos p)). apply (Zodd_div2 (Zpos p)); trivial. - unfold Zge, Zcompare in |- *; simpl in |- *; discriminate. - intro p; split with (Zdiv2 (Zpred (Zneg p))). - pattern (Zneg p) at 1 in |- *; rewrite (Zsucc_pred (Zneg p)). - pattern (Zpred (Zneg p)) at 1 in |- *; rewrite (Zeven_div2 (Zpred (Zneg p))). - reflexivity. - apply Zeven_pred; assumption. + intros Hn. apply Zeven_bool_iff in Hn. + rewrite (Zquot2_odd_eqn n) at 1. + now rewrite Zodd_even_bool, Hn, Z.add_0_r. Qed. -Lemma Zsplit2 : - forall n:Z, - {p : Z * Z | - let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}. +Lemma Zodd_quot2 n : n >= 0 -> Zodd n -> n = 2 * Z.quot2 n + 1. Proof. - intros x. - elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy; - rewrite <- Zplus_diag_eq_mult_2 in Hy. - exists (y, y); split. - assumption. - left; reflexivity. - exists (y, (y + 1)%Z); split. - rewrite Zplus_assoc; assumption. - right; reflexivity. + intros Hn Hn'. apply Zodd_bool_iff in Hn'. + rewrite (Zquot2_odd_eqn n) at 1. rewrite Hn'. f_equal. + destruct n; (now destruct Hn) || easy. Qed. +Lemma Zodd_quot2_neg n : n <= 0 -> Zodd n -> n = 2 * Z.quot2 n - 1. +Proof. + intros Hn Hn'. apply Zodd_bool_iff in Hn'. + rewrite (Zquot2_odd_eqn n) at 1; rewrite Hn'. unfold Z.sub. f_equal. + destruct n; (now destruct Hn) || easy. +Qed. -Theorem Zeven_ex: forall n, Zeven n -> exists m, n = 2 * m. +Lemma Zquot2_opp n : Z.quot2 (-n) = - Z.quot2 n. Proof. - intro n; exists (Zdiv2 n); apply Zeven_div2; auto. + now destruct n as [ |[p|p| ]|[p|p| ]]. Qed. -Theorem Zodd_ex: forall n, Zodd n -> exists m, n = 2 * m + 1. +Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2. Proof. - destruct n; intros. - inversion H. - exists (Zdiv2 (Zpos p)). - apply Zodd_div2; simpl; auto; compute; inversion 1. - exists (Zdiv2 (Zneg p) - 1). - unfold Zminus. - rewrite Zmult_plus_distr_r. - rewrite <- Zplus_assoc. - assert (Zneg p <= 0) by (compute; inversion 1). - exact (Zodd_div2_neg _ H0 H). + assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2). + BeginSubproof. + intros m Hm. + apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0). + now apply Z.lt_le_incl. + rewrite Z.sgn_pos by trivial. + destruct (Z.odd m); now split. + apply Zquot2_odd_eqn. + EndSubproof. + destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]]. + - now apply AUX. + - now subst. + - apply Z.opp_inj. rewrite <- Z.quot_opp_l, <- Zquot2_opp. + apply AUX. now destruct n. easy. Qed. -Theorem Zeven_2p: forall p, Zeven (2 * p). +(** More properties of parity *) + +Lemma Z_modulo_2 n : {y | n = 2 * y} + {y | n = 2 * y + 1}. Proof. - destruct p; simpl; auto. + destruct (Zeven_odd_dec n) as [Hn|Hn]. + - left. exists (Z.div2 n). exact (Zeven_div2 n Hn). + - right. exists (Z.div2 n). exact (Zodd_div2 n Hn). Qed. -Theorem Zodd_2p_plus_1: forall p, Zodd (2 * p + 1). +Lemma Zsplit2 n : + {p : Z * Z | let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}. Proof. - destruct p; simpl; auto. - destruct p; simpl; auto. + destruct (Z_modulo_2 n) as [(y,Hy)|(y,Hy)]; + rewrite Z.mul_comm, <- Zplus_diag_eq_mult_2 in Hy. + - exists (y, y). split. assumption. now left. + - exists (y, y + 1). split. now rewrite Z.add_assoc. now right. Qed. -Theorem Zeven_plus_Zodd: forall a b, - Zeven a -> Zodd b -> Zodd (a + b). +Theorem Zeven_ex n : Zeven n -> exists m, n = 2 * m. Proof. - intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. - case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto. - replace (2 * x + (2 * y + 1)) with (2 * (x + y) + 1); try apply Zodd_2p_plus_1; auto with zarith. - rewrite Zmult_plus_distr_r, Zplus_assoc; auto. + exists (Z.div2 n); apply Zeven_div2; auto. Qed. -Theorem Zeven_plus_Zeven: forall a b, - Zeven a -> Zeven b -> Zeven (a + b). +Theorem Zodd_ex n : Zodd n -> exists m, n = 2 * m + 1. Proof. - intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. - case Zeven_ex with (1 := H2); intros y H4; try rewrite H4; auto. - replace (2 * x + 2 * y) with (2 * (x + y)); try apply Zeven_2p; auto with zarith. - apply Zmult_plus_distr_r; auto. + exists (Z.div2 n); apply Zodd_div2; auto. Qed. -Theorem Zodd_plus_Zeven: forall a b, - Zodd a -> Zeven b -> Zodd (a + b). +Theorem Zeven_2p p : Zeven (2 * p). Proof. - intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto. + now destruct p. Qed. -Theorem Zodd_plus_Zodd: forall a b, - Zodd a -> Zodd b -> Zeven (a + b). +Theorem Zodd_2p_plus_1 p : Zodd (2 * p + 1). Proof. - intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. - case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto. - replace ((2 * x + 1) + (2 * y + 1)) with (2 * (x + y + 1)); try apply Zeven_2p; auto. - (* ring part *) - do 2 rewrite Zmult_plus_distr_r; auto. - repeat rewrite <- Zplus_assoc; f_equal. - rewrite (Zplus_comm 1). - repeat rewrite <- Zplus_assoc; auto. + destruct p as [|p|p]; now try destruct p. Qed. -Theorem Zeven_mult_Zeven_l: forall a b, - Zeven a -> Zeven (a * b). +Theorem Zeven_plus_Zodd a b : Zeven a -> Zodd b -> Zodd (a + b). Proof. - intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. - replace (2 * x * b) with (2 * (x * b)); try apply Zeven_2p; auto with zarith. - (* ring part *) - apply Zmult_assoc. + boolify_even_odd. rewrite <- Z.negb_odd, Bool.negb_true_iff. + intros Ha Hb. now rewrite Z.odd_add, Ha, Hb. Qed. -Theorem Zeven_mult_Zeven_r: forall a b, - Zeven b -> Zeven (a * b). +Theorem Zeven_plus_Zeven a b : Zeven a -> Zeven b -> Zeven (a + b). Proof. - intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. - replace (a * (2 * x)) with (2 * (x * a)); try apply Zeven_2p; auto. - (* ring part *) - rewrite (Zmult_comm x a). - do 2 rewrite Zmult_assoc. - rewrite (Zmult_comm 2 a); auto. + boolify_even_odd. intros Ha Hb. now rewrite Z.even_add, Ha, Hb. Qed. -Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l - Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand. +Theorem Zodd_plus_Zeven a b : Zodd a -> Zeven b -> Zodd (a + b). +Proof. + intros. rewrite Z.add_comm. now apply Zeven_plus_Zodd. +Qed. + +Theorem Zodd_plus_Zodd a b : Zodd a -> Zodd b -> Zeven (a + b). +Proof. + boolify_even_odd. rewrite <- 2 Z.negb_even, 2 Bool.negb_true_iff. + intros Ha Hb. now rewrite Z.even_add, Ha, Hb. +Qed. + +Theorem Zeven_mult_Zeven_l a b : Zeven a -> Zeven (a * b). +Proof. + boolify_even_odd. intros Ha. now rewrite Z.even_mul, Ha. +Qed. + +Theorem Zeven_mult_Zeven_r a b : Zeven b -> Zeven (a * b). +Proof. + intros. rewrite Z.mul_comm. now apply Zeven_mult_Zeven_l. +Qed. -Theorem Zodd_mult_Zodd: forall a b, - Zodd a -> Zodd b -> Zodd (a * b). +Theorem Zodd_mult_Zodd a b : Zodd a -> Zodd b -> Zodd (a * b). Proof. - intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. - case Zodd_ex with (1 := H2); intros y H4; try rewrite H4; auto. - replace ((2 * x + 1) * (2 * y + 1)) with (2 * (2 * x * y + x + y) + 1); try apply Zodd_2p_plus_1; auto. - (* ring part *) - autorewrite with Zexpand; f_equal. - repeat rewrite <- Zplus_assoc; f_equal. - repeat rewrite <- Zmult_assoc; f_equal. - repeat rewrite Zmult_assoc; f_equal; apply Zmult_comm. + boolify_even_odd. intros Ha Hb. now rewrite Z.odd_mul, Ha, Hb. Qed. (* for compatibility *) diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 86fe0ef9..ebf3d024 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zgcd_alt.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -(** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *) +(** * Zgcd_alt : an alternate version of Zgcd, based on Euclid's algorithm *) (** Author: Pierre Letouzey @@ -17,7 +15,7 @@ Author: Pierre Letouzey (** The alternate [Zgcd_alt] given here used to be the main [Zgcd] function (see file [Znumtheory]), but this main [Zgcd] is now based on a modern binary-efficient algorithm. This earlier - version, based on Euler's algorithm of iterated modulo, is kept + version, based on Euclid's algorithm of iterated modulo, is kept here due to both its intrinsic interest and its use as reference point when proving gcd on Int31 numbers *) diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index c2348967..6a14d693 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zhints.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** This file centralizes the lemmas about [Z], classifying them according to the way they can be used in automatic search *) @@ -100,440 +98,3 @@ Hint Resolve Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *) : zarith. - -(**********************************************************************) -(** * Reversible lemmas relating operators *) -(** Probably to be declared as hints but need to define precedences *) - -(** ** Conversion between comparisons/predicates and arithmetic operators *) - -(** Lemmas ending by eq *) -(** -<< -Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` -Zabs_eq: (x:Z)`0 <= x`->`|x| = x` -Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)` -Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` -Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` -Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` -Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` -Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` -Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)` -Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)` -Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` ->> -*) - -(** ** Conversion between nat comparisons and Z comparisons *) - -(** Lemmas ending by eq *) -(** -<< -inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` ->> -*) - -(** Lemmas ending by Zge *) -(** -<< -inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` ->> -*) - -(** ** Conversion between comparisons *) - -(** Lemmas ending by Zge *) -(** -<< -not_Zlt: (x,y:Z)~`x < y`->`x >= y` -Zle_ge: (m,n:Z)`m <= n`->`n >= m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` -not_Zle: (x,y:Z)~`x <= y`->`x > y` -Zlt_gt: (m,n:Z)`m < n`->`n > m` -Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -not_Zge: (x,y:Z)~`x >= y`->`x < y` -Zgt_lt: (m,n:Z)`m > n`->`n < m` -Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` -not_Zgt: (x,y:Z)~`x > y`->`x <= y` -Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p` -Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p` -Zge_le: (m,n:Z)`m >= n`->`n <= m` -Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p` -Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m` -Zlt_le_weak: (n,m:Z)`n < m`->`n <= m` -Zle_refl: (n,m:Z)`n = m`->`n <= m` ->> -*) - -(** ** Irreversible simplification involving several comparaisons *) -(** useful with clear precedences *) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` -Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` ->> -*) - -(** ** What is decreasing here ? *) - -(** Lemmas ending by eq *) -(** -<< -Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` ->> -*) - -(**********************************************************************) -(** * Useful Bottom-up lemmas *) - -(** ** Bottom-up simplification: should be used *) - -(** Lemmas ending by eq *) -(** -<< -Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` -Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` -Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` -Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` -Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` -Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` -Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` -Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` ->> -*) - -(** Lemmas ending by Zle *) -(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m` -Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m` -Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) - -(** ** Bottom-up irreversible (syntactic) simplification *) - -(** Lemmas ending by Zle *) -(** -<< -Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` ->> -*) - -(** ** Other unclearly simplifying lemmas *) - -(** Lemmas ending by Zeq *) -(** -<< -Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` ->> -*) - -(* Lemmas ending by Zgt *) -(** -<< -Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` ->> -*) - -(* Lemmas ending by Zlt *) -(** -<< -pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` ->> -*) - -(* Lemmas ending by Zle *) -(** -<< -Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` -OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` ->> -*) - - -(**********************************************************************) -(** * Irreversible lemmas with meta-variables *) -(** To be used by EAuto *) - -(* Hints Immediate *) -(** Lemmas ending by eq *) -(** -<< -Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` ->> -*) - -(** Lemmas ending by Zge *) -(** -<< -Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` -Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` -Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` -Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` -Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` -Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` ->> -*) - - -(**********************************************************************) -(** * Unclear or too specific lemmas *) -(** Not to be used ? *) - -(** ** Irreversible and too specific (not enough regular) *) - -(** Lemmas ending by Zle *) -(** -<< -Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x` -Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z` -OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z` -OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t` ->> -*) - -(** ** Expansion and too specific ? *) - -(** Lemmas ending by Zge *) -(** -<< -Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b` -Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b` -Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y` ->> -*) - -(** ** Reversible but too specific ? *) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_minus: (n,m:Z)`0 < m`->`n-m < n` ->> -*) - -(**********************************************************************) -(** * Lemmas to be used as rewrite rules *) -(** but can also be used as hints *) - -(** Left-to-right simplification lemmas (a symbol disappears) *) - -(** -<< -Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m) -Zmin_n_n: (n:Z)`(Zmin n n) = n` -Zmult_1_n: (n:Z)`1*n = n` -Zmult_n_1: (n:Z)`n*1 = n` -Zminus_plus: (n,m:Z)`n+m-n = m` -Zle_plus_minus: (n,m:Z)`n+(m-n) = m` -Zopp_Zopp: (x:Z)`(-(-x)) = x` -Zero_left: (x:Z)`0+x = x` -Zero_right: (x:Z)`x+0 = x` -Zplus_inverse_r: (x:Z)`x+(-x) = 0` -Zplus_inverse_l: (x:Z)`(-x)+x = 0` -Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y` -Zmult_one: (x:Z)`1*x = x` -Zero_mult_left: (x:Z)`0*x = 0` -Zero_mult_right: (x:Z)`x*0 = 0` -Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y` ->> -*) - -(** Right-to-left simplification lemmas (a symbol disappears) *) - -(** -<< -Zpred_Sn: (m:Z)`m = (Zpred (Zs m))` -Zs_pred: (n:Z)`n = (Zs (Zpred n))` -Zplus_n_O: (n:Z)`n = n+0` -Zmult_n_O: (n:Z)`0 = n*0` -Zminus_n_O: (n:Z)`n = n-0` -Zminus_n_n: (n:Z)`0 = n-n` -Zred_factor6: (x:Z)`x = x+0` -Zred_factor0: (x:Z)`x = x*1` ->> -*) - -(** Unclear orientation (no symbol disappears) *) - -(** -<< -Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)` -Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)` -Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))` -Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p` -Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)` -Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)` -Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)` -Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)` -Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m` -Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p` -Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p` -Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)` -Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p` -Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)` -Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m` -Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z` -Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p` -Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)` -Zplus_sym: (x,y:Z)`x+y = y+x` -Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z` -Zmult_sym: (x,y:Z)`x*y = y*x` -Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z` -Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))` -Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))` -Zopp_one: (x:Z)`(-x) = x*(-1)` -Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)` -Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)` -Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y` -Zred_factor1: (x:Z)`x+x = x*2` -Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)` -Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)` -Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)` -Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y` -Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n` ->> -*) - -(** nat <-> Z *) -(** -<< -inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))` -inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)` -inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)` -inj_minus1: - (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)` -inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0` ->> -*) - -(** Too specific ? *) -(** -<< -Zred_factor5: (x,y:Z)`x*0+y = y` ->> -*) - diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 59e76830..30948ca7 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -1,17 +1,21 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zlogarithm.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (**********************************************************************) -(** The integer logarithms with base 2. - There are three logarithms, +(** The integer logarithms with base 2. *) + +(** THIS FILE IS DEPRECATED. + Please rather use [Z.log2] (or [Z.log2_up]), which + are defined in [BinIntDef], and whose properties can + be found in [BinInt.Z]. *) + +(* There are three logarithms defined here, depending on the rounding of the real 2-based logarithm: - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)] i.e. [Log_inf x] is the biggest integer that is smaller than [Log x] @@ -20,11 +24,8 @@ - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)] i.e. [Log_nearest x] is the integer nearest from [Log x] *) -Require Import ZArith_base. -Require Import Omega. -Require Import Zcomplements. -Require Import Zpower. -Open Local Scope Z_scope. +Require Import ZArith_base Omega Zcomplements Zpower. +Local Open Scope Z_scope. Section Log_pos. (* Log of positive integers *) @@ -32,9 +33,9 @@ Section Log_pos. (* Log of positive integers *) Fixpoint log_inf (p:positive) : Z := match p with - | xH => 0 (* 1 *) - | xO q => Zsucc (log_inf q) (* 2n *) - | xI q => Zsucc (log_inf q) (* 2n+1 *) + | xH => 0 (* 1 *) + | xO q => Zsucc (log_inf q) (* 2n *) + | xI q => Zsucc (log_inf q) (* 2n+1 *) end. Fixpoint log_sup (p:positive) : Z := @@ -46,6 +47,27 @@ Section Log_pos. (* Log of positive integers *) Hint Unfold log_inf log_sup. + Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). + Proof. + induction p; simpl; now rewrite <- ?Z.succ_Zpos, ?IHp. + Qed. + + Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p. + Proof. + unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf. + Qed. + + Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p. + Proof. + induction p; simpl. + - change (Zpos p~1) with (2*(Zpos p)+1). + rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy. + unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc. + - change (Zpos p~0) with (2*Zpos p). + now rewrite Z.log2_up_double, IHp. + - reflexivity. + Qed. + (** Then we give the specifications of [log_inf] and [log_sup] and prove their validity *) diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index cb2fcf26..999564f0 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -1,106 +1,111 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmax.v 14641 2011-11-06 11:59:10Z herbelin $ i*) -(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) +(** THIS FILE IS DEPRECATED. *) -Require Export BinInt Zorder Zminmax. +Require Export BinInt Zcompare Zorder. -Open Local Scope Z_scope. - -(** [Zmax] is now [Zminmax.Zmax]. Code that do things like - [unfold Zmin.Zmin] will have to be adapted, and neither - a [Definition] or a [Notation] here can help much. *) +Local Open Scope Z_scope. +(** Definition [Zmax] is now [BinInt.Z.max]. *) (** * Characterization of maximum on binary integer numbers *) Definition Zmax_case := Z.max_case. Definition Zmax_case_strong := Z.max_case_strong. -Lemma Zmax_spec : forall x y, - x >= y /\ Zmax x y = x \/ x < y /\ Zmax x y = y. +Lemma Zmax_spec x y : + x >= y /\ Z.max x y = x \/ x < y /\ Z.max x y = y. Proof. - intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto. + Z.swap_greater. destruct (Z.max_spec x y); auto. Qed. -Lemma Zmax_left : forall n m, n>=m -> Zmax n m = n. -Proof. intros x y. rewrite Zge_iff_le. apply Zmax_l. Qed. +Lemma Zmax_left n m : n>=m -> Z.max n m = n. +Proof. Z.swap_greater. apply Zmax_l. Qed. -Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r. +Lemma Zmax_right : forall n m, n<=m -> Z.max n m = m. Proof Zmax_r. (** * Least upper bound properties of max *) -Definition Zle_max_l : forall n m, n <= Zmax n m := Z.le_max_l. -Definition Zle_max_r : forall n m, m <= Zmax n m := Z.le_max_r. +Lemma Zle_max_l : forall n m, n <= Z.max n m. Proof Z.le_max_l. +Lemma Zle_max_r : forall n m, m <= Z.max n m. Proof Z.le_max_r. -Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p - := Z.max_lub. +Lemma Zmax_lub : forall n m p, n <= p -> m <= p -> Z.max n m <= p. +Proof Z.max_lub. -Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p - := Z.max_lub_lt. +Lemma Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Z.max n m < p. +Proof Z.max_lub_lt. (** * Compatibility with order *) -Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p - := Z.max_le_compat_r. +Lemma Zle_max_compat_r : forall n m p, n <= m -> Z.max n p <= Z.max m p. +Proof Z.max_le_compat_r. -Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m - := Z.max_le_compat_l. +Lemma Zle_max_compat_l : forall n m p, n <= m -> Z.max p n <= Z.max p m. +Proof Z.max_le_compat_l. (** * Semi-lattice properties of max *) -Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id. -Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm. -Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p - := Z.max_assoc. +Lemma Zmax_idempotent : forall n, Z.max n n = n. Proof Z.max_id. +Lemma Zmax_comm : forall n m, Z.max n m = Z.max m n. Proof Z.max_comm. +Lemma Zmax_assoc : forall n m p, Z.max n (Z.max m p) = Z.max (Z.max n m) p. +Proof Z.max_assoc. (** * Additional properties of max *) -Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}. -Proof. exact Z.max_dec. Qed. +Lemma Zmax_irreducible_dec : forall n m, {Z.max n m = n} + {Z.max n m = m}. +Proof Z.max_dec. -Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m - := Z.max_le. +Lemma Zmax_le_prime : forall n m p, p <= Z.max n m -> p <= n \/ p <= m. +Proof Z.max_le. (** * Operations preserving max *) -Definition Zsucc_max_distr : - forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m) - := Z.succ_max_distr. +Lemma Zsucc_max_distr : + forall n m, Z.succ (Z.max n m) = Z.max (Z.succ n) (Z.succ m). +Proof Z.succ_max_distr. -Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m - := Z.plus_max_distr_l. +Lemma Zplus_max_distr_l : forall n m p, Z.max (p + n) (p + m) = p + Z.max n m. +Proof Z.add_max_distr_l. -Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p - := Z.plus_max_distr_r. +Lemma Zplus_max_distr_r : forall n m p, Z.max (n + p) (m + p) = Z.max n m + p. +Proof Z.add_max_distr_r. (** * Maximum and Zpos *) -Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q) - := Z.pos_max. +Lemma Zpos_max p q : Zpos (Pos.max p q) = Z.max (Zpos p) (Zpos q). +Proof. + unfold Zmax, Pmax. simpl. + case Pos.compare_spec; auto; congruence. +Qed. -Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p - := Z.pos_max_1. +Lemma Zpos_max_1 p : Z.max 1 (Zpos p) = Zpos p. +Proof. + now destruct p. +Qed. -(** * Characterization of Pminus in term of Zminus and Zmax *) +(** * Characterization of Pos.sub in term of Z.sub and Z.max *) -Definition Zpos_minus : - forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q) - := Zpos_minus. +Lemma Zpos_minus p q : Zpos (p - q) = Z.max 1 (Zpos p - Zpos q). +Proof. + simpl. rewrite Z.pos_sub_spec. case Pos.compare_spec; intros H. + subst; now rewrite Pos.sub_diag. + now rewrite Pos.sub_lt. + symmetry. apply Zpos_max_1. +Qed. (* begin hide *) (* Compatibility *) -Notation Zmax1 := Zle_max_l (only parsing). -Notation Zmax2 := Zle_max_r (only parsing). -Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing). -Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing). +Notation Zmax1 := Z.le_max_l (only parsing). +Notation Zmax2 := Z.le_max_r (only parsing). +Notation Zmax_irreducible_inf := Z.max_dec (only parsing). +Notation Zmax_le_prime_inf := Z.max_le (only parsing). (* end hide *) diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index 7b9ad469..2c5003a6 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -1,90 +1,95 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmin.v 14641 2011-11-06 11:59:10Z herbelin $ i*) -(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *) +(** THIS FILE IS DEPRECATED. *) -Require Import BinInt Zorder Zminmax. +Require Import BinInt Zcompare Zorder. -Open Local Scope Z_scope. - -(** [Zmin] is now [Zminmax.Zmin]. Code that do things like - [unfold Zmin.Zmin] will have to be adapted, and neither - a [Definition] or a [Notation] here can help much. *) +Local Open Scope Z_scope. +(** Definition [Zmin] is now [BinInt.Z.min]. *) (** * Characterization of the minimum on binary integer numbers *) Definition Zmin_case := Z.min_case. Definition Zmin_case_strong := Z.min_case_strong. -Lemma Zmin_spec : forall x y, - x <= y /\ Zmin x y = x \/ x > y /\ Zmin x y = y. +Lemma Zmin_spec x y : + x <= y /\ Z.min x y = x \/ x > y /\ Z.min x y = y. Proof. - intros x y. rewrite Zgt_iff_lt, Z.min_comm. destruct (Z.min_spec y x); auto. + Z.swap_greater. rewrite Z.min_comm. destruct (Z.min_spec y x); auto. Qed. (** * Greatest lower bound properties of min *) -Definition Zle_min_l : forall n m, Zmin n m <= n := Z.le_min_l. -Definition Zle_min_r : forall n m, Zmin n m <= m := Z.le_min_r. +Lemma Zle_min_l : forall n m, Z.min n m <= n. Proof Z.le_min_l. +Lemma Zle_min_r : forall n m, Z.min n m <= m. Proof Z.le_min_r. -Definition Zmin_glb : forall n m p, p <= n -> p <= m -> p <= Zmin n m - := Z.min_glb. -Definition Zmin_glb_lt : forall n m p, p < n -> p < m -> p < Zmin n m - := Z.min_glb_lt. +Lemma Zmin_glb : forall n m p, p <= n -> p <= m -> p <= Z.min n m. +Proof Z.min_glb. +Lemma Zmin_glb_lt : forall n m p, p < n -> p < m -> p < Z.min n m. +Proof Z.min_glb_lt. (** * Compatibility with order *) -Definition Zle_min_compat_r : forall n m p, n <= m -> Zmin n p <= Zmin m p - := Z.min_le_compat_r. -Definition Zle_min_compat_l : forall n m p, n <= m -> Zmin p n <= Zmin p m - := Z.min_le_compat_l. +Lemma Zle_min_compat_r : forall n m p, n <= m -> Z.min n p <= Z.min m p. +Proof Z.min_le_compat_r. +Lemma Zle_min_compat_l : forall n m p, n <= m -> Z.min p n <= Z.min p m. +Proof Z.min_le_compat_l. (** * Semi-lattice properties of min *) -Definition Zmin_idempotent : forall n, Zmin n n = n := Z.min_id. -Notation Zmin_n_n := Zmin_idempotent (only parsing). -Definition Zmin_comm : forall n m, Zmin n m = Zmin m n := Z.min_comm. -Definition Zmin_assoc : forall n m p, Zmin n (Zmin m p) = Zmin (Zmin n m) p - := Z.min_assoc. +Lemma Zmin_idempotent : forall n, Z.min n n = n. Proof Z.min_id. +Notation Zmin_n_n := Z.min_id (only parsing). +Lemma Zmin_comm : forall n m, Z.min n m = Z.min m n. Proof Z.min_comm. +Lemma Zmin_assoc : forall n m p, Z.min n (Z.min m p) = Z.min (Z.min n m) p. +Proof Z.min_assoc. (** * Additional properties of min *) -Lemma Zmin_irreducible_inf : forall n m, {Zmin n m = n} + {Zmin n m = m}. -Proof. exact Z.min_dec. Qed. +Lemma Zmin_irreducible_inf : forall n m, {Z.min n m = n} + {Z.min n m = m}. +Proof Z.min_dec. -Lemma Zmin_irreducible : forall n m, Zmin n m = n \/ Zmin n m = m. -Proof. intros; destruct (Z.min_dec n m); auto. Qed. +Lemma Zmin_irreducible n m : Z.min n m = n \/ Z.min n m = m. +Proof. destruct (Z.min_dec n m); auto. Qed. Notation Zmin_or := Zmin_irreducible (only parsing). -Lemma Zmin_le_prime_inf : forall n m p, Zmin n m <= p -> {n <= p} + {m <= p}. -Proof. intros n m p; apply Zmin_case; auto. Qed. +Lemma Zmin_le_prime_inf n m p : Z.min n m <= p -> {n <= p} + {m <= p}. +Proof. apply Zmin_case; auto. Qed. (** * Operations preserving min *) -Definition Zsucc_min_distr : - forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m) - := Z.succ_min_distr. +Lemma Zsucc_min_distr : + forall n m, Z.succ (Z.min n m) = Z.min (Z.succ n) (Z.succ m). +Proof Z.succ_min_distr. Notation Zmin_SS := Z.succ_min_distr (only parsing). -Definition Zplus_min_distr_r : - forall n m p, Zmin (n + p) (m + p) = Zmin n m + p - := Z.plus_min_distr_r. +Lemma Zplus_min_distr_r : + forall n m p, Z.min (n + p) (m + p) = Z.min n m + p. +Proof Z.add_min_distr_r. -Notation Zmin_plus := Z.plus_min_distr_r (only parsing). +Notation Zmin_plus := Z.add_min_distr_r (only parsing). (** * Minimum and Zpos *) -Definition Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q) - := Z.pos_min. +Lemma Zpos_min p q : Zpos (Pos.min p q) = Z.min (Zpos p) (Zpos q). +Proof. + unfold Z.min, Pos.min; simpl. destruct Pos.compare; auto. +Qed. + +Lemma Zpos_min_1 p : Z.min 1 (Zpos p) = 1. +Proof. + now destruct p. +Qed. + + diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v index 5aebcc55..8908175f 100644 --- a/theories/ZArith/Zminmax.v +++ b/theories/ZArith/Zminmax.v @@ -1,194 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Require Import Orders BinInt Zcompare Zorder ZOrderedType - GenericMinMax. - -(** * Maximum and Minimum of two [Z] numbers *) - -Local Open Scope Z_scope. - -Unboxed Definition Zmax (n m:Z) := - match n ?= m with - | Eq | Gt => n - | Lt => m - end. - -Unboxed Definition Zmin (n m:Z) := - match n ?= m with - | Eq | Lt => n - | Gt => m - end. - -(** The functions [Zmax] and [Zmin] implement indeed - a maximum and a minimum *) - -Lemma Zmax_l : forall x y, y<=x -> Zmax x y = x. -Proof. - unfold Zle, Zmax. intros x y. rewrite <- (Zcompare_antisym x y). - destruct (x ?= y); intuition. -Qed. - -Lemma Zmax_r : forall x y, x<=y -> Zmax x y = y. -Proof. - unfold Zle, Zmax. intros x y. generalize (Zcompare_Eq_eq x y). - destruct (x ?= y); intuition. -Qed. - -Lemma Zmin_l : forall x y, x<=y -> Zmin x y = x. -Proof. - unfold Zle, Zmin. intros x y. generalize (Zcompare_Eq_eq x y). - destruct (x ?= y); intuition. -Qed. - -Lemma Zmin_r : forall x y, y<=x -> Zmin x y = y. -Proof. - unfold Zle, Zmin. intros x y. - rewrite <- (Zcompare_antisym x y). generalize (Zcompare_Eq_eq x y). - destruct (x ?= y); intuition. -Qed. - -Module ZHasMinMax <: HasMinMax Z_as_OT. - Definition max := Zmax. - Definition min := Zmin. - Definition max_l := Zmax_l. - Definition max_r := Zmax_r. - Definition min_l := Zmin_l. - Definition min_r := Zmin_r. -End ZHasMinMax. - -Module Z. - -(** We obtain hence all the generic properties of max and min. *) - -Include UsualMinMaxProperties Z_as_OT ZHasMinMax. - -(** * Properties specific to the [Z] domain *) - -(** Compatibilities (consequences of monotonicity) *) - -Lemma plus_max_distr_l : forall n m p, Zmax (p + n) (p + m) = p + Zmax n m. -Proof. - intros. apply max_monotone. - intros x y. apply Zplus_le_compat_l. -Qed. - -Lemma plus_max_distr_r : forall n m p, Zmax (n + p) (m + p) = Zmax n m + p. -Proof. - intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p). - apply plus_max_distr_l. -Qed. - -Lemma plus_min_distr_l : forall n m p, Zmin (p + n) (p + m) = p + Zmin n m. -Proof. - intros. apply Z.min_monotone. - intros x y. apply Zplus_le_compat_l. -Qed. - -Lemma plus_min_distr_r : forall n m p, Zmin (n + p) (m + p) = Zmin n m + p. -Proof. - intros. rewrite (Zplus_comm n p), (Zplus_comm m p), (Zplus_comm _ p). - apply plus_min_distr_l. -Qed. - -Lemma succ_max_distr : forall n m, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m). -Proof. - unfold Zsucc. intros. symmetry. apply plus_max_distr_r. -Qed. - -Lemma succ_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). -Proof. - unfold Zsucc. intros. symmetry. apply plus_min_distr_r. -Qed. - -Lemma pred_max_distr : forall n m, Zpred (Zmax n m) = Zmax (Zpred n) (Zpred m). -Proof. - unfold Zpred. intros. symmetry. apply plus_max_distr_r. -Qed. - -Lemma pred_min_distr : forall n m, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). -Proof. - unfold Zpred. intros. symmetry. apply plus_min_distr_r. -Qed. - -(** Anti-monotonicity swaps the role of [min] and [max] *) - -Lemma opp_max_distr : forall n m : Z, -(Zmax n m) = Zmin (- n) (- m). -Proof. - intros. symmetry. apply min_max_antimonotone. - intros x x'. red. red. rewrite <- Zcompare_opp; auto. -Qed. - -Lemma opp_min_distr : forall n m : Z, - (Zmin n m) = Zmax (- n) (- m). -Proof. - intros. symmetry. apply max_min_antimonotone. - intros x x'. red. red. rewrite <- Zcompare_opp; auto. -Qed. - -Lemma minus_max_distr_l : forall n m p, Zmax (p - n) (p - m) = p - Zmin n m. -Proof. - unfold Zminus. intros. rewrite opp_min_distr. apply plus_max_distr_l. -Qed. - -Lemma minus_max_distr_r : forall n m p, Zmax (n - p) (m - p) = Zmax n m - p. -Proof. - unfold Zminus. intros. apply plus_max_distr_r. -Qed. - -Lemma minus_min_distr_l : forall n m p, Zmin (p - n) (p - m) = p - Zmax n m. -Proof. - unfold Zminus. intros. rewrite opp_max_distr. apply plus_min_distr_l. -Qed. - -Lemma minus_min_distr_r : forall n m p, Zmin (n - p) (m - p) = Zmin n m - p. -Proof. - unfold Zminus. intros. apply plus_min_distr_r. -Qed. - -(** Compatibility with [Zpos] *) - -Lemma pos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q). -Proof. - intros; unfold Zmax, Pmax; simpl; generalize (Pcompare_Eq_eq p q). - destruct Pcompare; auto. - intro H; rewrite H; auto. -Qed. - -Lemma pos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q). -Proof. - intros; unfold Zmin, Pmin; simpl; generalize (Pcompare_Eq_eq p q). - destruct Pcompare; auto. -Qed. - -Lemma pos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p. -Proof. - intros; unfold Zmax; simpl; destruct p; simpl; auto. -Qed. - -Lemma pos_min_1 : forall p, Zmin 1 (Zpos p) = 1. -Proof. - intros; unfold Zmax; simpl; destruct p; simpl; auto. -Qed. - -End Z. - - -(** * Characterization of Pminus in term of Zminus and Zmax *) - -Lemma Zpos_minus : forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q). -Proof. - intros; simpl. destruct (Pcompare p q Eq) as [ ]_eqn:H. - rewrite (Pcompare_Eq_eq _ _ H). - unfold Pminus; rewrite Pminus_mask_diag; reflexivity. - rewrite Pminus_Lt; auto. - symmetry. apply Z.pos_max_1. -Qed. +Require Import Orders BinInt Zcompare Zorder. +(** THIS FILE IS DEPRECATED. *) (*begin hide*) (* Compatibility with names of the old Zminmax file *) @@ -199,4 +19,4 @@ Notation Zmin_max_distr_r := Z.min_max_distr (only parsing). Notation Zmax_min_modular_r := Z.max_min_modular (only parsing). Notation Zmin_max_modular_r := Z.min_max_modular (only parsing). Notation max_min_disassoc := Z.max_min_disassoc (only parsing). -(*end hide*)
\ No newline at end of file +(*end hide*) diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index a8872bd5..ff844ec2 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmisc.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import Wf_nat. Require Import BinInt. Require Import Zcompare. @@ -20,72 +18,11 @@ Open Local Scope Z_scope. (** [n]th iteration of the function [f] *) -Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) : A := - match n with - | xH => f x - | xO n' => iter_pos n' A f (iter_pos n' A f x) - | xI n' => f (iter_pos n' A f (iter_pos n' A f x)) - end. - -Definition iter (n:Z) (A:Type) (f:A -> A) (x:A) := - match n with - | Z0 => x - | Zpos p => iter_pos p A f x - | Zneg p => x - end. - -Theorem iter_nat_of_P : - forall (p:positive) (A:Type) (f:A -> A) (x:A), - iter_pos p A f x = iter_nat (nat_of_P p) A f x. -Proof. - intro n; induction n as [p H| p H| ]; - [ intros; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); - rewrite (ZL6 p); symmetry in |- *; apply f_equal with (f := f); - apply iter_nat_plus - | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); - rewrite (ZL6 p); symmetry in |- *; apply iter_nat_plus - | simpl in |- *; auto with arith ]. -Qed. +Notation iter := @Z.iter (only parsing). Lemma iter_nat_of_Z : forall n A f x, 0 <= n -> - iter n A f x = iter_nat (Zabs_nat n) A f x. + iter n A f x = iter_nat (Z.abs_nat n) A f x. intros n A f x; case n; auto. -intros p _; unfold iter, Zabs_nat; apply iter_nat_of_P. +intros p _; unfold Z.iter, Z.abs_nat; apply iter_nat_of_P. intros p abs; case abs; trivial. Qed. - -Theorem iter_pos_plus : - forall (p q:positive) (A:Type) (f:A -> A) (x:A), - iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x). -Proof. - intros n m; intros. - rewrite (iter_nat_of_P m A f x). - rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)). - rewrite (iter_nat_of_P (n + m) A f x). - rewrite (nat_of_P_plus_morphism n m). - apply iter_nat_plus. -Qed. - -(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], - then the iterates of [f] also preserve it. *) - -Theorem iter_nat_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_nat n A f x). -Proof. - simple induction n; intros; - [ trivial with arith - | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H; - trivial with arith ]. -Qed. - -Theorem iter_pos_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_pos p A f x). -Proof. - intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith. -Qed. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 9585b6f6..e3843990 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -1,286 +1,997 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znat.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) Require Export Arith_base. -Require Import BinPos. -Require Import BinInt. -Require Import Zcompare. -Require Import Zorder. -Require Import Decidable. -Require Import Peano_dec. -Require Import Min Max Zmin Zmax. -Require Export Compare_dec. +Require Import BinPos BinInt BinNat Pnat Nnat. + +Local Open Scope Z_scope. + +(** * Chains of conversions *) + +(** When combining successive conversions, we have the following + commutative diagram: +<< + ---> Nat ---- + | ^ | + | | v + Pos ---------> Z + | | ^ + | v | + ----> N ----- +>> +*) + +Lemma nat_N_Z n : Z.of_N (N.of_nat n) = Z.of_nat n. +Proof. + now destruct n. +Qed. -Open Local Scope Z_scope. +Lemma N_nat_Z n : Z.of_nat (N.to_nat n) = Z.of_N n. +Proof. + destruct n; trivial. simpl. + destruct (Pos2Nat.is_succ p) as (m,H). + rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. +Qed. -Definition neq (x y:nat) := x <> y. +Lemma positive_nat_Z p : Z.of_nat (Pos.to_nat p) = Zpos p. +Proof. + destruct (Pos2Nat.is_succ p) as (n,H). + rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. +Qed. + +Lemma positive_N_Z p : Z.of_N (Npos p) = Zpos p. +Proof. + reflexivity. +Qed. + +Lemma positive_N_nat p : N.to_nat (Npos p) = Pos.to_nat p. +Proof. + reflexivity. +Qed. + +Lemma positive_nat_N p : N.of_nat (Pos.to_nat p) = Npos p. +Proof. + destruct (Pos2Nat.is_succ p) as (n,H). + rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. +Qed. -(************************************************) -(** Properties of the injection from nat into Z *) +Lemma Z_N_nat n : N.to_nat (Z.to_N n) = Z.to_nat n. +Proof. + now destruct n. +Qed. -(** Injection and successor *) +Lemma Z_nat_N n : N.of_nat (Z.to_nat n) = Z.to_N n. +Proof. + destruct n; simpl; trivial. apply positive_nat_N. +Qed. -Theorem inj_0 : Z_of_nat 0 = 0%Z. +Lemma Zabs_N_nat n : N.to_nat (Z.abs_N n) = Z.abs_nat n. Proof. - reflexivity. + now destruct n. Qed. -Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n). +Lemma Zabs_nat_N n : N.of_nat (Z.abs_nat n) = Z.abs_N n. Proof. - intro y; induction y as [| n H]; - [ unfold Zsucc in |- *; simpl in |- *; trivial with arith - | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *; - rewrite Zpos_succ_morphism; trivial with arith ]. + destruct n; simpl; trivial; apply positive_nat_N. Qed. -(** Injection and equality. *) -Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m. +(** * Conversions between [Z] and [N] *) + +Module N2Z. + +(** [Z.of_N] is a bijection between [N] and non-negative [Z], + with [Z.to_N] (or [Z.abs_N]) as reciprocal. + See [Z2N.id] below for the dual equation. *) + +Lemma id n : Z.to_N (Z.of_N n) = n. Proof. - intros x y H; rewrite H; trivial with arith. + now destruct n. Qed. -Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m). +(** [Z.of_N] is hence injective *) + +Lemma inj n m : Z.of_N n = Z.of_N m -> n = m. Proof. - unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2; - case x; case y; intros; - [ auto with arith - | discriminate H0 - | discriminate H0 - | simpl in H0; injection H0; - do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; - intros E; rewrite E; auto with arith ]. + destruct n, m; simpl; congruence. Qed. -Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m. +Lemma inj_iff n m : Z.of_N n = Z.of_N m <-> n = m. Proof. - intros x y H. - destruct (eq_nat_dec x y) as [H'|H']; auto. - exfalso. - exact (inj_neq _ _ H' H). + split. apply inj. intros; now f_equal. Qed. -Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m. +(** [Z.of_N] produce non-negative integers *) + +Lemma is_nonneg n : 0 <= Z.of_N n. Proof. - split; [apply inj_eq | apply inj_eq_rev]. + now destruct n. Qed. +(** [Z.of_N], basic equations *) + +Lemma inj_0 : Z.of_N 0 = 0. +Proof. + reflexivity. +Qed. -(** Injection and order relations: *) +Lemma inj_pos p : Z.of_N (Npos p) = Zpos p. +Proof. + reflexivity. +Qed. -(** One way ... *) +(** [Z.of_N] and usual operations. *) -Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m. +Lemma inj_compare n m : (Z.of_N n ?= Z.of_N m) = (n ?= m)%N. Proof. - intros x y; intros H; elim H; - [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x)); - intros H1 H2; rewrite H2; [ discriminate | trivial with arith ] - | intros m H1 H2; apply Zle_trans with (Z_of_nat m); - [ assumption | rewrite inj_S; apply Zle_succ ] ]. + now destruct n, m. Qed. -Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m. +Lemma inj_le n m : (n<=m)%N <-> Z.of_N n <= Z.of_N m. Proof. - intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le; - exact H. + unfold Z.le. now rewrite inj_compare. Qed. -Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m. +Lemma inj_lt n m : (n<m)%N <-> Z.of_N n < Z.of_N m. Proof. - intros x y H; apply Zle_ge; apply inj_le; apply H. + unfold Z.lt. now rewrite inj_compare. Qed. -Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m. +Lemma inj_ge n m : (n>=m)%N <-> Z.of_N n >= Z.of_N m. Proof. - intros x y H; apply Zlt_gt; apply inj_lt; exact H. + unfold Z.ge. now rewrite inj_compare. Qed. -(** The other way ... *) +Lemma inj_gt n m : (n>m)%N <-> Z.of_N n > Z.of_N m. +Proof. + unfold Z.gt. now rewrite inj_compare. +Qed. -Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat. +Lemma inj_abs_N z : Z.of_N (Z.abs_N z) = Z.abs z. Proof. - intros x y H. - destruct (le_lt_dec x y) as [H0|H0]; auto. - exfalso. - assert (H1:=inj_lt _ _ H0). - red in H; red in H1. - rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. + now destruct z. Qed. -Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat. +Lemma inj_add n m : Z.of_N (n+m) = Z.of_N n + Z.of_N m. Proof. - intros x y H. - destruct (le_lt_dec y x) as [H0|H0]; auto. - exfalso. - assert (H1:=inj_le _ _ H0). - red in H; red in H1. - rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. + now destruct n, m. Qed. -Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat. +Lemma inj_mul n m : Z.of_N (n*m) = Z.of_N n * Z.of_N m. Proof. - intros x y H. - destruct (le_lt_dec y x) as [H0|H0]; auto. - exfalso. - assert (H1:=inj_gt _ _ H0). - red in H; red in H1. - rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. + now destruct n, m. Qed. -Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat. +Lemma inj_sub_max n m : Z.of_N (n-m) = Z.max 0 (Z.of_N n - Z.of_N m). Proof. - intros x y H. - destruct (le_lt_dec x y) as [H0|H0]; auto. - exfalso. - assert (H1:=inj_ge _ _ H0). - red in H; red in H1. - rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. + destruct n as [|n], m as [|m]; simpl; trivial. + rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub. + now destruct (Pos.sub_mask n m). Qed. -(* Both ways ... *) +Lemma inj_sub n m : (m<=n)%N -> Z.of_N (n-m) = Z.of_N n - Z.of_N m. +Proof. + intros H. rewrite inj_sub_max. + unfold N.le in H. + rewrite N.compare_antisym, <- inj_compare, Z.compare_sub in H. + destruct (Z.of_N n - Z.of_N m); trivial; now destruct H. +Qed. -Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m. +Lemma inj_succ n : Z.of_N (N.succ n) = Z.succ (Z.of_N n). Proof. - split; [apply inj_le | apply inj_le_rev]. + destruct n. trivial. simpl. now rewrite Pos.add_1_r. Qed. -Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m. +Lemma inj_pred_max n : Z.of_N (N.pred n) = Z.max 0 (Z.pred (Z.of_N n)). Proof. - split; [apply inj_lt | apply inj_lt_rev]. + unfold Z.pred. now rewrite N.pred_sub, inj_sub_max. Qed. -Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m. +Lemma inj_pred n : (0<n)%N -> Z.of_N (N.pred n) = Z.pred (Z.of_N n). Proof. - split; [apply inj_ge | apply inj_ge_rev]. + intros H. unfold Z.pred. rewrite N.pred_sub, inj_sub; trivial. + now apply N.le_succ_l in H. Qed. -Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m. +Lemma inj_min n m : Z.of_N (N.min n m) = Z.min (Z.of_N n) (Z.of_N m). Proof. - split; [apply inj_gt | apply inj_gt_rev]. + unfold Z.min, N.min. rewrite inj_compare. now case N.compare. Qed. -(** Injection and usual operations *) +Lemma inj_max n m : Z.of_N (N.max n m) = Z.max (Z.of_N n) (Z.of_N m). +Proof. + unfold Z.max, N.max. rewrite inj_compare. + case N.compare_spec; intros; subst; trivial. +Qed. -Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m. +Lemma inj_div n m : Z.of_N (n/m) = Z.of_N n / Z.of_N m. Proof. - intro x; induction x as [| n H]; intro y; destruct y as [| m]; - [ simpl in |- *; trivial with arith - | simpl in |- *; trivial with arith - | simpl in |- *; rewrite <- plus_n_O; trivial with arith - | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *; - rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l; - trivial with arith ]. + destruct m as [|m]. now destruct n. + apply Z.div_unique_pos with (Z.of_N (n mod (Npos m))). + split. apply is_nonneg. apply inj_lt. now apply N.mod_lt. + rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod. Qed. -Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m. +Lemma inj_mod n m : (m<>0)%N -> Z.of_N (n mod m) = (Z.of_N n) mod (Z.of_N m). Proof. - intro x; induction x as [| n H]; - [ simpl in |- *; trivial with arith - | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H; - rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; - trivial with arith ]. + intros Hm. + apply Z.mod_unique_pos with (Z.of_N (n / m)). + split. apply is_nonneg. apply inj_lt. now apply N.mod_lt. + rewrite <- inj_mul, <- inj_add. f_equal. now apply N.div_mod. Qed. -Theorem inj_minus1 : - forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m. +Lemma inj_quot n m : Z.of_N (n/m) = Z.of_N n ÷ Z.of_N m. Proof. - intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *; - rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus; - rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; - trivial with arith. + destruct m. + - now destruct n. + - rewrite Z.quot_div_nonneg, inj_div; trivial. apply is_nonneg. easy. Qed. -Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0. +Lemma inj_rem n m : Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m). Proof. - intros x y H; rewrite not_le_minus_0; - [ trivial with arith | apply gt_not_le; assumption ]. + destruct m. + - now destruct n. + - rewrite Z.rem_mod_nonneg, inj_mod; trivial. easy. apply is_nonneg. easy. Qed. -Theorem inj_minus : forall n m:nat, - Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m). +Lemma inj_div2 n : Z.of_N (N.div2 n) = Z.div2 (Z.of_N n). Proof. - intros. - rewrite Zmax_comm. - unfold Zmax. - destruct (le_lt_dec m n) as [H|H]. + destruct n as [|p]; trivial. now destruct p. +Qed. - rewrite (inj_minus1 _ _ H). - assert (H':=Zle_minus_le_0 _ _ (inj_le _ _ H)). - unfold Zle in H'. - rewrite <- Zcompare_antisym in H'. - destruct Zcompare; simpl in *; intuition. +Lemma inj_quot2 n : Z.of_N (N.div2 n) = Z.quot2 (Z.of_N n). +Proof. + destruct n as [|p]; trivial. now destruct p. +Qed. - rewrite (inj_minus2 _ _ H). - assert (H':=Zplus_lt_compat_r _ _ (- Z_of_nat m) (inj_lt _ _ H)). - rewrite Zplus_opp_r in H'. - unfold Zminus; rewrite H'; auto. +Lemma inj_pow n m : Z.of_N (n^m) = (Z.of_N n)^(Z.of_N m). +Proof. + symmetry. destruct n, m; trivial. now apply Z.pow_0_l. apply Z.pow_Zpos. Qed. -Theorem inj_min : forall n m:nat, - Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m). +End N2Z. + +Module Z2N. + +(** [Z.to_N] is a bijection between non-negative [Z] and [N], + with [Pos.of_N] as reciprocal. + See [N2Z.id] above for the dual equation. *) + +Lemma id n : 0<=n -> Z.of_N (Z.to_N n) = n. Proof. - induction n; destruct m; try (compute; auto; fail). - simpl min. - do 3 rewrite inj_S. - rewrite <- Zsucc_min_distr; f_equal; auto. + destruct n; (now destruct 1) || trivial. Qed. -Theorem inj_max : forall n m:nat, - Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m). +(** [Z.to_N] is hence injective for non-negative integers. *) + +Lemma inj n m : 0<=n -> 0<=m -> Z.to_N n = Z.to_N m -> n = m. Proof. - induction n; destruct m; try (compute; auto; fail). - simpl max. - do 3 rewrite inj_S. - rewrite <- Zsucc_max_distr; f_equal; auto. + intros. rewrite <- (id n), <- (id m) by trivial. now f_equal. Qed. -(** Composition of injections **) +Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_N n = Z.to_N m <-> n = m). +Proof. + intros. split. now apply inj. intros; now subst. +Qed. + +(** [Z.to_N], basic equations *) + +Lemma inj_0 : Z.to_N 0 = 0%N. +Proof. + reflexivity. +Qed. + +Lemma inj_pos n : Z.to_N (Zpos n) = Npos n. +Proof. + reflexivity. +Qed. + +Lemma inj_neg n : Z.to_N (Zneg n) = 0%N. +Proof. + reflexivity. +Qed. + +(** [Z.to_N] and operations *) + +Lemma inj_add n m : 0<=n -> 0<=m -> Z.to_N (n+m) = (Z.to_N n + Z.to_N m)%N. +Proof. + destruct n, m; trivial; (now destruct 1) || (now destruct 2). +Qed. + +Lemma inj_mul n m : 0<=n -> 0<=m -> Z.to_N (n*m) = (Z.to_N n * Z.to_N m)%N. +Proof. + destruct n, m; trivial; (now destruct 1) || (now destruct 2). +Qed. + +Lemma inj_succ n : 0<=n -> Z.to_N (Z.succ n) = N.succ (Z.to_N n). +Proof. + unfold Z.succ. intros. rewrite inj_add by easy. apply N.add_1_r. +Qed. + +Lemma inj_sub n m : 0<=m -> Z.to_N (n - m) = (Z.to_N n - Z.to_N m)%N. +Proof. + destruct n as [|n|n], m as [|m|m]; trivial; try (now destruct 1). + intros _. simpl. + rewrite Z.pos_sub_spec, Pos.compare_sub_mask. unfold Pos.sub. + now destruct (Pos.sub_mask n m). +Qed. + +Lemma inj_pred n : Z.to_N (Z.pred n) = N.pred (Z.to_N n). +Proof. + unfold Z.pred. rewrite <- N.sub_1_r. now apply (inj_sub n 1). +Qed. + +Lemma inj_compare n m : 0<=n -> 0<=m -> + (Z.to_N n ?= Z.to_N m)%N = (n ?= m). +Proof. + intros Hn Hm. now rewrite <- N2Z.inj_compare, !id. +Qed. + +Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_N n <= Z.to_N m)%N). +Proof. + intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare. +Qed. + +Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_N n < Z.to_N m)%N). +Proof. + intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare. +Qed. + +Lemma inj_min n m : Z.to_N (Z.min n m) = N.min (Z.to_N n) (Z.to_N m). +Proof. + destruct n, m; simpl; trivial; unfold Z.min, N.min; simpl; + now case Pos.compare. +Qed. + +Lemma inj_max n m : Z.to_N (Z.max n m) = N.max (Z.to_N n) (Z.to_N m). +Proof. + destruct n, m; simpl; trivial; unfold Z.max, N.max; simpl. + case Pos.compare_spec; intros; subst; trivial. + now case Pos.compare. +Qed. + +Lemma inj_div n m : 0<=n -> 0<=m -> Z.to_N (n/m) = (Z.to_N n / Z.to_N m)%N. +Proof. + destruct n, m; trivial; intros Hn Hm; + (now destruct Hn) || (now destruct Hm) || clear. + simpl. rewrite <- (N2Z.id (_ / _)). f_equal. now rewrite N2Z.inj_div. +Qed. + +Lemma inj_mod n m : 0<=n -> 0<m -> + Z.to_N (n mod m) = ((Z.to_N n) mod (Z.to_N m))%N. +Proof. + destruct n, m; trivial; intros Hn Hm; + (now destruct Hn) || (now destruct Hm) || clear. + simpl. rewrite <- (N2Z.id (_ mod _)). f_equal. now rewrite N2Z.inj_mod. +Qed. -Theorem Zpos_eq_Z_of_nat_o_nat_of_P : - forall p:positive, Zpos p = Z_of_nat (nat_of_P p). +Lemma inj_quot n m : 0<=n -> 0<=m -> Z.to_N (n÷m) = (Z.to_N n / Z.to_N m)%N. Proof. - intros x; elim x; simpl in |- *; auto. - intros p H; rewrite ZL6. - apply f_equal with (f := Zpos). - apply nat_of_P_inj. - rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *; - simpl in |- *. - rewrite ZL6; auto. - intros p H; unfold nat_of_P in |- *; simpl in |- *. - rewrite ZL6; simpl in |- *. - rewrite inj_plus; repeat rewrite <- H. - rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity. + destruct m. + - now destruct n. + - intros. now rewrite Z.quot_div_nonneg, inj_div. + - now destruct 2. Qed. -(** Misc *) +Lemma inj_rem n m :0<=n -> 0<=m -> + Z.to_N (Z.rem n m) = ((Z.to_N n) mod (Z.to_N m))%N. +Proof. + destruct m. + - now destruct n. + - intros. now rewrite Z.rem_mod_nonneg, inj_mod. + - now destruct 2. +Qed. + +Lemma inj_div2 n : Z.to_N (Z.div2 n) = N.div2 (Z.to_N n). +Proof. + destruct n as [|p|p]; trivial. now destruct p. +Qed. + +Lemma inj_quot2 n : Z.to_N (Z.quot2 n) = N.div2 (Z.to_N n). +Proof. + destruct n as [|p|p]; trivial; now destruct p. +Qed. + +Lemma inj_pow n m : 0<=n -> 0<=m -> Z.to_N (n^m) = ((Z.to_N n)^(Z.to_N m))%N. +Proof. + destruct m. + - trivial. + - intros. now rewrite <- (N2Z.id (_ ^ _)), N2Z.inj_pow, id. + - now destruct 2. +Qed. + +End Z2N. + +Module Zabs2N. + +(** Results about [Z.abs_N], converting absolute values of [Z] integers + to [N]. *) + +Lemma abs_N_spec n : Z.abs_N n = Z.to_N (Z.abs n). +Proof. + now destruct n. +Qed. + +Lemma abs_N_nonneg n : 0<=n -> Z.abs_N n = Z.to_N n. +Proof. + destruct n; trivial; now destruct 1. +Qed. + +Lemma id_abs n : Z.of_N (Z.abs_N n) = Z.abs n. +Proof. + now destruct n. +Qed. + +Lemma id n : Z.abs_N (Z.of_N n) = n. +Proof. + now destruct n. +Qed. + +(** [Z.abs_N], basic equations *) + +Lemma inj_0 : Z.abs_N 0 = 0%N. +Proof. + reflexivity. +Qed. + +Lemma inj_pos p : Z.abs_N (Zpos p) = Npos p. +Proof. + reflexivity. +Qed. + +Lemma inj_neg p : Z.abs_N (Zneg p) = Npos p. +Proof. + reflexivity. +Qed. + +(** [Z.abs_N] and usual operations, with non-negative integers *) + +Lemma inj_opp n : Z.abs_N (-n) = Z.abs_N n. +Proof. + now destruct n. +Qed. + +Lemma inj_succ n : 0<=n -> Z.abs_N (Z.succ n) = N.succ (Z.abs_N n). +Proof. + intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_succ. + now apply Z.le_le_succ_r. +Qed. + +Lemma inj_add n m : 0<=n -> 0<=m -> Z.abs_N (n+m) = (Z.abs_N n + Z.abs_N m)%N. +Proof. + intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_add. + now apply Z.add_nonneg_nonneg. +Qed. + +Lemma inj_mul n m : Z.abs_N (n*m) = (Z.abs_N n * Z.abs_N m)%N. +Proof. + now destruct n, m. +Qed. + +Lemma inj_sub n m : 0<=m<=n -> Z.abs_N (n-m) = (Z.abs_N n - Z.abs_N m)%N. +Proof. + intros (Hn,H). rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_sub. + Z.order. + now apply Z.le_0_sub. +Qed. + +Lemma inj_pred n : 0<n -> Z.abs_N (Z.pred n) = N.pred (Z.abs_N n). +Proof. + intros. rewrite !abs_N_nonneg. now apply Z2N.inj_pred. + Z.order. + apply Z.lt_succ_r. now rewrite Z.succ_pred. +Qed. + +Lemma inj_compare n m : 0<=n -> 0<=m -> + (Z.abs_N n ?= Z.abs_N m)%N = (n ?= m). +Proof. + intros. rewrite !abs_N_nonneg by trivial. now apply Z2N.inj_compare. +Qed. + +Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_N n <= Z.abs_N m)%N). +Proof. + intros Hn Hm. unfold Z.le, N.le. now rewrite inj_compare. +Qed. + +Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_N n < Z.abs_N m)%N). +Proof. + intros Hn Hm. unfold Z.lt, N.lt. now rewrite inj_compare. +Qed. + +Lemma inj_min n m : 0<=n -> 0<=m -> + Z.abs_N (Z.min n m) = N.min (Z.abs_N n) (Z.abs_N m). +Proof. + intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_min. + now apply Z.min_glb. +Qed. + +Lemma inj_max n m : 0<=n -> 0<=m -> + Z.abs_N (Z.max n m) = N.max (Z.abs_N n) (Z.abs_N m). +Proof. + intros. rewrite !abs_N_nonneg; trivial. now apply Z2N.inj_max. + transitivity n; trivial. apply Z.le_max_l. +Qed. + +Lemma inj_quot n m : Z.abs_N (n÷m) = ((Z.abs_N n) / (Z.abs_N m))%N. +Proof. + assert (forall p q, Z.abs_N (Zpos p ÷ Zpos q) = (Npos p / Npos q)%N). + intros. rewrite abs_N_nonneg. now apply Z2N.inj_quot. now apply Z.quot_pos. + destruct n, m; trivial; simpl. + - trivial. + - now rewrite <- Z.opp_Zpos, Z.quot_opp_r, inj_opp. + - now rewrite <- Z.opp_Zpos, Z.quot_opp_l, inj_opp. + - now rewrite <- 2 Z.opp_Zpos, Z.quot_opp_opp. +Qed. + +Lemma inj_rem n m : Z.abs_N (Z.rem n m) = ((Z.abs_N n) mod (Z.abs_N m))%N. +Proof. + assert + (forall p q, Z.abs_N (Z.rem (Zpos p) (Zpos q)) = ((Npos p) mod (Npos q))%N). + intros. rewrite abs_N_nonneg. now apply Z2N.inj_rem. now apply Z.rem_nonneg. + destruct n, m; trivial; simpl. + - trivial. + - now rewrite <- Z.opp_Zpos, Z.rem_opp_r. + - now rewrite <- Z.opp_Zpos, Z.rem_opp_l, inj_opp. + - now rewrite <- 2 Z.opp_Zpos, Z.rem_opp_opp, inj_opp. +Qed. + +Lemma inj_pow n m : 0<=m -> Z.abs_N (n^m) = ((Z.abs_N n)^(Z.abs_N m))%N. +Proof. + intros Hm. rewrite abs_N_spec, Z.abs_pow, Z2N.inj_pow, <- abs_N_spec; trivial. + f_equal. symmetry; now apply abs_N_nonneg. apply Z.abs_nonneg. +Qed. + +(** [Z.abs_N] and usual operations, statements with [Z.abs] *) + +Lemma inj_succ_abs n : Z.abs_N (Z.succ (Z.abs n)) = N.succ (Z.abs_N n). +Proof. + destruct n; simpl; trivial; now rewrite Pos.add_1_r. +Qed. + +Lemma inj_add_abs n m : + Z.abs_N (Z.abs n + Z.abs m) = (Z.abs_N n + Z.abs_N m)%N. +Proof. + now destruct n, m. +Qed. + +Lemma inj_mul_abs n m : + Z.abs_N (Z.abs n * Z.abs m) = (Z.abs_N n * Z.abs_N m)%N. +Proof. + now destruct n, m. +Qed. + +End Zabs2N. + + +(** * Conversions between [Z] and [nat] *) + +Module Nat2Z. + +(** [Z.of_nat], basic equations *) -Theorem intro_Z : - forall n:nat, exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0. +Lemma inj_0 : Z.of_nat 0 = 0. Proof. - intros x; exists (Z_of_nat x); split; - [ trivial with arith - | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r; - unfold Zle in |- *; elim x; intros; simpl in |- *; - discriminate ]. + reflexivity. Qed. -Lemma Zpos_P_of_succ_nat : forall n:nat, - Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n). +Lemma inj_succ n : Z.of_nat (S n) = Z.succ (Z.of_nat n). +Proof. + destruct n. trivial. simpl. symmetry. apply Z.succ_Zpos. +Qed. + +(** [Z.of_N] produce non-negative integers *) + +Lemma is_nonneg n : 0 <= Z.of_nat n. +Proof. + now induction n. +Qed. + +(** [Z.of_nat] is a bijection between [nat] and non-negative [Z], + with [Z.to_nat] (or [Z.abs_nat]) as reciprocal. + See [Z2Nat.id] below for the dual equation. *) + +Lemma id n : Z.to_nat (Z.of_nat n) = n. +Proof. + now rewrite <- nat_N_Z, <- Z_N_nat, N2Z.id, Nat2N.id. +Qed. + +(** [Z.of_nat] is hence injective *) + +Lemma inj n m : Z.of_nat n = Z.of_nat m -> n = m. +Proof. + intros H. now rewrite <- (id n), <- (id m), H. +Qed. + +Lemma inj_iff n m : Z.of_nat n = Z.of_nat m <-> n = m. +Proof. + split. apply inj. intros; now f_equal. +Qed. + +(** [Z.of_nat] and usual operations *) + +Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = nat_compare n m. +Proof. + now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare. +Qed. + +Lemma inj_le n m : (n<=m)%nat <-> Z.of_nat n <= Z.of_nat m. +Proof. + unfold Z.le. now rewrite inj_compare, nat_compare_le. +Qed. + +Lemma inj_lt n m : (n<m)%nat <-> Z.of_nat n < Z.of_nat m. +Proof. + unfold Z.lt. now rewrite inj_compare, nat_compare_lt. +Qed. + +Lemma inj_ge n m : (n>=m)%nat <-> Z.of_nat n >= Z.of_nat m. +Proof. + unfold Z.ge. now rewrite inj_compare, nat_compare_ge. +Qed. + +Lemma inj_gt n m : (n>m)%nat <-> Z.of_nat n > Z.of_nat m. +Proof. + unfold Z.gt. now rewrite inj_compare, nat_compare_gt. +Qed. + +Lemma inj_abs_nat z : Z.of_nat (Z.abs_nat z) = Z.abs z. +Proof. + destruct z; simpl; trivial; + destruct (Pos2Nat.is_succ p) as (n,H); rewrite H; simpl; f_equal; + now apply SuccNat2Pos.inv. +Qed. + +Lemma inj_add n m : Z.of_nat (n+m) = Z.of_nat n + Z.of_nat m. +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_add, N2Z.inj_add. +Qed. + +Lemma inj_mul n m : Z.of_nat (n*m) = Z.of_nat n * Z.of_nat m. +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_mul, N2Z.inj_mul. +Qed. + +Lemma inj_sub_max n m : Z.of_nat (n-m) = Z.max 0 (Z.of_nat n - Z.of_nat m). +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub_max. +Qed. + +Lemma inj_sub n m : (m<=n)%nat -> Z.of_nat (n-m) = Z.of_nat n - Z.of_nat m. +Proof. + rewrite nat_compare_le, Nat2N.inj_compare. intros. + now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub. +Qed. + +Lemma inj_pred_max n : Z.of_nat (pred n) = Z.max 0 (Z.pred (Z.of_nat n)). +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max. +Qed. + +Lemma inj_pred n : (0<n)%nat -> Z.of_nat (pred n) = Z.pred (Z.of_nat n). +Proof. + rewrite nat_compare_lt, Nat2N.inj_compare. intros. + now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred. +Qed. + +Lemma inj_min n m : Z.of_nat (min n m) = Z.min (Z.of_nat n) (Z.of_nat m). +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min. +Qed. + +Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m). +Proof. + now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max. +Qed. + +End Nat2Z. + +Module Z2Nat. + +(** [Z.to_nat] is a bijection between non-negative [Z] and [nat], + with [Pos.of_nat] as reciprocal. + See [nat2Z.id] above for the dual equation. *) + +Lemma id n : 0<=n -> Z.of_nat (Z.to_nat n) = n. +Proof. + intros. now rewrite <- Z_N_nat, <- nat_N_Z, N2Nat.id, Z2N.id. +Qed. + +(** [Z.to_nat] is hence injective for non-negative integers. *) + +Lemma inj n m : 0<=n -> 0<=m -> Z.to_nat n = Z.to_nat m -> n = m. +Proof. + intros. rewrite <- (id n), <- (id m) by trivial. now f_equal. +Qed. + +Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_nat n = Z.to_nat m <-> n = m). +Proof. + intros. split. now apply inj. intros; now subst. +Qed. + +(** [Z.to_nat], basic equations *) + +Lemma inj_0 : Z.to_nat 0 = O. +Proof. + reflexivity. +Qed. + +Lemma inj_pos n : Z.to_nat (Zpos n) = Pos.to_nat n. +Proof. + reflexivity. +Qed. + +Lemma inj_neg n : Z.to_nat (Zneg n) = O. +Proof. + reflexivity. +Qed. + +(** [Z.to_nat] and operations *) + +Lemma inj_add n m : 0<=n -> 0<=m -> + Z.to_nat (n+m) = (Z.to_nat n + Z.to_nat m)%nat. +Proof. + intros. now rewrite <- !Z_N_nat, Z2N.inj_add, N2Nat.inj_add. +Qed. + +Lemma inj_mul n m : 0<=n -> 0<=m -> + Z.to_nat (n*m) = (Z.to_nat n * Z.to_nat m)%nat. +Proof. + intros. now rewrite <- !Z_N_nat, Z2N.inj_mul, N2Nat.inj_mul. +Qed. + +Lemma inj_succ n : 0<=n -> Z.to_nat (Z.succ n) = S (Z.to_nat n). +Proof. + intros. now rewrite <- !Z_N_nat, Z2N.inj_succ, N2Nat.inj_succ. +Qed. + +Lemma inj_sub n m : 0<=m -> Z.to_nat (n - m) = (Z.to_nat n - Z.to_nat m)%nat. +Proof. + intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub. +Qed. + +Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n). +Proof. + now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred. +Qed. + +Lemma inj_compare n m : 0<=n -> 0<=m -> + nat_compare (Z.to_nat n) (Z.to_nat m) = (n ?= m). +Proof. + intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id. +Qed. + +Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_nat n <= Z.to_nat m)%nat). +Proof. + intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare. +Qed. + +Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_nat n < Z.to_nat m)%nat). +Proof. + intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare. +Qed. + +Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat m). +Proof. + now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min. +Qed. + +Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat m). +Proof. + now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max. +Qed. + +End Z2Nat. + +Module Zabs2Nat. + +(** Results about [Z.abs_nat], converting absolute values of [Z] integers + to [nat]. *) + +Lemma abs_nat_spec n : Z.abs_nat n = Z.to_nat (Z.abs n). +Proof. + now destruct n. +Qed. + +Lemma abs_nat_nonneg n : 0<=n -> Z.abs_nat n = Z.to_nat n. +Proof. + destruct n; trivial; now destruct 1. +Qed. + +Lemma id_abs n : Z.of_nat (Z.abs_nat n) = Z.abs n. +Proof. + rewrite <-Zabs_N_nat, N_nat_Z. apply Zabs2N.id_abs. +Qed. + +Lemma id n : Z.abs_nat (Z.of_nat n) = n. +Proof. + now rewrite <-Zabs_N_nat, <-nat_N_Z, Zabs2N.id, Nat2N.id. +Qed. + +(** [Z.abs_nat], basic equations *) + +Lemma inj_0 : Z.abs_nat 0 = 0%nat. +Proof. + reflexivity. +Qed. + +Lemma inj_pos p : Z.abs_nat (Zpos p) = Pos.to_nat p. +Proof. + reflexivity. +Qed. + +Lemma inj_neg p : Z.abs_nat (Zneg p) = Pos.to_nat p. +Proof. + reflexivity. +Qed. + +(** [Z.abs_nat] and usual operations, with non-negative integers *) + +Lemma inj_succ n : 0<=n -> Z.abs_nat (Z.succ n) = S (Z.abs_nat n). +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ, N2Nat.inj_succ. +Qed. + +Lemma inj_add n m : 0<=n -> 0<=m -> + Z.abs_nat (n+m) = (Z.abs_nat n + Z.abs_nat m)%nat. +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_add, N2Nat.inj_add. +Qed. + +Lemma inj_mul n m : Z.abs_nat (n*m) = (Z.abs_nat n * Z.abs_nat m)%nat. +Proof. + destruct n, m; simpl; trivial using Pos2Nat.inj_mul. +Qed. + +Lemma inj_sub n m : 0<=m<=n -> + Z.abs_nat (n-m) = (Z.abs_nat n - Z.abs_nat m)%nat. +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub. +Qed. + +Lemma inj_pred n : 0<n -> Z.abs_nat (Z.pred n) = pred (Z.abs_nat n). +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred. +Qed. + +Lemma inj_compare n m : 0<=n -> 0<=m -> + nat_compare (Z.abs_nat n) (Z.abs_nat m) = (n ?= m). +Proof. + intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare. +Qed. + +Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_nat n <= Z.abs_nat m)%nat). +Proof. + intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare. +Qed. + +Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_nat n < Z.abs_nat m)%nat). +Proof. + intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare. +Qed. + +Lemma inj_min n m : 0<=n -> 0<=m -> + Z.abs_nat (Z.min n m) = min (Z.abs_nat n) (Z.abs_nat m). +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min. +Qed. + +Lemma inj_max n m : 0<=n -> 0<=m -> + Z.abs_nat (Z.max n m) = max (Z.abs_nat n) (Z.abs_nat m). +Proof. + intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max. +Qed. + +(** [Z.abs_nat] and usual operations, statements with [Z.abs] *) + +Lemma inj_succ_abs n : Z.abs_nat (Z.succ (Z.abs n)) = S (Z.abs_nat n). +Proof. + now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ_abs, N2Nat.inj_succ. +Qed. + +Lemma inj_add_abs n m : + Z.abs_nat (Z.abs n + Z.abs m) = (Z.abs_nat n + Z.abs_nat m)%nat. +Proof. + now rewrite <- !Zabs_N_nat, Zabs2N.inj_add_abs, N2Nat.inj_add. +Qed. + +Lemma inj_mul_abs n m : + Z.abs_nat (Z.abs n * Z.abs m) = (Z.abs_nat n * Z.abs_nat m)%nat. +Proof. + now rewrite <- !Zabs_N_nat, Zabs2N.inj_mul_abs, N2Nat.inj_mul. +Qed. + +End Zabs2Nat. + + +(** Compatibility *) + +Definition neq (x y:nat) := x <> y. + +Lemma inj_neq n m : neq n m -> Zne (Z_of_nat n) (Z_of_nat m). +Proof. intros H H'. now apply H, Nat2Z.inj. Qed. + +Lemma Zpos_P_of_succ_nat n : Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n). +Proof (Nat2Z.inj_succ n). + +(** For these one, used in omega, a Definition is necessary *) + +Definition inj_eq := (f_equal Z.of_nat). +Definition inj_le n m := proj1 (Nat2Z.inj_le n m). +Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m). +Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m). +Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m). + +(** For the others, a Notation is fine *) + +Notation inj_0 := Nat2Z.inj_0 (only parsing). +Notation inj_S := Nat2Z.inj_succ (only parsing). +Notation inj_compare := Nat2Z.inj_compare (only parsing). +Notation inj_eq_rev := Nat2Z.inj (only parsing). +Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (only parsing). +Notation inj_le_iff := Nat2Z.inj_le (only parsing). +Notation inj_lt_iff := Nat2Z.inj_lt (only parsing). +Notation inj_ge_iff := Nat2Z.inj_ge (only parsing). +Notation inj_gt_iff := Nat2Z.inj_gt (only parsing). +Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (only parsing). +Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (only parsing). +Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (only parsing). +Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (only parsing). +Notation inj_plus := Nat2Z.inj_add (only parsing). +Notation inj_mult := Nat2Z.inj_mul (only parsing). +Notation inj_minus1 := Nat2Z.inj_sub (only parsing). +Notation inj_minus := Nat2Z.inj_sub_max (only parsing). +Notation inj_min := Nat2Z.inj_min (only parsing). +Notation inj_max := Nat2Z.inj_max (only parsing). + +Notation Z_of_nat_of_P := positive_nat_Z (only parsing). +Notation Zpos_eq_Z_of_nat_o_nat_of_P := + (fun p => sym_eq (positive_nat_Z p)) (only parsing). + +Notation Z_of_nat_of_N := N_nat_Z (only parsing). +Notation Z_of_N_of_nat := nat_N_Z (only parsing). + +Notation Z_of_N_eq := (f_equal Z.of_N) (only parsing). +Notation Z_of_N_eq_rev := N2Z.inj (only parsing). +Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (only parsing). +Notation Z_of_N_compare := N2Z.inj_compare (only parsing). +Notation Z_of_N_le_iff := N2Z.inj_le (only parsing). +Notation Z_of_N_lt_iff := N2Z.inj_lt (only parsing). +Notation Z_of_N_ge_iff := N2Z.inj_ge (only parsing). +Notation Z_of_N_gt_iff := N2Z.inj_gt (only parsing). +Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (only parsing). +Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (only parsing). +Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (only parsing). +Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (only parsing). +Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (only parsing). +Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (only parsing). +Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (only parsing). +Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (only parsing). +Notation Z_of_N_pos := N2Z.inj_pos (only parsing). +Notation Z_of_N_abs := N2Z.inj_abs_N (only parsing). +Notation Z_of_N_le_0 := N2Z.is_nonneg (only parsing). +Notation Z_of_N_plus := N2Z.inj_add (only parsing). +Notation Z_of_N_mult := N2Z.inj_mul (only parsing). +Notation Z_of_N_minus := N2Z.inj_sub_max (only parsing). +Notation Z_of_N_succ := N2Z.inj_succ (only parsing). +Notation Z_of_N_min := N2Z.inj_min (only parsing). +Notation Z_of_N_max := N2Z.inj_max (only parsing). +Notation Zabs_of_N := Zabs2N.id (only parsing). +Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (only parsing). +Notation Zabs_N_succ := Zabs2N.inj_succ (only parsing). +Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (only parsing). +Notation Zabs_N_plus := Zabs2N.inj_add (only parsing). +Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (only parsing). +Notation Zabs_N_mult := Zabs2N.inj_mul (only parsing). + +Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0. Proof. - intros. - unfold Z_of_nat. - destruct n. - simpl; auto. - simpl (P_of_succ_nat (S n)). - apply Zpos_succ_morphism. + intros. rewrite not_le_minus_0; auto with arith. Qed. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 26ff4251..6eb1a709 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -1,19 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znumtheory.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - Require Import ZArith_base. Require Import ZArithRing. Require Import Zcomplements. Require Import Zdiv. Require Import Wf_nat. -Open Local Scope Z_scope. + +(** For compatibility reasons, this Open Scope isn't local as it should *) + +Open Scope Z_scope. (** This file contains some notions of number theory upon Z numbers: - a divisibility predicate [Zdivide] @@ -21,308 +22,173 @@ Open Local Scope Z_scope. - Euclid algorithm [euclid] - a relatively prime predicate [rel_prime] - a prime predicate [prime] - - an efficient [Zgcd] function + - properties of the efficient [Z.gcd] function *) -(** * Divisibility *) +Notation Zgcd := Z.gcd (only parsing). +Notation Zggcd := Z.ggcd (only parsing). +Notation Zggcd_gcd := Z.ggcd_gcd (only parsing). +Notation Zggcd_correct_divisors := Z.ggcd_correct_divisors (only parsing). +Notation Zgcd_divide_l := Z.gcd_divide_l (only parsing). +Notation Zgcd_divide_r := Z.gcd_divide_r (only parsing). +Notation Zgcd_greatest := Z.gcd_greatest (only parsing). +Notation Zgcd_nonneg := Z.gcd_nonneg (only parsing). +Notation Zggcd_opp := Z.ggcd_opp (only parsing). -Inductive Zdivide (a b:Z) : Prop := - Zdivide_intro : forall q:Z, b = q * a -> Zdivide a b. +(** The former specialized inductive predicate [Zdivide] is now + a generic existential predicate. *) -(** Syntax for divisibility *) +Notation Zdivide := Z.divide (only parsing). -Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope. +(** Its former constructor is now a pseudo-constructor. *) -(** Results concerning divisibility*) +Definition Zdivide_intro a b q (H:b=q*a) : Z.divide a b := ex_intro _ q H. -Lemma Zdivide_refl : forall a:Z, (a | a). -Proof. - intros; apply Zdivide_intro with 1; ring. -Qed. - -Lemma Zone_divide : forall a:Z, (1 | a). -Proof. - intros; apply Zdivide_intro with a; ring. -Qed. - -Lemma Zdivide_0 : forall a:Z, (a | 0). -Proof. - intros; apply Zdivide_intro with 0; ring. -Qed. - -Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith. - -Lemma Zmult_divide_compat_l : forall a b c:Z, (a | b) -> (c * a | c * b). -Proof. - simple induction 1; intros; apply Zdivide_intro with q. - rewrite H0; ring. -Qed. - -Lemma Zmult_divide_compat_r : forall a b c:Z, (a | b) -> (a * c | b * c). -Proof. - intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c). - apply Zmult_divide_compat_l; trivial. -Qed. - -Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith. - -Lemma Zdivide_plus_r : forall a b c:Z, (a | b) -> (a | c) -> (a | b + c). -Proof. - simple induction 1; intros q Hq; simple induction 1; intros q' Hq'. - apply Zdivide_intro with (q + q'). - rewrite Hq; rewrite Hq'; ring. -Qed. - -Lemma Zdivide_opp_r : forall a b:Z, (a | b) -> (a | - b). -Proof. - simple induction 1; intros; apply Zdivide_intro with (- q). - rewrite H0; ring. -Qed. - -Lemma Zdivide_opp_r_rev : forall a b:Z, (a | - b) -> (a | b). -Proof. - intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring. -Qed. +(** Results concerning divisibility*) -Lemma Zdivide_opp_l : forall a b:Z, (a | b) -> (- a | b). -Proof. - simple induction 1; intros; apply Zdivide_intro with (- q). - rewrite H0; ring. -Qed. +Notation Zdivide_refl := Z.divide_refl (only parsing). +Notation Zone_divide := Z.divide_1_l (only parsing). +Notation Zdivide_0 := Z.divide_0_r (only parsing). +Notation Zmult_divide_compat_l := Z.mul_divide_mono_l (only parsing). +Notation Zmult_divide_compat_r := Z.mul_divide_mono_r (only parsing). +Notation Zdivide_plus_r := Z.divide_add_r (only parsing). +Notation Zdivide_minus_l := Z.divide_sub_r (only parsing). +Notation Zdivide_mult_l := Z.divide_mul_l (only parsing). +Notation Zdivide_mult_r := Z.divide_mul_r (only parsing). +Notation Zdivide_factor_r := Z.divide_factor_l (only parsing). +Notation Zdivide_factor_l := Z.divide_factor_r (only parsing). -Lemma Zdivide_opp_l_rev : forall a b:Z, (- a | b) -> (a | b). -Proof. - intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring. -Qed. +Lemma Zdivide_opp_r a b : (a | b) -> (a | - b). +Proof. apply Z.divide_opp_r. Qed. -Lemma Zdivide_minus_l : forall a b c:Z, (a | b) -> (a | c) -> (a | b - c). -Proof. - simple induction 1; intros q Hq; simple induction 1; intros q' Hq'. - apply Zdivide_intro with (q - q'). - rewrite Hq; rewrite Hq'; ring. -Qed. +Lemma Zdivide_opp_r_rev a b : (a | - b) -> (a | b). +Proof. apply Z.divide_opp_r. Qed. -Lemma Zdivide_mult_l : forall a b c:Z, (a | b) -> (a | b * c). -Proof. - simple induction 1; intros q Hq; apply Zdivide_intro with (q * c). - rewrite Hq; ring. -Qed. +Lemma Zdivide_opp_l a b : (a | b) -> (- a | b). +Proof. apply Z.divide_opp_l. Qed. -Lemma Zdivide_mult_r : forall a b c:Z, (a | c) -> (a | b * c). -Proof. - simple induction 1; intros q Hq; apply Zdivide_intro with (q * b). - rewrite Hq; ring. -Qed. +Lemma Zdivide_opp_l_rev a b : (- a | b) -> (a | b). +Proof. apply Z.divide_opp_l. Qed. -Lemma Zdivide_factor_r : forall a b:Z, (a | a * b). -Proof. - intros; apply Zdivide_intro with b; ring. -Qed. +Theorem Zdivide_Zabs_l a b : (Z.abs a | b) -> (a | b). +Proof. apply Z.divide_abs_l. Qed. -Lemma Zdivide_factor_l : forall a b:Z, (a | b * a). -Proof. - intros; apply Zdivide_intro with b; ring. -Qed. +Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b). +Proof. apply Z.divide_abs_l. Qed. +Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith. +Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith. Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l Zdivide_opp_l_rev Zdivide_minus_l Zdivide_mult_l Zdivide_mult_r Zdivide_factor_r Zdivide_factor_l: zarith. (** Auxiliary result. *) -Lemma Zmult_one : forall x y:Z, x >= 0 -> x * y = 1 -> x = 1. +Lemma Zmult_one x y : x >= 0 -> x * y = 1 -> x = 1. Proof. - intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg]. - assumption. - rewrite Hneg in H; simpl in H. - contradiction (Zle_not_lt 0 (-1)). - apply Zge_le; assumption. - apply Zorder.Zlt_neg_0. + Z.swap_greater. apply Z.eq_mul_1_nonneg. Qed. (** Only [1] and [-1] divide [1]. *) -Lemma Zdivide_1 : forall x:Z, (x | 1) -> x = 1 \/ x = -1. -Proof. - simple induction 1; intros. - elim (Z_lt_ge_dec 0 x); [ left | right ]. - apply Zmult_one with q; auto with zarith; rewrite H0; ring. - assert (- x = 1); auto with zarith. - apply Zmult_one with (- q); auto with zarith; rewrite H0; ring. -Qed. +Notation Zdivide_1 := Z.divide_1_r (only parsing). (** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *) -Lemma Zdivide_antisym : forall a b:Z, (a | b) -> (b | a) -> a = b \/ a = - b. -Proof. - simple induction 1; intros. - inversion H1. - rewrite H0 in H2; clear H H1. - case (Z_zerop a); intro. - left; rewrite H0; rewrite e; ring. - assert (Hqq0 : q0 * q = 1). - apply Zmult_reg_l with a. - assumption. - ring_simplify. - pattern a at 2 in |- *; rewrite H2; ring. - assert (q | 1). - rewrite <- Hqq0; auto with zarith. - elim (Zdivide_1 q H); intros. - rewrite H1 in H0; left; omega. - rewrite H1 in H0; right; omega. -Qed. - -Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) -> (a | c). -Proof. - intros a b c [d H1] [e H2]; exists (d * e); auto with zarith. - rewrite H2; rewrite H1; ring. -Qed. +Notation Zdivide_antisym := Z.divide_antisym (only parsing). +Notation Zdivide_trans := Z.divide_trans (only parsing). (** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *) -Lemma Zdivide_bounds : forall a b:Z, (a | b) -> b <> 0 -> Zabs a <= Zabs b. +Lemma Zdivide_bounds a b : (a | b) -> b <> 0 -> Z.abs a <= Z.abs b. Proof. - simple induction 1; intros. - assert (Zabs b = Zabs q * Zabs a). - subst; apply Zabs_Zmult. - rewrite H2. - assert (H3 := Zabs_pos q). - assert (H4 := Zabs_pos a). - assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith. - apply Zmult_ge_compat; auto with zarith. - elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ]. - assert (Zabs q = 0). - omega. - assert (q = 0). - rewrite <- (Zabs_Zsgn q). - rewrite H5; auto with zarith. - subst q; omega. + intros H Hb. + rewrite <- Z.divide_abs_l, <- Z.divide_abs_r in H. + apply Z.abs_pos in Hb. + now apply Z.divide_pos_le. Qed. (** [Zdivide] can be expressed using [Zmod]. *) Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a). Proof. - intros a b NZ EQ. - apply Zdivide_intro with (a/b). - rewrite (Z_div_mod_eq_full a b NZ) at 1. - rewrite EQ; ring. + apply Z.mod_divide. Qed. Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0. Proof. - intros a b (c,->); apply Z_mod_mult. + intros a b (c,->); apply Z_mod_mult. Qed. (** [Zdivide] is hence decidable *) -Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}. -Proof. - intros a b; elim (Ztrichotomy_inf a 0). - (* a<0 *) - intros H; elim H; intros. - case (Z_eq_dec (b mod - a) 0). - left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith. - intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. - (* a=0 *) - case (Z_eq_dec b 0); intro. - left; subst; auto with zarith. - right; subst; intro H0; inversion H0; omega. - (* a>0 *) - intro H; case (Z_eq_dec (b mod a) 0). - left; apply Zmod_divide; auto with zarith. - intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. -Qed. - -Theorem Zdivide_Zdiv_eq: forall a b : Z, - 0 < a -> (a | b) -> b = a * (b / a). +Lemma Zdivide_dec a b : {(a | b)} + {~ (a | b)}. Proof. - intros a b Hb Hc. - pattern b at 1; rewrite (Z_div_mod_eq b a); auto with zarith. - rewrite (Zdivide_mod b a); auto with zarith. -Qed. - -Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, - 0 < a -> (a | b) -> (c * b)/a = c * (b / a). -Proof. - intros a b c H1 H2. - inversion H2 as [z Hz]. - rewrite Hz; rewrite Zmult_assoc. - repeat rewrite Z_div_mult; auto with zarith. -Qed. + destruct (Z.eq_dec a 0) as [Ha|Ha]. + destruct (Z.eq_dec b 0) as [Hb|Hb]. + left; subst; apply Z.divide_0_r. + right. subst. contradict Hb. now apply Z.divide_0_l. + destruct (Z.eq_dec (b mod a) 0). + left. now apply Z.mod_divide. + right. now rewrite <- Z.mod_divide. +Defined. -Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) -> (a | b). +Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) -> b = a * (b / a). Proof. - intros a b [x H]; subst b. - pattern (Zabs a); apply Zabs_intro. - exists (- x); ring. - exists x; ring. + intros Ha H. + rewrite (Z.div_mod b a) at 1; auto with zarith. + rewrite Zdivide_mod; auto with zarith. Qed. -Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) -> (Zabs a | b). +Theorem Zdivide_Zdiv_eq_2 a b c : + 0 < a -> (a | b) -> (c * b) / a = c * (b / a). Proof. - intros a b [x H]; subst b. - pattern (Zabs a); apply Zabs_intro. - exists (- x); ring. - exists x; ring. + intros. apply Z.divide_div_mul_exact; auto with zarith. Qed. Theorem Zdivide_le: forall a b : Z, 0 <= a -> 0 < b -> (a | b) -> a <= b. Proof. - intros a b H1 H2 [q H3]; subst b. - case (Zle_lt_or_eq 0 a); auto with zarith; intros H3. - case (Zle_lt_or_eq 0 q); auto with zarith. - apply (Zmult_le_0_reg_r a); auto with zarith. - intros H4; apply Zle_trans with (1 * a); auto with zarith. - intros H4; subst q; omega. + intros. now apply Z.divide_pos_le. Qed. -Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, +Theorem Zdivide_Zdiv_lt_pos a b : 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . Proof. - intros a b H1 H2 H3; split. - apply Zmult_lt_reg_r with a; auto with zarith. - rewrite (Zmult_comm (Zdiv b a)); rewrite <- Zdivide_Zdiv_eq; auto with zarith. - apply Zmult_lt_reg_r with a; auto with zarith. - repeat rewrite (fun x => Zmult_comm x a); auto with zarith. + intros H1 H2 H3; split. + apply Z.mul_pos_cancel_l with a; auto with zarith. rewrite <- Zdivide_Zdiv_eq; auto with zarith. - pattern b at 1; replace b with (1 * b); auto with zarith. - apply Zmult_lt_compat_r; auto with zarith. + now apply Z.div_lt. Qed. -Lemma Zmod_div_mod: forall n m a, 0 < n -> 0 < m -> - (n | m) -> a mod n = (a mod m) mod n. +Lemma Zmod_div_mod n m a: + 0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n. Proof. - intros n m a H1 H2 H3. - pattern a at 1; rewrite (Z_div_mod_eq a m); auto with zarith. - case H3; intros q Hq; pattern m at 1; rewrite Hq. - rewrite (Zmult_comm q). - rewrite Zplus_mod; auto with zarith. - rewrite <- Zmult_assoc; rewrite Zmult_mod; auto with zarith. - rewrite Z_mod_same; try rewrite Zmult_0_l; auto with zarith. - rewrite (Zmod_small 0); auto with zarith. - rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. + intros H1 H2 (p,Hp). + rewrite (Z.div_mod a m) at 1; auto with zarith. + rewrite Hp at 1. + rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith. Qed. -Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> - a mod b = c -> (b | a - c). +Lemma Zmod_divide_minus a b c: + 0 < b -> a mod b = c -> (b | a - c). Proof. - intros a b c H H1; apply Zmod_divide; auto with zarith. + intros H H1. apply Z.mod_divide; auto with zarith. rewrite Zminus_mod; auto with zarith. - rewrite H1; pattern c at 1; rewrite <- (Zmod_small c b); auto with zarith. - rewrite Zminus_diag; apply Zmod_small; auto with zarith. - subst; apply Z_mod_lt; auto with zarith. + rewrite H1. rewrite <- (Z.mod_small c b) at 1. + rewrite Z.sub_diag, Z.mod_0_l; auto with zarith. + subst. now apply Z.mod_pos_bound. Qed. -Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> - (b | a - c) -> a mod b = c. +Lemma Zdivide_mod_minus a b c: + 0 <= c < b -> (b | a - c) -> a mod b = c. Proof. - intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto. + intros (H1, H2) H3. + assert (0 < b) by Z.order. replace a with ((a - c) + c); auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite (Zdivide_mod (a -c) b); try rewrite Zplus_0_l; auto with zarith. - rewrite Zmod_mod; try apply Zmod_small; auto with zarith. + rewrite Z.add_mod; auto with zarith. + rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith. + rewrite Z.mod_mod; try apply Zmod_small; auto with zarith. Qed. (** * Greatest common divisor (gcd). *) @@ -338,12 +204,12 @@ Inductive Zis_gcd (a b d:Z) : Prop := (** Trivial properties of [gcd] *) -Lemma Zis_gcd_sym : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a d. +Lemma Zis_gcd_sym : forall a b d, Zis_gcd a b d -> Zis_gcd b a d. Proof. - simple induction 1; constructor; intuition. + induction 1; constructor; intuition. Qed. -Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 a. +Lemma Zis_gcd_0 : forall a, Zis_gcd a 0 a. Proof. constructor; auto with zarith. Qed. @@ -358,19 +224,18 @@ Proof. constructor; auto with zarith. Qed. -Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d. +Lemma Zis_gcd_minus : forall a b d, Zis_gcd a (- b) d -> Zis_gcd b a d. Proof. - simple induction 1; constructor; intuition. + induction 1; constructor; intuition. Qed. -Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d). +Lemma Zis_gcd_opp : forall a b d, Zis_gcd a b d -> Zis_gcd b a (- d). Proof. - simple induction 1; constructor; intuition. + induction 1; constructor; intuition. Qed. -Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a). +Lemma Zis_gcd_0_abs a : Zis_gcd 0 a (Z.abs a). Proof. - intros a. apply Zabs_ind. intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto. intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto. @@ -429,7 +294,7 @@ Section extended_euclid_algorithm. (** The recursive part of Euclid's algorithm uses well-founded recursion of non-negative integers. It maintains 6 integers [u1,u2,u3,v1,v2,v3] such that the following invariant holds: - [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. + [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u3,v3)=gcd(a,b)]. *) Lemma euclid_rec : @@ -519,14 +384,15 @@ Qed. Lemma Zis_gcd_mult : forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d). Proof. - intros a b c d; simple induction 1; constructor; intuition. - elim (Zis_gcd_bezout a b d H). intros. - elim H3; intros. - elim H4; intros. - apply Zdivide_intro with (u * q + v * q0). - rewrite <- H5. + intros a b c d; simple induction 1. constructor; auto with zarith. + intros x Ha Hb. + elim (Zis_gcd_bezout a b d H). intros u v Huv. + elim Ha; intros a' Ha'. + elim Hb; intros b' Hb'. + apply Zdivide_intro with (u * a' + v * b'). + rewrite <- Huv. replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)). - rewrite H6; rewrite H7; ring. + rewrite Ha'; rewrite Hb'; ring. ring. Qed. @@ -625,14 +491,14 @@ Proof. exists a'; auto with zarith. exists b'; auto with zarith. intros x (xa,H5) (xb,H6). - destruct (H4 (x*g)). + destruct (H4 (x*g)) as (x',Hx'). exists xa; rewrite Zmult_assoc; rewrite <- H5; auto. exists xb; rewrite Zmult_assoc; rewrite <- H6; auto. - replace g with (1*g) in H7; auto with zarith. - do 2 rewrite Zmult_assoc in H7. - generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros. - rewrite Zmult_1_r in H7. - exists q; auto with zarith. + replace g with (1*g) in Hx'; auto with zarith. + do 2 rewrite Zmult_assoc in Hx'. + apply Zmult_reg_r in Hx'; trivial. + rewrite Zmult_1_r in Hx'. + exists x'; auto with zarith. Qed. Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a. @@ -875,249 +741,62 @@ Proof. contradict Hp; auto with zarith. Qed. +(** we now prove that [Z.gcd] is indeed a gcd in + the sense of [Zis_gcd]. *) -(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose - here a binary version of [Zgcd], faster and executable within Coq. - - Algorithm: - - gcd 0 b = b - gcd a 0 = a - gcd (2a) (2b) = 2(gcd a b) - gcd (2a+1) (2b) = gcd (2a+1) b - gcd (2a) (2b+1) = gcd a (2b+1) - gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1) - or gcd (a-b) (2*b+1), depending on whether a<b -*) +Notation Zgcd_is_pos := Z.gcd_nonneg (only parsing). -Open Scope positive_scope. - -Fixpoint Pgcdn (n: nat) (a b : positive) : positive := - match n with - | O => 1 - | S n => - match a,b with - | xH, _ => 1 - | _, xH => 1 - | xO a, xO b => xO (Pgcdn n a b) - | a, xO b => Pgcdn n a b - | xO a, b => Pgcdn n a b - | xI a', xI b' => - match Pcompare a' b' Eq with - | Eq => a - | Lt => Pgcdn n (b'-a') a - | Gt => Pgcdn n (a'-b') b - end - end - end. - -Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b. - -Close Scope positive_scope. - -Definition Zgcd (a b : Z) : Z := - match a,b with - | Z0, _ => Zabs b - | _, Z0 => Zabs a - | Zpos a, Zpos b => Zpos (Pgcd a b) - | Zpos a, Zneg b => Zpos (Pgcd a b) - | Zneg a, Zpos b => Zpos (Pgcd a b) - | Zneg a, Zneg b => Zpos (Pgcd a b) - end. - -Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b. +Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b). Proof. - unfold Zgcd; destruct a; destruct b; auto with zarith. -Qed. - -Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> - Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. -Proof. - intros. - destruct H. - constructor; auto. - destruct H as (e,H2); exists (2*e); auto with zarith. - rewrite Zpos_xO; rewrite H2; ring. - intros. - apply H1; auto. - rewrite Zpos_xO in H2. - rewrite Zpos_xI in H3. - apply Gauss with 2; auto. - apply bezout_rel_prime. - destruct H3 as (bb, H3). - apply Bezout_intro with bb (-Zpos b). - omega. -Qed. - -Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> - Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)). -Proof. - intro n; pattern n; apply lt_wf_ind; clear n; intros. - destruct n. - simpl. - destruct a; simpl in *; try inversion H0. - destruct a. - destruct b; simpl. - case_eq (Pcompare a b Eq); intros. - (* a = xI, b = xI, compare = Eq *) - rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl. - (* a = xI, b = xI, compare = Lt *) - apply Zis_gcd_sym. - apply Zis_gcd_for_euclid with 1. - apply Zis_gcd_sym. - replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))). - apply Zis_gcd_even_odd. - apply H; auto. - simpl in *. - assert (Psize (b-a) <= Psize b)%nat. - apply Psize_monotone. - change (Zpos (b-a) < Zpos b). - rewrite (Zpos_minus_morphism _ _ H1). - assert (0 < Zpos a) by (compute; auto). - omega. - omega. - rewrite Zpos_xO; do 2 rewrite Zpos_xI. - rewrite Zpos_minus_morphism; auto. - omega. - (* a = xI, b = xI, compare = Gt *) - apply Zis_gcd_for_euclid with 1. - replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))). - apply Zis_gcd_sym. - apply Zis_gcd_even_odd. - apply H; auto. - simpl in *. - assert (Psize (a-b) <= Psize a)%nat. - apply Psize_monotone. - change (Zpos (a-b) < Zpos a). - rewrite (Zpos_minus_morphism b a). - assert (0 < Zpos b) by (compute; auto). - omega. - rewrite ZC4; rewrite H1; auto. - omega. - rewrite Zpos_xO; do 2 rewrite Zpos_xI. - rewrite Zpos_minus_morphism; auto. - omega. - rewrite ZC4; rewrite H1; auto. - (* a = xI, b = xO *) - apply Zis_gcd_sym. - apply Zis_gcd_even_odd. - apply Zis_gcd_sym. - apply H; auto. - simpl in *; omega. - (* a = xI, b = xH *) - apply Zis_gcd_1. - destruct b; simpl. - (* a = xO, b = xI *) - apply Zis_gcd_even_odd. - apply H; auto. - simpl in *; omega. - (* a = xO, b = xO *) - rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)). - apply Zis_gcd_mult. - apply H; auto. - simpl in *; omega. - (* a = xO, b = xH *) - apply Zis_gcd_1. - (* a = xH *) - simpl; apply Zis_gcd_sym; apply Zis_gcd_1. -Qed. - -Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)). -Proof. - unfold Pgcd; intros. - apply Pgcdn_correct; auto. -Qed. - -Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b). -Proof. - destruct a. - intros. - simpl. - apply Zis_gcd_0_abs. - destruct b; simpl. - apply Zis_gcd_0. - apply Pgcd_correct. - apply Zis_gcd_sym. - apply Zis_gcd_minus; simpl. - apply Pgcd_correct. - destruct b; simpl. - apply Zis_gcd_minus; simpl. - apply Zis_gcd_sym. - apply Zis_gcd_0. - apply Zis_gcd_minus; simpl. - apply Zis_gcd_sym. - apply Pgcd_correct. - apply Zis_gcd_sym. - apply Zis_gcd_minus; simpl. - apply Zis_gcd_minus; simpl. - apply Zis_gcd_sym. - apply Pgcd_correct. + constructor. + apply Z.gcd_divide_l. + apply Z.gcd_divide_r. + apply Z.gcd_greatest. Qed. Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}. Proof. - intros x y; exists (Zgcd x y). - split; [apply Zgcd_is_gcd | apply Zgcd_is_pos]. + intros x y; exists (Z.gcd x y). + split; [apply Zgcd_is_gcd | apply Z.gcd_nonneg]. Qed. Theorem Zdivide_Zgcd: forall p q r : Z, - (p | q) -> (p | r) -> (p | Zgcd q r). + (p | q) -> (p | r) -> (p | Z.gcd q r). Proof. - intros p q r H1 H2. - assert (H3: (Zis_gcd q r (Zgcd q r))). - apply Zgcd_is_gcd. - inversion_clear H3; auto. + intros. now apply Z.gcd_greatest. Qed. Theorem Zis_gcd_gcd: forall a b c : Z, - 0 <= c -> Zis_gcd a b c -> Zgcd a b = c. + 0 <= c -> Zis_gcd a b c -> Z.gcd a b = c. Proof. intros a b c H1 H2. case (Zis_gcd_uniqueness_apart_sign a b c (Zgcd a b)); auto. apply Zgcd_is_gcd; auto. - case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; subst; auto. - intros H3; subst. - generalize (Zgcd_is_pos a b); auto with zarith. - case (Zgcd a b); simpl; auto; intros; discriminate. -Qed. - -Theorem Zgcd_inv_0_l: forall x y, Zgcd x y = 0 -> x = 0. -Proof. - intros x y H. - assert (F1: Zdivide 0 x). - rewrite <- H. - generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto. - inversion F1 as [z H1]. - rewrite H1; ring. + Z.le_elim H1. + generalize (Z.gcd_nonneg a b); auto with zarith. + subst. now case (Z.gcd a b). Qed. -Theorem Zgcd_inv_0_r: forall x y, Zgcd x y = 0 -> y = 0. -Proof. - intros x y H. - assert (F1: Zdivide 0 y). - rewrite <- H. - generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto. - inversion F1 as [z H1]. - rewrite H1; ring. -Qed. +Notation Zgcd_inv_0_l := Z.gcd_eq_0_l (only parsing). +Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (only parsing). Theorem Zgcd_div_swap0 : forall a b : Z, - 0 < Zgcd a b -> + 0 < Z.gcd a b -> 0 < b -> - (a / Zgcd a b) * b = a * (b/Zgcd a b). + (a / Z.gcd a b) * b = a * (b/Z.gcd a b). Proof. intros a b Hg Hb. assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. - pattern b at 2; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto. repeat rewrite Zmult_assoc; f_equal. rewrite Zmult_comm. rewrite <- Zdivide_Zdiv_eq; auto. Qed. Theorem Zgcd_div_swap : forall a b c : Z, - 0 < Zgcd a b -> + 0 < Z.gcd a b -> 0 < b -> - (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b). + (c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b). Proof. intros a b c Hg Hb. assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3]. @@ -1129,44 +808,21 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Lemma Zgcd_comm : forall a b, Zgcd a b = Zgcd b a. -Proof. - intros. - apply Zis_gcd_gcd. - apply Zgcd_is_pos. - apply Zis_gcd_sym. - apply Zgcd_is_gcd. -Qed. - -Lemma Zgcd_ass : forall a b c, Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c). -Proof. - intros. - apply Zis_gcd_gcd. - apply Zgcd_is_pos. - destruct (Zgcd_is_gcd a b). - destruct (Zgcd_is_gcd b c). - destruct (Zgcd_is_gcd a (Zgcd b c)). - constructor; eauto using Zdivide_trans. -Qed. +Notation Zgcd_comm := Z.gcd_comm (only parsing). -Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b. +Lemma Zgcd_ass a b c : Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c). Proof. - destruct a; simpl; auto. + symmetry. apply Z.gcd_assoc. Qed. -Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a. -Proof. - destruct a; simpl; auto. -Qed. +Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing). +Notation Zgcd_0 := Z.gcd_0_r (only parsing). +Notation Zgcd_1 := Z.gcd_1_r (only parsing). -Lemma Zgcd_1 : forall a, Zgcd a 1 = 1. -Proof. - intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1. -Qed. Hint Resolve Zgcd_0 Zgcd_1 : zarith. Theorem Zgcd_1_rel_prime : forall a b, - Zgcd a b = 1 <-> rel_prime a b. + Z.gcd a b = 1 <-> rel_prime a b. Proof. unfold rel_prime; split; intro H. rewrite <- H; apply Zgcd_is_gcd. @@ -1249,167 +905,3 @@ Proof. absurd (n = 0); auto with zarith. case Hr1; auto with zarith. Qed. - -(** A Generalized Gcd that also computes Bezout coefficients. - The algorithm is the same as for Zgcd. *) - -Open Scope positive_scope. - -Fixpoint Pggcdn (n: nat) (a b : positive) : (positive*(positive*positive)) := - match n with - | O => (1,(a,b)) - | S n => - match a,b with - | xH, b => (1,(1,b)) - | a, xH => (1,(a,1)) - | xO a, xO b => - let (g,p) := Pggcdn n a b in - (xO g,p) - | a, xO b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in - (g,(aa, xO bb)) - | xO a, b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in - (g,(xO aa, bb)) - | xI a', xI b' => - match Pcompare a' b' Eq with - | Eq => (a,(1,1)) - | Lt => - let (g,p) := Pggcdn n (b'-a') a in - let (ba,aa) := p in - (g,(aa, aa + xO ba)) - | Gt => - let (g,p) := Pggcdn n (a'-b') b in - let (ab,bb) := p in - (g,(bb+xO ab, bb)) - end - end - end. - -Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b. - -Open Scope Z_scope. - -Definition Zggcd (a b : Z) : Z*(Z*Z) := - match a,b with - | Z0, _ => (Zabs b,(0, Zsgn b)) - | _, Z0 => (Zabs a,(Zsgn a, 0)) - | Zpos a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in - (Zpos g, (Zpos aa, Zpos bb)) - | Zpos a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in - (Zpos g, (Zpos aa, Zneg bb)) - | Zneg a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in - (Zpos g, (Zneg aa, Zpos bb)) - | Zneg a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in - (Zpos g, (Zneg aa, Zneg bb)) - end. - - -Lemma Pggcdn_gcdn : forall n a b, - fst (Pggcdn n a b) = Pgcdn n a b. -Proof. - induction n. - simpl; auto. - destruct a; destruct b; simpl; auto. - destruct (Pcompare a b Eq); simpl; auto. - rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto. - rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto. - rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto. - rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto. - rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto. -Qed. - -Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b. -Proof. - intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b). -Qed. - -Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b. -Proof. - destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; - destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto. -Qed. - -Open Scope positive_scope. - -Lemma Pggcdn_correct_divisors : forall n a b, - let (g,p) := Pggcdn n a b in - let (aa,bb):=p in - (a=g*aa) /\ (b=g*bb). -Proof. - induction n. - simpl; auto. - destruct a; destruct b; simpl; auto. - case_eq (Pcompare a b Eq); intros. - (* Eq *) - rewrite Pmult_comm; simpl; auto. - rewrite (Pcompare_Eq_eq _ _ H); auto. - (* Lt *) - generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl. - intros (H0,H1); split; auto. - rewrite Pmult_plus_distr_l. - rewrite Pmult_xO_permute_r. - rewrite <- H1; rewrite <- H0. - simpl; f_equal; symmetry. - apply Pplus_minus; auto. - rewrite ZC4; rewrite H; auto. - (* Gt *) - generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl. - intros (H0,H1); split; auto. - rewrite Pmult_plus_distr_l. - rewrite Pmult_xO_permute_r. - rewrite <- H1; rewrite <- H0. - simpl; f_equal; symmetry. - apply Pplus_minus; auto. - (* Then... *) - generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl. - intros (H0,H1); split; auto. - rewrite Pmult_xO_permute_r; rewrite H1; auto. - generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl. - intros (H0,H1); split; auto. - rewrite Pmult_xO_permute_r; rewrite H0; auto. - generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl. - intros (H0,H1); split; subst; auto. -Qed. - -Lemma Pggcd_correct_divisors : forall a b, - let (g,p) := Pggcd a b in - let (aa,bb):=p in - (a=g*aa) /\ (b=g*bb). -Proof. - intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b). -Qed. - -Close Scope positive_scope. - -Lemma Zggcd_correct_divisors : forall a b, - let (g,p) := Zggcd a b in - let (aa,bb):=p in - (a=g*aa) /\ (b=g*bb). -Proof. - destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; - generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); - destruct 1; subst; auto. -Qed. - -Theorem Zggcd_opp: forall x y, - Zggcd (-x) y = let (p1,p) := Zggcd x y in - let (p2,p3) := p in - (p1,(-p2,p3)). -Proof. -intros [|x|x] [|y|y]; unfold Zggcd, Zopp; auto. -case Pggcd; intros p1 (p2, p3); auto. -case Pggcd; intros p1 (p2, p3); auto. -case Pggcd; intros p1 (p2, p3); auto. -case Pggcd; intros p1 (p2, p3); auto. -Qed. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 91c16929..a8cd69bb 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -1,337 +1,200 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zorder.v 14641 2011-11-06 11:59:10Z herbelin $ i*) -(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) +(** Binary Integers : results about order predicates *) +(** Initial author : Pierre Crégut (CNET, Lannion, France) *) -Require Import BinPos. -Require Import BinInt. -Require Import Arith_base. -Require Import Decidable. -Require Import Zcompare. +(** THIS FILE IS DEPRECATED. + It is now almost entirely made of compatibility formulations + for results already present in BinInt.Z. *) -Open Local Scope Z_scope. +Require Import BinPos BinInt Decidable Zcompare. +Require Import Arith_base. (* Useless now, for compatibility only *) -Implicit Types x y z : Z. +Local Open Scope Z_scope. (*********************************************************) (** Properties of the order relations on binary integers *) (** * Trichotomy *) -Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}. +Theorem Ztrichotomy_inf n m : {n < m} + {n = m} + {n > m}. Proof. - unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)). - set (x := m ?= n) in H at 2 |- *. - destruct x; - [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ]; - reflexivity. -Qed. + unfold ">", "<". generalize (Z.compare_eq n m). + destruct (n ?= m); [ left; right | left; left | right]; auto. +Defined. -Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m. +Theorem Ztrichotomy n m : n < m \/ n = m \/ n > m. Proof. - intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt]; - [ left | right; left | right; right ]; assumption. + Z.swap_greater. apply Z.lt_trichotomy. Qed. (**********************************************************************) (** * Decidability of equality and order on Z *) -Theorem dec_eq : forall n m:Z, decidable (n = m). -Proof. - intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y); - intros H1 H2; elim (Dcompare (x ?= y)); - [ tauto - | intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4); - intros H5; discriminate H5 ]. -Qed. - -Theorem dec_Zne : forall n m:Z, decidable (Zne n m). -Proof. - intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y). - intros H1 H2; elim (Dcompare (x ?= y)); - [ right; rewrite H1; auto - | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq); - [ elim H; intros HR; rewrite HR; discriminate | auto ] ]. -Qed. - -Theorem dec_Zle : forall n m:Z, decidable (n <= m). -Proof. - intros x y; unfold decidable, Zle in |- *; elim (x ?= y); - [ left; discriminate - | left; discriminate - | right; unfold not in |- *; intros H; apply H; trivial with arith ]. -Qed. +Notation dec_eq := Z.eq_decidable (only parsing). +Notation dec_Zle := Z.le_decidable (only parsing). +Notation dec_Zlt := Z.lt_decidable (only parsing). -Theorem dec_Zgt : forall n m:Z, decidable (n > m). +Theorem dec_Zne n m : decidable (Zne n m). Proof. - intros x y; unfold decidable, Zgt in |- *; elim (x ?= y); - [ right; discriminate | right; discriminate | auto with arith ]. + destruct (Z.eq_decidable n m); [right|left]; subst; auto. Qed. -Theorem dec_Zge : forall n m:Z, decidable (n >= m). +Theorem dec_Zgt n m : decidable (n > m). Proof. - intros x y; unfold decidable, Zge in |- *; elim (x ?= y); - [ left; discriminate - | right; unfold not in |- *; intros H; apply H; trivial with arith - | left; discriminate ]. + destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto. Qed. -Theorem dec_Zlt : forall n m:Z, decidable (n < m). +Theorem dec_Zge n m : decidable (n >= m). Proof. - intros x y; unfold decidable, Zlt in |- *; elim (x ?= y); - [ right; discriminate | auto with arith | right; discriminate ]. + destruct (Z.le_decidable m n); [left|right]; Z.swap_greater; auto. Qed. -Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n. +Theorem not_Zeq n m : n <> m -> n < m \/ m < n. Proof. - intros x y; elim (Dcompare (x ?= y)); - [ intros H1 H2; absurd (x = y); - [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ] - | unfold Zlt in |- *; intros H; elim H; intros H1; - [ auto with arith - | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ]. + apply Z.lt_gt_cases. Qed. (** * Relating strict and large orders *) -Lemma Zgt_lt : forall n m:Z, n > m -> m < n. -Proof. - unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n); - auto with arith. -Qed. - -Lemma Zlt_gt : forall n m:Z, n < m -> m > n. -Proof. - unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m); - auto with arith. -Qed. +Notation Zgt_lt := Z.gt_lt (only parsing). +Notation Zlt_gt := Z.lt_gt (only parsing). +Notation Zge_le := Z.ge_le (only parsing). +Notation Zle_ge := Z.le_ge (only parsing). +Notation Zgt_iff_lt := Z.gt_lt_iff (only parsing). +Notation Zge_iff_le := Z.ge_le_iff (only parsing). -Lemma Zge_le : forall n m:Z, n >= m -> m <= n. +Lemma Zle_not_lt n m : n <= m -> ~ m < n. Proof. - intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *; - intros H1 H2; apply H1; apply Zgt_lt; assumption. + apply Z.le_ngt. Qed. -Lemma Zle_ge : forall n m:Z, n <= m -> m >= n. +Lemma Zlt_not_le n m : n < m -> ~ m <= n. Proof. - intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *; - intros H1 H2; apply H1; apply Zlt_gt; assumption. + apply Z.lt_nge. Qed. -Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m. +Lemma Zle_not_gt n m : n <= m -> ~ n > m. Proof. trivial. Qed. -Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m. +Lemma Zgt_not_le n m : n > m -> ~ n <= m. Proof. - intros n m H1 H2; apply H2; assumption. + Z.swap_greater. apply Z.lt_nge. Qed. -Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n. +Lemma Znot_ge_lt n m : ~ n >= m -> n < m. Proof. - intros n m H1 H2. - assert (H3 := Zlt_gt _ _ H2). - apply Zle_not_gt with n m; assumption. + Z.swap_greater. apply Z.nle_gt. Qed. -Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n. -Proof. - intros n m H1 H2. - apply Zle_not_lt with m n; assumption. -Qed. - -Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m. -Proof. - unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not; - [ exact (dec_Zlt x y) | assumption ]. -Qed. - -Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m. -Proof. - unfold Zlt, Zge in |- *; auto with arith. -Qed. - -Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m. +Lemma Znot_lt_ge n m : ~ n < m -> n >= m. Proof. trivial. Qed. -Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m. +Lemma Znot_gt_le n m: ~ n > m -> n <= m. Proof. - unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not; - [ exact (dec_Zgt x y) | assumption ]. + trivial. Qed. -Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n. +Lemma Znot_le_gt n m : ~ n <= m -> n > m. Proof. - intros x y; intros. split. intro. apply Zge_le. assumption. - intro. apply Zle_ge. assumption. + Z.swap_greater. apply Z.nle_gt. Qed. -Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n. +Lemma not_Zne n m : ~ Zne n m -> n = m. Proof. - intros x y. split. intro. apply Zgt_lt. assumption. - intro. apply Zlt_gt. assumption. + intros H. + destruct (Z.eq_decidable n m); [assumption|now elim H]. Qed. (** * Equivalence and order properties *) (** Reflexivity *) -Lemma Zle_refl : forall n:Z, n <= n. -Proof. - intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate. -Qed. +Notation Zle_refl := Z.le_refl (only parsing). +Notation Zeq_le := Z.eq_le_incl (only parsing). -Lemma Zeq_le : forall n m:Z, n = m -> n <= m. -Proof. - intros; rewrite H; apply Zle_refl. -Qed. - -Hint Resolve Zle_refl: zarith. +Hint Resolve Z.le_refl: zarith. (** Antisymmetry *) -Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m. -Proof. - intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. - absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption. - assumption. - absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption. -Qed. +Notation Zle_antisym := Z.le_antisymm (only parsing). (** Asymmetry *) -Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n. -Proof. - unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m); - intros H1 H2; rewrite H1; [ discriminate | assumption ]. -Qed. +Notation Zlt_asym := Z.lt_asymm (only parsing). -Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n. +Lemma Zgt_asym n m : n > m -> ~ m > n. Proof. - intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption. - assert (H3 : n > m). apply Zlt_gt; assumption. - apply Zgt_asym with m n; assumption. + Z.swap_greater. apply Z.lt_asymm. Qed. (** Irreflexivity *) -Lemma Zgt_irrefl : forall n:Z, ~ n > n. -Proof. - intros n H; apply (Zgt_asym n n H H). -Qed. - -Lemma Zlt_irrefl : forall n:Z, ~ n < n. -Proof. - intros n H; apply (Zlt_asym n n H H). -Qed. +Notation Zlt_irrefl := Z.lt_irrefl (only parsing). +Notation Zlt_not_eq := Z.lt_neq (only parsing). -Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m. +Lemma Zgt_irrefl n : ~ n > n. Proof. - unfold not in |- *; intros x y H H0. - rewrite H0 in H. - apply (Zlt_irrefl _ H). + Z.swap_greater. apply Z.lt_irrefl. Qed. (** Large = strict or equal *) -Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m. -Proof. - intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption. -Qed. - -Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m. -Proof. - intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]; - [ left; assumption - | right; assumption - | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ]. -Qed. +Notation Zlt_le_weak := Z.lt_le_incl (only parsing). +Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (only parsing). -Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m. +Lemma Zle_lt_or_eq n m : n <= m -> n < m \/ n = m. Proof. - unfold Zle, Zlt. intros. - generalize (Zcompare_Eq_iff_eq n m). - destruct (n ?= m); intuition; discriminate. + apply Z.lt_eq_cases. Qed. (** Dichotomy *) -Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n. -Proof. - intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]; - [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt); - apply Zgt_asym with m n; assumption - | left; rewrite Heq; apply Zle_refl - | right; apply Zgt_lt; assumption ]. -Qed. +Notation Zle_or_lt := Z.le_gt_cases (only parsing). (** Transitivity of strict orders *) -Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p. -Proof. - exact Zcompare_Gt_trans. -Qed. +Notation Zlt_trans := Z.lt_trans (only parsing). -Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p. -Proof. - exact Zcompare_Lt_trans. -Qed. +Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p. +Proof Zcompare_Gt_trans. (** Mixed transitivity *) -Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p. -Proof. - intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq]; - [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ] - | rewrite <- Heq; assumption ]. -Qed. +Notation Zlt_le_trans := Z.lt_le_trans (only parsing). +Notation Zle_lt_trans := Z.le_lt_trans (only parsing). -Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p. +Lemma Zle_gt_trans n m p : m <= n -> m > p -> n > p. Proof. - intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq]; - [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ] - | rewrite Heq; assumption ]. + Z.swap_greater. Z.order. Qed. -Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p. - intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m); - [ assumption | apply Zlt_gt; assumption ]. -Qed. - -Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p. +Lemma Zgt_le_trans n m p : n > m -> p <= m -> n > p. Proof. - intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m); - [ apply Zlt_gt; assumption | assumption ]. + Z.swap_greater. Z.order. Qed. (** Transitivity of large orders *) -Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p. -Proof. - intros n m p H1 H2; apply Znot_gt_le. - intro Hgt; apply Zle_not_gt with n m. assumption. - exact (Zgt_le_trans n p m Hgt H2). -Qed. +Notation Zle_trans := Z.le_trans (only parsing). -Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p. +Lemma Zge_trans n m p : n >= m -> m >= p -> n >= p. Proof. - intros n m p H1 H2. - apply Zle_ge. - apply Zle_trans with m; apply Zge_le; trivial. + Z.swap_greater. Z.order. Qed. -Hint Resolve Zle_trans: zarith. - +Hint Resolve Z.le_trans: zarith. (** * Compatibility of order and operations on Z *) @@ -339,700 +202,448 @@ Hint Resolve Zle_trans: zarith. (** Compatibility of successor wrt to order *) -Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n. +Lemma Zsucc_le_compat n m : m <= n -> Z.succ m <= Z.succ n. Proof. - unfold Zle, not in |- *; intros m n H1 H2; apply H1; - rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1); - exact H2. + apply Z.succ_le_mono. Qed. -Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n. +Lemma Zsucc_lt_compat n m : n < m -> Z.succ n < Z.succ m. Proof. - unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat; - auto with arith. + apply Z.succ_lt_mono. Qed. -Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m. +Lemma Zsucc_gt_compat n m : m > n -> Z.succ m > Z.succ n. Proof. - intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption. + Z.swap_greater. apply Z.succ_lt_mono. Qed. Hint Resolve Zsucc_le_compat: zarith. (** Simplification of successor wrt to order *) -Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n. +Lemma Zsucc_gt_reg n m : Z.succ m > Z.succ n -> m > n. Proof. - unfold Zsucc, Zgt in |- *; intros n p; - do 2 rewrite (fun m:Z => Zplus_comm m 1); - rewrite (Zcompare_plus_compat p n 1); trivial with arith. + Z.swap_greater. apply Z.succ_lt_mono. Qed. -Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n. +Lemma Zsucc_le_reg n m : Z.succ m <= Z.succ n -> m <= n. Proof. - unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *; - do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1); - assumption. + apply Z.succ_le_mono. Qed. -Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m. +Lemma Zsucc_lt_reg n m : Z.succ n < Z.succ m -> n < m. Proof. - intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption. + apply Z.succ_lt_mono. Qed. (** Special base instances of order *) -Lemma Zgt_succ : forall n:Z, Zsucc n > n. -Proof. - exact Zcompare_succ_Gt. -Qed. - -Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n. -Proof. - intros n; apply Zgt_not_le; apply Zgt_succ. -Qed. +Notation Zlt_succ := Z.lt_succ_diag_r (only parsing). +Notation Zlt_pred := Z.lt_pred_l (only parsing). -Lemma Zlt_succ : forall n:Z, n < Zsucc n. +Lemma Zgt_succ n : Z.succ n > n. Proof. - intro n; apply Zgt_lt; apply Zgt_succ. + Z.swap_greater. apply Z.lt_succ_diag_r. Qed. -Lemma Zlt_pred : forall n:Z, Zpred n < n. +Lemma Znot_le_succ n : ~ Z.succ n <= n. Proof. - intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ. + apply Z.lt_nge, Z.lt_succ_diag_r. Qed. (** Relating strict and large order using successor or predecessor *) -Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m. -Proof. - unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n); - intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; - apply H1; - [ assumption - | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ]. -Qed. +Notation Zlt_succ_r := Z.lt_succ_r (only parsing). +Notation Zle_succ_l := Z.le_succ_l (only parsing). -Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n. +Lemma Zgt_le_succ n m : m > n -> Z.succ n <= m. Proof. - intros n p H; apply Zgt_le_trans with p. - apply Zgt_succ. - assumption. + Z.swap_greater. apply Z.le_succ_l. Qed. -Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m. +Lemma Zle_gt_succ n m : n <= m -> Z.succ m > n. Proof. - intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption. + Z.swap_greater. apply Z.lt_succ_r. Qed. -Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m. +Lemma Zle_lt_succ n m : n <= m -> n < Z.succ m. Proof. - intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption. + apply Z.lt_succ_r. Qed. -Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m. +Lemma Zlt_le_succ n m : n < m -> Z.succ n <= m. Proof. - intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption. + apply Z.le_succ_l. Qed. -Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m. +Lemma Zgt_succ_le n m : Z.succ m > n -> n <= m. Proof. - intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption. + Z.swap_greater. apply Z.lt_succ_r. Qed. -Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n. +Lemma Zlt_succ_le n m : n < Z.succ m -> n <= m. Proof. - intros n m H; apply Zle_gt_trans with (m := Zsucc n); - [ assumption | apply Zgt_succ ]. + apply Z.lt_succ_r. Qed. -Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m. +Lemma Zle_succ_gt n m : Z.succ n <= m -> m > n. Proof. - split; [apply Zlt_succ_le | apply Zle_lt_succ]. + Z.swap_greater. apply Z.le_succ_l. Qed. (** Weakening order *) -Lemma Zle_succ : forall n:Z, n <= Zsucc n. -Proof. - intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n); - apply Zgt_succ. -Qed. - -Hint Resolve Zle_succ: zarith. - -Lemma Zle_pred : forall n:Z, Zpred n <= n. -Proof. - intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ. -Qed. - -Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m. - intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m); - [ apply Zgt_succ | apply Zlt_gt; assumption ]. -Qed. +Notation Zle_succ := Z.le_succ_diag_r (only parsing). +Notation Zle_pred := Z.le_pred_l (only parsing). +Notation Zlt_lt_succ := Z.lt_lt_succ_r (only parsing). +Notation Zle_le_succ := Z.le_le_succ_r (only parsing). -Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m. +Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m. Proof. - intros x y H. - apply Zle_trans with y; trivial with zarith. -Qed. - -Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m. -Proof. - intros n m H; apply Zle_trans with (m := Zsucc n); - [ apply Zle_succ | assumption ]. + intros. now apply Z.lt_le_incl, Z.le_succ_l. Qed. +Hint Resolve Z.le_succ_diag_r: zarith. Hint Resolve Zle_le_succ: zarith. (** Relating order wrt successor and order wrt predecessor *) -Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n. +Lemma Zgt_succ_pred n m : m > Z.succ n -> Z.pred m > n. Proof. - unfold Zgt, Zsucc, Zpred in |- *; intros n p H; - rewrite <- (fun x y => Zcompare_plus_compat x y 1); - rewrite (Zplus_comm p); rewrite Zplus_assoc; - rewrite (fun x => Zplus_comm x n); simpl in |- *; - assumption. + Z.swap_greater. apply Z.lt_succ_lt_pred. Qed. -Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m. +Lemma Zlt_succ_pred n m : Z.succ n < m -> n < Z.pred m. Proof. - intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption. + apply Z.lt_succ_lt_pred. Qed. (** Relating strict order and large order on positive *) -Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n. +Lemma Zlt_0_le_0_pred n : 0 < n -> 0 <= Z.pred n. Proof. - intros x H. - rewrite (Zsucc_pred x) in H. - apply Zgt_succ_le. - apply Zlt_gt. - assumption. + apply Z.lt_le_pred. Qed. -Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n. +Lemma Zgt_0_le_0_pred n : n > 0 -> 0 <= Z.pred n. Proof. - intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption. + Z.swap_greater. apply Z.lt_le_pred. Qed. - (** Special cases of ordered integers *) -Lemma Zlt_0_1 : 0 < 1. -Proof. - change (0 < Zsucc 0) in |- *. apply Zlt_succ. -Qed. - -Lemma Zle_0_1 : 0 <= 1. -Proof. - change (0 <= Zsucc 0) in |- *. apply Zle_succ. -Qed. +Notation Zlt_0_1 := Z.lt_0_1 (only parsing). +Notation Zle_0_1 := Z.le_0_1 (only parsing). Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q. Proof. - intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate. + easy. Qed. Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0. Proof. - unfold Zgt in |- *; trivial. + easy. Qed. (* weaker but useful (in [Zpower] for instance) *) Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p. Proof. - intro; unfold Zle in |- *; discriminate. + easy. Qed. Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0. Proof. - unfold Zlt in |- *; trivial. + easy. Qed. -Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n. +Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. Proof. - simple induction n; simpl in |- *; intros; - [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ]. + induction n; simpl; intros. apply Z.le_refl. easy. Qed. Hint Immediate Zeq_le: zarith. -(** Transitivity using successor *) - -Lemma Zgt_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p. -Proof. - intros n m p H1 H2; apply Zle_gt_trans with (m := m); - [ apply Zgt_succ_le; assumption | assumption ]. -Qed. - (** Derived lemma *) -Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n. +Lemma Zgt_succ_gt_or_eq n m : Z.succ n > m -> n > m \/ m = n. Proof. - intros n m H. - assert (Hle : m <= n). - apply Zgt_succ_le; assumption. - destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq]. - left; apply Zlt_gt; assumption. - right; assumption. + Z.swap_greater. intros. now apply Z.lt_eq_cases, Z.lt_succ_r. Qed. (** ** Addition *) (** Compatibility of addition wrt to order *) -Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m. -Proof. - unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p); - assumption. -Qed. - -Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p. -Proof. - intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p); - apply Zplus_gt_compat_l; trivial. -Qed. - -Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m. -Proof. - intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1; - rewrite <- (Zcompare_plus_compat n m p); assumption. -Qed. +Notation Zplus_lt_le_compat := Z.add_lt_le_mono (only parsing). +Notation Zplus_le_lt_compat := Z.add_le_lt_mono (only parsing). +Notation Zplus_le_compat := Z.add_le_mono (only parsing). +Notation Zplus_lt_compat := Z.add_lt_mono (only parsing). -Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p. +Lemma Zplus_gt_compat_l n m p : n > m -> p + n > p + m. Proof. - intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c); - exact (Zplus_le_compat_l a b c). + Z.swap_greater. apply Z.add_lt_mono_l. Qed. -Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m. +Lemma Zplus_gt_compat_r n m p : n > m -> n + p > m + p. Proof. - unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat; - trivial with arith. + Z.swap_greater. apply Z.add_lt_mono_r. Qed. -Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p. +Lemma Zplus_le_compat_l n m p : n <= m -> p + n <= p + m. Proof. - intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p); - apply Zplus_lt_compat_l; trivial. + apply Z.add_le_mono_l. Qed. -Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q. +Lemma Zplus_le_compat_r n m p : n <= m -> n + p <= m + p. Proof. - intros a b c d H0 H1. - apply Zlt_le_trans with (b + c). - apply Zplus_lt_compat_r; trivial. - apply Zplus_le_compat_l; trivial. + apply Z.add_le_mono_r. Qed. -Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q. +Lemma Zplus_lt_compat_l n m p : n < m -> p + n < p + m. Proof. - intros a b c d H0 H1. - apply Zle_lt_trans with (b + c). - apply Zplus_le_compat_r; trivial. - apply Zplus_lt_compat_l; trivial. + apply Z.add_lt_mono_l. Qed. -Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q. +Lemma Zplus_lt_compat_r n m p : n < m -> n + p < m + p. Proof. - intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q); - [ apply Zplus_le_compat_l; assumption - | apply Zplus_le_compat_r; assumption ]. -Qed. - - -Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q. - intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption. + apply Z.add_lt_mono_r. Qed. - (** Compatibility of addition wrt to being positive *) -Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. - intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption. -Qed. +Notation Zplus_le_0_compat := Z.add_nonneg_nonneg (only parsing). (** Simplification of addition wrt to order *) -Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m. +Lemma Zplus_le_reg_l n m p : p + n <= p + m -> n <= m. Proof. - unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p); - assumption. + apply Z.add_le_mono_l. Qed. -Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m. +Lemma Zplus_le_reg_r n m p : n + p <= m + p -> n <= m. Proof. - intros n m p H; apply Zplus_gt_reg_l with p. - rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial. + apply Z.add_le_mono_r. Qed. -Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m. +Lemma Zplus_lt_reg_l n m p : p + n < p + m -> n < m. Proof. - intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1; - rewrite (Zcompare_plus_compat n m p); assumption. + apply Z.add_lt_mono_l. Qed. -Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m. +Lemma Zplus_lt_reg_r n m p : n + p < m + p -> n < m. Proof. - intros n m p H; apply Zplus_le_reg_l with p. - rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial. + apply Z.add_lt_mono_r. Qed. -Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m. +Lemma Zplus_gt_reg_l n m p : p + n > p + m -> n > m. Proof. - unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat; - trivial with arith. + Z.swap_greater. apply Z.add_lt_mono_l. Qed. -Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m. +Lemma Zplus_gt_reg_r n m p : n + p > m + p -> n > m. Proof. - intros n m p H; apply Zplus_lt_reg_l with p. - rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial. + Z.swap_greater. apply Z.add_lt_mono_r. Qed. (** ** Multiplication *) (** Compatibility of multiplication by a positive wrt to order *) -Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p. +Lemma Zmult_le_compat_r n m p : n <= m -> 0 <= p -> n * p <= m * p. Proof. - intros a b c H H0; destruct c. - do 2 rewrite Zmult_0_r; assumption. - rewrite (Zmult_comm a); rewrite (Zmult_comm b). - unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption. - unfold Zle in H0; contradiction H0; reflexivity. + intros. now apply Z.mul_le_mono_nonneg_r. Qed. -Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m. +Lemma Zmult_le_compat_l n m p : n <= m -> 0 <= p -> p * n <= p * m. Proof. - intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b). - apply Zmult_le_compat_r; trivial. + intros. now apply Z.mul_le_mono_nonneg_l. Qed. -Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p. +Lemma Zmult_lt_compat_r n m p : 0 < p -> n < m -> n * p < m * p. Proof. - intros x y z H H0; destruct z. - contradiction (Zlt_irrefl 0). - rewrite (Zmult_comm x); rewrite (Zmult_comm y). - unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption. - discriminate H. + apply Z.mul_lt_mono_pos_r. Qed. -Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p. +Lemma Zmult_gt_compat_r n m p : p > 0 -> n > m -> n * p > m * p. Proof. - intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt; - assumption. + Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. -Lemma Zmult_gt_0_lt_compat_r : - forall n m p:Z, p > 0 -> n < m -> n * p < m * p. +Lemma Zmult_gt_0_lt_compat_r n m p : p > 0 -> n < m -> n * p < m * p. Proof. - intros x y z; intros; apply Zmult_lt_compat_r; - [ apply Zgt_lt; assumption | assumption ]. + Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. -Lemma Zmult_gt_0_le_compat_r : - forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p. +Lemma Zmult_gt_0_le_compat_r n m p : p > 0 -> n <= m -> n * p <= m * p. Proof. - intros x y z Hz Hxy. - elim (Zle_lt_or_eq x y Hxy). - intros; apply Zlt_le_weak. - apply Zmult_gt_0_lt_compat_r; trivial. - intros; apply Zeq_le. - rewrite H; trivial. + Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. -Lemma Zmult_lt_0_le_compat_r : - forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p. +Lemma Zmult_lt_0_le_compat_r n m p : 0 < p -> n <= m -> n * p <= m * p. Proof. - intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt; - assumption. + apply Z.mul_le_mono_pos_r. Qed. -Lemma Zmult_gt_0_lt_compat_l : - forall n m p:Z, p > 0 -> n < m -> p * n < p * m. +Lemma Zmult_gt_0_lt_compat_l n m p : p > 0 -> n < m -> p * n < p * m. Proof. - intros x y z; intros. - rewrite (Zmult_comm z x); rewrite (Zmult_comm z y); - apply Zmult_gt_0_lt_compat_r; assumption. + Z.swap_greater. apply Z.mul_lt_mono_pos_l. Qed. -Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m. +Lemma Zmult_lt_compat_l n m p : 0 < p -> n < m -> p * n < p * m. Proof. - intros x y z; intros. - rewrite (Zmult_comm z x); rewrite (Zmult_comm z y); - apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption. + apply Z.mul_lt_mono_pos_l. Qed. -Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m. +Lemma Zmult_gt_compat_l n m p : p > 0 -> n > m -> p * n > p * m. Proof. - intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y); - apply Zmult_gt_compat_r; assumption. + Z.swap_greater. apply Z.mul_lt_mono_pos_l. Qed. -Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p. +Lemma Zmult_ge_compat_r n m p : n >= m -> p >= 0 -> n * p >= m * p. Proof. - intros a b c H1 H2; apply Zle_ge. - apply Zmult_le_compat_r; apply Zge_le; trivial. + Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_r. Qed. -Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m. +Lemma Zmult_ge_compat_l n m p : n >= m -> p >= 0 -> p * n >= p * m. Proof. - intros a b c H1 H2; apply Zle_ge. - apply Zmult_le_compat_l; apply Zge_le; trivial. + Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg_l. Qed. -Lemma Zmult_ge_compat : - forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q. +Lemma Zmult_ge_compat n m p q : + n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q. Proof. - intros a b c d H0 H1 H2 H3. - apply Zge_trans with (a * d). - apply Zmult_ge_compat_l; trivial. - apply Zge_trans with c; trivial. - apply Zmult_ge_compat_r; trivial. + Z.swap_greater. intros. now apply Z.mul_le_mono_nonneg. Qed. -Lemma Zmult_le_compat : - forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q. +Lemma Zmult_le_compat n m p q : + n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q. Proof. - intros a b c d H0 H1 H2 H3. - apply Zle_trans with (c * b). - apply Zmult_le_compat_r; assumption. - apply Zmult_le_compat_l. - assumption. - apply Zle_trans with a; assumption. + intros. now apply Z.mul_le_mono_nonneg. Qed. (** Simplification of multiplication by a positive wrt to being positive *) -Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m. +Lemma Zmult_gt_0_lt_reg_r n m p : p > 0 -> n * p < m * p -> n < m. Proof. - intros x y z; intros; destruct z. - contradiction (Zgt_irrefl 0). - rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0. - unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption. - discriminate H. + Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. -Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m. +Lemma Zmult_lt_reg_r n m p : 0 < p -> n * p < m * p -> n < m. Proof. - intros a b c H0 H1. - apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption. + apply Z.mul_lt_mono_pos_r. Qed. -Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m. +Lemma Zmult_le_reg_r n m p : p > 0 -> n * p <= m * p -> n <= m. Proof. - intros x y z Hz Hxy. - elim (Zle_lt_or_eq (x * z) (y * z) Hxy). - intros; apply Zlt_le_weak. - apply Zmult_gt_0_lt_reg_r with z; trivial. - intros; apply Zeq_le. - apply Zmult_reg_r with z. - intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0). - assumption. + Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. -Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m. +Lemma Zmult_lt_0_le_reg_r n m p : 0 < p -> n * p <= m * p -> n <= m. Proof. - intros x y z; intros; apply Zmult_le_reg_r with z. - try apply Zlt_gt; assumption. - assumption. + apply Z.mul_le_mono_pos_r. Qed. - -Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m. +Lemma Zmult_ge_reg_r n m p : p > 0 -> n * p >= m * p -> n >= m. Proof. - intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial. - apply Zge_le; trivial. + Z.swap_greater. apply Z.mul_le_mono_pos_r. Qed. -Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m. +Lemma Zmult_gt_reg_r n m p : p > 0 -> n * p > m * p -> n > m. Proof. - intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial. - apply Zgt_lt; trivial. + Z.swap_greater. apply Z.mul_lt_mono_pos_r. Qed. - -(** Compatibility of multiplication by a positive wrt to being positive *) - -Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m. +Lemma Zmult_lt_compat n m p q : + 0 <= n < p -> 0 <= m < q -> n * m < p * q. Proof. - intros x y; case x. - intros; rewrite Zmult_0_l; trivial. - intros p H1; unfold Zle in |- *. - pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)). - rewrite Zcompare_mult_compat; trivial. - intros p H1 H2; absurd (0 > Zneg p); trivial. - unfold Zgt in |- *; simpl in |- *; auto with zarith. + intros (Hn,Hnp) (Hm,Hmq). now apply Z.mul_lt_mono_nonneg. Qed. -Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0. +Lemma Zmult_lt_compat2 n m p q : + 0 < n <= p -> 0 < m < q -> n * m < p * q. Proof. - intros x y; case x. - intros H; discriminate H. - intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *; - rewrite <- (Zmult_0_r (Zpos p)). - rewrite Zcompare_mult_compat; trivial. - intros p H; discriminate H. + intros (Hn, Hnp) (Hm,Hmq). + apply Z.le_lt_trans with (p * m). + apply Z.mul_le_mono_pos_r; trivial. + apply Z.mul_lt_mono_pos_l; Z.order. Qed. -Lemma Zmult_lt_0_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m. +(** Compatibility of multiplication by a positive wrt to being positive *) + +Notation Zmult_le_0_compat := Z.mul_nonneg_nonneg (only parsing). +Notation Zmult_lt_0_compat := Z.mul_pos_pos (only parsing). +Notation Zmult_lt_O_compat := Z.mul_pos_pos (only parsing). + +Lemma Zmult_gt_0_compat n m : n > 0 -> m > 0 -> n * m > 0. Proof. - intros a b apos bpos. - apply Zgt_lt. - apply Zmult_gt_0_compat; try apply Zlt_gt; assumption. + Z.swap_greater. apply Z.mul_pos_pos. Qed. -(** For compatibility *) -Notation Zmult_lt_O_compat := Zmult_lt_0_compat (only parsing). +(* To remove someday ... *) -Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n. +Lemma Zmult_gt_0_le_0_compat n m : n > 0 -> 0 <= m -> 0 <= m * n. Proof. - intros x y H1 H2; apply Zmult_le_0_compat; trivial. - apply Zlt_le_weak; apply Zgt_lt; trivial. + Z.swap_greater. intros. apply Z.mul_nonneg_nonneg. trivial. + now apply Z.lt_le_incl. Qed. (** Simplification of multiplication by a positive wrt to being positive *) -Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m. +Lemma Zmult_le_0_reg_r n m : n > 0 -> 0 <= m * n -> 0 <= m. Proof. - intros x y; case x; - [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H - | intros p H1; unfold Zle in |- *; rewrite Zmult_comm; - pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)); - rewrite Zcompare_mult_compat; auto with arith - | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ]. + Z.swap_greater. apply Z.mul_nonneg_cancel_r. Qed. -Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m. +Lemma Zmult_lt_0_reg_r n m : 0 < n -> 0 < m * n -> 0 < m. Proof. - intros x y; case x; - [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H - | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm; - pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)); - rewrite Zcompare_mult_compat; auto with arith - | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ]. + apply Z.mul_pos_cancel_r. Qed. -Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m. +Lemma Zmult_gt_0_lt_0_reg_r n m : n > 0 -> 0 < m * n -> 0 < m. Proof. - intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt; - assumption. + Z.swap_greater. apply Z.mul_pos_cancel_r. Qed. -Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0. +Lemma Zmult_gt_0_reg_l n m : n > 0 -> n * m > 0 -> m > 0. Proof. - intros x y; case x. - intros H; discriminate H. - intros p H1; unfold Zgt in |- *. - pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)). - rewrite Zcompare_mult_compat; trivial. - intros p H; discriminate H. + Z.swap_greater. apply Z.mul_pos_cancel_l. Qed. (** ** Square *) (** Simplification of square wrt order *) -Lemma Zgt_square_simpl : - forall n m:Z, n >= 0 -> n * n > m * m -> n > m. +Lemma Zlt_square_simpl n m : 0 <= n -> m * m < n * n -> m < n. Proof. - intros n m H0 H1. - case (dec_Zlt m n). - intro; apply Zlt_gt; trivial. - intros H2; cut (m >= n). - intros H. - elim Zgt_not_le with (1 := H1). - apply Zge_le. - apply Zmult_ge_compat; auto. - apply Znot_lt_ge; trivial. + apply Z.square_lt_simpl_nonneg. Qed. -Lemma Zlt_square_simpl : - forall n m:Z, 0 <= n -> m * m < n * n -> m < n. +Lemma Zgt_square_simpl n m : n >= 0 -> n * n > m * m -> n > m. Proof. - intros x y H0 H1. - apply Zgt_lt. - apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption. + Z.swap_greater. apply Z.square_lt_simpl_nonneg. Qed. (** * Equivalence between inequalities *) -Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p. -Proof. - intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z). - rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H). - intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc. - apply Zplus_le_compat_r. assumption. -Qed. - -Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p. -Proof. - intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x). - rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. - assumption. - intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z). - rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption. -Qed. - -Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p. -Proof. - intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry in |- *. rewrite Zplus_comm. - assumption. - intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. - rewrite Zplus_opp_l. apply Zplus_0_r. -Qed. - -Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n. -Proof. - intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus; - pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); - rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; - assumption. -Qed. - -Lemma Zlt_0_minus_lt : forall n m:Z, 0 < n - m -> m < n. -Proof. - intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l; - rewrite Zplus_comm; exact H. -Qed. +Notation Zle_plus_swap := Z.le_add_le_sub_r (only parsing). +Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (only parsing). +Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (only parsing). -Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n. +Lemma Zeq_plus_swap n m p : n + p = m <-> n = m - p. Proof. - intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l; - rewrite Zplus_comm; exact H. + apply Z.add_move_r. Qed. -Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m. +Lemma Zlt_0_minus_lt n m : 0 < n - m -> m < n. Proof. - intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); - rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. + apply Z.lt_0_sub. Qed. -Lemma Zmult_lt_compat: - forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q. +Lemma Zle_0_minus_le n m : 0 <= n - m -> m <= n. Proof. - intros n m p q (H1, H2) (H3,H4). - assert (0<p) by (apply Zle_lt_trans with n; auto). - assert (0<q) by (apply Zle_lt_trans with m; auto). - case Zle_lt_or_eq with (1 := H1); intros H5; auto with zarith. - case Zle_lt_or_eq with (1 := H3); intros H6; auto with zarith. - apply Zlt_trans with (n * q). - apply Zmult_lt_compat_l; auto. - apply Zmult_lt_compat_r; auto with zarith. - rewrite <- H6; rewrite Zmult_0_r; apply Zmult_lt_0_compat; auto with zarith. - rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith. + apply Z.le_0_sub. Qed. -Lemma Zmult_lt_compat2: - forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q. +Lemma Zle_minus_le_0 n m : m <= n -> 0 <= n - m. Proof. - intros n m p q (H1, H2) (H3, H4). - apply Zle_lt_trans with (p * m). - apply Zmult_le_compat_r; auto. - apply Zlt_le_weak; auto. - apply Zmult_lt_compat_l; auto. - apply Zlt_le_trans with n; auto. + apply Z.le_0_sub. Qed. (** For compatibility *) diff --git a/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v new file mode 100644 index 00000000..a90eedb4 --- /dev/null +++ b/theories/ZArith/Zpow_alt.v @@ -0,0 +1,83 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinInt. +Local Open Scope Z_scope. + +(** An alternative power function for Z *) + +(** This [Zpower_alt] is extensionnaly equal to [Z.pow], + but not convertible with it. The number of + multiplications is logarithmic instead of linear, but + these multiplications are bigger. Experimentally, it seems + that [Zpower_alt] is slightly quicker than [Z.pow] on average, + but can be quite slower on powers of 2. +*) + +Definition Zpower_alt n m := + match m with + | Z0 => 1 + | Zpos p => Pos.iter_op Z.mul p n + | Zneg p => 0 + end. + +Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope. + +Lemma Piter_mul_acc : forall f, + (forall x y:Z, (f x)*y = f (x*y)) -> + forall p k, Pos.iter p f k = (Pos.iter p f 1)*k. +Proof. + intros f Hf. + induction p; simpl; intros. + - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Hf, Z.mul_assoc. + - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Z.mul_assoc. + - now rewrite Hf, Z.mul_1_l. +Qed. + +Lemma Piter_op_square : forall p a, + Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a). +Proof. + induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1. +Qed. + +Lemma Zpower_equiv a b : a^^b = a^b. +Proof. + destruct b as [|p|p]; trivial. + unfold Zpower_alt, Z.pow, Z.pow_pos. + revert a. + induction p; simpl; intros. + - f_equal. + rewrite Piter_mul_acc. + now rewrite Piter_op_square, IHp. + intros. symmetry; apply Z.mul_assoc. + - rewrite Piter_mul_acc. + now rewrite Piter_op_square, IHp. + intros. symmetry; apply Z.mul_assoc. + - now Z.nzsimpl. +Qed. + +Lemma Zpower_alt_0_r n : n^^0 = 1. +Proof. reflexivity. Qed. + +Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b. +Proof. + destruct b as [|b|b]; intros Hb; simpl. + - now Z.nzsimpl. + - now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc. + - now elim Hb. +Qed. + +Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0. +Proof. + now destruct b. +Qed. + +Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q). +Proof. + now rewrite Zpower_equiv, Z.pow_Zpos. +Qed. diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v index 620d6324..6f1ebc06 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -1,27 +1,31 @@ -Require Import ZArith_base. -Require Import Ring_theory. +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) -Open Local Scope Z_scope. +Require Import BinInt Ring_theory. +Local Open Scope Z_scope. -(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary - integer (type [positive]) and [z] a signed integer (type [Z]) *) -Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1. +(** * Power functions over [Z] *) -Definition Zpower (x y:Z) := - match y with - | Zpos p => Zpower_pos x p - | Z0 => 1 - | Zneg p => 0 - end. +(** Nota : this file is mostly deprecated. The definition of [Z.pow] + and its usual properties are now provided by module [BinInt.Z]. *) -Lemma Zpower_theory : power_theory 1 Zmult (eq (A:=Z)) Z_of_N Zpower. +Notation Zpower_pos := Z.pow_pos (only parsing). +Notation Zpower := Z.pow (only parsing). +Notation Zpower_0_r := Z.pow_0_r (only parsing). +Notation Zpower_succ_r := Z.pow_succ_r (only parsing). +Notation Zpower_neg_r := Z.pow_neg_r (only parsing). +Notation Zpower_Ppow := Z.pow_Zpos (only parsing). + +Lemma Zpower_theory : power_theory 1 Z.mul (@eq Z) Z.of_N Z.pow. Proof. constructor. intros. destruct n;simpl;trivial. - unfold Zpower_pos. - assert (forall k, iter_pos p Z (fun x : Z => r * x) k = pow_pos Zmult r p*k). - induction p;simpl;intros;repeat rewrite IHp;trivial; - repeat rewrite Zmult_assoc;trivial. - rewrite H;rewrite Zmult_1_r;trivial. + unfold Z.pow_pos. + rewrite <- (Z.mul_1_r (pow_pos _ _ _)). generalize 1. + induction p; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial. Qed. - diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 7879fe42..27e3def4 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -1,295 +1,109 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpow_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import ZArith_base. -Require Import ZArithRing. -Require Import Zcomplements. +Require Import ZArith_base ZArithRing Zcomplements Zdiv Znumtheory. Require Export Zpower. -Require Import Zdiv. -Require Import Znumtheory. -Open Local Scope Z_scope. +Local Open Scope Z_scope. -Lemma Zpower_pos_1_r: forall x, Zpower_pos x 1 = x. -Proof. - intros x; unfold Zpower_pos; simpl; auto with zarith. -Qed. +(** Properties of the power function over [Z] *) -Lemma Zpower_pos_1_l: forall p, Zpower_pos 1 p = 1. -Proof. - induction p. - (* xI *) - rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l. - repeat rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r, IHp; auto. - (* xO *) - rewrite <- Pplus_diag. - repeat rewrite Zpower_pos_is_exp. - rewrite IHp; auto. - (* xH *) - rewrite Zpower_pos_1_r; auto. -Qed. +(** Nota: the usual properties of [Z.pow] are now already provided + by [BinInt.Z]. Only remain here some compatibility elements, + as well as more specific results about power and modulo and/or + primality. *) -Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0. -Proof. - induction p. - change (xI p) with (1 + (xO p))%positive. - rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto. - rewrite <- Pplus_diag. - rewrite Zpower_pos_is_exp, IHp; auto. - rewrite Zpower_pos_1_r; auto. -Qed. +Lemma Zpower_pos_1_r x : Z.pow_pos x 1 = x. +Proof (Z.pow_1_r x). -Lemma Zpower_pos_pos: forall x p, - 0 < x -> 0 < Zpower_pos x p. -Proof. - induction p; intros. - (* xI *) - rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l. - repeat rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r. - repeat apply Zmult_lt_0_compat; auto. - (* xO *) - rewrite <- Pplus_diag. - repeat rewrite Zpower_pos_is_exp. - repeat apply Zmult_lt_0_compat; auto. - (* xH *) - rewrite Zpower_pos_1_r; auto. -Qed. +Lemma Zpower_pos_1_l p : Z.pow_pos 1 p = 1. +Proof. now apply (Z.pow_1_l (Zpos p)). Qed. +Lemma Zpower_pos_0_l p : Z.pow_pos 0 p = 0. +Proof. now apply (Z.pow_0_l (Zpos p)). Qed. -Theorem Zpower_1_r: forall z, z^1 = z. -Proof. - exact Zpower_pos_1_r. -Qed. - -Theorem Zpower_1_l: forall z, 0 <= z -> 1^z = 1. -Proof. - destruct z; simpl; auto. - intros; apply Zpower_pos_1_l. - intros; compute in H; elim H; auto. -Qed. +Lemma Zpower_pos_pos x p : 0 < x -> 0 < Z.pow_pos x p. +Proof. intros. now apply (Z.pow_pos_nonneg x (Zpos p)). Qed. -Theorem Zpower_0_l: forall z, z<>0 -> 0^z = 0. -Proof. - destruct z; simpl; auto with zarith. - intros; apply Zpower_pos_0_l. -Qed. +Notation Zpower_1_r := Z.pow_1_r (only parsing). +Notation Zpower_1_l := Z.pow_1_l (only parsing). +Notation Zpower_0_l := Z.pow_0_l' (only parsing). +Notation Zpower_0_r := Z.pow_0_r (only parsing). +Notation Zpower_2 := Z.pow_2_r (only parsing). +Notation Zpower_gt_0 := Z.pow_pos_nonneg (only parsing). +Notation Zpower_ge_0 := Z.pow_nonneg (only parsing). +Notation Zpower_Zabs := Z.abs_pow (only parsing). +Notation Zpower_Zsucc := Z.pow_succ_r (only parsing). +Notation Zpower_mult := Z.pow_mul_r (only parsing). +Notation Zpower_le_monotone2 := Z.pow_le_mono_r (only parsing). -Theorem Zpower_0_r: forall z, z^0 = 1. -Proof. - simpl; auto. -Qed. - -Theorem Zpower_2: forall z, z^2 = z * z. -Proof. - intros; ring. -Qed. - -Theorem Zpower_gt_0: forall x y, - 0 < x -> 0 <= y -> 0 < x^y. -Proof. - destruct y; simpl; auto with zarith. - intros; apply Zpower_pos_pos; auto. - intros; compute in H0; elim H0; auto. -Qed. - -Theorem Zpower_Zabs: forall a b, Zabs (a^b) = (Zabs a)^b. -Proof. - intros a b; case (Zle_or_lt 0 b). - intros Hb; pattern b; apply natlike_ind; auto with zarith. - intros x Hx Hx1; unfold Zsucc. - (repeat rewrite Zpower_exp); auto with zarith. - rewrite Zabs_Zmult; rewrite Hx1. - f_equal; auto. - replace (a ^ 1) with a; auto. - simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. - simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. - case b; simpl; auto with zarith. - intros p Hp; discriminate. -Qed. - -Theorem Zpower_Zsucc: forall p n, 0 <= n -> p^(Zsucc n) = p * p^n. -Proof. - intros p n H. - unfold Zsucc; rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; apply Zmult_comm. -Qed. - -Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p^(q*r) = (p^q)^r. -Proof. - intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto. - intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto. - intros r1 H3 H4 H5. - unfold Zsucc; rewrite Zpower_exp; auto with zarith. - rewrite <- H4; try rewrite Zpower_1_r; try rewrite <- Zpower_exp; try f_equal; auto with zarith. - ring. - apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto. -Qed. - -Theorem Zpower_le_monotone: forall a b c, +Theorem Zpower_le_monotone a b c : 0 < a -> 0 <= b <= c -> a^b <= a^c. -Proof. - intros a b c H (H1, H2). - rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. - rewrite Zpower_exp; auto with zarith. - apply Zmult_le_compat_l; auto with zarith. - assert (0 < a ^ (c - b)); auto with zarith. - apply Zpower_gt_0; auto with zarith. - apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. -Qed. +Proof. intros. now apply Z.pow_le_mono_r. Qed. -Theorem Zpower_lt_monotone: forall a b c, +Theorem Zpower_lt_monotone a b c : 1 < a -> 0 <= b < c -> a^b < a^c. -Proof. - intros a b c H (H1, H2). - rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. - rewrite Zpower_exp; auto with zarith. - apply Zmult_lt_compat_l; auto with zarith. - apply Zpower_gt_0; auto with zarith. - assert (0 < a ^ (c - b)); auto with zarith. - apply Zpower_gt_0; auto with zarith. - apply Zlt_le_trans with (a ^1); auto with zarith. - rewrite Zpower_1_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. -Qed. - -Theorem Zpower_gt_1 : forall x y, - 1 < x -> 0 < y -> 1 < x^y. -Proof. - intros x y H1 H2. - replace 1 with (x ^ 0) by apply Zpower_0_r. - apply Zpower_lt_monotone; auto with zarith. -Qed. +Proof. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed. -Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. -Proof. - intros x y; case y; auto with zarith. - simpl ; auto with zarith. - intros p H1; assert (H: 0 <= Zpos p); auto with zarith. - generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith. - intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. - generalize H1; case x; compute; intros; auto; try discriminate. -Qed. - -Theorem Zpower_le_monotone2: - forall a b c, 0 < a -> b <= c -> a^b <= a^c. -Proof. - intros a b c H H2. - destruct (Z_le_gt_dec 0 b). - apply Zpower_le_monotone; auto. - replace (a^b) with 0. - destruct (Z_le_gt_dec 0 c). - destruct (Zle_lt_or_eq _ _ z0). - apply Zlt_le_weak;apply Zpower_gt_0;trivial. - rewrite <- H0;simpl;auto with zarith. - replace (a^c) with 0. auto with zarith. - destruct c;trivial;unfold Zgt in z0;discriminate z0. - destruct b;trivial;unfold Zgt in z;discriminate z. -Qed. +Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y. +Proof. apply Z.pow_gt_1. Qed. -Theorem Zmult_power: forall p q r, 0 <= r -> - (p*q)^r = p^r * q^r. -Proof. - intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto. - clear r H1; intros r H1 H2 H3. - unfold Zsucc; rewrite Zpower_exp; auto with zarith. - rewrite H2; repeat rewrite Zpower_exp; auto with zarith; ring. -Qed. +Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r. +Proof. intros. apply Z.pow_mul_l. Qed. -Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith. +Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith. -Theorem Zpower_le_monotone3: forall a b c, +Theorem Zpower_le_monotone3 a b c : 0 <= c -> 0 <= a <= b -> a^c <= b^c. -Proof. - intros a b c H (H1, H2). - generalize H; pattern c; apply natlike_ind; auto. - intros x HH HH1 _; unfold Zsucc; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Zpower_1_r. - apply Zle_trans with (a^x * b); auto with zarith. -Qed. +Proof. intros. now apply Z.pow_le_mono_l. Qed. -Lemma Zpower_le_monotone_inv: forall a b c, +Lemma Zpower_le_monotone_inv a b c : 1 < a -> 0 < b -> a^b <= a^c -> b <= c. Proof. - intros a b c H H0 H1. - destruct (Z_le_gt_dec b c);trivial. - assert (2 <= a^b). - apply Zle_trans with (2^b). - pattern 2 at 1;replace 2 with (2^1);trivial. - apply Zpower_le_monotone;auto with zarith. - apply Zpower_le_monotone3;auto with zarith. - assert (c > 0). - destruct (Z_le_gt_dec 0 c);trivial. - destruct (Zle_lt_or_eq _ _ z0);auto with zarith. - rewrite <- H3 in H1;simpl in H1; exfalso;omega. - destruct c;try discriminate z0. simpl in H1. exfalso;omega. - assert (H4 := Zpower_lt_monotone a c b H). exfalso;omega. + intros Ha Hb H. apply (Z.pow_le_mono_r_iff a); trivial. + apply Z.lt_le_incl; apply (Z.pow_gt_1 a); trivial. + apply Z.lt_le_trans with (a^b); trivial. now apply Z.pow_gt_1. Qed. -Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> - p^q = Zpower_nat p (Zabs_nat q). -Proof. - intros p1 q1; case q1; simpl. - intros _; exact (refl_equal _). - intros p2 _; apply Zpower_pos_nat. - intros p2 H1; case H1; auto. -Qed. +Notation Zpower_nat_Zpower := Zpower_nat_Zpower (only parsing). -Theorem Zpower2_lt_lin: forall n, 0 <= n -> n < 2^n. -Proof. - intros n; apply (natlike_ind (fun n => n < 2 ^n)); clear n. - simpl; auto with zarith. - intros n H1 H2; unfold Zsucc. - case (Zle_lt_or_eq _ _ H1); clear H1; intros H1. - apply Zle_lt_trans with (n + n); auto with zarith. - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r. - assert (tmp: forall p, p * 2 = p + p); intros; try ring; - rewrite tmp; auto with zarith. - subst n; simpl; unfold Zpower_pos; simpl; auto with zarith. -Qed. +Theorem Zpower2_lt_lin n : 0 <= n -> n < 2^n. +Proof. intros. now apply Z.pow_gt_lin_r. Qed. -Theorem Zpower2_le_lin: forall n, 0 <= n -> n <= 2^n. -Proof. - intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto. -Qed. +Theorem Zpower2_le_lin n : 0 <= n -> n <= 2^n. +Proof. intros. apply Z.lt_le_incl. now apply Z.pow_gt_lin_r. Qed. -Lemma Zpower2_Psize : - forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat. +Lemma Zpower2_Psize n p : + Zpos p < 2^(Z.of_nat n) <-> (Pos.size_nat p <= n)%nat. Proof. - induction n. - destruct p; split; intros H; discriminate H || inversion H. - destruct p; simpl Psize. - rewrite inj_S, Zpower_Zsucc; auto with zarith. - rewrite Zpos_xI; specialize IHn with p; omega. - rewrite inj_S, Zpower_Zsucc; auto with zarith. - rewrite Zpos_xO; specialize IHn with p; omega. - split; auto with arith. - intros _; apply Zpower_gt_1; auto with zarith. - rewrite inj_S; generalize (Zle_0_nat n); omega. + revert p; induction n. + destruct p; now split. + assert (Hn := Nat2Z.is_nonneg n). + destruct p; simpl Pos.size_nat. + - specialize IHn with p. + rewrite Z.pos_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega. + - specialize IHn with p. + rewrite Z.pos_xO, Nat2Z.inj_succ, Z.pow_succ_r; omega. + - split; auto with zarith. + intros _. apply Z.pow_gt_1. easy. + now rewrite Nat2Z.inj_succ, Z.lt_succ_r. Qed. (** * Zpower and modulo *) -Theorem Zpower_mod: forall p q n, 0 < n -> - (p^q) mod n = ((p mod n)^q) mod n. +Theorem Zpower_mod p q n : + 0 < n -> (p^q) mod n = ((p mod n)^q) mod n. Proof. - intros p q n Hn; case (Zle_or_lt 0 q); intros H1. - generalize H1; pattern q; apply natlike_ind; auto. - intros q1 Hq1 Rec _; unfold Zsucc; repeat rewrite Zpower_exp; repeat rewrite Zpower_1_r; auto with zarith. - rewrite (fun x => (Zmult_mod x p)); try rewrite Rec; auto with zarith. - rewrite (fun x y => (Zmult_mod (x ^y))); try f_equal; auto with zarith. - f_equal; auto; apply sym_equal; apply Zmod_mod; auto with zarith. - generalize H1; case q; simpl; auto. - intros; discriminate. + intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1]. + - pattern q; apply natlike_ind; trivial. + clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial. + rewrite Z.mul_mod_idemp_l; auto with zarith. + rewrite Z.mul_mod, Rec, <- Z.mul_mod; auto with zarith. + - rewrite !Z.pow_neg_r; auto with zarith. Qed. (** A direct way to compute Zpower modulo **) @@ -313,153 +127,113 @@ Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z := Definition Zpow_mod a m n := match m with - | 0 => 1 + | 0 => 1 mod n | Zpos p => Zpow_mod_pos a p n | Zneg p => 0 end. -Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> - Zpow_mod_pos a m n = (Zpower_pos a m) mod n. +Theorem Zpow_mod_pos_correct a m n : + n <> 0 -> Zpow_mod_pos a m n = (Z.pow_pos a m) mod n. Proof. - intros a m; elim m; simpl; auto. - intros p Rec n H1; rewrite xI_succ_xO, Pplus_one_succ_r, <-Pplus_diag; auto. - repeat rewrite Zpower_pos_is_exp; auto. - repeat rewrite Rec; auto. - rewrite Zpower_pos_1_r. - repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. - case (Zpower_pos a p mod n); auto. - intros p Rec n H1; rewrite <- Pplus_diag; auto. - repeat rewrite Zpower_pos_is_exp; auto. - repeat rewrite Rec; auto. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. - case (Zpower_pos a p mod n); auto. - unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith. + intros Hn. induction m. + - rewrite Pos.xI_succ_xO at 2. rewrite <- Pos.add_1_r, <- Pos.add_diag. + rewrite 2 Zpower_pos_is_exp, Zpower_pos_1_r. + rewrite Z.mul_mod, (Z.mul_mod (Z.pow_pos a m)) by trivial. + rewrite <- IHm, <- Z.mul_mod by trivial. + simpl. now destruct (Zpow_mod_pos a m n). + - rewrite <- Pos.add_diag at 2. + rewrite Zpower_pos_is_exp. + rewrite Z.mul_mod by trivial. + rewrite <- IHm. + simpl. now destruct (Zpow_mod_pos a m n). + - now rewrite Zpower_pos_1_r. Qed. -Theorem Zpow_mod_correct: forall a m n, 1 < n -> 0 <= m -> - Zpow_mod a m n = (a ^ m) mod n. +Theorem Zpow_mod_correct a m n : + n <> 0 -> Zpow_mod a m n = (a ^ m) mod n. Proof. - intros a m n; case m; simpl. - intros; apply sym_equal; apply Zmod_small; auto with zarith. - intros; apply Zpow_mod_pos_correct; auto with zarith. - intros p H H1; case H1; auto. + intros Hn. destruct m; simpl. + - trivial. + - apply Zpow_mod_pos_correct; auto with zarith. + - rewrite Z.mod_0_l; auto with zarith. Qed. (* Complements about power and number theory. *) -Lemma Zpower_divide: forall p q, 0 < q -> (p | p ^ q). +Lemma Zpower_divide p q : 0 < q -> (p | p ^ q). Proof. - intros p q H; exists (p ^(q - 1)). - pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith. + exists (p^(q - 1)). + rewrite Z.mul_comm, <- Z.pow_succ_r; f_equal; auto with zarith. Qed. -Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> - rel_prime p q -> rel_prime p (q^i). +Theorem rel_prime_Zpower_r i p q : + 0 <= i -> rel_prime p q -> rel_prime p (q^i). Proof. - intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi. - intros H; contradict H; auto with zarith. - intros i Hi Rec _; rewrite Zpower_Zsucc; auto. + intros Hi Hpq; pattern i; apply natlike_ind; auto with zarith. + simpl. apply rel_prime_sym, rel_prime_1. + clear i Hi. intros i Hi Rec; rewrite Z.pow_succ_r; auto. apply rel_prime_mult; auto. - case Zle_lt_or_eq with (1 := Hi); intros Hi1; subst; auto. - rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. Qed. -Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> - rel_prime p q -> rel_prime (p^i) (q^j). +Theorem rel_prime_Zpower i j p q : + 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). Proof. - intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q. - intros _ j p q H H1; rewrite Zpower_0_r; apply rel_prime_1. - intros n Hn Rec _ j p q Hj Hpq. - rewrite Zpower_Zsucc; auto. - case Zle_lt_or_eq with (1 := Hj); intros Hj1; subst. - apply rel_prime_sym; apply rel_prime_mult; auto. - apply rel_prime_sym; apply rel_prime_Zpower_r; auto with arith. - apply rel_prime_sym; apply Rec; auto. - rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. + intros Hi Hj H. apply rel_prime_Zpower_r; trivial. + apply rel_prime_sym. apply rel_prime_Zpower_r; trivial. + now apply rel_prime_sym. Qed. -Theorem prime_power_prime: forall p q n, 0 <= n -> - prime p -> prime q -> (p | q^n) -> p = q. +Theorem prime_power_prime p q n : + 0 <= n -> prime p -> prime q -> (p | q^n) -> p = q. Proof. - intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. - rewrite Zpower_0_r; intros. - assert (2<=p) by (apply prime_ge_2; auto). - assert (p<=1) by (apply Zdivide_le; auto with zarith). - omega. - intros n1 H H1. - unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. - assert (2<=p) by (apply prime_ge_2; auto). - assert (2<=q) by (apply prime_ge_2; auto). - intros H3; case prime_mult with (2 := H3); auto. - intros; apply prime_div_prime; auto. + intros Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. + - simpl; intros. + assert (2<=p) by (apply prime_ge_2; auto). + assert (p<=1) by (apply Z.divide_pos_le; auto with zarith). + omega. + - intros n Hn Rec. + rewrite Z.pow_succ_r by trivial. intros. + assert (2<=p) by (apply prime_ge_2; auto). + assert (2<=q) by (apply prime_ge_2; auto). + destruct prime_mult with (2 := H); auto. + apply prime_div_prime; auto. Qed. -Theorem Zdivide_power_2: forall x p n, 0 <= n -> 0 <= x -> prime p -> - (x | p^n) -> exists m, x = p^m. +Theorem Zdivide_power_2 x p n : + 0 <= n -> 0 <= x -> prime p -> (x | p^n) -> exists m, x = p^m. Proof. - intros x p n Hn Hx; revert p n Hn; generalize Hx. + intros Hn Hx; revert p n Hn. generalize Hx. pattern x; apply Z_lt_induction; auto. clear x Hx; intros x IH Hx p n Hn Hp H. - case Zle_lt_or_eq with (1 := Hx); auto; clear Hx; intros Hx; subst. - case (Zle_lt_or_eq 1 x); auto with zarith; clear Hx; intros Hx; subst. + Z.le_elim Hx; subst. + apply Z.le_succ_l in Hx; simpl in Hx. + Z.le_elim Hx; subst. (* x > 1 *) - case (prime_dec x); intros H2. - exists 1; rewrite Zpower_1_r; apply prime_power_prime with n; auto. - case not_prime_divide with (2 := H2); auto. - intros p1 ((H3, H4), (q1, Hq1)); subst. - case (IH p1) with p n; auto with zarith. - apply Zdivide_trans with (2 := H); exists q1; auto with zarith. - intros r1 Hr1. - case (IH q1) with p n; auto with zarith. - case (Zle_lt_or_eq 0 q1). - apply Zmult_le_0_reg_r with p1; auto with zarith. + case (prime_dec x); intros Hpr. + exists 1; rewrite Z.pow_1_r; apply prime_power_prime with n; auto. + case not_prime_divide with (2 := Hpr); auto. + intros p1 ((Hp1, Hpq1),(q1,->)). + assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; auto with zarith). + destruct (IH p1) with p n as (r1,Hr1); auto with zarith. + transitivity (q1 * p1); trivial. exists q1; auto with zarith. + destruct (IH q1) with p n as (r2,Hr2); auto with zarith. split; auto with zarith. - pattern q1 at 1; replace q1 with (q1 * 1); auto with zarith. - apply Zmult_lt_compat_l; auto with zarith. - intros H5; subst; contradict Hx; auto with zarith. - apply Zmult_le_0_reg_r with p1; auto with zarith. - apply Zdivide_trans with (2 := H); exists p1; auto with zarith. - intros r2 Hr2; exists (r2 + r1); subst. - apply sym_equal; apply Zpower_exp. - generalize Hx; case r2; simpl; auto with zarith. - intros; red; simpl; intros; discriminate. - generalize H3; case r1; simpl; auto with zarith. - intros; red; simpl; intros; discriminate. + rewrite <- (Z.mul_1_r q1) at 1. + apply Z.mul_lt_mono_pos_l; auto with zarith. + transitivity (q1 * p1); trivial. exists p1; auto with zarith. + exists (r2 + r1); subst. + symmetry. apply Z.pow_add_r. + generalize Hq1; case r2; now auto with zarith. + generalize Hp1; case r1; now auto with zarith. (* x = 1 *) - exists 0; rewrite Zpower_0_r; auto. + exists 0; rewrite Z.pow_0_r; auto. (* x = 0 *) - exists n; destruct H; rewrite Zmult_0_r in H; auto. + exists n; destruct H; rewrite Z.mul_0_r in H; auto. Qed. (** * Zsquare: a direct definition of [z^2] *) -Fixpoint Psquare (p: positive): positive := - match p with - | xH => xH - | xO p => xO (xO (Psquare p)) - | xI p => xI (xO (Pplus (Psquare p) p)) - end. - -Definition Zsquare p := - match p with - | Z0 => Z0 - | Zpos p => Zpos (Psquare p) - | Zneg p => Zpos (Psquare p) - end. - -Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive. -Proof. - induction p; simpl; auto; f_equal; rewrite IHp. - apply trans_equal with (xO p + xO (p*p))%positive; auto. - rewrite (Pplus_comm (xO p)); auto. - rewrite Pmult_xI_permute_r; rewrite Pplus_assoc. - f_equal; auto. - symmetry; apply Pplus_diag. - symmetry; apply Pmult_xO_permute_r. -Qed. - -Theorem Zsquare_correct: forall p, Zsquare p = p * p. -Proof. - intro p; case p; simpl; auto; intros p1; rewrite Psquare_correct; auto. -Qed. +Notation Psquare := Pos.square (only parsing). +Notation Zsquare := Z.square (only parsing). +Notation Psquare_correct := Pos.square_spec (only parsing). +Notation Zsquare_correct := Z.square_spec (only parsing). diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 038748b5..5052d01a 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -1,79 +1,89 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpower.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - -Require Import Wf_nat. -Require Import ZArith_base. +Require Import Wf_nat ZArith_base Omega Zcomplements. Require Export Zpow_def. -Require Import Omega. -Require Import Zcomplements. -Open Local Scope Z_scope. +Local Open Scope Z_scope. + +(** * Power functions over [Z] *) -Infix "^" := Zpower : Z_scope. +(** Nota : this file is mostly deprecated. The definition of [Z.pow] + and its usual properties are now provided by module [BinInt.Z]. + Powers of 2 are also available there (see [Z.shiftl] and [Z.shiftr]). + Only remain here: + - [Zpower_nat] : a power function with a [nat] exponent + - old-style powers of two, such as [two_p] + - [Zdiv_rest] : a division + modulo when the divisor is a power of 2 +*) -(** * Definition of powers over [Z]*) (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary integer (type [nat]) and [z] a signed integer (type [Z]) *) -Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1. +Definition Zpower_nat (z:Z) (n:nat) := nat_iter n (Z.mul z) 1. + +Lemma Zpower_nat_0_r z : Zpower_nat z 0 = 1. +Proof. reflexivity. Qed. + +Lemma Zpower_nat_succ_r n z : Zpower_nat z (S n) = z * (Zpower_nat z n). +Proof. reflexivity. Qed. (** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for - [plus : nat->nat] and [Zmult : Z->Z] *) + [plus : nat->nat->nat] and [Z.mul : Z->Z->Z] *) Lemma Zpower_nat_is_exp : forall (n m:nat) (z:Z), Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m. Proof. - intros; elim n; - [ simpl in |- *; elim (Zpower_nat z m); auto with zarith - | unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H; - apply Zmult_assoc ]. + induction n. + - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l. + - intros. simpl. now rewrite 2 Zpower_nat_succ_r, IHn, Z.mul_assoc. +Qed. + +(** Conversions between powers of unary and binary integers *) + +Lemma Zpower_pos_nat (z : Z) (p : positive) : + Z.pow_pos z p = Zpower_nat z (Pos.to_nat p). +Proof. + apply Pos2Nat.inj_iter. Qed. -(** This theorem shows that powers of unary and binary integers - are the same thing, modulo the function convert : [positive -> nat] *) +Lemma Zpower_nat_Z (z : Z) (n : nat) : + Zpower_nat z n = z ^ (Z.of_nat n). +Proof. + induction n. trivial. + rewrite Zpower_nat_succ_r, Nat2Z.inj_succ, Z.pow_succ_r. + now f_equal. + apply Nat2Z.is_nonneg. +Qed. -Lemma Zpower_pos_nat : - forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p). +Theorem Zpower_nat_Zpower z n : 0 <= n -> + z^n = Zpower_nat z (Z.abs_nat n). Proof. - intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *; - apply iter_nat_of_P. + intros. now rewrite Zpower_nat_Z, Zabs2Nat.id_abs, Z.abs_eq. Qed. -(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we - deduce that the function [[n:positive](Zpower_pos z n)] is a morphism - for [add : positive->positive] and [Zmult : Z->Z] *) +(** The function [(Z.pow_pos z)] is a morphism + for [Pos.add : positive->positive->positive] and [Z.mul : Z->Z->Z] *) -Lemma Zpower_pos_is_exp : - forall (n m:positive) (z:Z), - Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m. +Lemma Zpower_pos_is_exp (n m : positive)(z:Z) : + Z.pow_pos z (n + m) = Z.pow_pos z n * Z.pow_pos z m. Proof. - intros. - rewrite (Zpower_pos_nat z n). - rewrite (Zpower_pos_nat z m). - rewrite (Zpower_pos_nat z (n + m)). - rewrite (nat_of_P_plus_morphism n m). - apply Zpower_nat_is_exp. + now apply (Z.pow_add_r z (Zpos n) (Zpos m)). Qed. Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith. Hint Unfold Zpower_pos Zpower_nat: zarith. -Theorem Zpower_exp : - forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m. +Theorem Zpower_exp x n m : + n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m. Proof. - destruct n; destruct m; auto with zarith. - simpl; intros; apply Zred_factor0. - simpl; auto with zarith. - intros; compute in H0; elim H0; auto. - intros; compute in H; elim H; auto. + Z.swap_greater. apply Z.pow_add_r. Qed. Section Powers_of_2. @@ -81,178 +91,137 @@ Section Powers_of_2. (** * Powers of 2 *) (** For the powers of two, that will be widely used, a more direct - calculus is possible. We will also prove some properties such - as [(x:positive) x < 2^x] that are true for all integers bigger - than 2 but more difficult to prove and useless. *) - - (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *) + calculus is possible. [shift n m] computes [2^n * m], i.e. + [m] shifted by [n] positions *) - Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. - Definition shift_pos (n z:positive) := iter_pos n positive xO z. + Definition shift_nat (n:nat) (z:positive) := nat_iter n xO z. + Definition shift_pos (n z:positive) := Pos.iter n xO z. Definition shift (n:Z) (z:positive) := match n with | Z0 => z - | Zpos p => iter_pos p positive xO z + | Zpos p => Pos.iter p xO z | Zneg p => z end. Definition two_power_nat (n:nat) := Zpos (shift_nat n 1). Definition two_power_pos (x:positive) := Zpos (shift_pos x 1). - Lemma two_power_nat_S : - forall n:nat, two_power_nat (S n) = 2 * two_power_nat n. + Definition two_p (x:Z) := + match x with + | Z0 => 1 + | Zpos y => two_power_pos y + | Zneg y => 0 + end. + + (** Equivalence with notions defined in BinInt *) + + Lemma shift_nat_equiv n p : shift_nat n p = Pos.shiftl_nat p n. + Proof. reflexivity. Qed. + + Lemma shift_pos_equiv n p : shift_pos n p = Pos.shiftl p (Npos n). + Proof. reflexivity. Qed. + + Lemma shift_equiv n p : 0<=n -> Zpos (shift n p) = Z.shiftl (Zpos p) n. Proof. - intro; simpl in |- *; apply refl_equal. + destruct n. + - trivial. + - simpl; intros. now apply Pos.iter_swap_gen. + - now destruct 1. Qed. - Lemma shift_nat_plus : - forall (n m:nat) (x:positive), - shift_nat (n + m) x = shift_nat n (shift_nat m x). + Lemma two_power_nat_equiv n : two_power_nat n = 2 ^ (Z.of_nat n). Proof. - intros; unfold shift_nat in |- *; apply iter_nat_plus. + induction n. + - trivial. + - now rewrite Nat2Z.inj_succ, Z.pow_succ_r, <- IHn by apply Nat2Z.is_nonneg. Qed. - Theorem shift_nat_correct : - forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x. + Lemma two_power_pos_equiv p : two_power_pos p = 2 ^ Zpos p. Proof. - unfold shift_nat in |- *; simple induction n; - [ simpl in |- *; trivial with zarith - | intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0); - [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity - | auto with zarith ] ]. + now apply Pos.iter_swap_gen. Qed. - Theorem two_power_nat_correct : - forall n:nat, two_power_nat n = Zpower_nat 2 n. + Lemma two_p_equiv x : two_p x = 2 ^ x. Proof. - intro n. - unfold two_power_nat in |- *. - rewrite (shift_nat_correct n). - omega. + destruct x; trivial. apply two_power_pos_equiv. Qed. - (** Second we show that [two_power_pos] and [two_power_nat] are the same *) - Lemma shift_pos_nat : - forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x. + (** Properties of these old versions of powers of two *) + + Lemma two_power_nat_S n : two_power_nat (S n) = 2 * two_power_nat n. + Proof. reflexivity. Qed. + + Lemma shift_nat_plus n m x : + shift_nat (n + m) x = shift_nat n (shift_nat m x). Proof. - unfold shift_pos in |- *. - unfold shift_nat in |- *. - intros; apply iter_nat_of_P. + apply iter_nat_plus. Qed. - Lemma two_power_pos_nat : - forall p:positive, two_power_pos p = two_power_nat (nat_of_P p). + Theorem shift_nat_correct n x : + Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x. Proof. - intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *. - apply f_equal with (f := Zpos). - apply shift_pos_nat. + induction n. + - trivial. + - now rewrite Zpower_nat_succ_r, <- Z.mul_assoc, <- IHn. Qed. - (** Then we deduce that [two_power_pos] is also correct *) + Theorem two_power_nat_correct n : two_power_nat n = Zpower_nat 2 n. + Proof. + now rewrite two_power_nat_equiv, Zpower_nat_Z. + Qed. - Theorem shift_pos_correct : - forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x. + Lemma shift_pos_nat p x : shift_pos p x = shift_nat (Pos.to_nat p) x. Proof. - intros. - rewrite (shift_pos_nat p x). - rewrite (Zpower_pos_nat 2 p). - apply shift_nat_correct. + apply Pos2Nat.inj_iter. Qed. - Theorem two_power_pos_correct : - forall x:positive, two_power_pos x = Zpower_pos 2 x. + Lemma two_power_pos_nat p : two_power_pos p = two_power_nat (Pos.to_nat p). Proof. - intro. - rewrite two_power_pos_nat. - rewrite Zpower_pos_nat. - apply two_power_nat_correct. + unfold two_power_pos. now rewrite shift_pos_nat. Qed. - (** Some consequences *) + Theorem shift_pos_correct p x : + Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x. + Proof. + now rewrite shift_pos_nat, Zpower_pos_nat, shift_nat_correct. + Qed. - Theorem two_power_pos_is_exp : - forall x y:positive, - two_power_pos (x + y) = two_power_pos x * two_power_pos y. + Theorem two_power_pos_correct x : two_power_pos x = Z.pow_pos 2 x. Proof. - intros. - rewrite (two_power_pos_correct (x + y)). - rewrite (two_power_pos_correct x). - rewrite (two_power_pos_correct y). - apply Zpower_pos_is_exp. + apply two_power_pos_equiv. Qed. - (** The exponentiation [z -> 2^z] for [z] a signed integer. - For convenience, we assume that [2^z = 0] for all [z < 0] - We could also define a inductive type [Log_result] with - 3 contructors [ Zero | Pos positive -> | minus_infty] - but it's more complexe and not so useful. *) + Theorem two_power_pos_is_exp x y : + two_power_pos (x + y) = two_power_pos x * two_power_pos y. + Proof. + rewrite 3 two_power_pos_equiv. now apply (Z.pow_add_r 2 (Zpos x) (Zpos y)). + Qed. - Definition two_p (x:Z) := - match x with - | Z0 => 1 - | Zpos y => two_power_pos y - | Zneg y => 0 - end. + Lemma two_p_correct x : two_p x = 2^x. + Proof (two_p_equiv x). - Theorem two_p_is_exp : - forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y. + Theorem two_p_is_exp x y : + 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y. Proof. - simple induction x; - [ simple induction y; simpl in |- *; auto with zarith - | simple induction y; - [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1); - rewrite (Zmult_1_l (two_power_pos p)); auto with zarith - | unfold Zplus in |- *; unfold two_p in |- *; intros; - apply two_power_pos_is_exp - | intros; unfold Zle in H0; unfold Zcompare in H0; - absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] - | simple induction y; - [ simpl in |- *; auto with zarith - | intros; unfold Zle in H; unfold Zcompare in H; - absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith - | intros; unfold Zle in H; unfold Zcompare in H; - absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ]. + rewrite !two_p_equiv. apply Z.pow_add_r. Qed. - Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0. + Lemma two_p_gt_ZERO x : 0 <= x -> two_p x > 0. Proof. - simple induction x; intros; - [ simpl in |- *; omega - | simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0 - | absurd (0 <= Zneg p); - [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *; - do 2 unfold not in |- *; auto with zarith - | assumption ] ]. + Z.swap_greater. rewrite two_p_equiv. now apply Z.pow_pos_nonneg. Qed. - Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x. + Lemma two_p_S x : 0 <= x -> two_p (Z.succ x) = 2 * two_p x. Proof. - intros; unfold Zsucc in |- *. - rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)). - apply Zmult_comm. + rewrite !two_p_equiv. now apply Z.pow_succ_r. Qed. - Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x. + Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x. Proof. - intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x); - [ simpl in |- *; unfold Zlt in |- *; auto with zarith - | intros; elim (Zle_lt_or_eq 0 x0 H0); - [ intros; - replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0))); - [ rewrite (two_p_S (Zpred x0)); - [ rewrite (two_p_S x0); [ omega | assumption ] - | apply Zorder.Zlt_0_le_0_pred; assumption ] - | rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0); - trivial with zarith ] - | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *; - auto with zarith ] - | assumption ]. + rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed. - Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y. - intros; omega. Qed. - - End Powers_of_2. +End Powers_of_2. Hint Resolve two_p_gt_ZERO: zarith. Hint Immediate two_p_pred two_p_S: zarith. @@ -261,100 +230,88 @@ Section power_div_with_rest. (** * Division by a power of two. *) - (** To [n:Z] and [p:positive], [q],[r] are associated such that - [n = 2^p.q + r] and [0 <= r < 2^p] *) + (** To [x:Z] and [p:positive], [q],[r] are associated such that + [x = 2^p.q + r] and [0 <= r < 2^p] *) - (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *) + (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<=r<d /\ 0<=r'<d'] *) Definition Zdiv_rest_aux (qrd:Z * Z * Z) := - let (qr, d) := qrd in - let (q, r) := qr in - (match q with - | Z0 => (0, r) - | Zpos xH => (0, d + r) - | Zpos (xI n) => (Zpos n, d + r) - | Zpos (xO n) => (Zpos n, r) - | Zneg xH => (-1, d + r) - | Zneg (xI n) => (Zneg n - 1, d + r) - | Zneg (xO n) => (Zneg n, r) - end, 2 * d). + let '(q,r,d) := qrd in + (match q with + | Z0 => (0, r) + | Zpos xH => (0, d + r) + | Zpos (xI n) => (Zpos n, d + r) + | Zpos (xO n) => (Zpos n, r) + | Zneg xH => (-1, d + r) + | Zneg (xI n) => (Zneg n - 1, d + r) + | Zneg (xO n) => (Zneg n, r) + end, 2 * d). Definition Zdiv_rest (x:Z) (p:positive) := - let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr. + let (qr, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in qr. - Lemma Zdiv_rest_correct1 : - forall (x:Z) (p:positive), - let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p. + Lemma Zdiv_rest_correct1 (x:Z) (p:positive) : + let (_, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in + d = two_power_pos p. Proof. - intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1)); - rewrite (two_power_pos_nat p); elim (nat_of_P p); - simpl in |- *; - [ trivial with zarith - | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *; - elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); - destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z); - assumption ]. + rewrite Pos2Nat.inj_iter, two_power_pos_nat. + induction (Pos.to_nat p); simpl; trivial. + destruct (nat_iter n Zdiv_rest_aux (x,0,1)) as ((q,r),d). + unfold Zdiv_rest_aux. rewrite two_power_nat_S; now f_equal. Qed. - Lemma Zdiv_rest_correct2 : - forall (x:Z) (p:positive), - let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in - let (q, r) := qr in x = q * d + r /\ 0 <= r < d. + Lemma Zdiv_rest_correct2 (x:Z) (p:positive) : + let '(q,r,d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in + x = q * d + r /\ 0 <= r < d. Proof. - intros; - apply iter_pos_invariant with - (f := Zdiv_rest_aux) - (Inv := fun qrd:Z * Z * Z => - let (qr, d) := qrd in - let (q, r) := qr in x = q * d + r /\ 0 <= r < d); - [ intro x0; elim x0; intro y0; elim y0; intros q r d; - unfold Zdiv_rest_aux in |- *; elim q; - [ omega - | destruct p0; - [ rewrite BinInt.Zpos_xI; intro; elim H; intros; split; - [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l; - rewrite Zmult_1_l; rewrite Zmult_assoc; - rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal - | omega ] - | rewrite BinInt.Zpos_xO; intro; elim H; intros; split; - [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2); - apply refl_equal - | omega ] - | omega ] - | destruct p0; - [ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros; - split; - [ rewrite H0; rewrite Zplus_assoc; - apply f_equal with (f := fun z:Z => z + r); - do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc; - rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc; - apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); - omega - | omega ] - | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros; - split; - [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2); - apply refl_equal - | omega ] - | omega ] ] - | omega ]. + apply Pos.iter_invariant; [|omega]. + intros ((q,r),d) (H,H'). unfold Zdiv_rest_aux. + destruct q as [ |[q|q| ]|[q|q| ]]; try omega. + - rewrite Z.pos_xI, Z.mul_add_distr_r in H. + rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + - rewrite Z.pos_xO in H. + rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + - rewrite Z.neg_xI, Z.mul_sub_distr_r in H. + rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega. + - rewrite Z.neg_xO in H. + rewrite Z.mul_shuffle3, Z.mul_assoc. omega. Qed. + (** Old-style rich specification by proof of existence *) + Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set := Zdiv_rest_proof : forall q r:Z, x = q * two_power_pos p + r -> 0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p. - Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p. + Lemma Zdiv_rest_correct (x:Z) (p:positive) : Zdiv_rest_proofs x p. Proof. - intros x p. generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). - elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)). - simple induction a. - intros. - elim H; intros H1 H2; clear H. - rewrite H0 in H1; rewrite H0 in H2; elim H2; intros; - apply Zdiv_rest_proof with (q := a0) (r := b); assumption. + destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). + intros (H1,(H2,H3)) ->. now exists q r. + Qed. + + (** Direct correctness of [Zdiv_rest] *) + + Lemma Zdiv_rest_ok x p : + let (q,r) := Zdiv_rest x p in + x = q * 2^(Zpos p) + r /\ 0 <= r < 2^(Zpos p). + Proof. + unfold Zdiv_rest. + generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p). + destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d). + intros H ->. now rewrite two_power_pos_equiv in H. + Qed. + + (** Equivalence with [Z.shiftr] *) + + Lemma Zdiv_rest_shiftr x p : + fst (Zdiv_rest x p) = Z.shiftr x (Zpos p). + Proof. + generalize (Zdiv_rest_ok x p). destruct (Zdiv_rest x p) as (q,r). + intros (H,H'). simpl. + rewrite Z.shiftr_div_pow2 by easy. + apply Z.div_unique_pos with r; trivial. now rewrite Z.mul_comm. Qed. End power_div_with_rest. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v new file mode 100644 index 00000000..9a95669f --- /dev/null +++ b/theories/ZArith/Zquot.v @@ -0,0 +1,536 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Nnat ZArith_base ROmega ZArithRing Zdiv Morphisms. + +Local Open Scope Z_scope. + +(** This file provides results about the Round-Toward-Zero Euclidean + division [Zquotrem], whose projections are [Zquot] and [Zrem]. + Definition of this division can be found in file [BinIntDef]. + + This division and the one defined in Zdiv agree only on positive + numbers. Otherwise, Zdiv performs Round-Toward-Bottom (a.k.a Floor). + + The current approach is compatible with the division of usual + programming languages such as Ocaml. In addition, it has nicer + properties with respect to opposite and other usual operations. +*) + +(** * Relation between division on N and on Z. *) + +Lemma Ndiv_Zquot : forall a b:N, + Z_of_N (a/b) = (Z_of_N a ÷ Z_of_N b). +Proof. + intros. + destruct a; destruct b; simpl; auto. + unfold N.div, Z.quot; simpl. destruct N.pos_div_eucl; auto. +Qed. + +Lemma Nmod_Zrem : forall a b:N, + Z.of_N (a mod b) = Z.rem (Z.of_N a) (Z.of_N b). +Proof. + intros. + destruct a; destruct b; simpl; auto. + unfold N.modulo, Z.rem; simpl; destruct N.pos_div_eucl; auto. +Qed. + +(** * Characterization of this euclidean division. *) + +(** First, the usual equation [a=q*b+r]. Notice that [a mod 0] + has been chosen to be [a], so this equation holds even for [b=0]. +*) + +Notation Z_quot_rem_eq := Z.quot_rem' (only parsing). + +(** Then, the inequalities constraining the remainder: + The remainder is bounded by the divisor, in term of absolute values *) + +Theorem Zrem_lt : forall a b:Z, b<>0 -> + Z.abs (Z.rem a b) < Z.abs b. +Proof. + apply Z.rem_bound_abs. +Qed. + +(** The sign of the remainder is the one of [a]. Due to the possible + nullity of [a], a general result is to be stated in the following form: +*) + +Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a. +Proof. + destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith; + unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; + simpl; destruct n0; simpl; auto with zarith. +Qed. + +(** This can also be said in a simplier way: *) + +Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a. +Proof. + rewrite <-Z.sgn_nonneg, Z.sgn_mul; apply Zrem_sgn. +Qed. + +(** Reformulation of [Zquot_lt] and [Zrem_sgn] in 2 + then 4 particular cases. *) + +Theorem Zrem_lt_pos a b : 0<=a -> b<>0 -> 0 <= Z.rem a b < Z.abs b. +Proof. + intros. + assert (0 <= Z.rem a b). + generalize (Zrem_sgn a b). + destruct (Zle_lt_or_eq 0 a H). + rewrite <- Zsgn_pos in H1; rewrite H1. romega with *. + subst a; simpl; auto. + generalize (Zrem_lt a b H0); romega with *. +Qed. + +Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0. +Proof. + intros. + assert (Z.rem a b <= 0). + generalize (Zrem_sgn a b). + destruct (Zle_lt_or_eq a 0 H). + rewrite <- Zsgn_neg in H1; rewrite H1; romega with *. + subst a; simpl; auto. + generalize (Zrem_lt a b H0); romega with *. +Qed. + +Theorem Zrem_lt_pos_pos a b : 0<=a -> 0<b -> 0 <= Z.rem a b < b. +Proof. + intros; generalize (Zrem_lt_pos a b); romega with *. +Qed. + +Theorem Zrem_lt_pos_neg a b : 0<=a -> b<0 -> 0 <= Z.rem a b < -b. +Proof. + intros; generalize (Zrem_lt_pos a b); romega with *. +Qed. + +Theorem Zrem_lt_neg_pos a b : a<=0 -> 0<b -> -b < Z.rem a b <= 0. +Proof. + intros; generalize (Zrem_lt_neg a b); romega with *. +Qed. + +Theorem Zrem_lt_neg_neg a b : a<=0 -> b<0 -> b < Z.rem a b <= 0. +Proof. + intros; generalize (Zrem_lt_neg a b); romega with *. +Qed. + +(** * Division and Opposite *) + +(* The precise equalities that are invalid with "historic" Zdiv. *) + +Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b). +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b). +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b). +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b. +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b. +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.quot, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b). +Proof. + destruct a; destruct b; simpl; auto; + unfold Z.rem, Z.quotrem; destruct N.pos_div_eucl; simpl; auto with zarith. +Qed. + +(** * Unicity results *) + +Definition Remainder a b r := + (0 <= a /\ 0 <= r < Z.abs b) \/ (a <= 0 /\ -Z.abs b < r <= 0). + +Definition Remainder_alt a b r := + Z.abs r < Z.abs b /\ 0 <= r * a. + +Lemma Remainder_equiv : forall a b r, + Remainder a b r <-> Remainder_alt a b r. +Proof. + unfold Remainder, Remainder_alt; intuition. + romega with *. + romega with *. + rewrite <-(Zmult_opp_opp). + apply Zmult_le_0_compat; romega. + assert (0 <= Z.sgn r * Z.sgn a) by (rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto). + destruct r; simpl Z.sgn in *; romega with *. +Qed. + +Theorem Zquot_mod_unique_full: + forall a b q r, Remainder a b r -> + a = b*q + r -> q = a÷b /\ r = Z.rem a b. +Proof. + destruct 1 as [(H,H0)|(H,H0)]; intros. + apply Zdiv_mod_unique with b; auto. + apply Zrem_lt_pos; auto. + romega with *. + rewrite <- H1; apply Z_quot_rem_eq. + + rewrite <- (Zopp_involutive a). + rewrite Zquot_opp_l, Zrem_opp_l. + generalize (Zdiv_mod_unique b (-q) (-a÷b) (-r) (Z.rem (-a) b)). + generalize (Zrem_lt_pos (-a) b). + rewrite <-Z_quot_rem_eq, <-Zopp_mult_distr_r, <-Zopp_plus_distr, <-H1. + romega with *. +Qed. + +Theorem Zquot_unique_full: + forall a b q r, Remainder a b r -> + a = b*q + r -> q = a÷b. +Proof. + intros; destruct (Zquot_mod_unique_full a b q r); auto. +Qed. + +Theorem Zquot_unique: + forall a b q r, 0 <= a -> 0 <= r < b -> + a = b*q + r -> q = a÷b. +Proof. exact Z.quot_unique. Qed. + +Theorem Zrem_unique_full: + forall a b q r, Remainder a b r -> + a = b*q + r -> r = Z.rem a b. +Proof. + intros; destruct (Zquot_mod_unique_full a b q r); auto. +Qed. + +Theorem Zrem_unique: + forall a b q r, 0 <= a -> 0 <= r < b -> + a = b*q + r -> r = Z.rem a b. +Proof. exact Z.rem_unique. Qed. + +(** * Basic values of divisions and modulo. *) + +Lemma Zrem_0_l: forall a, Z.rem 0 a = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zrem_0_r: forall a, Z.rem a 0 = a. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zquot_0_l: forall a, 0÷a = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zquot_0_r: forall a, a÷0 = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zrem_1_r: forall a, Z.rem a 1 = 0. +Proof. exact Z.rem_1_r. Qed. + +Lemma Zquot_1_r: forall a, a÷1 = a. +Proof. exact Z.quot_1_r. Qed. + +Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Zquot_1_r Zrem_1_r + : zarith. + +Lemma Zquot_1_l: forall a, 1 < a -> 1÷a = 0. +Proof. exact Z.quot_1_l. Qed. + +Lemma Zrem_1_l: forall a, 1 < a -> Z.rem 1 a = 1. +Proof. exact Z.rem_1_l. Qed. + +Lemma Z_quot_same : forall a:Z, a<>0 -> a÷a = 1. +Proof. exact Z.quot_same. Qed. + +Ltac zero_or_not a := + destruct (Z.eq_dec a 0); + [subst; rewrite ?Zrem_0_l, ?Zquot_0_l, ?Zrem_0_r, ?Zquot_0_r; + auto with zarith|]. + +Lemma Z_rem_same : forall a, Z.rem a a = 0. +Proof. intros. zero_or_not a. apply Z.rem_same; auto. Qed. + +Lemma Z_rem_mult : forall a b, Z.rem (a*b) b = 0. +Proof. intros. zero_or_not b. apply Z.rem_mul; auto. Qed. + +Lemma Z_quot_mult : forall a b:Z, b <> 0 -> (a*b)÷b = a. +Proof. exact Z.quot_mul. Qed. + +(** * Order results about Zrem and Zquot *) + +(* Division of positive numbers is positive. *) + +Lemma Z_quot_pos: forall a b, 0 <= a -> 0 <= b -> 0 <= a÷b. +Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed. + +(** As soon as the divisor is greater or equal than 2, + the division is strictly decreasing. *) + +Lemma Z_quot_lt : forall a b:Z, 0 < a -> 2 <= b -> a÷b < a. +Proof. intros. apply Z.quot_lt; auto with zarith. Qed. + +(** A division of a small number by a bigger one yields zero. *) + +Theorem Zquot_small: forall a b, 0 <= a < b -> a÷b = 0. +Proof. exact Z.quot_small. Qed. + +(** Same situation, in term of modulo: *) + +Theorem Zrem_small: forall a n, 0 <= a < n -> Z.rem a n = a. +Proof. exact Z.rem_small. Qed. + +(** [Zge] is compatible with a positive division. *) + +Lemma Z_quot_monotone : forall a b c, 0<=c -> a<=b -> a÷c <= b÷c. +Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed. + +(** With our choice of division, rounding of (a÷b) is always done toward zero: *) + +Lemma Z_mult_quot_le : forall a b:Z, 0 <= a -> 0 <= b*(a÷b) <= a. +Proof. intros. zero_or_not b. apply Z.mul_quot_le; auto with zarith. Qed. + +Lemma Z_mult_quot_ge : forall a b:Z, a <= 0 -> a <= b*(a÷b) <= 0. +Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed. + +(** The previous inequalities between [b*(a÷b)] and [a] are exact + iff the modulo is zero. *) + +Lemma Z_quot_exact_full : forall a b:Z, a = b*(a÷b) <-> Z.rem a b = 0. +Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed. + +(** A modulo cannot grow beyond its starting point. *) + +Theorem Zrem_le: forall a b, 0 <= a -> 0 <= b -> Z.rem a b <= a. +Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. + +(** Some additionnal inequalities about Zdiv. *) + +Theorem Zquot_le_upper_bound: + forall a b q, 0 < b -> a <= q*b -> a÷b <= q. +Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_upper_bound. Qed. + +Theorem Zquot_lt_upper_bound: + forall a b q, 0 <= a -> 0 < b -> a < q*b -> a÷b < q. +Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_lt_upper_bound. Qed. + +Theorem Zquot_le_lower_bound: + forall a b q, 0 < b -> q*b <= a -> q <= a÷b. +Proof. intros a b q; rewrite Zmult_comm; apply Z.quot_le_lower_bound. Qed. + +Theorem Zquot_sgn: forall a b, + 0 <= Z.sgn (a÷b) * Z.sgn a * Z.sgn b. +Proof. + destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; + unfold Z.quot; simpl; destruct N.pos_div_eucl; simpl; destruct n; simpl; auto with zarith. +Qed. + +(** * Relations between usual operations and Zmod and Zdiv *) + +(** First, a result that used to be always valid with Zdiv, + but must be restricted here. + For instance, now (9+(-5)*2) rem 2 = -1 <> 1 = 9 rem 2 *) + +Lemma Z_rem_plus : forall a b c:Z, + 0 <= (a+b*c) * a -> + Z.rem (a + b * c) c = Z.rem a c. +Proof. intros. zero_or_not c. apply Z.rem_add; auto with zarith. Qed. + +Lemma Z_quot_plus : forall a b c:Z, + 0 <= (a+b*c) * a -> c<>0 -> + (a + b * c) ÷ c = a ÷ c + b. +Proof. intros. apply Z.quot_add; auto with zarith. Qed. + +Theorem Z_quot_plus_l: forall a b c : Z, + 0 <= (a*b+c)*c -> b<>0 -> + b<>0 -> (a * b + c) ÷ b = a + c ÷ b. +Proof. intros. apply Z.quot_add_l; auto with zarith. Qed. + +(** Cancellations. *) + +Lemma Zquot_mult_cancel_r : forall a b c:Z, + c<>0 -> (a*c)÷(b*c) = a÷b. +Proof. intros. zero_or_not b. apply Z.quot_mul_cancel_r; auto. Qed. + +Lemma Zquot_mult_cancel_l : forall a b c:Z, + c<>0 -> (c*a)÷(c*b) = a÷b. +Proof. + intros. rewrite (Zmult_comm c b). zero_or_not b. + rewrite (Zmult_comm b c). apply Z.quot_mul_cancel_l; auto. +Qed. + +Lemma Zmult_rem_distr_l: forall a b c, + Z.rem (c*a) (c*b) = c * (Z.rem a b). +Proof. + intros. zero_or_not c. rewrite (Zmult_comm c b). zero_or_not b. + rewrite (Zmult_comm b c). apply Z.mul_rem_distr_l; auto. +Qed. + +Lemma Zmult_rem_distr_r: forall a b c, + Z.rem (a*c) (b*c) = (Z.rem a b) * c. +Proof. + intros. zero_or_not b. rewrite (Zmult_comm b c). zero_or_not c. + rewrite (Zmult_comm c b). apply Z.mul_rem_distr_r; auto. +Qed. + +(** Operations modulo. *) + +Theorem Zrem_rem: forall a n, Z.rem (Z.rem a n) n = Z.rem a n. +Proof. intros. zero_or_not n. apply Z.rem_rem; auto. Qed. + +Theorem Zmult_rem: forall a b n, + Z.rem (a * b) n = Z.rem (Z.rem a n * Z.rem b n) n. +Proof. intros. zero_or_not n. apply Z.mul_rem; auto. Qed. + +(** addition and modulo + + Generally speaking, unlike with Zdiv, we don't have + (a+b) rem n = (a rem n + b rem n) rem n + for any a and b. + For instance, take (8 + (-10)) rem 3 = -2 whereas + (8 rem 3 + (-10 rem 3)) rem 3 = 1. *) + +Theorem Zplus_rem: forall a b n, + 0 <= a * b -> + Z.rem (a + b) n = Z.rem (Z.rem a n + Z.rem b n) n. +Proof. intros. zero_or_not n. apply Z.add_rem; auto. Qed. + +Lemma Zplus_rem_idemp_l: forall a b n, + 0 <= a * b -> + Z.rem (Z.rem a n + b) n = Z.rem (a + b) n. +Proof. intros. zero_or_not n. apply Z.add_rem_idemp_l; auto. Qed. + +Lemma Zplus_rem_idemp_r: forall a b n, + 0 <= a*b -> + Z.rem (b + Z.rem a n) n = Z.rem (b + a) n. +Proof. + intros. zero_or_not n. apply Z.add_rem_idemp_r; auto. + rewrite Zmult_comm; auto. +Qed. + +Lemma Zmult_rem_idemp_l: forall a b n, Z.rem (Z.rem a n * b) n = Z.rem (a * b) n. +Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_l; auto. Qed. + +Lemma Zmult_rem_idemp_r: forall a b n, Z.rem (b * Z.rem a n) n = Z.rem (b * a) n. +Proof. intros. zero_or_not n. apply Z.mul_rem_idemp_r; auto. Qed. + +(** Unlike with Zdiv, the following result is true without restrictions. *) + +Lemma Zquot_Zquot : forall a b c, (a÷b)÷c = a÷(b*c). +Proof. + intros. zero_or_not b. rewrite Zmult_comm. zero_or_not c. + rewrite Zmult_comm. apply Z.quot_quot; auto. +Qed. + +(** A last inequality: *) + +Theorem Zquot_mult_le: + forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b. +Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed. + +(** Z.rem is related to divisibility (see more in Znumtheory) *) + +Lemma Zrem_divides : forall a b, + Z.rem a b = 0 <-> exists c, a = b*c. +Proof. + intros. zero_or_not b. firstorder. + rewrite Z.rem_divide; trivial. + split; intros (c,Hc); exists c; subst; auto with zarith. +Qed. + +(** Particular case : dividing by 2 is related with parity *) + +Lemma Zquot2_odd_remainder : forall a, + Remainder a 2 (if Z.odd a then Z.sgn a else 0). +Proof. + intros [ |p|p]. simpl. + left. simpl. auto with zarith. + left. destruct p; simpl; auto with zarith. + right. destruct p; simpl; split; now auto with zarith. +Qed. + +Notation Zquot2_quot := Zquot2_quot (only parsing). + +Lemma Zrem_odd : forall a, Z.rem a 2 = if Z.odd a then Z.sgn a else 0. +Proof. + intros. symmetry. + apply Zrem_unique_full with (Zquot2 a). + apply Zquot2_odd_remainder. + apply Zquot2_odd_eqn. +Qed. + +Lemma Zrem_even : forall a, Z.rem a 2 = if Z.even a then 0 else Z.sgn a. +Proof. + intros a. rewrite Zrem_odd, Zodd_even_bool. now destruct Zeven_bool. +Qed. + +Lemma Zeven_rem : forall a, Z.even a = Zeq_bool (Z.rem a 2) 0. +Proof. + intros a. rewrite Zrem_even. + destruct a as [ |p|p]; trivial; now destruct p. +Qed. + +Lemma Zodd_rem : forall a, Z.odd a = negb (Zeq_bool (Z.rem a 2) 0). +Proof. + intros a. rewrite Zrem_odd. + destruct a as [ |p|p]; trivial; now destruct p. +Qed. + +(** * Interaction with "historic" Zdiv *) + +(** They agree at least on positive numbers: *) + +Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> + a÷b = a/b /\ Z.rem a b = a mod b. +Proof. + intros. + apply Zdiv_mod_unique with b. + apply Zrem_lt_pos; auto with zarith. + rewrite Zabs_eq; auto with *; apply Z_mod_lt; auto with *. + rewrite <- Z_div_mod_eq; auto with *. + symmetry; apply Z_quot_rem_eq; auto with *. +Qed. + +Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> + a÷b = a/b. +Proof. + intros a b Ha Hb. + destruct (Zle_lt_or_eq _ _ Hb). + generalize (Zquotrem_Zdiv_eucl_pos a b Ha H); intuition. + subst; rewrite Zquot_0_r, Zdiv_0_r; reflexivity. +Qed. + +Theorem Zrem_Zmod_pos : forall a b, 0 <= a -> 0 < b -> + Z.rem a b = a mod b. +Proof. + intros a b Ha Hb; generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); + intuition. +Qed. + +(** Modulos are null at the same places *) + +Theorem Zrem_Zmod_zero : forall a b, b<>0 -> + (Z.rem a b = 0 <-> a mod b = 0). +Proof. + intros. + rewrite Zrem_divides, Zmod_divides; intuition. +Qed. diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt_compat.v index 1a67bbb2..4584c3f8 100644 --- a/theories/ZArith/Zsqrt.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -1,18 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zsqrt.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import ZArithRing. Require Import Omega. Require Export ZArith_base. Open Local Scope Z_scope. +(** THIS FILE IS DEPRECATED + + Instead of the various [Zsqrt] defined here, please use rather + [Z.sqrt] (or [Z.sqrtrem]). The latter are pure functions without + proof parts, and more results are available about them. + Some equivalence proofs between the old and the new versions + can be found below. Importing ZArith will provides by default + the new versions. + +*) + (**********************************************************************) (** Definition and properties of square root on Z *) @@ -213,3 +222,12 @@ Proof. Qed. +(** Equivalence between Zsqrt_plain and [Z.sqrt] *) + +Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Z.sqrt n. +Proof. + intros. destruct (Z_le_gt_dec 0 n). + symmetry. apply Z.sqrt_unique; trivial. + now apply Zsqrt_interval. + now destruct n. +Qed.
\ No newline at end of file diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 53f167e8..30802f82 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zwf.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import ZArith_base. Require Export Wf_nat. Require Import Omega. diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index ade35bef..742f4bde 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -1,14 +1,12 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auxiliary.v 14641 2011-11-06 11:59:10Z herbelin $ i*) - (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) Require Export Arith_base. @@ -18,96 +16,79 @@ Require Import Decidable. Require Import Peano_dec. Require Export Compare_dec. -Open Local Scope Z_scope. +Local Open Scope Z_scope. (***************************************************************) (** * Moving terms from one side to the other of an inequality *) -Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0. +Theorem Zne_left n m : Zne n m -> Zne (n + - m) 0. Proof. - intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1; - apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; - rewrite Zplus_comm; trivial with arith. + unfold Zne. now rewrite <- Z.sub_move_0_r. Qed. -Theorem Zegal_left : forall n m:Z, n = m -> n + - m = 0. +Theorem Zegal_left n m : n = m -> n + - m = 0. Proof. - intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute; - rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption. + apply Z.sub_move_0_r. Qed. -Theorem Zle_left : forall n m:Z, n <= m -> 0 <= m + - n. +Theorem Zle_left n m : n <= m -> 0 <= m + - n. Proof. - intros x y H; replace 0 with (x + - x). - apply Zplus_le_compat_r; trivial. - apply Zplus_opp_r. + apply Z.le_0_sub. Qed. -Theorem Zle_left_rev : forall n m:Z, 0 <= m + - n -> n <= m. +Theorem Zle_left_rev n m : 0 <= m + - n -> n <= m. Proof. - intros x y H; apply Zplus_le_reg_r with (- x). - rewrite Zplus_opp_r; trivial. + apply Z.le_0_sub. Qed. -Theorem Zlt_left_rev : forall n m:Z, 0 < m + - n -> n < m. +Theorem Zlt_left_rev n m : 0 < m + - n -> n < m. Proof. - intros x y H; apply Zplus_lt_reg_r with (- x). - rewrite Zplus_opp_r; trivial. + apply Z.lt_0_sub. Qed. -Theorem Zlt_left : forall n m:Z, n < m -> 0 <= m + -1 + - n. +Theorem Zlt_left_lt n m : n < m -> 0 < m + - n. Proof. - intros x y H; apply Zle_left; apply Zsucc_le_reg; - change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred; - apply Zlt_le_succ; assumption. + apply Z.lt_0_sub. Qed. -Theorem Zlt_left_lt : forall n m:Z, n < m -> 0 < m + - n. +Theorem Zlt_left n m : n < m -> 0 <= m + -1 + - n. Proof. - intros x y H; replace 0 with (x + - x). - apply Zplus_lt_compat_r; trivial. - apply Zplus_opp_r. + intros. rewrite Z.add_shuffle0. change (-1) with (- Z.succ 0). + now apply Z.le_0_sub, Z.le_succ_l, Z.lt_0_sub. Qed. -Theorem Zge_left : forall n m:Z, n >= m -> 0 <= n + - m. +Theorem Zge_left n m : n >= m -> 0 <= n + - m. Proof. - intros x y H; apply Zle_left; apply Zge_le; assumption. + Z.swap_greater. apply Z.le_0_sub. Qed. -Theorem Zgt_left : forall n m:Z, n > m -> 0 <= n + -1 + - m. +Theorem Zgt_left n m : n > m -> 0 <= n + -1 + - m. Proof. - intros x y H; apply Zlt_left; apply Zgt_lt; assumption. + Z.swap_greater. apply Zlt_left. Qed. -Theorem Zgt_left_gt : forall n m:Z, n > m -> n + - m > 0. +Theorem Zgt_left_gt n m : n > m -> n + - m > 0. Proof. - intros x y H; replace 0 with (y + - y). - apply Zplus_gt_compat_r; trivial. - apply Zplus_opp_r. + Z.swap_greater. apply Z.lt_0_sub. Qed. -Theorem Zgt_left_rev : forall n m:Z, n + - m > 0 -> n > m. +Theorem Zgt_left_rev n m : n + - m > 0 -> n > m. Proof. - intros x y H; apply Zplus_gt_reg_r with (- y). - rewrite Zplus_opp_r; trivial. + Z.swap_greater. apply Z.lt_0_sub. Qed. -Theorem Zle_mult_approx : - forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. +Theorem Zle_mult_approx n m p : + n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. Proof. - intros x y z H1 H2 H3; apply Zle_trans with (m := y * x); - [ apply Zmult_gt_0_le_0_compat; assumption - | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r; - apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; - assumption ]. + Z.swap_greater. intros. Z.order_pos. Qed. -Theorem Zmult_le_approx : - forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. +Theorem Zmult_le_approx n m p : + n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. - intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x; - [ assumption - | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse; - apply Zplus_lt_compat_l; apply Zgt_lt; assumption ]. + Z.swap_greater. intros. apply Z.lt_succ_r. + apply Z.mul_pos_cancel_r with n; trivial. Z.nzsimpl. + apply Z.le_lt_trans with (m*n+p); trivial. + now apply Z.add_lt_mono_l. Qed. diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget index 3efa7055..178111cd 100644 --- a/theories/ZArith/vo.itarget +++ b/theories/ZArith/vo.itarget @@ -1,4 +1,5 @@ auxiliary.vo +BinIntDef.vo BinInt.vo Int.vo Wf_Z.vo @@ -13,6 +14,7 @@ Zcomplements.vo Zdiv.vo Zeven.vo Zgcd_alt.vo +Zpow_alt.vo Zhints.vo Zlogarithm.vo Zmax.vo @@ -21,12 +23,11 @@ Zmin.vo Zmisc.vo Znat.vo Znumtheory.vo -ZOdiv_def.vo -ZOdiv.vo +Zquot.vo Zorder.vo Zpow_def.vo Zpower.vo Zpow_facts.vo -Zsqrt.vo +Zsqrt_compat.vo Zwf.vo -ZOrderedType.vo +Zeuclid.vo diff --git a/theories/theories.itarget b/theories/theories.itarget index afc3554b..3a87d8cf 100644 --- a/theories/theories.itarget +++ b/theories/theories.itarget @@ -6,7 +6,9 @@ MSets/vo.otarget Structures/vo.otarget Init/vo.otarget Lists/vo.otarget +Vectors/vo.otarget Logic/vo.otarget +PArith/vo.otarget NArith/vo.otarget Numbers/vo.otarget Program/vo.otarget |