diff options
| author |  Samuel Mimram <smimram@debian.org> | 2008-07-25 15:12:53 +0200 |
|---|---|---|
| committer | Samuel Mimram <smimram@debian.org> | 2008-07-25 15:12:53 +0200 |
| commit | a0cfa4f118023d35b767a999d5a2ac4b082857b4 (patch) | |
| tree | dabcac548e299fee1da464c93b3dba98484f45b1 /theories | |
| parent | 2281410e38ef99d025ea77194585a9bc019fdaa9 (diff) | |
Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg
Diffstat (limited to 'theories')
292 files changed, 51229 insertions, 17572 deletions
diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index b076de2a..fbdf2a41 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: Arith_base.v 11072 2008-06-08 16:13:37Z herbelin $ i*) Require Export Le. Require Export Lt. @@ -18,3 +18,5 @@ Require Export Between. Require Export Peano_dec. Require Export Compare_dec. Require Export Factorial. +Require Export EqNat. +Require Export Wf_nat. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index b431fd05..e6cb5be4 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare_dec.v 9941 2007-07-05 12:42:35Z letouzey $ i*) +(*i $Id: Compare_dec.v 10295 2007-11-06 22:46:21Z letouzey $ i*) Require Import Le. Require Import Lt. @@ -170,7 +170,7 @@ Proof. exact (lt_irrefl n). intros. apply not_gt. - swap H. + contradict H. destruct (nat_compare_gt n m); auto. Qed. @@ -184,7 +184,7 @@ Proof. exact (lt_irrefl m). intros. apply not_lt. - swap H. + contradict H. destruct (nat_compare_lt n m); auto. Qed. diff --git a/theories/Arith/Div.v b/theories/Arith/Div.v deleted file mode 100644 index 1dec34e2..00000000 --- a/theories/Arith/Div.v +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $Id: Div.v 9245 2006-10-17 12:53:34Z notin $ i*) - -(** Euclidean division *) - -V7only [Import nat_scope.]. -Open Local Scope nat_scope. - -Require Le. -Require Euclid_def. -Require Compare_dec. - -Implicit Variables Type n,a,b,q,r:nat. - -Fixpoint inf_dec [n:nat] : nat->bool := - [m:nat] Cases n m of - O _ => true - | (S n') O => false - | (S n') (S m') => (inf_dec n' m') - end. - -Theorem div1 : (b:nat)(gt b O)->(a:nat)(diveucl a b). - Realizer Fix div1 {div1/2: nat->nat->diveucl := - [b,a]Cases a of - O => (O,O) - | (S n) => - let (q,r) = (div1 b n) in - if (le_gt_dec b (S r)) then ((S q),O) - else (q,(S r)) - end}. - Program_all. - Rewrite e. - Replace b with (S r). - Simpl. - Elim plus_n_O; Auto with arith. - Apply le_antisym; Auto with arith. - Elim plus_n_Sm; Auto with arith. -Qed. - -Theorem div2 : (b:nat)(gt b O)->(a:nat)(diveucl a b). - Realizer Fix div1 {div1/2: nat->nat->diveucl := - [b,a]Cases a of - O => (O,O) - | (S n) => - let (q,r) = (div1 b n) in - if (inf_dec b (S r)) :: :: { {(le b (S r))}+{(gt b (S r))} } - then ((S q),O) - else (q,(S r)) - end}. - Program_all. - Rewrite e. - Replace b with (S r). - Simpl. - Elim plus_n_O; Auto with arith. - Apply le_antisym; Auto with arith. - Elim plus_n_Sm; Auto with arith. -Qed. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index c32759b2..1216a545 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Div2.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Div2.v 10625 2008-03-06 11:21:01Z notin $ i*) Require Import Lt. Require Import Plus. @@ -169,12 +169,12 @@ Hint Resolve even_double double_even odd_double double_odd: arith. Lemma even_2n : forall n, even n -> {p : nat | n = double p}. Proof. intros n H. exists (div2 n). auto with arith. -Qed. +Defined. Lemma odd_S2n : forall n, odd n -> {p : nat | n = S (double p)}. Proof. intros n H. exists (div2 n). auto with arith. -Qed. +Defined. (** Doubling before dividing by two brings back to the initial number. *) diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 82d05e2c..a9244455 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqNat.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: EqNat.v 9966 2007-07-10 23:54:53Z letouzey $ i*) (** Equality on natural numbers *) @@ -89,3 +89,13 @@ Proof. intros n H1 H2. discriminate H2. intros n H1 z H2 H3. case (H2 _ H3). reflexivity. Defined. + +Lemma beq_nat_true : forall x y, beq_nat x y = true -> x=y. +Proof. + induction x; destruct y; simpl; auto; intros; discriminate. +Qed. + +Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y. +Proof. + induction x; destruct y; simpl; auto; intros; discriminate. +Qed. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 83c0ce17..1484666b 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Even.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Even.v 10410 2007-12-31 13:11:55Z msozeau $ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. @@ -40,7 +40,7 @@ Proof. induction n. auto with arith. elim IHn; auto with arith. -Qed. +Defined. Lemma not_even_and_odd : forall n, even n -> odd n -> False. Proof. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index e0222e41..95af67f8 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Max.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Max.v 9883 2007-06-07 18:44:59Z letouzey $ i*) -Require Import Arith. +Require Import Le. Open Local Scope nat_scope. @@ -30,6 +30,13 @@ Proof. auto with arith. Qed. +Theorem max_assoc : forall m n p : nat, max m (max n p) = max (max m n) p. +Proof. + induction m; destruct n; destruct p; trivial. + simpl. + auto using IHm. +Qed. + Lemma max_comm : forall n m, max n m = max m n. Proof. induction n; induction m; simpl in |- *; auto with arith. diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index db14e74b..aa009963 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Min.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Min.v 9660 2007-02-19 11:36:30Z notin $ i*) Require Import Le. @@ -25,11 +25,28 @@ Fixpoint min n m {struct n} : nat := (** * Simplifications of [min] *) +Lemma min_0_l : forall n : nat, min 0 n = 0. +Proof. + trivial. +Qed. + +Lemma min_0_r : forall n : nat, min n 0 = 0. +Proof. + destruct n; trivial. +Qed. + Lemma min_SS : forall n m, S (min n m) = min (S n) (S m). Proof. auto with arith. Qed. +Lemma min_assoc : forall m n p : nat, min m (min n p) = min (min m n) p. +Proof. + induction m; destruct n; destruct p; trivial. + simpl. + auto using (IHm n p). +Qed. + Lemma min_comm : forall n m, min n m = min m n. Proof. induction n; induction m; simpl in |- *; auto with arith. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 2380c2de..b961886d 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Minus.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Minus.v 11072 2008-06-08 16:13:37Z herbelin $ i*) (** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as: << Fixpoint minus (n m:nat) {struct n} : nat := match n, m with - | O, _ => 0 + | O, _ => n | S k, O => S k | S k, S l => k - l end @@ -51,11 +51,18 @@ Qed. (** * Diagonal *) -Lemma minus_n_n : forall n, 0 = n - n. +Lemma minus_diag : forall n, n - n = 0. Proof. induction n; simpl in |- *; auto with arith. Qed. -Hint Resolve minus_n_n: arith v62. + +Lemma minus_diag_reverse : forall n, 0 = n - n. +Proof. + auto using minus_diag. +Qed. +Hint Resolve minus_diag_reverse: arith v62. + +Notation minus_n_n := minus_diag_reverse. (** * Simplification *) @@ -97,23 +104,39 @@ Hint Resolve le_plus_minus_r: arith v62. (** * Relation with order *) -Theorem le_minus : forall n m, n - m <= n. +Theorem minus_le_compat_r : forall n m p : nat, n <= m -> n - p <= m - p. Proof. - intros i h; pattern i, h in |- *; apply nat_double_ind; - [ auto - | auto - | intros m n H; simpl in |- *; apply le_trans with (m := m); auto ]. + intros n m p; generalize n m; clear n m; induction p as [|p HI]. + intros n m; rewrite <- (minus_n_O n); rewrite <- (minus_n_O m); trivial. + + intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); auto with arith. + intros q r H _. simpl. auto using HI. +Qed. + +Theorem minus_le_compat_l : forall n m p : nat, n <= m -> p - m <= p - n. +Proof. + intros n m p; generalize n m; clear n m; induction p as [|p HI]. + trivial. + + intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial. + intros q; destruct q; auto with arith. + simpl. + apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O]; + auto with arith. + + intros q r Hqr _. simpl. auto using HI. +Qed. + +Corollary le_minus : forall n m, n - m <= n. +Proof. + intros n m; rewrite minus_n_O; auto using minus_le_compat_l with arith. Qed. Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n. Proof. intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *; - auto with arith. - intros; absurd (0 < 0); auto with arith. - intros p q lepq Hp gtp. - elim (le_lt_or_eq 0 p); auto with arith. - auto with arith. - induction 1; elim minus_n_O; auto with arith. + auto using le_minus with arith. + intros; absurd (0 < 0); auto with arith. Qed. Hint Resolve lt_minus: arith v62. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 2315e12c..a43579f9 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mult.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Mult.v 11015 2008-05-28 20:06:42Z herbelin $ i*) Require Export Plus. Require Export Minus. @@ -104,6 +104,43 @@ Proof. Qed. Hint Resolve mult_assoc: arith v62. +(** ** Inversion lemmas *) + +Lemma mult_is_O : forall n m, n * m = 0 -> n = 0 \/ m = 0. +Proof. + destruct n as [| n]. + intros; left; trivial. + + simpl; intros m H; right. + assert (H':m = 0 /\ n * m = 0) by apply (plus_is_O _ _ H). + destruct H'; trivial. +Qed. + +Lemma mult_is_one : forall n m, n * m = 1 -> n = 1 /\ m = 1. +Proof. + destruct n as [|n]. + simpl; intros m H; elim (O_S _ H). + + simpl; intros m H. + destruct (plus_is_one _ _ H) as [[Hm Hnm] | [Hm Hnm]]. + rewrite Hm in H; simpl in H; rewrite mult_0_r in H; elim (O_S _ H). + rewrite Hm in Hnm; rewrite mult_1_r in Hnm; auto. +Qed. + +(** ** Multiplication and successor *) + +Lemma mult_succ_l : forall n m:nat, S n * m = n * m + m. +Proof. + intros; simpl. rewrite plus_comm. reflexivity. +Qed. + +Lemma mult_succ_r : forall n m:nat, n * S m = n * m + n. +Proof. + induction n as [| p H]; intro m; simpl. + reflexivity. + rewrite H, <- plus_n_Sm; apply f_equal; rewrite plus_assoc; reflexivity. +Qed. + (** * Compatibility with orders *) Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n. @@ -223,4 +260,4 @@ Qed. Ltac tail_simpl := repeat rewrite <- plus_tail_plus; repeat rewrite <- mult_tail_mult; - simpl in |- *.
\ No newline at end of file + simpl in |- *. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 9ae80d79..cc970ae4 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano_dec.v 9941 2007-07-05 12:42:35Z letouzey $ i*) +(*i $Id: Peano_dec.v 9698 2007-03-12 17:11:32Z letouzey $ i*) Require Import Decidable. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 74d0dc93..6d510447 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Plus.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Plus.v 9750 2007-04-06 00:58:14Z letouzey $ i*) (** Properties of addition. [add] is defined in [Init/Peano.v] as: << @@ -198,16 +198,14 @@ Qed. tail-recursive, whereas [plus] is not. This can be useful when extracting programs. *) -Fixpoint plus_acc q n {struct n} : nat := +Fixpoint tail_plus n m {struct n} : nat := match n with - | O => q - | S p => plus_acc (S q) p + | O => m + | S n => tail_plus n (S m) end. -Definition tail_plus n m := plus_acc m n. - Lemma plus_tail_plus : forall n m, n + m = tail_plus n m. -unfold tail_plus in |- *; induction n as [| n IHn]; simpl in |- *; auto. +induction n as [| n IHn]; simpl in |- *; auto. intro m; rewrite <- IHn; simpl in |- *; auto. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 11fcd161..6ad640eb 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf_nat.v 9341 2006-11-06 13:08:10Z notin $ i*) +(*i $Id: Wf_nat.v 11072 2008-06-08 16:13:37Z herbelin $ i*) (** Well-founded relations and natural numbers *) @@ -50,10 +50,12 @@ Defined. the ML-like program for [induction_ltof1] is : [[ - let induction_ltof1 F a = indrec ((f a)+1) a - where rec indrec = - function 0 -> (function a -> error) - |(S m) -> (function a -> (F a (function y -> indrec y m)));; +let induction_ltof1 f F a = + let rec indrec n k = + match n with + | O -> error + | S m -> F k (indrec m) + in indrec (f a + 1) a ]] the ML-like program for [induction_ltof2] is : @@ -210,3 +212,67 @@ Lemma well_founded_inv_rel_inv_lt_rel : forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F). intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. Qed. + +(** A constructive proof that any non empty decidable subset of + natural numbers has a least element *) + +Set Implicit Arguments. + +Require Import Le. +Require Import Compare_dec. +Require Import Decidable. + +Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) := + exists! x, P x /\ forall x', P x' -> R x x'. + +Lemma dec_inh_nat_subset_has_unique_least_element : + forall P:nat->Prop, (forall n, P n \/ ~ P n) -> + (exists n, P n) -> has_unique_least_element le P. +Proof. + intros P Pdec (n0,HPn0). + assert + (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'') + \/(forall n', P n' -> n<=n')). + induction n. + right. + intros n' Hn'. + apply le_O_n. + destruct IHn. + left; destruct H as (n', (Hlt', HPn')). + exists n'; split. + apply lt_S; assumption. + assumption. + destruct (Pdec n). + left; exists n; split. + apply lt_n_Sn. + split; assumption. + right. + intros n' Hltn'. + destruct (le_lt_eq_dec n n') as [Hltn|Heqn]. + apply H; assumption. + assumption. + destruct H0. + rewrite Heqn; assumption. + destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0]; + repeat split; + assumption || intros n' (HPn',Hminn'); apply le_antisym; auto. +Qed. + +Unset Implicit Arguments. + +(** [n]th iteration of the function [f] *) + +Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : 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. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index e126ad35..47b9fc83 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bool.v 9246 2006-10-17 14:01:18Z herbelin $ i*) +(*i $Id: Bool.v 10812 2008-04-17 16:42:37Z letouzey $ i*) (** The type [bool] is defined in the prelude as [Inductive bool : Set := true : bool | false : bool] *) @@ -126,9 +126,8 @@ Proof. destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity. Qed. - (************************) -(** * Logical combinators *) +(** * A synonym of [if] on [bool] *) (************************) Definition ifb (b1 b2 b3:bool) : bool := @@ -137,31 +136,8 @@ Definition ifb (b1 b2 b3:bool) : bool := | false => b3 end. -Definition andb (b1 b2:bool) : bool := ifb b1 b2 false. - -Definition orb (b1 b2:bool) : bool := ifb b1 true b2. - -Definition implb (b1 b2:bool) : bool := ifb b1 b2 true. - -Definition xorb (b1 b2:bool) : bool := - match b1, b2 with - | true, true => false - | true, false => true - | false, true => true - | false, false => false - end. - -Definition negb (b:bool) := if b then false else true. - -Infix "||" := orb (at level 50, left associativity) : bool_scope. -Infix "&&" := andb (at level 40, left associativity) : bool_scope. - Open Scope bool_scope. -Delimit Scope bool_scope with bool. - -Bind Scope bool_scope with bool. - (****************************) (** * De Morgan laws *) (****************************) @@ -220,7 +196,7 @@ Qed. Lemma if_negb : - forall (A:Set) (b:bool) (x y:A), + forall (A:Type) (b:bool) (x y:A), (if negb b then x else y) = (if b then y else x). Proof. destruct b; trivial. @@ -332,12 +308,11 @@ Hint Resolve orb_comm orb_assoc: bool v62. (** * Properties of [andb] *) (*******************************) -Lemma andb_prop : forall a b:bool, a && b = true -> a = true /\ b = true. +Lemma andb_true_iff : + forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. Proof. - destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); - auto with bool. + destruct b1; destruct b2; intuition. Qed. -Hint Resolve andb_prop: bool v62. Lemma andb_true_eq : forall a b:bool, true = a && b -> true = a /\ true = b. @@ -345,13 +320,6 @@ Proof. destruct a; destruct b; auto. Defined. -Lemma andb_true_intro : - forall b1 b2:bool, b1 = true /\ b2 = true -> b1 && b2 = true. -Proof. - destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. -Qed. -Hint Resolve andb_true_intro: bool v62. - Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false. Proof. destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. @@ -715,3 +683,43 @@ Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b). Proof. destruct b; intuition. Qed. + +(** Rewrite rules about andb, orb and if (used in romega) *) + +Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), + (if b && b' then a else a') = + (if b then if b' then a else a' else a'). +Proof. + destruct b; destruct b'; auto. +Qed. + +Lemma negb_if : forall (A:Type)(a a':A)(b:bool), + (if negb b then a else a') = + (if b then a' else a). +Proof. + destruct b; auto. +Qed. + +(*****************************************) +(** * Alternative versions of [andb] and [orb] + with lazy behavior (for vm_compute) *) +(*****************************************) + +Notation "a &&& b" := (if a then b else false) + (at level 40, left associativity) : lazy_bool_scope. +Notation "a ||| b" := (if a then true else b) + (at level 50, left associativity) : lazy_bool_scope. + +Open Local Scope lazy_bool_scope. + +Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b. +Proof. + unfold andb; auto. +Qed. + +Lemma orb_lazy_alt : forall a b : bool, a || b = a ||| b. +Proof. + unfold orb; auto. +Qed. + + diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 659630c5..0e8ea33c 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bvector.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Bvector.v 11004 2008-05-28 09:09:12Z herbelin $ i*) (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) @@ -25,10 +25,10 @@ Malheureusement, cette verification a posteriori amene a faire de nombreux lemmes pour gerer les longueurs. La seconde idée est de faire un type dépendant dans lequel la longueur est un paramètre de construction. Cela complique un -peu les inductions structurelles, la solution qui a ma préférence -est alors d'utiliser un terme de preuve comme définition, car le -mécanisme d'inférence du type du filtrage n'est pas aussi puissant que -celui implanté par les tactiques d'élimination. +peu les inductions structurelles et dans certains cas on +utilisera un terme de preuve comme définition, car le +mécanisme d'inférence du type du filtrage n'est pas toujours +aussi puissant que celui implanté par les tactiques d'élimination. *) Section VECTORS. @@ -52,39 +52,39 @@ Inductive vector : nat -> Type := | Vnil : vector 0 | Vcons : forall (a:A) (n:nat), vector n -> vector (S n). -Definition Vhead : forall n:nat, vector (S n) -> A. -Proof. - intros n v; inversion v; exact a. -Defined. +Definition Vhead (n:nat) (v:vector (S n)) := + match v with + | Vcons a _ _ => a + end. -Definition Vtail : forall n:nat, vector (S n) -> vector n. -Proof. - intros n v; inversion v as [|_ n0 H0 H1]; exact H0. -Defined. +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. -Definition Vconst : forall (a:A) (n:nat), vector n. -Proof. - induction n as [| n v]. - exact Vnil. +Fixpoint Vconst (a:A) (n:nat) := + match n return vector n with + | O => Vnil + | S n => Vcons a _ (Vconst a n) + end. - exact (Vcons a n v). -Defined. +(** 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. @@ -123,25 +123,23 @@ Proof. auto with *. Defined. -Lemma Vextend : forall n p:nat, vector n -> vector p -> vector (n + p). -Proof. - induction n as [| n f]; intros p v v0. - simpl in |- *; exact v0. - - inversion v as [| a n0 H0 H1]. - simpl in |- *; exact (Vcons a (n + p) (f p H0 v0)). -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. -Lemma Vunary : forall n:nat, vector n -> vector n. -Proof. - induction n as [| n g]; intro v. - exact Vnil. - - inversion v as [| a n0 H0 H1]. - exact (Vcons (f a) n (g H0)). -Defined. +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. @@ -154,14 +152,15 @@ Proof. exact (Vcons (g a a0) n (h H0 H2)). Defined. -Definition Vid : forall n:nat, vector n -> vector n. -Proof. - destruct n; intro X. - exact Vnil. - exact (Vcons (Vhead _ X) _ (Vtail _ X)). -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). +Lemma Vid_eq : forall (n:nat) (v:vector n), v = Vid n v. Proof. destruct v; auto. Qed. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v new file mode 100644 index 00000000..debe953a --- /dev/null +++ b/theories/Classes/EquivDec.v @@ -0,0 +1,158 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Decidable equivalences. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(* $Id: EquivDec.v 10919 2008-05-11 22:04:26Z msozeau $ *) + +Set Implicit Arguments. +Unset Strict Implicit. + +(** Export notations. *) + +Require Export Coq.Classes.Equivalence. + +(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more + classically. *) + +Require Import Coq.Logic.Decidable. + +Open Scope equiv_scope. + +Class [ equiv : Equivalence A ] => DecidableEquivalence := + setoid_decidable : forall x y : A, decidable (x === y). + +(** The [EqDec] class gives a decision procedure for a particular setoid equality. *) + +Class [ equiv : Equivalence A ] => EqDec := + equiv_dec : forall x y : A, { x === y } + { x =/= y }. + +(** We define the [==] overloaded notation for deciding equality. It does not take precedence + of [==] defined in the type scope, hence we can have both at the same time. *) + +Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70). + +Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := + match x with + | left H => @right _ _ H + | right H => @left _ _ H + end. + +Require Import Coq.Program.Program. + +Open Local Scope program_scope. + +(** Invert the branches. *) + +Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). + +(** Overloaded notation for inequality. *) + +Infix "=/=" := nequiv_dec (no associativity, at level 70). + +(** Define boolean versions, losing the logical information. *) + +Definition equiv_decb [ EqDec A ] (x y : A) : bool := + if x == y then true else false. + +Definition nequiv_decb [ EqDec A ] (x y : A) : bool := + negb (equiv_decb x y). + +Infix "==b" := equiv_decb (no associativity, at level 70). +Infix "<>b" := nequiv_decb (no associativity, at level 70). + +(** Decidable leibniz equality instances. *) + +Require Import Coq.Arith.Peano_dec. + +(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) + +Program Instance nat_eq_eqdec : ! EqDec nat eq := + equiv_dec := eq_nat_dec. + +Require Import Coq.Bool.Bool. + +Program Instance bool_eqdec : ! EqDec bool eq := + equiv_dec := bool_dec. + +Program Instance unit_eqdec : ! EqDec unit eq := + equiv_dec x y := in_left. + + Next Obligation. + Proof. + destruct x ; destruct y. + reflexivity. + Qed. + +Program Instance prod_eqdec [ EqDec A eq, EqDec B eq ] : + ! EqDec (prod A B) eq := + equiv_dec x y := + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then + if x2 == y2 then in_left + else in_right + else in_right. + + Solve Obligations using unfold complement, equiv ; program_simpl. + +Program Instance sum_eqdec [ EqDec A eq, EqDec B eq ] : + ! EqDec (sum A B) eq := + equiv_dec x y := + match x, y with + | inl a, inl b => if a == b then in_left else in_right + | inr a, inr b => if a == b then in_left else in_right + | inl _, inr _ | inr _, inl _ => in_right + end. + + Solve Obligations using unfold complement, equiv ; program_simpl. + +(** Objects of function spaces with countable domains like bool have decidable equality. *) + +Require Import Coq.Program.FunctionalExtensionality. + +Program Instance bool_function_eqdec [ EqDec A eq ] : ! EqDec (bool -> A) eq := + equiv_dec f g := + if f true == g true then + if f false == g false then in_left + else in_right + else in_right. + + Solve Obligations using try red ; unfold equiv, complement ; program_simpl. + + Next Obligation. + Proof. + extensionality x. + destruct x ; auto. + Qed. + +Require Import List. + +Program Instance list_eqdec [ eqa : EqDec A eq ] : ! EqDec (list A) eq := + equiv_dec := + fix aux (x : list A) y { struct x } := + match x, y with + | nil, nil => in_left + | cons hd tl, cons hd' tl' => + if hd == hd' then + if aux tl tl' then in_left else in_right + else in_right + | _, _ => in_right + end. + + Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). + + Next Obligation. + Proof. clear aux. red in H0. subst. + destruct y; intuition (discriminate || eauto). + Defined.
\ No newline at end of file diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v new file mode 100644 index 00000000..70bf3483 --- /dev/null +++ b/theories/Classes/Equivalence.v @@ -0,0 +1,144 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Typeclass-based setoids. Definitions on [Equivalence]. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: Equivalence.v 10919 2008-05-11 22:04:26Z msozeau $ *) + +Require Export Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +Require Import Coq.Classes.Init. +Require Import Relation_Definitions. +Require Import Coq.Classes.RelationClasses. +Require Export Coq.Classes.Morphisms. + +Set Implicit Arguments. +Unset Strict Implicit. + +Open Local Scope signature_scope. + +Definition equiv [ Equivalence A R ] : relation A := R. + +Typeclasses unfold equiv. + +(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) + +Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. + +Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. + +Open Local Scope equiv_scope. + +(** Overloading for [PER]. *) + +Definition pequiv [ PER A R ] : relation A := R. + +Typeclasses unfold pequiv. + +(** Overloaded notation for partial equivalence. *) + +Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope. + +(** Shortcuts to make proof search easier. *) + +Program Instance equiv_reflexive [ sa : Equivalence A ] : Reflexive equiv. + +Program Instance equiv_symmetric [ sa : Equivalence A ] : Symmetric equiv. + + Next Obligation. + Proof. + symmetry ; auto. + Qed. + +Program Instance equiv_transitive [ sa : Equivalence A ] : Transitive equiv. + + Next Obligation. + Proof. + transitivity y ; auto. + Qed. + +(** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) + +Ltac setoid_subst H := + match type of H with + ?x === ?y => substitute H ; clear H x + end. + +Ltac setoid_subst_nofail := + match goal with + | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail + | _ => idtac + end. + +(** [subst*] will try its best at substituting every equality in the goal. *) + +Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. + +(** Simplify the goal w.r.t. equivalence. *) + +Ltac equiv_simplify_one := + match goal with + | [ H : ?x === ?x |- _ ] => clear H + | [ H : ?x === ?y |- _ ] => setoid_subst H + | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name + | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name + end. + +Ltac equiv_simplify := repeat equiv_simplify_one. + +(** "reify" relations which are equivalences to applications of the overloaded [equiv] method + for easy recognition in tactics. *) + +Ltac equivify_tac := + match goal with + | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H + | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) + end. + +Ltac equivify := repeat equivify_tac. + +Section Respecting. + + (** Here we build an equivalence instance for functions which relates respectful ones only, + we do not export it. *) + + Definition respecting [ Equivalence A (R : relation A), Equivalence B (R' : relation B) ] : Type := + { morph : A -> B | respectful R R' morph morph }. + + Program Instance respecting_equiv [ Equivalence A R, Equivalence B R' ] : + Equivalence respecting + (fun (f g : respecting) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). + + Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. + + Next Obligation. + Proof. + unfold respecting in *. program_simpl. red in H2,H3,H4. + transitivity (y x0) ; auto. + transitivity (y y0) ; auto. + symmetry. auto. + Qed. + +End Respecting. + +(** The default equivalence on function spaces, with higher-priority than [eq]. *) + +Program Instance pointwise_equivalence [ Equivalence A eqA ] : + Equivalence (B -> A) (pointwise_relation eqA) | 9. + + Next Obligation. + Proof. + transitivity (y x0) ; auto. + Qed. + diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v new file mode 100644 index 00000000..49fc4f89 --- /dev/null +++ b/theories/Classes/Functions.v @@ -0,0 +1,42 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Functional morphisms. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: Functions.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +Require Import Coq.Classes.RelationClasses. +Require Import Coq.Classes.Morphisms. + +Set Implicit Arguments. +Unset Strict Implicit. + +Class [ m : Morphism (A -> B) (RA ++> RB) f ] => Injective : Prop := + injective : forall x y : A, RB (f x) (f y) -> RA x y. + +Class [ m : Morphism (A -> B) (RA ++> RB) f ] => Surjective : Prop := + surjective : forall y, exists x : A, RB y (f x). + +Definition Bijective [ m : Morphism (A -> B) (RA ++> RB) (f : A -> B) ] := + Injective m /\ Surjective m. + +Class [ m : Morphism (A -> B) (eqA ++> eqB) ] => MonoMorphism := + monic :> Injective m. + +Class [ m : Morphism (A -> B) (eqA ++> eqB) ] => EpiMorphism := + epic :> Surjective m. + +Class [ m : Morphism (A -> B) (eqA ++> eqB) ] => IsoMorphism := + monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m. + +Class [ m : Morphism (A -> A) (eqA ++> eqA), ! IsoMorphism m ] => AutoMorphism. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v new file mode 100644 index 00000000..6ba0c61e --- /dev/null +++ b/theories/Classes/Init.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Initialization code for typeclasses, setting up the default tactic + for instance search. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: Init.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +(* Ltac typeclass_instantiation := typeclasses eauto || eauto. *) + +Tactic Notation "clapply" ident(c) := + eapply @c ; eauto with typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v new file mode 100644 index 00000000..f21c68a6 --- /dev/null +++ b/theories/Classes/Morphisms.v @@ -0,0 +1,467 @@ +(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms"); compile-command: "make -C ../.. TIME='time'" -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Typeclass-based morphism definition and standard, minimal instances. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: Morphisms.v 11092 2008-06-10 18:28:26Z msozeau $ *) + +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. +Require Import Coq.Relations.Relation_Definitions. +Require Export Coq.Classes.RelationClasses. + +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Morphisms. + + We now turn to the definition of [Morphism] and declare standard instances. + These will be used by the [setoid_rewrite] tactic later. *) + +(** A morphism on a relation [R] is an object respecting the relation (in its kernel). + The relation [R] will be instantiated by [respectful] and [A] by an arrow type + for usual morphisms. *) + +Class Morphism A (R : relation A) (m : A) : Prop := + respect : R m m. + +(** We make the type implicit, it can be infered from the relations. *) + +Implicit Arguments Morphism [A]. + +(** We allow to unfold the [relation] definition while doing morphism search. *) + +Typeclasses unfold relation. + +(** Respectful morphisms. *) + +(** The fully dependent version, not used yet. *) + +Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Prop) + (R' : forall (x : A) (y : B), C x -> D y -> Prop) : + (forall x : A, C x) -> (forall x : B, D x) -> Prop := + fun f g => forall x y, R x y -> R' x y (f x) (g y). + +(** The non-dependent version is an instance where we forget dependencies. *) + +Definition respectful (A B : Type) + (R : relation A) (R' : relation B) : relation (A -> B) := + Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). + +(** Notations reminiscent of the old syntax for declaring morphisms. *) + +Delimit Scope signature_scope with signature. +Arguments Scope Morphism [type_scope signature_scope]. + +Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) + (right associativity, at level 55) : signature_scope. + +Arguments Scope respectful [type_scope type_scope signature_scope signature_scope]. + +Open Local Scope signature_scope. + +(** We can build a PER on the Coq function space if we have PERs on the domain and + codomain. *) + +Program Instance respectful_per [ PER A (R : relation A), PER B (R' : relation B) ] : + PER (A -> B) (R ==> R'). + + Next Obligation. + Proof with auto. + assert(R x0 x0). + transitivity y0... symmetry... + transitivity (y x0)... + Qed. + +(** Subrelations induce a morphism on the identity, not used for morphism search yet. *) + +Lemma subrelation_id_morphism [ subrelation A Râ‚ Râ‚‚ ] : Morphism (Râ‚ ==> Râ‚‚) id. +Proof. firstorder. Qed. + +(** The subrelation property goes through products as usual. *) + +Instance morphisms_subrelation [ sub : subrelation A Râ‚ Râ‚‚ ] : + ! subrelation (B -> A) (R ==> Râ‚) (R ==> Râ‚‚). +Proof. firstorder. Qed. + +Instance morphisms_subrelation_left [ sub : subrelation A Râ‚‚ Râ‚ ] : + ! subrelation (A -> B) (Râ‚ ==> R) (Râ‚‚ ==> R) | 3. +Proof. firstorder. Qed. + +(** [Morphism] is itself a covariant morphism for [subrelation]. *) + +Lemma subrelation_morphism [ sub : subrelation A Râ‚ Râ‚‚, mor : Morphism A Râ‚ m ] : Morphism Râ‚‚ m. +Proof. + intros. apply sub. apply mor. +Qed. + +Instance morphism_subrelation_morphism : + Morphism (subrelation ++> @eq _ ==> impl) (@Morphism A). +Proof. reduce. subst. firstorder. Qed. + +(** We use an external tactic to manage the application of subrelation, which is otherwise + always applicable. We allow its use only once per branch. *) + +Inductive subrelation_done : Prop := + did_subrelation : subrelation_done. + +Ltac subrelation_tac := + match goal with + | [ _ : subrelation_done |- _ ] => fail 1 + | [ |- @Morphism _ _ _ ] => let H := fresh "H" in + set(H:=did_subrelation) ; eapply @subrelation_morphism + end. + +Hint Extern 4 (@Morphism _ _ _) => subrelation_tac : typeclass_instances. + +(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) + +Instance iff_impl_subrelation : subrelation iff impl. +Proof. firstorder. Qed. + +Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl). +Proof. firstorder. Qed. + +Instance pointwise_subrelation [ sub : subrelation A R R' ] : + subrelation (pointwise_relation (A:=B) R) (pointwise_relation R') | 4. +Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. + +(** The complement of a relation conserves its morphisms. *) + +Program Instance complement_morphism + [ mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R ] : + Morphism (RA ==> RA ==> iff) (complement R). + + Next Obligation. + Proof. + unfold complement. + pose (mR x y H x0 y0 H0). + intuition. + Qed. + +(** The [inverse] too, actually the [flip] instance is a bit more general. *) + +Program Instance flip_morphism + [ mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f ] : + Morphism (RB ==> RA ==> RC) (flip f). + + Next Obligation. + Proof. + apply mor ; auto. + Qed. + +(** Every Transitive relation gives rise to a binary morphism on [impl], + contravariant in the first argument, covariant in the second. *) + +Program Instance trans_contra_co_morphism + [ Transitive A R ] : Morphism (R --> R ++> impl) R. + + Next Obligation. + Proof with auto. + transitivity x... + transitivity x0... + Qed. + +(* (** Dually... *) *) + +(* Program Instance [ Transitive A R ] => *) +(* trans_co_contra_inv_impl_morphism : Morphism (R ++> R --> inverse impl) R. *) + +(* Next Obligation. *) +(* Proof with auto. *) +(* apply* trans_contra_co_morphism ; eauto. eauto. *) +(* Qed. *) + +(** Morphism declarations for partial applications. *) + +Program Instance trans_contra_inv_impl_morphism + [ Transitive A R ] : Morphism (R --> inverse impl) (R x). + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + +Program Instance trans_co_impl_morphism + [ Transitive A R ] : Morphism (R ==> impl) (R x). + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + +Program Instance trans_sym_co_inv_impl_morphism + [ Transitive A R, Symmetric A R ] : Morphism (R ==> inverse impl) (R x). + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + +Program Instance trans_sym_contra_impl_morphism + [ Transitive A R, Symmetric _ R ] : Morphism (R --> impl) (R x). + + Next Obligation. + Proof with auto. + transitivity x0... + Qed. + +Program Instance equivalence_partial_app_morphism + [ Equivalence A R ] : Morphism (R ==> iff) (R x). + + Next Obligation. + Proof with auto. + split. intros ; transitivity x0... + intros. + transitivity y... + symmetry... + Qed. + +(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof + to get an [R y z] goal. *) + +Program Instance trans_co_eq_inv_impl_morphism + [ Transitive A R ] : Morphism (R ==> (@eq A) ==> inverse impl) R. + + Next Obligation. + Proof with auto. + transitivity y... + Qed. + +(* Program Instance [ Transitive A R ] => *) +(* trans_contra_eq_impl_morphism : Morphism (R --> (@eq A) ==> impl) R. *) + +(* Next Obligation. *) +(* Proof with auto. *) +(* transitivity x... *) +(* Qed. *) + +(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) + +Program Instance trans_sym_morphism + [ Transitive A R, Symmetric _ R ] : Morphism (R ==> R ==> iff) R. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... + + transitivity y... transitivity y0... + Qed. + +Program Instance equiv_morphism [ Equivalence A R ] : + Morphism (R ==> R ==> iff) R. + + Next Obligation. + Proof with auto. + split ; intros. + transitivity x0... transitivity x... symmetry... + + transitivity y... transitivity y0... symmetry... + Qed. + +(** In case the rewrite happens at top level. *) + +Program Instance iff_inverse_impl_id : + Morphism (iff ==> inverse impl) id. + +Program Instance inverse_iff_inverse_impl_id : + Morphism (iff --> inverse impl) id. + +Program Instance iff_impl_id : + Morphism (iff ==> impl) id. + +Program Instance inverse_iff_impl_id : + Morphism (iff --> impl) id. + +(** Coq functions are morphisms for leibniz equality, + applied only if really needed. *) + +(* Instance (A : Type) [ Reflexive B R ] => *) +(* eq_reflexive_morphism : Morphism (@Logic.eq A ==> R) m | 3. *) +(* Proof. simpl_relation. Qed. *) + +Instance reflexive_eq_dom_reflexive (A : Type) [ Reflexive B R' ] : + Reflexive (@Logic.eq A ==> R'). +Proof. simpl_relation. Qed. + +(** [respectful] is a morphism for relation equivalence. *) + +Instance respectful_morphism : + Morphism (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). +Proof. + reduce. + unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. + split ; intros. + + rewrite <- H0. + apply H1. + rewrite H. + assumption. + + rewrite H0. + apply H1. + rewrite <- H. + assumption. +Qed. + +(** Every element in the carrier of a reflexive relation is a morphism for this relation. + We use a proxy class for this case which is used internally to discharge reflexivity constraints. + The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of + [Morphism (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able + to set different priorities in different hint bases and select a particular hint database for + resolution of a type class constraint.*) + +Class MorphismProxy A (R : relation A) (m : A) : Prop := + respect_proxy : R m m. + +Instance reflexive_morphism_proxy + [ Reflexive A R ] (x : A) : MorphismProxy A R x | 1. +Proof. firstorder. Qed. + +Instance morphism_morphism_proxy + [ Morphism A R x ] : MorphismProxy A R x | 2. +Proof. firstorder. Qed. + +(* Instance (A : Type) [ Reflexive B R ] => *) +(* eq_reflexive_morphism : Morphism (@Logic.eq A ==> R) m | 3. *) +(* Proof. simpl_relation. Qed. *) + +(** [R] is Reflexive, hence we can build the needed proof. *) + +Lemma Reflexive_partial_app_morphism [ Morphism (A -> B) (R ==> R') m, MorphismProxy A R x ] : + Morphism R' (m x). +Proof. simpl_relation. Qed. + +Ltac partial_application_tactic := + let tac x := + match type of x with + | Type => fail 1 + | _ => eapply @Reflexive_partial_app_morphism + end + in + let on_morphism m := + match m with + | ?m' ?x => tac x + | ?m' _ ?x => tac x + | ?m' _ _ ?x => tac x + | ?m' _ _ _ ?x => tac x + | ?m' _ _ _ _ ?x => tac x + | ?m' _ _ _ _ _ ?x => tac x + | ?m' _ _ _ _ _ _ ?x => tac x + | ?m' _ _ _ _ _ _ _ ?x => tac x + | ?m' _ _ _ _ _ _ _ _ ?x => tac x + end + in + match goal with + | [ |- @Morphism _ _ ?m ] => on_morphism m + end. + +(* Program Instance [ Morphism (A -> B) (R ==> R') m, Reflexive A R ] (x : A) => *) +(* reflexive_partial_app_morphism : Morphism R' (m x). *) + +Hint Extern 4 (@Morphism _ _ _) => partial_application_tactic : typeclass_instances. + +Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B), + relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R'). +Proof. + intros. + unfold flip, respectful. + split ; intros ; intuition. +Qed. + +(** Special-purpose class to do normalization of signatures w.r.t. inverse. *) + +Class (A : Type) => Normalizes (m : relation A) (m' : relation A) : Prop := + normalizes : relation_equivalence m m'. + +Instance inverse_respectful_norm : + Normalizes (A -> B) (inverse R ==> inverse R') (inverse (R ==> R')) . +Proof. firstorder. Qed. + +(* If not an inverse on the left, do a double inverse. *) + +Instance not_inverse_respectful_norm : + Normalizes (A -> B) (R ==> inverse R') (inverse (inverse R ==> R')) | 4. +Proof. firstorder. Qed. + +Instance inverse_respectful_rec_norm [ Normalizes B R' (inverse R'') ] : + Normalizes (A -> B) (inverse R ==> R') (inverse (R ==> R'')). +Proof. red ; intros. + pose normalizes as r. + setoid_rewrite r. + setoid_rewrite inverse_respectful. + reflexivity. +Qed. + +(** Once we have normalized, we will apply this instance to simplify the problem. *) + +Program Instance morphism_inverse_morphism + [ Morphism A R m ] : Morphism (inverse R) m | 2. + +(** Bootstrap !!! *) + +Instance morphism_morphism : Morphism (relation_equivalence ==> @eq _ ==> iff) (@Morphism A). +Proof. + simpl_relation. + reduce in H. + split ; red ; intros. + setoid_rewrite <- H. + apply H0. + setoid_rewrite H. + apply H0. +Qed. + +Lemma morphism_releq_morphism [ Normalizes A R R', Morphism _ R' m ] : Morphism R m. +Proof. + intros. + pose respect as r. + pose normalizes as norm. + setoid_rewrite norm. + assumption. +Qed. + +Inductive normalization_done : Prop := did_normalization. + +Ltac morphism_normalization := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ |- @Morphism _ _ _ ] => let H := fresh "H" in + set(H:=did_normalization) ; eapply @morphism_releq_morphism + end. + +Hint Extern 6 (@Morphism _ _ _) => morphism_normalization : typeclass_instances. + +(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) + +Lemma reflexive_morphism [ Reflexive A R ] (x : A) + : Morphism R x. +Proof. firstorder. Qed. + +Ltac morphism_reflexive := + match goal with + | [ _ : normalization_done |- _ ] => fail 1 + | [ _ : subrelation_done |- _ ] => fail 1 + | [ |- @Morphism _ _ _ ] => eapply @reflexive_morphism + end. + +Hint Extern 4 (@Morphism _ _ _) => morphism_reflexive : typeclass_instances.
\ No newline at end of file diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v new file mode 100644 index 00000000..7dc1f95e --- /dev/null +++ b/theories/Classes/Morphisms_Prop.v @@ -0,0 +1,132 @@ +(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Morphism instances for propositional connectives. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +Require Import Coq.Classes.Morphisms. +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. + +(** Standard instances for [not], [iff] and [impl]. *) + +(** Logical negation. *) + +Program Instance not_impl_morphism : + Morphism (impl --> impl) not. + +Program Instance not_iff_morphism : + Morphism (iff ++> iff) not. + +(** Logical conjunction. *) + +Program Instance and_impl_iff_morphism : + Morphism (impl ==> impl ==> impl) and. + +(* Program Instance and_impl_iff_morphism : *) +(* Morphism (impl ==> iff ==> impl) and. *) + +(* Program Instance and_iff_impl_morphism : *) +(* Morphism (iff ==> impl ==> impl) and. *) + +(* Program Instance and_inverse_impl_iff_morphism : *) +(* Morphism (inverse impl ==> iff ==> inverse impl) and. *) + +(* Program Instance and_iff_inverse_impl_morphism : *) +(* Morphism (iff ==> inverse impl ==> inverse impl) and. *) + +Program Instance and_iff_morphism : + Morphism (iff ==> iff ==> iff) and. + +(** Logical disjunction. *) + +Program Instance or_impl_iff_morphism : + Morphism (impl ==> impl ==> impl) or. + +(* Program Instance or_impl_iff_morphism : *) +(* Morphism (impl ==> iff ==> impl) or. *) + +(* Program Instance or_iff_impl_morphism : *) +(* Morphism (iff ==> impl ==> impl) or. *) + +(* Program Instance or_inverse_impl_iff_morphism : *) +(* Morphism (inverse impl ==> iff ==> inverse impl) or. *) + +(* Program Instance or_iff_inverse_impl_morphism : *) +(* Morphism (iff ==> inverse impl ==> inverse impl) or. *) + +Program Instance or_iff_morphism : + Morphism (iff ==> iff ==> iff) or. + +(** Logical implication [impl] is a morphism for logical equivalence. *) + +Program Instance iff_iff_iff_impl_morphism : Morphism (iff ==> iff ==> iff) impl. + +(** Morphisms for quantifiers *) + +Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation iff ==> iff) (@ex A). + + Next Obligation. + Proof. + unfold pointwise_relation in H. + split ; intros. + destruct H0 as [xâ‚ Hâ‚]. + exists xâ‚. rewrite H in Hâ‚. assumption. + + destruct H0 as [xâ‚ Hâ‚]. + exists xâ‚. rewrite H. assumption. + Qed. + +Program Instance ex_impl_morphism {A : Type} : + Morphism (pointwise_relation impl ==> impl) (@ex A). + + Next Obligation. + Proof. + unfold pointwise_relation in H. + exists H0. apply H. assumption. + Qed. + +Program Instance ex_inverse_impl_morphism {A : Type} : + Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@ex A). + + Next Obligation. + Proof. + unfold pointwise_relation in H. + exists H0. apply H. assumption. + Qed. + +Program Instance all_iff_morphism {A : Type} : + Morphism (pointwise_relation iff ==> iff) (@all A). + + Next Obligation. + Proof. + unfold pointwise_relation, all in *. + intuition ; specialize (H x0) ; intuition. + Qed. + +Program Instance all_impl_morphism {A : Type} : + Morphism (pointwise_relation impl ==> impl) (@all A). + + Next Obligation. + Proof. + unfold pointwise_relation, all in *. + intuition ; specialize (H x0) ; intuition. + Qed. + +Program Instance all_inverse_impl_morphism {A : Type} : + Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@all A). + + Next Obligation. + Proof. + unfold pointwise_relation, all in *. + intuition ; specialize (H x0) ; intuition. + Qed. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v new file mode 100644 index 00000000..5018fa01 --- /dev/null +++ b/theories/Classes/Morphisms_Relations.v @@ -0,0 +1,50 @@ +(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Morphism instances for relations. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +Require Import Coq.Classes.Morphisms. +Require Import Coq.Program.Program. + +(** Morphisms for relations *) + +Instance relation_conjunction_morphism : Morphism (relation_equivalence (A:=A) ==> + relation_equivalence ==> relation_equivalence) relation_conjunction. + Proof. firstorder. Qed. + +Instance relation_disjunction_morphism : Morphism (relation_equivalence (A:=A) ==> + relation_equivalence ==> relation_equivalence) relation_disjunction. + Proof. firstorder. Qed. + +(* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *) + +Require Import List. + +Lemma predicate_equivalence_pointwise (l : list Type) : + Morphism (@predicate_equivalence l ==> pointwise_lifting iff l) id. +Proof. do 2 red. unfold predicate_equivalence. auto. Qed. + +Lemma predicate_implication_pointwise (l : list Type) : + Morphism (@predicate_implication l ==> pointwise_lifting impl l) id. +Proof. do 2 red. unfold predicate_implication. auto. Qed. + +(** The instanciation at relation allows to rewrite applications of relations [R x y] to [R' x y] *) +(* when [R] and [R'] are in [relation_equivalence]. *) + +Instance relation_equivalence_pointwise : + Morphism (relation_equivalence ==> pointwise_relation (A:=A) (pointwise_relation (A:=A) iff)) id. +Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed. + +Instance subrelation_pointwise : + Morphism (subrelation ==> pointwise_relation (A:=A) (pointwise_relation (A:=A) impl)) id. +Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v new file mode 100644 index 00000000..a9a53068 --- /dev/null +++ b/theories/Classes/RelationClasses.v @@ -0,0 +1,400 @@ +(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.RelationClasses") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Typeclass-based relations, tactics and standard instances. + This is the basic theory needed to formalize morphisms and setoids. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: RelationClasses.v 11092 2008-06-10 18:28:26Z msozeau $ *) + +Require Export Coq.Classes.Init. +Require Import Coq.Program.Basics. +Require Import Coq.Program.Tactics. +Require Export Coq.Relations.Relation_Definitions. + +Notation inverse R := (flip (R:relation _) : relation _). + +Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False. + +Definition pointwise_relation {A B : Type} (R : relation B) : relation (A -> B) := + fun f g => forall x : A, R (f x) (g x). + +(** These are convertible. *) + +Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). +Proof. reflexivity. Qed. + +(** We rebind relations in separate classes to be able to overload each proof. *) + +Set Implicit Arguments. +Unset Strict Implicit. + +Class Reflexive A (R : relation A) := + reflexivity : forall x, R x x. + +Class Irreflexive A (R : relation A) := + irreflexivity :> Reflexive A (complement R). + +Class Symmetric A (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Class Asymmetric A (R : relation A) := + asymmetry : forall x y, R x y -> R y x -> False. + +Class Transitive A (R : relation A) := + transitivity : forall x y z, R x y -> R y z -> R x z. + +Implicit Arguments Reflexive [A]. +Implicit Arguments Irreflexive [A]. +Implicit Arguments Symmetric [A]. +Implicit Arguments Asymmetric [A]. +Implicit Arguments Transitive [A]. + +Hint Resolve @irreflexivity : ord. + +Unset Implicit Arguments. + +(** We can already dualize all these properties. *) + +Program Instance flip_Reflexive [ Reflexive A R ] : Reflexive (flip R) := + reflexivity := reflexivity (R:=R). + +Program Instance flip_Irreflexive [ Irreflexive A R ] : Irreflexive (flip R) := + irreflexivity := irreflexivity (R:=R). + +Program Instance flip_Symmetric [ Symmetric A R ] : Symmetric (flip R). + + Solve Obligations using unfold flip ; program_simpl ; clapply Symmetric. + +Program Instance flip_Asymmetric [ Asymmetric A R ] : Asymmetric (flip R). + + Solve Obligations using program_simpl ; unfold flip in * ; intros ; clapply asymmetry. + +Program Instance flip_Transitive [ Transitive A R ] : Transitive (flip R). + + Solve Obligations using unfold flip ; program_simpl ; clapply transitivity. + +Program Instance Reflexive_complement_Irreflexive [ Reflexive A (R : relation A) ] + : Irreflexive (complement R). + + Next Obligation. + Proof. + unfold complement. + red. intros H. + intros H' ; apply H'. + apply (reflexivity H). + Qed. + + +Program Instance complement_Symmetric [ Symmetric A (R : relation A) ] : Symmetric (complement R). + + Next Obligation. + Proof. + red ; intros H'. + apply (H (symmetry H')). + Qed. + +(** * Standard instances. *) + +Ltac reduce_hyp H := + match type of H with + | context [ _ <-> _ ] => fail 1 + | _ => red in H ; try reduce_hyp H + end. + +Ltac reduce_goal := + match goal with + | [ |- _ <-> _ ] => fail 1 + | _ => red ; intros ; try reduce_goal + end. + +Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. + +Ltac reduce := reduce_goal. + +Tactic Notation "apply" "*" constr(t) := + first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | + refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. + +Ltac simpl_relation := + unfold flip, impl, arrow ; try reduce ; program_simpl ; + try ( solve [ intuition ]). + +Ltac obligations_tactic ::= simpl_relation. + +(** Logical implication. *) + +Program Instance impl_Reflexive : Reflexive impl. +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. + +(** Leibniz equality. *) + +Program Instance eq_Reflexive : Reflexive (@eq A). +Program Instance eq_Symmetric : Symmetric (@eq A). +Program Instance eq_Transitive : Transitive (@eq A). + +(** Various combinations of reflexivity, symmetry and transitivity. *) + +(** A [PreOrder] is both Reflexive and Transitive. *) + +Class PreOrder A (R : relation A) : Prop := + PreOrder_Reflexive :> Reflexive R ; + PreOrder_Transitive :> Transitive R. + +(** A partial equivalence relation is Symmetric and Transitive. *) + +Class PER (carrier : Type) (pequiv : relation carrier) : Prop := + PER_Symmetric :> Symmetric pequiv ; + PER_Transitive :> Transitive pequiv. + +(** Equivalence relations. *) + +Class Equivalence (carrier : Type) (equiv : relation carrier) : Prop := + Equivalence_Reflexive :> Reflexive equiv ; + Equivalence_Symmetric :> Symmetric equiv ; + Equivalence_Transitive :> Transitive equiv. + +(** An Equivalence is a PER plus reflexivity. *) + +Instance Equivalence_PER [ Equivalence A R ] : PER A R := + PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive. + +(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) + +Class [ Equivalence A eqA ] => Antisymmetric (R : relation A) := + antisymmetry : forall x y, R x y -> R y x -> eqA x y. + +Program Instance flip_antiSymmetric [ eq : Equivalence A eqA, ! Antisymmetric eq R ] : + Antisymmetric eq (flip R). + +(** Leibinz equality [eq] is an equivalence relation. + The instance has low priority as it is always applicable + if only the type is constrained. *) + +Program Instance eq_equivalence : Equivalence A (@eq A) | 10. + +(** Logical equivalence [iff] is an equivalence relation. *) + +Program Instance iff_equivalence : Equivalence Prop iff. + +(** We now develop a generalization of results on relations for arbitrary predicates. + The resulting theory can be applied to homogeneous binary relations but also to + arbitrary n-ary predicates. *) + +Require Import List. + +(* Notation " [ ] " := nil : list_scope. *) +(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) + +(* Open Local Scope list_scope. *) + +(** A compact representation of non-dependent arities, with the codomain singled-out. *) + +Fixpoint arrows (l : list Type) (r : Type) : Type := + match l with + | nil => 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 (cons A nil) A. +Definition binary_operation A := arrows (cons A (cons A nil)) A. +Definition ternary_operation A := arrows (cons A (cons A (cons A nil))) A. + +(** We define n-ary [predicate]s as functions into [Prop]. *) + +Notation predicate l := (arrows l Prop). + +(** Unary predicates, or sets. *) + +Definition unary_predicate A := predicate (cons A nil). + +(** Homogeneous binary relations, equivalent to [relation A]. *) + +Definition binary_relation A := predicate (cons A (cons A nil)). + +(** We can close a predicate by universal or existential quantification. *) + +Fixpoint predicate_all (l : list Type) : predicate l -> Prop := + match l with + | nil => 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 := + match l with + | nil => fun f => f + | A :: tl => fun f => exists x : A, predicate_exists tl (f x) + end. + +(** Pointwise extension of a binary operation on [T] to a binary operation + on functions whose codomain is [T]. + 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) := + match l with + | nil => 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) := + match l with + | nil => 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) := + pointwise_lifting iff l. + +(** The n-ary implication relation, defined by lifting the 0-ary [impl] relation. *) + +Definition predicate_implication {l : list Type} := + pointwise_lifting impl l. + +(** Notations for pointwise equivalence and implication of predicates. *) + +Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. +Infix "-∙>" := predicate_implication (at level 70) : predicate_scope. + +Open Local Scope predicate_scope. + +(** The pointwise liftings of conjunction and disjunctions. + Note that these are [binary_operation]s, building new relations out of old ones. *) + +Definition predicate_intersection := pointwise_extension and. +Definition predicate_union := pointwise_extension or. + +Infix "/∙\" := predicate_intersection (at level 80, right associativity) : predicate_scope. +Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_scope. + +(** The always [True] and always [False] predicates. *) + +Fixpoint true_predicate {l : list Type} : predicate l := + match l with + | nil => True + | A :: tl => fun _ => @true_predicate tl + end. + +Fixpoint false_predicate {l : list Type} : predicate l := + match l with + | nil => False + | A :: tl => fun _ => @false_predicate tl + end. + +Notation "∙⊤∙" := true_predicate : predicate_scope. +Notation "∙⊥∙" := false_predicate : predicate_scope. + +(** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) + +Program Instance predicate_equivalence_equivalence : + Equivalence (predicate l) predicate_equivalence. + + Next Obligation. + induction l ; firstorder. + Qed. + + Next Obligation. + induction l ; firstorder. + Qed. + + Next Obligation. + fold pointwise_lifting. + induction l. firstorder. + intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). + firstorder. + Qed. + +Program Instance predicate_implication_preorder : + PreOrder (predicate l) predicate_implication. + + Next Obligation. + induction l ; firstorder. + Qed. + + Next Obligation. + induction l. firstorder. + unfold predicate_implication in *. simpl in *. + intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. + Qed. + +(** We define the various operations which define the algebra on binary relations, + from the general ones. *) + +Definition relation_equivalence {A : Type} : relation (relation A) := + @predicate_equivalence (cons _ (cons _ nil)). + +Class subrelation {A:Type} (R R' : relation A) : Prop := + is_subrelation : @predicate_implication (cons A (cons A nil)) R R'. + +Implicit Arguments subrelation [[A]]. + +Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A := + @predicate_intersection (cons A (cons A nil)) R R'. + +Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A := + @predicate_union (cons A (cons A nil)) R R'. + +(** Relation equivalence is an equivalence, and subrelation defines a partial order. *) + +Instance relation_equivalence_equivalence (A : Type) : + Equivalence (relation A) relation_equivalence. +Proof. intro A. exact (@predicate_equivalence_equivalence (cons A (cons A nil))). Qed. + +Instance relation_implication_preorder : PreOrder (relation A) subrelation. +Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Qed. + +(** *** Partial Order. + A partial order is a preorder which is additionally antisymmetric. + We give an equivalent definition, up-to an equivalence relation + on the carrier. *) + +Class [ equ : Equivalence A eqA, PreOrder A R ] => PartialOrder := + partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). + +(** The equivalence proof is sufficient for proving that [R] must be a morphism + for equivalence (see Morphisms). + It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) + +Instance partial_order_antisym [ PartialOrder A eqA R ] : ! Antisymmetric A eqA R. +Proof with auto. + reduce_goal. pose proof partial_order_equivalence as poe. do 3 red in poe. + apply <- poe. firstorder. +Qed. + +(** The partial order defined by subrelation and relation equivalence. *) + +Program Instance subrelation_partial_order : + ! PartialOrder (relation A) relation_equivalence subrelation. + + Next Obligation. + Proof. + unfold relation_equivalence in *. firstorder. + Qed. + +Lemma inverse_pointwise_relation A (R : relation A) : + relation_equivalence (pointwise_relation (inverse R)) (inverse (pointwise_relation (A:=A) R)). +Proof. reflexivity. Qed. diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v new file mode 100644 index 00000000..9264b6d2 --- /dev/null +++ b/theories/Classes/SetoidAxioms.v @@ -0,0 +1,35 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Extensionality axioms that can be used when reasoning with setoids. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(* $Id: SetoidAxioms.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +Require Import Coq.Program.Program. + +Set Implicit Arguments. +Unset Strict Implicit. + +Require Export Coq.Classes.SetoidClass. + +(* Application of the extensionality axiom to turn a goal on leibinz equality to + a setoid equivalence. *) + +Axiom setoideq_eq : forall [ sa : Setoid a ] (x y : a), x == y -> x = y. + +(** Application of the extensionality principle for setoids. *) + +Ltac setoid_extensionality := + match goal with + [ |- @eq ?A ?X ?Y ] => apply (setoideq_eq (a:=A) (x:=X) (y:=Y)) + end. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v new file mode 100644 index 00000000..a9bdaa8f --- /dev/null +++ b/theories/Classes/SetoidClass.v @@ -0,0 +1,181 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Typeclass-based setoids, tactics and standard instances. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + 91405 Orsay, France *) + +(* $Id: SetoidClass.v 11065 2008-06-06 22:39:43Z msozeau $ *) + +Set Implicit Arguments. +Unset Strict Implicit. + +Require Import Coq.Program.Program. + +Require Import Coq.Classes.Init. +Require Export Coq.Classes.RelationClasses. +Require Export Coq.Classes.Morphisms. +Require Import Coq.Classes.Functions. + +(** A setoid wraps an equivalence. *) + +Class Setoid A := + equiv : relation A ; + setoid_equiv :> Equivalence A equiv. + +Typeclasses unfold equiv. + +(* Too dangerous instance *) +(* Program Instance [ eqa : Equivalence A eqA ] => *) +(* equivalence_setoid : Setoid A := *) +(* equiv := eqA ; setoid_equiv := eqa. *) + +(** Shortcuts to make proof search easier. *) + +Definition setoid_refl [ sa : Setoid A ] : Reflexive equiv. +Proof. eauto with typeclass_instances. Qed. + +Definition setoid_sym [ sa : Setoid A ] : Symmetric equiv. +Proof. eauto with typeclass_instances. Qed. + +Definition setoid_trans [ sa : Setoid A ] : Transitive equiv. +Proof. eauto with typeclass_instances. Qed. + +Existing Instance setoid_refl. +Existing Instance setoid_sym. +Existing Instance setoid_trans. + +(** Standard setoids. *) + +(* Program Instance eq_setoid : Setoid A := *) +(* equiv := eq ; setoid_equiv := eq_equivalence. *) + +Program Instance iff_setoid : Setoid Prop := + equiv := iff ; setoid_equiv := iff_equivalence. + +(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) + +(** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *) +(* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *) + +Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope. + +Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope. + +(** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) + +Ltac clsubst H := + match type of H with + ?x == ?y => substitute H ; clear H x + end. + +Ltac clsubst_nofail := + match goal with + | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail + | _ => idtac + end. + +(** [subst*] will try its best at substituting every equality in the goal. *) + +Tactic Notation "clsubst" "*" := clsubst_nofail. + +Lemma nequiv_equiv_trans : forall [ Setoid A ] (x y z : A), x =/= y -> y == z -> x =/= z. +Proof with auto. + intros; intro. + assert(z == y) by (symmetry ; auto). + assert(x == y) by (transitivity z ; eauto). + contradiction. +Qed. + +Lemma equiv_nequiv_trans : forall [ Setoid A ] (x y z : A), x == y -> y =/= z -> x =/= z. +Proof. + intros; intro. + assert(y == x) by (symmetry ; auto). + assert(y == z) by (transitivity x ; eauto). + contradiction. +Qed. + +Ltac setoid_simplify_one := + match goal with + | [ H : (?x == ?x)%type |- _ ] => clear H + | [ H : (?x == ?y)%type |- _ ] => clsubst H + | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name + end. + +Ltac setoid_simplify := repeat setoid_simplify_one. + +Ltac setoidify_tac := + match goal with + | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H + | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y) + end. + +Ltac setoidify := repeat setoidify_tac. + +(** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) + +Program Definition setoid_morphism [ sa : Setoid A ] : Morphism (equiv ++> equiv ++> iff) equiv := + trans_sym_morphism. + +(** Add this very useful instance in the database. *) + +Implicit Arguments setoid_morphism [[!sa]]. +Existing Instance setoid_morphism. + +Program Definition setoid_partial_app_morphism [ sa : Setoid A ] (x : A) : Morphism (equiv ++> iff) (equiv x) := + Reflexive_partial_app_morphism. + +Existing Instance setoid_partial_app_morphism. + +Definition type_eq : relation Type := + fun x y => x = y. + +Program Instance type_equivalence : Equivalence Type type_eq. + +Ltac morphism_tac := try red ; unfold arrow ; intros ; program_simpl ; try tauto. + +Ltac obligations_tactic ::= morphism_tac. + +(** These are morphisms used to rewrite at the top level of a proof, + using [iff_impl_id_morphism] if the proof is in [Prop] and + [eq_arrow_id_morphism] if it is in Type. *) + +Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) Basics.id. + +(* Program Instance eq_arrow_id_morphism : ? Morphism (eq +++> arrow) id. *) + +(* Definition compose_respect (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) +(* (x y : A -> C) : Prop := forall (f : A -> B) (g : B -> C), R f f -> R' g g. *) + +(* Program Instance (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) +(* [ mg : ? Morphism R' g ] [ mf : ? Morphism R f ] => *) +(* compose_morphism : ? Morphism (compose_respect R R') (g o f). *) + +(* Next Obligation. *) +(* Proof. *) +(* apply (respect (m0:=mg)). *) +(* apply (respect (m0:=mf)). *) +(* assumption. *) +(* Qed. *) + +(** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) + +Class PartialSetoid (carrier : Type) := + pequiv : relation carrier ; + pequiv_prf :> PER carrier pequiv. + +(** Overloaded notation for partial setoid equivalence. *) + +Infix "=~=" := pequiv (at level 70, no associativity) : type_scope. + +(** Reset the default Program tactic. *) + +Ltac obligations_tactic ::= program_simpl. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v new file mode 100644 index 00000000..cf3d202d --- /dev/null +++ b/theories/Classes/SetoidDec.v @@ -0,0 +1,126 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Decidable setoid equality theory. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(* $Id: SetoidDec.v 10919 2008-05-11 22:04:26Z msozeau $ *) + +Set Implicit Arguments. +Unset Strict Implicit. + +(** Export notations. *) + +Require Export Coq.Classes.SetoidClass. + +(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more + classically. *) + +Require Import Coq.Logic.Decidable. + +Class [ Setoid A ] => DecidableSetoid := + setoid_decidable : forall x y : A, decidable (x == y). + +(** The [EqDec] class gives a decision procedure for a particular setoid equality. *) + +Class [ Setoid A ] => EqDec := + equiv_dec : forall x y : A, { x == y } + { x =/= y }. + +(** We define the [==] overloaded notation for deciding equality. It does not take precedence + of [==] defined in the type scope, hence we can have both at the same time. *) + +Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70). + +Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := + match x with + | left H => @right _ _ H + | right H => @left _ _ H + end. + +Require Import Coq.Program.Program. + +Open Local Scope program_scope. + +(** Invert the branches. *) + +Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). + +(** Overloaded notation for inequality. *) + +Infix "=/=" := nequiv_dec (no associativity, at level 70). + +(** Define boolean versions, losing the logical information. *) + +Definition equiv_decb [ EqDec A ] (x y : A) : bool := + if x == y then true else false. + +Definition nequiv_decb [ EqDec A ] (x y : A) : bool := + negb (equiv_decb x y). + +Infix "==b" := equiv_decb (no associativity, at level 70). +Infix "<>b" := nequiv_decb (no associativity, at level 70). + +(** Decidable leibniz equality instances. *) + +Require Import Coq.Arith.Arith. + +(** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) + +Program Instance eq_setoid : Setoid A := + equiv := eq ; setoid_equiv := eq_equivalence. + +Program Instance nat_eq_eqdec : EqDec (@eq_setoid nat) := + equiv_dec := eq_nat_dec. + +Require Import Coq.Bool.Bool. + +Program Instance bool_eqdec : EqDec (@eq_setoid bool) := + equiv_dec := bool_dec. + +Program Instance unit_eqdec : EqDec (@eq_setoid unit) := + equiv_dec x y := in_left. + + Next Obligation. + Proof. + destruct x ; destruct y. + reflexivity. + Qed. + +Program Instance prod_eqdec [ ! EqDec (@eq_setoid A), ! EqDec (@eq_setoid B) ] : EqDec (@eq_setoid (prod A B)) := + equiv_dec x y := + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then + if x2 == y2 then in_left + else in_right + else in_right. + + Solve Obligations using unfold complement ; program_simpl. + +(** Objects of function spaces with countable domains like bool have decidable equality. *) + +Require Import Coq.Program.FunctionalExtensionality. + +Program Instance bool_function_eqdec [ ! EqDec (@eq_setoid A) ] : EqDec (@eq_setoid (bool -> A)) := + equiv_dec f g := + if f true == g true then + if f false == g false then in_left + else in_right + else in_right. + + Solve Obligations using try red ; unfold equiv, complement ; program_simpl. + + Next Obligation. + Proof. + extensionality x. + destruct x ; auto. + Qed. diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v new file mode 100644 index 00000000..b29a52cc --- /dev/null +++ b/theories/Classes/SetoidTactics.v @@ -0,0 +1,176 @@ +(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.SetoidTactics") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Tactics for typeclass-based setoids. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(* $Id: SetoidTactics.v 10921 2008-05-12 12:27:25Z msozeau $ *) + +Require Export Coq.Classes.RelationClasses. +Require Export Coq.Classes.Morphisms. +Require Export Coq.Classes.Morphisms_Prop. +Require Export Coq.Classes.Equivalence. +Require Export Coq.Relations.Relation_Definitions. + +Set Implicit Arguments. +Unset Strict Implicit. + +(** Default relation on a given support. Can be used by tactics + to find a sensible default relation on any carrier. Users can + declare an [Instance A RA] anywhere to declare default relations. + This is also done by the [Declare Relation A RA] command with no + parameters for backward compatibility. *) + +Class DefaultRelation A (R : relation A). + +(** To search for the default relation, just call [default_relation]. *) + +Definition default_relation [ DefaultRelation A R ] := R. + +(** Every [Equivalence] gives a default relation, if no other is given (lowest priority). *) + +Instance equivalence_default [ Equivalence A R ] : DefaultRelation A R | 4. + +(** The setoid_replace tactics in Ltac, defined in terms of default relations and + the setoid_rewrite tactic. *) + +Ltac setoidreplace H t := + let Heq := fresh "Heq" in + cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq ; clear Heq | t ]. + +Ltac setoidreplacein H H' t := + let Heq := fresh "Heq" in + cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq in H' ; clear Heq | t ]. + +Ltac setoidreplaceinat H H' t occs := + let Heq := fresh "Heq" in + cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq in H' at occs ; clear Heq | t ]. + +Ltac setoidreplaceat H t occs := + let Heq := fresh "Heq" in + cut(H) ; unfold default_relation ; [ intro Heq ; setoid_rewrite Heq at occs ; clear Heq | t ]. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) := + setoidreplace (default_relation x y) idtac. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "at" int_or_var_list(o) := + setoidreplaceat (default_relation x y) idtac o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) := + setoidreplacein (default_relation x y) id idtac. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) + "at" int_or_var_list(o) := + setoidreplaceinat (default_relation x y) id idtac o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "by" tactic3(t) := + setoidreplace (default_relation x y) ltac:t. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "at" int_or_var_list(o) + "by" tactic3(t) := + setoidreplaceat (default_relation x y) ltac:t o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) + "by" tactic3(t) := + setoidreplacein (default_relation x y) id ltac:t. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) + "at" int_or_var_list(o) + "by" tactic3(t) := + setoidreplaceinat (default_relation x y) id ltac:t o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) := + setoidreplace (rel x y) idtac. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "at" int_or_var_list(o) := + setoidreplaceat (rel x y) idtac o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "by" tactic3(t) := + setoidreplace (rel x y) ltac:t. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "at" int_or_var_list(o) + "by" tactic3(t) := + setoidreplaceat (rel x y) ltac:t o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "in" hyp(id) := + setoidreplacein (rel x y) id idtac. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "in" hyp(id) + "at" int_or_var_list(o) := + setoidreplaceinat (rel x y) id idtac o. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "in" hyp(id) + "by" tactic3(t) := + setoidreplacein (rel x y) id ltac:t. + +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "in" hyp(id) + "at" int_or_var_list(o) + "by" tactic3(t) := + setoidreplaceinat (rel x y) id ltac:t o. + +(** The [add_morphism_tactic] tactic is run at each [Add Morphism] command before giving the hand back + to the user to discharge the proof. It essentially amounts to unfold the right amount of [respectful] calls + and substitute leibniz equalities. One can redefine it using [Ltac add_morphism_tactic ::= t]. *) + +Require Import Coq.Program.Tactics. + +Open Local Scope signature_scope. + +Ltac red_subst_eq_morphism concl := + match concl with + | @Logic.eq ?A ==> ?R' => red ; intros ; subst ; red_subst_eq_morphism R' + | ?R ==> ?R' => red ; intros ; red_subst_eq_morphism R' + | _ => idtac + end. + +Ltac destruct_morphism := + match goal with + | [ |- @Morphism ?A ?R ?m ] => red + end. + +Ltac reverse_arrows x := + match x with + | @Logic.eq ?A ==> ?R' => revert_last ; reverse_arrows R' + | ?R ==> ?R' => do 3 revert_last ; reverse_arrows R' + | _ => idtac + end. + +Ltac default_add_morphism_tactic := + intros ; + (try destruct_morphism) ; + match goal with + | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y) + end. + +Ltac add_morphism_tactic := default_add_morphism_tactic. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 4807ed66..8cb1236e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -9,35 +9,35 @@ (* Finite map library. *) -(* $Id: FMapAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *) +(* $Id: FMapAVL.v 11033 2008-06-01 22:56:50Z letouzey $ *) -(** This module implements map using AVL trees. - It follows the implementation from Ocaml's standard library. *) +(** * FMapAVL *) -Require Import FSetInterface. -Require Import FMapInterface. -Require Import FMapList. +(** This module implements maps using AVL trees. + It follows the implementation from Ocaml's standard library. + + See the comments at the beginning of FSetAVL for more details. +*) -Require Import ZArith. -Require Import Int. +Require Import FMapInterface FMapList ZArith Int. -Set Firstorder Depth 3. Set Implicit Arguments. Unset Strict Implicit. +(** Notations and helper lemma about pairs *) -Module Raw (I:Int)(X: OrderedType). -Import I. -Module II:=MoreInt(I). -Import II. -Open Local Scope Int_scope. +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. -Module E := X. -Module MX := OrderedTypeFacts X. -Module PX := KeyOrderedType X. -Module L := FMapList.Raw X. -Import MX. -Import PX. +(** * The Raw functor + + Functor of pure functions + separate proofs of invariant + preservation *) + +Module Raw (Import I:Int)(X: OrderedType). +Open Local Scope pair_scope. +Open Local Scope lazy_bool_scope. +Open Local Scope Int_scope. Definition key := X.t. @@ -45,30 +45,391 @@ Definition key := X.t. Section Elt. -Variable elt : Set. +Variable elt : Type. -(* Now in KeyOrderedType: -Definition eqk (p p':key*elt) := X.eq (fst p) (fst p'). -Definition eqke (p p':key*elt) := - X.eq (fst p) (fst p') /\ (snd p) = (snd p'). -Definition ltk (p p':key*elt) := X.lt (fst p) (fst p'). -*) +(** * Trees -Notation eqk := (eqk (elt:= elt)). -Notation eqke := (eqke (elt:= elt)). -Notation ltk := (ltk (elt:= elt)). + The fifth field of [Node] is the height of the tree *) -Inductive tree : Set := +Inductive tree := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. Notation t := tree. -(** The Sixth field of [Node] is the height of the tree *) +(** * Basic functions on trees: height and cardinal *) + +Definition height (m : t) : int := + match m with + | Leaf => 0 + | Node _ _ _ _ h => h + end. + +Fixpoint cardinal (m : t) : nat := + match m with + | Leaf => 0%nat + | Node l _ _ r _ => S (cardinal l + cardinal r) + end. + +(** * Empty Map *) + +Definition empty := Leaf. + +(** * Emptyness test *) + +Definition is_empty m := match m with Leaf => true | _ => false end. + +(** * Appartness *) + +(** The [mem] function is deciding appartness. It exploits the [bst] property + to achieve logarithmic complexity. *) + +Fixpoint mem x m : bool := + match m with + | Leaf => false + | Node l y _ r _ => match X.compare x y with + | LT _ => mem x l + | EQ _ => true + | GT _ => mem x r + end + end. + +Fixpoint find x m : option elt := + match m with + | Leaf => None + | Node l y d r _ => match X.compare x y with + | LT _ => find x l + | EQ _ => Some d + | GT _ => find x r + end + end. + +(** * Helper functions *) -(** * Occurrence in a tree *) +(** [create l x r] creates a node, assuming [l] and [r] + to be balanced and [|height l - height r| <= 2]. *) -Inductive MapsTo (x : key)(e : elt) : tree -> Prop := +Definition create l x e r := + Node l x e r (max (height l) (height r) + 1). + +(** [bal l x e r] acts as [create], but performs one step of + rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) + +Definition assert_false := create. + +Fixpoint bal l x d r := + let hl := height l in + let hr := height r in + if gt_le_dec hl (hr+2) then + match l with + | Leaf => assert_false l x d r + | Node ll lx ld lr _ => + if ge_lt_dec (height ll) (height lr) then + create ll lx ld (create lr x d r) + else + match lr with + | Leaf => assert_false l x d r + | Node lrl lrx lrd lrr _ => + create (create ll lx ld lrl) lrx lrd (create lrr x d r) + end + end + else + if gt_le_dec hr (hl+2) then + match r with + | Leaf => assert_false l x d r + | Node rl rx rd rr _ => + if ge_lt_dec (height rr) (height rl) then + create (create l x d rl) rx rd rr + else + match rl with + | Leaf => assert_false l x d r + | Node rll rlx rld rlr _ => + create (create l x d rll) rlx rld (create rlr rx rd rr) + end + end + else + create l x d r. + +(** * Insertion *) + +Fixpoint add x d m := + match m with + | Leaf => Node Leaf x d Leaf 1 + | Node l y d' r h => + match X.compare x y with + | LT _ => bal (add x d l) y d' r + | EQ _ => Node l y d r h + | GT _ => bal l y d' (add x d r) + end + end. + +(** * Extraction of minimum binding + + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x e r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). +*) + +Fixpoint remove_min l x d r : t*(key*elt) := + match l with + | Leaf => (r,(x,d)) + | Node ll lx ld lr lh => + let (l',m) := remove_min ll lx ld lr in + (bal l' x d r, m) + end. + +(** * Merging two trees + + [merge t1 t2] builds the union of [t1] and [t2] assuming all elements + of [t1] to be smaller than all elements of [t2], and + [|height t1 - height t2| <= 2]. +*) + +Fixpoint merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 d2 r2 h2 => + match remove_min l2 x2 d2 r2 with + (s2',(x,d)) => bal s1 x d s2' + end +end. + +(** * Deletion *) + +Fixpoint remove x m := match m with + | Leaf => Leaf + | Node l y d r h => + match X.compare x y with + | LT _ => bal (remove x l) y d r + | EQ _ => merge l r + | GT _ => bal l y d (remove x r) + end + end. + +(** * join + + Same as [bal] but does not assume anything regarding heights of [l] + and [r]. +*) + +Fixpoint join l : key -> elt -> t -> t := + match l with + | Leaf => add + | Node ll lx ld lr lh => fun x d => + fix join_aux (r:t) : t := match r with + | Leaf => add x d l + | Node rl rx rd rr rh => + if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr + else create l x d r + end + end. + +(** * Splitting + + [split x m] returns a triple [(l, o, r)] where + - [l] is the set of elements of [m] that are [< x] + - [r] is the set of elements of [m] that are [> x] + - [o] is the result of [find x m]. +*) + +Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. +Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). + +Fixpoint split x m : triple := match m with + | Leaf => << Leaf, None, Leaf >> + | Node l y d r h => + match X.compare x y with + | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >> + | EQ _ => << l, Some d, r >> + | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >> + end + end. + +(** * Concatenation + + Same as [merge] but does not assume anything about heights. +*) + +Definition concat m1 m2 := + match m1, m2 with + | Leaf, _ => m2 + | _ , Leaf => m1 + | _, Node l2 x2 d2 r2 _ => + let (m2',xd) := remove_min l2 x2 d2 r2 in + join m1 xd#1 xd#2 m2' + end. + +(** * Elements *) + +(** [elements_tree_aux acc t] catenates the elements of [t] in infix + order to the list [acc] *) + +Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) := + match m with + | Leaf => acc + | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l + end. + +(** then [elements] is an instanciation with an empty [acc] *) + +Definition elements := elements_aux nil. + +(** * Fold *) + +Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := + fun a => match m with + | Leaf => a + | Node l x d r _ => fold f r (f x d (fold f l a)) + end. + +(** * Comparison *) + +Variable cmp : elt->elt->bool. + +(** ** Enumeration of the elements of a tree *) + +Inductive enumeration := + | End : enumeration + | More : key -> elt -> t -> enumeration -> enumeration. + +(** [cons m e] adds the elements of tree [m] on the head of + enumeration [e]. *) + +Fixpoint cons m e : enumeration := + match m with + | Leaf => e + | Node l x d r h => cons l (More x d r e) + end. + +(** One step of comparison of elements *) + +Definition equal_more x1 d1 (cont:enumeration->bool) e2 := + match e2 with + | End => false + | More x2 d2 r2 e2 => + match X.compare x1 x2 with + | EQ _ => cmp d1 d2 &&& cont (cons r2 e2) + | _ => false + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := + match m1 with + | Leaf => cont e2 + | Node l1 x1 d1 r1 _ => + equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition equal_end e2 := match e2 with End => true | _ => false end. + +(** The complete comparison *) + +Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). + +End Elt. +Notation t := tree. +Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). +Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). +Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). +Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). + + +(** * Map *) + +Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := + match m with + | Leaf => Leaf _ + | Node l x d r h => Node (map f l) x (f d) (map f r) h + end. + +(* * Mapi *) + +Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := + match m with + | Leaf => Leaf _ + | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h + end. + +(** * Map with removal *) + +Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) + : t elt' := + match m with + | Leaf => Leaf _ + | Node l x d r h => + match f x d with + | Some d' => join (map_option f l) x d' (map_option f r) + | None => concat (map_option f l) (map_option f r) + end + end. + +(** * Optimized map2 + + Suggestion by B. Gregoire: a [map2] function with specialized + arguments allowing to bypass some tree traversal. Instead of one + [f0] of type [key -> option elt -> option elt' -> option elt''], + we ask here for: + - [f] which is a specialisation of [f0] when first option isn't [None] + - [mapl] treats a [tree elt] with [f0] when second option is [None] + - [mapr] treats a [tree elt'] with [f0] when first option is [None] + + The idea is that [mapl] and [mapr] can be instantaneous (e.g. + the identity or some constant function). +*) + +Section Map2_opt. +Variable elt elt' elt'' : Type. +Variable f : key -> elt -> option elt' -> option elt''. +Variable mapl : t elt -> t elt''. +Variable mapr : t elt' -> t elt''. + +Fixpoint map2_opt m1 m2 := + match m1, m2 with + | Leaf, _ => mapr m2 + | _, Leaf => mapl m1 + | Node l1 x1 d1 r1 h1, _ => + let (l2',o2,r2') := split x1 m2 in + match f x1 d1 o2 with + | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') + | None => concat (map2_opt l1 l2') (map2_opt r1 r2') + end + end. + +End Map2_opt. + +(** * Map2 + + The [map2] function of the Map interface can be implemented + via [map2_opt] and [map_option]. +*) + +Section Map2. +Variable elt elt' elt'' : Type. +Variable f : option elt -> option elt' -> option elt''. + +Definition map2 : t elt -> t elt' -> t elt'' := + map2_opt + (fun _ d o => f (Some d) o) + (map_option (fun _ d => f (Some d) None)) + (map_option (fun _ d' => f None (Some d'))). + +End Map2. + + + +(** * Invariants *) + +Section Invariants. +Variable elt : Type. + +(** ** Occurrence in a tree *) + +Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := | MapsRoot : forall l r h y, X.eq x y -> MapsTo x e (Node l y e r h) | MapsLeft : forall l r h y e', @@ -76,7 +437,7 @@ Inductive MapsTo (x : key)(e : elt) : tree -> Prop := | MapsRight : forall l r h y e', MapsTo x e r -> MapsTo x e (Node l y e' r h). -Inductive In (x : key) : tree -> Prop := +Inductive In (x : key) : t elt -> Prop := | InRoot : forall l r h y e, X.eq x y -> In x (Node l y e r h) | InLeft : forall l r h y e', @@ -84,58 +445,66 @@ Inductive In (x : key) : tree -> Prop := | InRight : forall l r h y e', In x r -> In x (Node l y e' r h). -Definition In0 (k:key)(m:t) : Prop := exists e:elt, MapsTo k e m. +Definition In0 k m := exists e:elt, MapsTo k e m. -(** * Binary search trees *) +(** ** Binary search trees *) (** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) -Definition lt_tree x s := forall y:key, In y s -> X.lt y x. -Definition gt_tree x s := forall y:key, In y s -> X.lt x y. +Definition lt_tree x m := forall y, In y m -> X.lt y x. +Definition gt_tree x m := forall y, In y m -> X.lt x y. (** [bst t] : [t] is a binary search tree *) -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall x e l r h, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h). +Inductive bst : t elt -> Prop := + | BSLeaf : bst (Leaf _) + | BSNode : forall x e l r h, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node l x e r h). -(** * AVL trees *) +End Invariants. -(** [avl s] : [s] is a properly balanced AVL tree, - i.e. for any node the heights of the two children - differ by at most 2 *) -Definition height (s : tree) : int := - match s with - | Leaf => 0 - | Node _ _ _ _ h => h - end. +(** * Correctness proofs, isolated in a sub-module *) -Inductive avl : tree -> Prop := - | RBLeaf : avl Leaf - | RBNode : forall x e l r h, - avl l -> - avl r -> - -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> - avl (Node l x e r h). +Module Proofs. + Module MX := OrderedTypeFacts X. + Module PX := KeyOrderedType X. + Module L := FMapList.Raw X. -(* We should end this section before the big proofs that follows, - otherwise the discharge takes a lot of time. *) -End Elt. +Functional Scheme mem_ind := Induction for mem Sort Prop. +Functional Scheme find_ind := Induction for find Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme add_ind := Induction for add Sort Prop. +Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme remove_ind := Induction for remove Sort Prop. +Functional Scheme concat_ind := Induction for concat Sort Prop. +Functional Scheme split_ind := Induction for split Sort Prop. +Functional Scheme map_option_ind := Induction for map_option Sort Prop. +Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. -(** Some helpful hints and tactics. *) +(** * Automation and dedicated tactics. *) -Notation t := tree. -Hint Constructors tree. -Hint Constructors MapsTo. -Hint Constructors In. -Hint Constructors bst. -Hint Constructors avl. +Hint Constructors tree MapsTo In bst. Hint Unfold lt_tree gt_tree. +Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) + "as" ident(s) := + set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. + +(** A tactic for cleaning hypothesis after use of functional induction. *) + +Ltac clearf := + match goal with + | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf + | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf + | _ => idtac + end. + +(** A tactic to repeat [inversion_clear] on all hyps of the + form [(f (Node ...))] *) + Ltac inv f := match goal with | H:f (Leaf _) |- _ => inversion_clear H; inv f @@ -149,14 +518,6 @@ Ltac inv f := | _ => idtac end. -Ltac safe_inv f := match goal with - | H:f (Node _ _ _ _ _) |- _ => - generalize H; inversion_clear H; safe_inv f - | H:f _ (Node _ _ _ _ _) |- _ => - generalize H; inversion_clear H; safe_inv f - | _ => intros - end. - Ltac inv_all f := match goal with | H: f _ |- _ => inversion_clear H; inv f @@ -166,55 +527,54 @@ Ltac inv_all f := | _ => idtac end. +(** Helper tactic concerning order of elements. *) + Ltac order := match goal with - | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order - | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order + | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order end. Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). -Ltac firstorder_in := repeat progress (firstorder; inv In; inv MapsTo). - -Lemma height_non_negative : forall elt (s : t elt), avl s -> height s >= 0. -Proof. - induction s; simpl; intros; auto with zarith. - inv avl; intuition; omega_max. -Qed. - -Ltac avl_nn_hyp H := - let nz := fresh "nz" in assert (nz := height_non_negative H). -Ltac avl_nn h := - let t := type of h in - match type of t with - | Prop => avl_nn_hyp h - | _ => match goal with H : avl h |- _ => avl_nn_hyp H end - end. - -(* Repeat the previous tactic. - Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) +(* Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) + +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)); + [ 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)); + [ 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] + end + | ] ] ] ]; intros. -Ltac avl_nns := - match goal with - | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns - | _ => idtac - end. +Section Elt. +Variable elt:Type. +Implicit Types m r : t elt. +(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) (** Facts about [MapsTo] and [In]. *) -Lemma MapsTo_In : forall elt k e (m:t elt), MapsTo k e m -> In k m. +Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. Hint Resolve MapsTo_In. -Lemma In_MapsTo : forall elt k (m:t elt), In k m -> exists e, MapsTo k e m. +Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. Proof. induction 1; try destruct IHIn as (e,He); exists e; auto. Qed. -Lemma In_alt : forall elt k (m:t elt), In0 k m <-> In k m. +Lemma In_alt : forall k m, In0 k m <-> In k m. Proof. split. intros (e,H); eauto. @@ -222,64 +582,70 @@ Proof. Qed. Lemma MapsTo_1 : - forall elt (m:t elt) x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. + forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. induction m; simpl; intuition_in; eauto. Qed. Hint Immediate MapsTo_1. Lemma In_1 : - forall elt (m:t elt) x y, X.eq x y -> In x m -> In y m. + forall m x y, X.eq x y -> In x m -> In y m. Proof. - intros elt m x y; induction m; simpl; intuition_in; eauto. + intros m x y; induction m; simpl; intuition_in; eauto. Qed. +Lemma In_node_iff : + forall l x e r h y, + In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. +Proof. + intuition_in. +Qed. (** Results about [lt_tree] and [gt_tree] *) -Lemma lt_leaf : forall elt x, lt_tree x (Leaf elt). +Lemma lt_leaf : forall x, lt_tree x (Leaf elt). Proof. unfold lt_tree in |- *; intros; intuition_in. Qed. -Lemma gt_leaf : forall elt x, gt_tree x (Leaf elt). +Lemma gt_leaf : forall x, gt_tree x (Leaf elt). Proof. unfold gt_tree in |- *; intros; intuition_in. Qed. -Lemma lt_tree_node : forall elt x y (l:t elt) r e h, +Lemma lt_tree_node : forall x y l r e h, lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). Proof. - unfold lt_tree in *; firstorder_in; order. + unfold lt_tree in *; intuition_in; order. Qed. -Lemma gt_tree_node : forall elt x y (l:t elt) r e h, +Lemma gt_tree_node : forall x y l r e h, gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h). Proof. - unfold gt_tree in *; firstorder_in; order. + unfold gt_tree in *; intuition_in; order. Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Lemma lt_left : forall elt x y (l: t elt) r e h, +Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. Proof. intuition_in. Qed. -Lemma lt_right : forall elt x y (l:t elt) r e h, +Lemma lt_right : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x r. Proof. intuition_in. Qed. -Lemma gt_left : forall elt x y (l:t elt) r e h, +Lemma gt_left : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x l. Proof. intuition_in. Qed. -Lemma gt_right : forall elt x y (l:t elt) r e h, +Lemma gt_right : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x r. Proof. intuition_in. @@ -288,731 +654,639 @@ Qed. Hint Resolve lt_left lt_right gt_left gt_right. Lemma lt_tree_not_in : - forall elt x (t : t elt), lt_tree x t -> ~ In x t. + forall x m, lt_tree x m -> ~ In x m. Proof. intros; intro; generalize (H _ H0); order. Qed. Lemma lt_tree_trans : - forall elt x y, X.lt x y -> forall (t:t elt), lt_tree x t -> lt_tree y t. + forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m. Proof. - firstorder eauto. + eauto. Qed. Lemma gt_tree_not_in : - forall elt x (t : t elt), gt_tree x t -> ~ In x t. + forall x m, gt_tree x m -> ~ In x m. Proof. intros; intro; generalize (H _ H0); order. Qed. Lemma gt_tree_trans : - forall elt x y, X.lt y x -> forall (t:t elt), gt_tree x t -> gt_tree y t. + forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m. Proof. - firstorder eauto. + eauto. Qed. Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -(** Results about [avl] *) +(** * Empty map *) -Lemma avl_node : forall elt x e (l:t elt) r, - avl l -> - avl r -> - -(2) <= height l - height r <= 2 -> - avl (Node l x e r (max (height l) (height r) + 1)). +Definition Empty m := forall (a:key)(e:elt) , ~ MapsTo a e m. + +Lemma empty_bst : bst (empty elt). Proof. - intros; auto. + unfold empty; auto. Qed. -Hint Resolve avl_node. -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) +Lemma empty_1 : Empty (empty elt). +Proof. + unfold empty, Empty; intuition_in. +Qed. -Definition create elt (l:t elt) x e r := - Node l x e r (max (height l) (height r) + 1). +(** * Emptyness test *) -Lemma create_bst : - forall elt (l:t elt) x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> - bst (create l x e r). +Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. - unfold create; auto. + destruct m as [|r x e l h]; simpl; auto. + intro H; elim (H x e); auto. Qed. -Hint Resolve create_bst. -Lemma create_avl : - forall elt (l:t elt) x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - avl (create l x e r). -Proof. - unfold create; auto. +Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. +Proof. + destruct m; simpl; intros; try discriminate; red; intuition_in. Qed. -Lemma create_height : - forall elt (l:t elt) x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (create l x e r) = max (height l) (height r) + 1. -Proof. - unfold create; intros; auto. +(** * Appartness *) + +Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. +Proof. + intros m x; functional induction (mem x m); auto; intros; clearf; + inv bst; intuition_in; order. Qed. -Lemma create_in : - forall elt (l:t elt) x e r y, In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. +Lemma mem_2 : forall m x, mem x m = true -> In x m. +Proof. + intros m x; functional induction (mem x m); auto; intros; discriminate. Qed. -(** trick for emulating [assert false] in Coq *) +Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. +Proof. + intros m x; functional induction (find x m); auto; intros; clearf; + inv bst; intuition_in; simpl; auto; + try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. +Qed. -Notation assert_false := Leaf. +Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. +Proof. + intros m x; functional induction (find x m); subst; intros; clearf; + try discriminate. + constructor 2; auto. + inversion H; auto. + constructor 3; auto. +Qed. -(** [bal l x e r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) +Lemma find_iff : forall m x e, bst m -> + (find x m = Some e <-> MapsTo x e m). +Proof. + split; auto using find_1, find_2. +Qed. -Definition bal elt (l: tree elt) x e r := - let hl := height l in - let hr := height r in - if gt_le_dec hl (hr+2) then - match l with - | Leaf => assert_false _ - | Node ll lx le lr _ => - if ge_lt_dec (height ll) (height lr) then - create ll lx le (create lr x e r) - else - match lr with - | Leaf => assert_false _ - | Node lrl lrx lre lrr _ => - create (create ll lx le lrl) lrx lre (create lrr x e r) - end - end - else - if gt_le_dec hr (hl+2) then - match r with - | Leaf => assert_false _ - | Node rl rx re rr _ => - if ge_lt_dec (height rr) (height rl) then - create (create l x e rl) rx re rr - else - match rl with - | Leaf => assert_false _ - | Node rll rlx rle rlr _ => - create (create l x e rll) rlx rle (create rlr rx re rr) - end - end - else - create l x e r. - -Ltac bal_tac := - intros elt l x e r; - unfold bal; - destruct (gt_le_dec (height l) (height r + 2)); - [ destruct l as [ |ll lx le lr lh]; - [ | destruct (ge_lt_dec (height ll) (height lr)); - [ | destruct lr ] ] - | destruct (gt_le_dec (height r) (height l + 2)); - [ destruct r as [ |rl rx re rr rh]; - [ | destruct (ge_lt_dec (height rr) (height rl)); - [ | destruct rl ] ] - | ] ]; intros. - -Ltac bal_tac_imp := match goal with - | |- context [ assert_false ] => - inv avl; avl_nns; simpl in *; false_omega - | _ => idtac -end. +Lemma find_in : forall m x, find x m <> None -> In x m. +Proof. + intros. + case_eq (find x m); [intros|congruence]. + apply MapsTo_In with e; apply find_2; auto. +Qed. -Lemma bal_bst : forall elt (l:t elt) x e r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (bal l x e r). +Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. Proof. - bal_tac; - inv bst; repeat apply create_bst; auto; unfold create; - apply lt_tree_node || apply gt_tree_node; auto; - eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto. + intros. + destruct (In_MapsTo H0) as (d,Hd). + rewrite (find_1 H Hd); discriminate. Qed. -Lemma bal_avl : forall elt (l:t elt) x e r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> avl (bal l x e r). +Lemma find_in_iff : forall m x, bst m -> + (find x m <> None <-> In x m). Proof. - bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max. + split; auto using find_in, in_find. Qed. -Lemma bal_height_1 : forall elt (l:t elt) x e r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> - 0 <= height (bal l x e r) - max (height l) (height r) <= 1. +Lemma not_find_iff : forall m x, bst m -> + (find x m = None <-> ~In x m). Proof. - bal_tac; inv avl; avl_nns; simpl in *; omega_max. + split; intros. + red; intros. + elim (in_find H H1 H0). + case_eq (find x m); [ intros | auto ]. + elim H0; apply find_in; congruence. Qed. -Lemma bal_height_2 : - forall elt (l:t elt) x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (bal l x e r) == max (height l) (height r) +1. +Lemma find_find : forall m m' x, + find x m = find x m' <-> + (forall d, find x m = Some d <-> find x m' = Some d). Proof. - bal_tac; inv avl; simpl in *; omega_max. + intros; destruct (find x m); destruct (find x m'); split; intros; + try split; try congruence. + rewrite H; auto. + symmetry; rewrite <- H; auto. + rewrite H; auto. Qed. -Lemma bal_in : forall elt (l:t elt) x e r y, avl l -> avl r -> - (In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r). +Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> + (find x m = find x m' <-> + (forall d, MapsTo x d m <-> MapsTo x d m')). Proof. - bal_tac; bal_tac_imp; repeat rewrite create_in; intuition_in. + intros m m' x Hm Hm'. + rewrite find_find. + split; intros H d; specialize H with d. + rewrite <- 2 find_iff; auto. + rewrite 2 find_iff; auto. Qed. -Lemma bal_mapsto : forall elt (l:t elt) x e r y e', avl l -> avl r -> - (MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r)). +Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> + find x m = find x m' -> + (In x m <-> In x m'). Proof. - bal_tac; bal_tac_imp; unfold create; intuition_in. + split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; + apply in_find; auto. Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => - generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); - omega_max - end. +(** * Helper functions *) -(** * Insertion *) +Lemma create_bst : + forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> + bst (create l x e r). +Proof. + unfold create; auto. +Qed. +Hint Resolve create_bst. -Function add (elt:Set)(x:key)(e:elt)(s:t elt) { struct s } : t elt := match s with - | Leaf => Node (Leaf _) x e (Leaf _) 1 - | Node l y e' r h => - match X.compare x y with - | LT _ => bal (add x e l) y e' r - | EQ _ => Node l y e r h - | GT _ => bal l y e' (add x e r) - end - end. +Lemma create_in : + forall l x e r y, + In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. +Proof. + unfold create; split; [ inversion_clear 1 | ]; intuition. +Qed. -Lemma add_avl_1 : forall elt (m:t elt) x e, avl m -> - avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. -Proof. - intros elt m x e; functional induction (add x e m); intros; inv avl; simpl in *. - intuition; try constructor; simpl; auto; try omega_max. - (* LT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. - (* EQ *) - intuition; omega_max. - (* GT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. +Lemma bal_bst : forall l x e r, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (bal l x e r). +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. Qed. +Hint Resolve bal_bst. -Lemma add_avl : forall elt (m:t elt) x e, avl m -> avl (add x e m). +Lemma bal_in : forall l x e r y, + In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. - intros; generalize (add_avl_1 x e H); intuition. + intros l x e r; functional induction (bal l x e r); intros; clearf; + rewrite !create_in; intuition_in. Qed. -Hint Resolve add_avl. -Lemma add_in : forall elt (m:t elt) x y e, avl m -> - (In y (add x e m) <-> X.eq y x \/ In y m). +Lemma bal_mapsto : forall l x e r y e', + MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). Proof. - intros elt m x y e; functional induction (add x e m); auto; intros. - intuition_in. - (* LT *) - inv avl. - rewrite bal_in; auto. - rewrite (IHt H0); intuition_in. - (* EQ *) - inv avl. - firstorder_in. - eapply In_1; eauto. - (* GT *) - inv avl. - rewrite bal_in; auto. - rewrite (IHt H1); intuition_in. + intros l x e r; functional induction (bal l x e r); intros; clearf; + unfold assert_false, create; intuition_in. Qed. -Lemma add_bst : forall elt (m:t elt) x e, bst m -> avl m -> bst (add x e m). -Proof. - intros elt m x e; functional induction (add x e m); - intros; inv bst; inv avl; auto; apply bal_bst; auto. - (* lt_tree -> lt_tree (add ...) *) - red; red in H4. - intros. - rewrite (add_in x y0 e H) in H0. - intuition. - eauto. - (* gt_tree -> gt_tree (add ...) *) - red; red in H4. - intros. - rewrite (add_in x y0 e H5) in H0. - intuition. - apply lt_eq with x; auto. +Lemma bal_find : forall l x e r y, + bst l -> bst r -> lt_tree x l -> gt_tree x r -> + find y (bal l x e r) = find y (create l x e r). +Proof. + intros; rewrite find_mapsto_equiv; auto; intros; apply bal_mapsto. Qed. -Lemma add_1 : forall elt (m:t elt) x y e, avl m -> X.eq x y -> MapsTo y e (add x e m). +(** * Insertion *) + +Lemma add_in : forall m x y e, + In y (add x e m) <-> X.eq y x \/ In y m. +Proof. + intros m x y e; functional induction (add x e m); auto; intros; + try (rewrite bal_in, IHt); intuition_in. + apply In_1 with x; auto. +Qed. + +Lemma add_bst : forall m x e, bst m -> bst (add x e m). +Proof. + intros m x e; functional induction (add x e m); intros; + inv bst; try apply bal_bst; auto; + intro z; rewrite add_in; intuition. + apply MX.eq_lt with x; auto. + apply MX.lt_eq with x; auto. +Qed. +Hint Resolve add_bst. + +Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. - intros elt m x y e; functional induction (add x e m); - intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; eauto. -Qed. + intros m x y e; functional induction (add x e m); + intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. +Qed. -Lemma add_2 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> +Lemma add_2 : forall m x y e e', ~X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. - intros elt m x y e e'; induction m; simpl; auto. + intros m x y e e'; induction m; simpl; auto. destruct (X.compare x k); - intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; inv MapsTo; auto; order. Qed. -Lemma add_3 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> +Lemma add_3 : forall m x y e e', ~X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. - intros elt m x y e e'; induction m; simpl; auto. - intros; inv avl; inv MapsTo; auto; order. - destruct (X.compare x k); intro; inv avl; + intros m x y e e'; induction m; simpl; auto. + intros; inv MapsTo; auto; order. + destruct (X.compare x k); intro; try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; - order. + order. Qed. - -(** * Extraction of minimum binding - - morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Function remove_min (elt:Set)(l:t elt)(x:key)(e:elt)(r:t elt) { struct l } : t elt*(key*elt) := - match l with - | Leaf => (r,(x,e)) - | Node ll lx le lr lh => let (l',m) := (remove_min ll lx le lr : t elt*(key*elt)) in (bal l' x e r, m) - end. - -Lemma remove_min_avl_1 : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> - avl (fst (remove_min l x e r)) /\ - 0 <= height (Node l x e r h) - height (fst (remove_min l x e r)) <= 1. +Lemma add_find : forall m x y e, bst m -> + find y (add x e m) = + match X.compare y x with EQ _ => Some e | _ => find y m end. Proof. - intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. - inv avl; simpl in *; split; auto. - avl_nns; omega_max. - (* l = Node *) - inversion_clear H. - destruct (IHp lh); auto. - split; simpl in *. - rewrite_all e1. simpl in *. - apply bal_avl; subst;auto; omega_max. - rewrite_all e1;simpl in *;omega_bal. + intros. + assert (~X.eq x y -> find y (add x e m) = find y m). + intros; rewrite find_mapsto_equiv; auto. + split; eauto using add_2, add_3. + destruct X.compare; try (apply H0; order). + auto using find_1, add_1. Qed. -Lemma remove_min_avl : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> - avl (fst (remove_min l x e r)). -Proof. - intros; generalize (remove_min_avl_1 H); intuition. -Qed. +(** * Extraction of minimum binding *) -Lemma remove_min_in : forall elt (l:t elt) x e r h y, avl (Node l x e r h) -> - (In y (Node l x e r h) <-> - X.eq y (fst (snd (remove_min l x e r))) \/ In y (fst (remove_min l x e r))). +Lemma remove_min_in : forall l x e r h y, + In y (Node l x e r h) <-> + X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. Proof. - intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. + intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. intuition_in. - (* l = Node *) - inversion_clear H. - generalize (remove_min_avl H0). - - rewrite_all e1; simpl; intros. - rewrite bal_in; auto. - generalize (IHp lh y H0). - intuition. - inversion_clear H7; intuition. + rewrite e0 in *; simpl; intros. + rewrite bal_in, In_node_iff, IHp; intuition. Qed. -Lemma remove_min_mapsto : forall elt (l:t elt) x e r h y e', avl (Node l x e r h) -> - (MapsTo y e' (Node l x e r h) <-> - ((X.eq y (fst (snd (remove_min l x e r))) /\ e' = (snd (snd (remove_min l x e r)))) - \/ MapsTo y e' (fst (remove_min l x e r)))). +Lemma remove_min_mapsto : forall l x e r h y e', + MapsTo y e' (Node l x e r h) <-> + ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) + \/ MapsTo y e' (remove_min l x e r)#1. Proof. - intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. + intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. intuition_in; subst; auto. - (* l = Node *) - inversion_clear H. - generalize (remove_min_avl H0). - rewrite_all e1; simpl; intros. + rewrite e0 in *; simpl; intros. rewrite bal_mapsto; auto; unfold create. - simpl in *;destruct (IHp lh y e'). - auto. + simpl in *;destruct (IHp _x y e'). intuition. - inversion_clear H2; intuition. - inversion_clear H9; intuition. + inversion_clear H1; intuition. + inversion_clear H3; intuition. Qed. -Lemma remove_min_bst : forall elt (l:t elt) x e r h, - bst (Node l x e r h) -> avl (Node l x e r h) -> bst (fst (remove_min l x e r)). +Lemma remove_min_bst : forall l x e r h, + bst (Node l x e r h) -> bst (remove_min l x e r)#1. Proof. - intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. + intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. inversion_clear H; inversion_clear H0. apply bal_bst; auto. - rewrite_all e1;simpl in *;firstorder. + rewrite e0 in *; simpl in *; apply (IHp _x); auto. intro; intros. - generalize (remove_min_in y H). - rewrite_all e1; simpl in *. + generalize (remove_min_in ll lx ld lr _x y). + rewrite e0; simpl in *. destruct 1. - apply H3; intuition. + apply H2; intuition. Qed. +Hint Resolve remove_min_bst. -Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h, - bst (Node l x e r h) -> avl (Node l x e r h) -> - gt_tree (fst (snd (remove_min l x e r))) (fst (remove_min l x e r)). +Lemma remove_min_gt_tree : forall l x e r h, + bst (Node l x e r h) -> + gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. Proof. - intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. + intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. - inversion_clear H; inversion_clear H0. + inversion_clear H. intro; intro. - rewrite_all e1;simpl in *. - generalize (IHp lh H1 H); clear H7 H6 IHp. - generalize (remove_min_avl H). - generalize (remove_min_in (fst m) H). - rewrite e1; simpl; intros. - rewrite (bal_in x e y H7 H5) in H0. - destruct H6. - firstorder. - apply lt_eq with x; auto. - apply X.lt_trans with x; auto. -Qed. - -(** * Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Function merge (elt:Set) (s1 s2 : t elt) : tree elt := match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 e2 r2 h2 => - match remove_min l2 x2 e2 r2 with - (s2',(x,e)) => bal s1 x e s2' - end -end. - -Lemma merge_avl_1 : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> - avl (merge s1 s2) /\ - 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. -Proof. - intros elt s1 s2; functional induction (merge s1 s2); simpl in *; intros. - split; auto; avl_nns; omega_max. - destruct s1;try contradiction;clear y. - split; auto; avl_nns; simpl in *; omega_max. - destruct s1;try contradiction;clear y. - generalize (remove_min_avl_1 H0). - rewrite e3; simpl;destruct 1. - split. - apply bal_avl; auto. - simpl; omega_max. - omega_bal. + rewrite e0 in *;simpl in *. + generalize (IHp _x H0). + generalize (remove_min_in ll lx ld lr _x m#1). + rewrite e0; simpl; intros. + rewrite (bal_in l' x d r y) in H. + assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4. + assert (X.lt m#1 x) by order. + decompose [or] H; order. +Qed. +Hint Resolve remove_min_gt_tree. + +Lemma remove_min_find : forall l x e r h y, + bst (Node l x e r h) -> + find y (Node l x e r h) = + match X.compare y (remove_min l x e r)#2#1 with + | LT _ => None + | EQ _ => Some (remove_min l x e r)#2#2 + | GT _ => find y (remove_min l x e r)#1 + end. +Proof. + intros. + destruct X.compare. + rewrite not_find_iff; auto. + rewrite remove_min_in; red; destruct 1 as [H'|H']; [ order | ]. + generalize (remove_min_gt_tree H H'); order. + apply find_1; auto. + rewrite remove_min_mapsto; auto. + rewrite find_mapsto_equiv; eauto; intros. + rewrite remove_min_mapsto; intuition; order. Qed. -Lemma merge_avl : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). -Proof. - intros; generalize (merge_avl_1 H H0 H1); intuition. -Qed. +(** * Merging two trees *) -Lemma merge_in : forall elt (s1 s2:t elt) y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (In y (merge s1 s2) <-> In y s1 \/ In y s2). +Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> + (In y (merge m1 m2) <-> In y m1 \/ In y m2). Proof. - intros elt s1 s2; functional induction (merge s1 s2);intros. + intros m1 m2; functional induction (merge m1 m2);intros; + try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. - destruct s1;try contradiction;clear y. -(* rewrite H_eq_2; rewrite H_eq_2 in H_eq_1; clear H_eq_2. *) - replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto]. - rewrite bal_in; auto. - generalize (remove_min_avl H2); rewrite e3; simpl; auto. - generalize (remove_min_in y0 H2); rewrite e3; simpl; intro. - rewrite H3; intuition. + rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_mapsto : forall elt (s1 s2:t elt) y e, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (MapsTo y e (merge s1 s2) <-> MapsTo y e s1 \/ MapsTo y e s2). +Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> + (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). Proof. - intros elt s1 s2; functional induction (@merge elt s1 s2); intros. + intros m1 m2; functional induction (merge m1 m2); intros; + try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. - destruct s1;try contradiction;clear y. - replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto]. - rewrite bal_mapsto; auto; unfold create. - generalize (remove_min_avl H2); rewrite e3; simpl; auto. - generalize (remove_min_mapsto y0 e H2); rewrite e3; simpl; intro. - rewrite H3; intuition (try subst; auto). - inversion_clear H3; intuition. + rewrite bal_mapsto, remove_min_mapsto, e1; simpl; auto. + unfold create. + intuition; subst; auto. + inversion_clear H1; intuition. Qed. -Lemma merge_bst : forall elt (s1 s2:t elt), bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (forall y1 y2 : key, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (merge s1 s2). +Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + bst (merge m1 m2). Proof. - intros elt s1 s2; functional induction (@merge elt s1 s2); intros; auto. - + intros m1 m2; functional induction (merge m1 m2); intros; auto; + try factornode _x _x0 _x1 _x2 _x3 as m1. apply bal_bst; auto. - destruct s1;try contradiction. - generalize (remove_min_bst H1); rewrite e3; simpl in *; auto. - destruct s1;try contradiction. + generalize (remove_min_bst H0); rewrite e1; simpl in *; auto. intro; intro. - apply H3; auto. - generalize (remove_min_in x H2); rewrite e3; simpl; intuition. - destruct s1;try contradiction. - generalize (remove_min_gt_tree H1); rewrite e3; simpl; auto. -Qed. - -(** * Deletion *) - -Function remove (elt:Set)(x:key)(s:t elt) { struct s } : t elt := match s with - | Leaf => Leaf _ - | Node l y e r h => - match X.compare x y with - | LT _ => bal (remove x l) y e r - | EQ _ => merge l r - | GT _ => bal l y e (remove x r) - end - end. - -Lemma remove_avl_1 : forall elt (s:t elt) x, avl s -> - avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. -Proof. - intros elt s x; functional induction (@remove elt x s); intros. - split; auto; omega_max. - (* LT *) - inv avl. - destruct (IHt H0). - split. - apply bal_avl; auto. - omega_max. - omega_bal. - (* EQ *) - inv avl. - generalize (merge_avl_1 H0 H1 H2). - intuition omega_max. - (* GT *) - inv avl. - destruct (IHt H1). - split. - apply bal_avl; auto. - omega_max. - omega_bal. + apply H1; auto. + generalize (remove_min_in l2 x2 d2 r2 _x4 x); rewrite e1; simpl; intuition. + generalize (remove_min_gt_tree H0); rewrite e1; simpl; auto. Qed. -Lemma remove_avl : forall elt (s:t elt) x, avl s -> avl (remove x s). -Proof. - intros; generalize (remove_avl_1 x H); intuition. -Qed. -Hint Resolve remove_avl. +(** * Deletion *) -Lemma remove_in : forall elt (s:t elt) x y, bst s -> avl s -> - (In y (remove x s) <-> ~ X.eq y x /\ In y s). +Lemma remove_in : forall m x y, bst m -> + (In y (remove x m) <-> ~ X.eq y x /\ In y m). Proof. - intros elt s x; functional induction (@remove elt x s); simpl; intros. + intros m x; functional induction (remove x m); simpl; intros. intuition_in. (* LT *) - inv avl; inv bst; clear e1. + inv bst; clear e0. rewrite bal_in; auto. generalize (IHt y0 H0); intuition; [ order | order | intuition_in ]. (* EQ *) - inv avl; inv bst; clear e1. + inv bst; clear e0. rewrite merge_in; intuition; [ order | order | intuition_in ]. - elim H9; eauto. + elim H4; eauto. (* GT *) - inv avl; inv bst; clear e1. + inv bst; clear e0. rewrite bal_in; auto. - generalize (IHt y0 H5); intuition; [ order | order | intuition_in ]. + generalize (IHt y0 H1); intuition; [ order | order | intuition_in ]. Qed. -Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s). +Lemma remove_bst : forall m x, bst m -> bst (remove x m). Proof. - intros elt s x; functional induction (@remove elt x s); simpl; intros. + intros m x; functional induction (remove x m); simpl; intros. auto. (* LT *) - inv avl; inv bst. + inv bst. apply bal_bst; auto. intro; intro. rewrite (remove_in x y0 H0) in H; auto. destruct H; eauto. (* EQ *) - inv avl; inv bst. + inv bst. apply merge_bst; eauto. (* GT *) - inv avl; inv bst. + inv bst. apply bal_bst; auto. intro; intro. - rewrite (remove_in x y0 H5) in H; auto. + rewrite (remove_in x y0 H1) in H; auto. destruct H; eauto. Qed. -Lemma remove_1 : forall elt (m:t elt) x y, bst m -> avl m -> X.eq x y -> ~ In y (remove x m). +Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). Proof. intros; rewrite remove_in; intuition. -Qed. +Qed. -Lemma remove_2 : forall elt (m:t elt) x y e, bst m -> avl m -> ~X.eq x y -> +Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. - intros elt m x y e; induction m; simpl; auto. + intros m x y e; induction m; simpl; auto. destruct (X.compare x k); - intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; try solve [inv MapsTo; auto]. rewrite merge_mapsto; auto. inv MapsTo; auto; order. Qed. -Lemma remove_3 : forall elt (m:t elt) x y e, bst m -> avl m -> +Lemma remove_3 : forall m x y e, bst m -> MapsTo y e (remove x m) -> MapsTo y e m. Proof. - intros elt m x y e; induction m; simpl; auto. - destruct (X.compare x k); intros Bs Av; inv avl; inv bst; + intros m x y e; induction m; simpl; auto. + destruct (X.compare x k); intros Bs; inv bst; try rewrite bal_mapsto; auto; unfold create. - intros; inv MapsTo; auto. + intros; inv MapsTo; auto. rewrite merge_mapsto; intuition. intros; inv MapsTo; auto. Qed. -Section Elt2. +(** * join *) -Variable elt:Set. +Lemma join_in : forall l x d r y, + In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. +Proof. + join_tac. + simpl. + rewrite add_in; intuition_in. + rewrite add_in; intuition_in. + rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. + rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. + apply create_in. +Qed. -Notation eqk := (eqk (elt:= elt)). -Notation eqke := (eqke (elt:= elt)). -Notation ltk := (ltk (elt:= elt)). +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 *. + intuition; [ apply MX.lt_eq with x | ]; eauto. + intuition; [ apply MX.eq_lt with x | ]; eauto. +Qed. +Hint Resolve join_bst. -(** * Empty map *) +Lemma join_find : forall l x d r y, + bst l -> bst r -> lt_tree x l -> gt_tree x r -> + find y (join l x d r) = find y (create l x d r). +Proof. + join_tac; auto; inv bst; + simpl (join (Leaf elt)); + try (assert (X.lt lx x) by auto); + try (assert (X.lt x rx) by auto); + rewrite ?add_find, ?bal_find; auto. -Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + simpl; destruct X.compare; auto. + rewrite not_find_iff; auto; intro; order. -Definition empty := (Leaf elt). + simpl; repeat (destruct X.compare; auto); try (order; fail). + rewrite not_find_iff by auto; intro. + assert (X.lt y x) by auto; order. -Lemma empty_bst : bst empty. + simpl; rewrite Hlr; simpl; auto. + repeat (destruct X.compare; auto); order. + intros u Hu; rewrite join_in in Hu. + destruct Hu as [Hu|[Hu|Hu]]; try generalize (H2 _ Hu); order. + + simpl; rewrite Hrl; simpl; auto. + repeat (destruct X.compare; auto); order. + intros u Hu; rewrite join_in in Hu. + destruct Hu as [Hu|[Hu|Hu]]; order. +Qed. + +(** * split *) + +Lemma split_in_1 : forall m x, bst m -> forall y, + (In y (split x m)#l <-> In y m /\ X.lt y x). Proof. - unfold empty; auto. + intros m x; functional induction (split x m); simpl; intros; + inv bst; try clear e0. + intuition_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. + intuition_in; order. + rewrite join_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma empty_avl : avl empty. +Lemma split_in_2 : forall m x, bst m -> forall y, + (In y (split x m)#r <-> In y m /\ X.lt x y). Proof. - unfold empty; auto. + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0. + intuition_in. + rewrite join_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. + intuition_in; order. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma empty_1 : Empty empty. +Lemma split_in_3 : forall m x, bst m -> + (split x m)#o = find x m. Proof. - unfold empty, Empty; intuition_in. + intros m x; functional induction (split x m); subst; simpl; auto; + intros; inv bst; try clear e0; + destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto. Qed. -(** * Emptyness test *) - -Definition is_empty (s:t elt) := match s with Leaf => true | _ => false end. +Lemma split_bst : forall m x, bst m -> + bst (split x m)#l /\ bst (split x m)#r. +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; + apply join_bst; auto. + intros y0. + generalize (split_in_2 x H0 y0); rewrite e1; simpl; intuition. + intros y0. + generalize (split_in_1 x H1 y0); rewrite e1; simpl; intuition. +Qed. -Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. +Lemma split_lt_tree : forall m x, bst m -> lt_tree x (split x m)#l. Proof. - destruct s as [|r x e l h]; simpl; auto. - intro H; elim (H x e); auto. + intros m x B y Hy; rewrite split_in_1 in Hy; intuition. Qed. -Lemma is_empty_2 : forall s, is_empty s = true -> Empty s. -Proof. - destruct s; simpl; intros; try discriminate; red; intuition_in. +Lemma split_gt_tree : forall m x, bst m -> gt_tree x (split x m)#r. +Proof. + intros m x B y Hy; rewrite split_in_2 in Hy; intuition. Qed. -(** * Appartness *) +Lemma split_find : forall m x y, bst m -> + find y m = match X.compare y x with + | LT _ => find y (split x m)#l + | EQ _ => (split x m)#o + | GT _ => find y (split x m)#r + end. +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; + [ destruct X.compare; auto | .. ]; + try match goal with E:split ?x ?t = _, B:bst ?t |- _ => + generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); + rewrite E; simpl; destruct 3 end. -(** The [mem] function is deciding appartness. It exploits the [bst] property - to achieve logarithmic complexity. *) + rewrite join_find, IHt; auto; clear IHt; simpl. + repeat (destruct X.compare; auto); order. + intro y1; rewrite H4; intuition. -Function mem (x:key)(m:t elt) { struct m } : bool := - match m with - | Leaf => false - | Node l y e r _ => match X.compare x y with - | LT _ => mem x l - | EQ _ => true - | GT _ => mem x r - end - end. -Implicit Arguments mem. + repeat (destruct X.compare; auto); order. -Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true. -Proof. - intros s x. - functional induction (mem x s); inversion_clear 1; auto. - intuition_in. - intuition_in; firstorder; absurd (X.lt x y); eauto. - intuition_in; firstorder; absurd (X.lt y x); eauto. + rewrite join_find, IHt; auto; clear IHt; simpl. + repeat (destruct X.compare; auto); order. + intros y1; rewrite H; intuition. Qed. -Lemma mem_2 : forall s x, mem x s = true -> In x s. -Proof. - intros s x. - functional induction (mem x s); firstorder; intros; try discriminate. -Qed. - -Function find (x:key)(m:t elt) { struct m } : option elt := - match m with - | Leaf => None - | Node l y e r _ => match X.compare x y with - | LT _ => find x l - | EQ _ => Some e - | GT _ => find x r - end - end. +(** * Concatenation *) -Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. -Proof. - intros m x e. - functional induction (find x m); inversion_clear 1; auto. +Lemma concat_in : forall m1 m2 y, + In y (concat m1 m2) <-> In y m1 \/ In y m2. +Proof. + intros m1 m2; functional induction (concat m1 m2); intros; + try factornode _x _x0 _x1 _x2 _x3 as m1. + intuition_in. intuition_in. - intuition_in; firstorder; absurd (X.lt x y); eauto. - intuition_in; auto. - absurd (X.lt x y); eauto. - absurd (X.lt y x); eauto. - intuition_in; firstorder; absurd (X.lt y x); eauto. + rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. - intros m x. - functional induction (find x m); subst;firstorder; intros; try discriminate. - inversion H; subst; auto. -Qed. - -(** An all-in-one spec for [add] used later in the naive [map2] *) - -Lemma add_spec : forall m x y e , bst m -> avl m -> - find x (add y e m) = if eq_dec x y then Some e else find x m. -Proof. -intros. -destruct (eq_dec x y). -apply find_1. -apply add_bst; auto. -eapply MapsTo_1 with y; eauto. -apply add_1; auto. -case_eq (find x m); intros. -apply find_1. -apply add_bst; auto. -apply add_2; auto. -apply find_2; auto. -case_eq (find x (add y e m)); auto; intros. -rewrite <- H1; symmetry. -apply find_1; auto. -eapply add_3; eauto. -apply find_2; eauto. +Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + bst (concat m1 m2). +Proof. + intros m1 m2; functional induction (concat m1 m2); intros; auto; + try factornode _x _x0 _x1 _x2 _x3 as m1. + apply join_bst; auto. + change (bst (m2',xd)#1); rewrite <-e1; eauto. + intros y Hy. + apply H1; auto. + rewrite remove_min_in, e1; simpl; auto. + change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto. Qed. +Hint Resolve concat_bst. -(** * Elements *) +Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + find y (concat m1 m2) = + match find y m2 with Some d => Some d | None => find y m1 end. +Proof. + intros m1 m2; functional induction (concat m1 m2); intros; auto; + try factornode _x _x0 _x1 _x2 _x3 as m1. + simpl; destruct (find y m2); auto. -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) + generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) + (remove_min_bst H0)(remove_min_gt_tree H0); + rewrite e1; simpl fst; simpl snd; intros. + + inv bst. + rewrite H2, join_find; auto; clear H2. + simpl; destruct X.compare; simpl; auto. + destruct (find y m2'); auto. + symmetry; rewrite not_find_iff; auto; intro. + apply (MX.lt_not_gt l); apply H1; auto; rewrite H3; auto. -Fixpoint elements_aux (acc : list (key*elt)) (t : t elt) {struct t} : list (key*elt) := - match t with - | Leaf => acc - | Node l x e r _ => elements_aux ((x,e) :: elements_aux acc r) l - end. + intros z Hz; apply H1; auto; rewrite H3; auto. +Qed. -(** then [elements] is an instanciation with an empty [acc] *) -Definition elements := elements_aux nil. +(** * Elements *) -Lemma elements_aux_mapsto : forall s acc x e, +Notation eqk := (PX.eqk (elt:= elt)). +Notation eqke := (PX.eqke (elt:= elt)). +Notation ltk := (PX.ltk (elt:= elt)). + +Lemma elements_aux_mapsto : forall (s:t elt) acc x e, InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. Proof. induction s as [ | l Hl x e r Hr h ]; simpl; auto. @@ -1025,13 +1299,13 @@ Proof. destruct H0; simpl in *; subst; intuition. Qed. -Lemma elements_mapsto : forall s x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. +Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. Proof. intros; generalize (elements_aux_mapsto s nil x e); intuition. inversion_clear H0. Qed. -Lemma elements_in : forall s x, L.PX.In x (elements s) <-> In x s. +Lemma elements_in : forall (s:t elt) x, L.PX.In x (elements s) <-> In x s. Proof. intros. unfold L.PX.In. @@ -1043,7 +1317,7 @@ Proof. unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. -Lemma elements_aux_sort : forall s acc, bst s -> sort ltk acc -> +Lemma elements_aux_sort : forall (s:t elt) acc, bst s -> sort ltk acc -> (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) -> sort ltk (elements_aux acc s). Proof. @@ -1052,7 +1326,7 @@ Proof. apply Hl; auto. constructor. apply Hr; eauto. - apply (InA_InfA (eqke_refl (elt:=elt))); intros (y',e') H6. + apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. red; simpl; eauto. @@ -1070,20 +1344,49 @@ Proof. Qed. Hint Resolve elements_sort. +Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). +Proof. + intros; apply PX.Sort_NoDupA; auto. +Qed. -(** * Fold *) +Lemma elements_aux_cardinal : + forall (m:t elt) acc, (length acc + cardinal m)%nat = length (elements_aux acc m). +Proof. + simple induction m; simpl; intuition. + rewrite <- H; simpl. + rewrite <- H0; omega. +Qed. -Fixpoint fold (A : Set) (f : key -> elt -> A -> A)(s : t elt) {struct s} : A -> A := - fun a => match s with - | Leaf => a - | Node l x e r _ => fold f r (f x e (fold f l a)) - end. +Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m). +Proof. + exact (fun m => elements_aux_cardinal m nil). +Qed. -Definition fold' (A : Set) (f : key -> elt -> A -> A)(s : t elt) := +Lemma elements_app : + forall (s:t elt) acc, elements_aux acc s = elements s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. +Qed. + +Lemma elements_node : + forall (t1 t2:t elt) x e z l, + elements t1 ++ (x,e) :: elements t2 ++ l = + elements (Node t1 x e t2 z) ++ l. +Proof. + unfold elements; simpl; intros. + rewrite !elements_app, <- !app_nil_end, !app_ass; auto. +Qed. + +(** * Fold *) + +Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := L.fold f (elements s). Lemma fold_equiv_aux : - forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc, + forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc, L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). Proof. simple induction s. @@ -1095,7 +1398,7 @@ Proof. Qed. Lemma fold_equiv : - forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A), + forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. unfold fold', elements in |- *. @@ -1106,8 +1409,8 @@ Proof. Qed. Lemma fold_1 : - forall (s:t elt)(Hs:bst s)(A : Set)(i:A)(f : key -> elt -> A -> A), - fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i. + forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), + fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. Proof. intros. rewrite fold_equiv. @@ -1118,288 +1421,93 @@ Qed. (** * Comparison *) -Definition Equal (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -(** ** Enumeration of the elements of a tree *) - -Inductive enumeration : Set := - | End : enumeration - | More : key -> elt -> t elt -> enumeration -> enumeration. - -(** [flatten_e e] returns the list of elements of [e] i.e. the list - of elements actually compared *) +(** [flatten_e e] returns the list of elements of the enumeration [e] + i.e. the list of elements actually compared *) -Fixpoint flatten_e (e : enumeration) : list (key*elt) := match e with +Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with | End => nil | More x e t r => (x,e) :: elements t ++ flatten_e r end. -(** [sorted_e e] expresses that elements in the enumeration [e] are - sorted, and that all trees in [e] are binary search trees. *) - -Inductive In_e (p:key*elt) : enumeration -> Prop := - | InEHd1 : - forall (y : key)(d:elt) (s : t elt) (e : enumeration), - eqke p (y,d) -> In_e p (More y d s e) - | InEHd2 : - forall (y : key) (d:elt) (s : t elt) (e : enumeration), - MapsTo (fst p) (snd p) s -> In_e p (More y d s e) - | InETl : - forall (y : key) (d:elt) (s : t elt) (e : enumeration), - In_e p e -> In_e p (More y d s e). - -Hint Constructors In_e. - -Inductive sorted_e : enumeration -> Prop := - | SortedEEnd : sorted_e End - | SortedEMore : - forall (x : key) (d:elt) (s : t elt) (e : enumeration), - bst s -> - (gt_tree x s) -> - sorted_e e -> - (forall p, In_e p e -> ltk (x,d) p) -> - (forall p, - MapsTo (fst p) (snd p) s -> forall q, In_e q e -> ltk p q) -> - sorted_e (More x d s e). - -Hint Constructors sorted_e. - -Lemma in_flatten_e : - forall p e, InA eqke p (flatten_e e) -> In_e p e. -Proof. - simple induction e; simpl in |- *; intuition. - inversion_clear H. - inversion_clear H0; auto. - elim (InA_app H1); auto. - destruct (elements_mapsto t a b); auto. +Lemma flatten_e_elements : + forall (l:t elt) r x d z e, + elements l ++ flatten_e (More x d r e) = + elements (Node l x d r z) ++ flatten_e e. +Proof. + intros; simpl; apply elements_node. Qed. -Lemma sorted_flatten_e : - forall e : enumeration, sorted_e e -> sort ltk (flatten_e e). +Lemma cons_1 : forall (s:t elt) e, + flatten_e (cons s e) = elements s ++ flatten_e e. Proof. - simple induction e; simpl in |- *; intuition. - apply cons_sort. - apply (SortA_app (eqke_refl (elt:=elt))); inversion_clear H0; auto. - intros; apply H5; auto. - rewrite <- elements_mapsto; auto; destruct x; auto. - apply in_flatten_e; auto. - inversion_clear H0. - apply In_InfA; intros. - intros; elim (in_app_or _ _ _ H0); intuition. - generalize (In_InA (eqke_refl (elt:=elt)) H6). - destruct y; rewrite elements_mapsto; eauto. - apply H4; apply in_flatten_e; auto. - apply In_InA; auto. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements; auto. Qed. -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. +(** Proof of correction for the comparison *) + +Variable cmp : elt->elt->bool. + +Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. + +Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> cmp d1 d2 = true -> + IfEq b l1 l2 -> + IfEq b ((x1,d1)::l1) ((x2,d2)::l2). Proof. - simple induction s; simpl in |- *; intuition. - rewrite H0. - rewrite H. - unfold elements; simpl. - do 2 rewrite H. - rewrite H0. - repeat rewrite <- app_nil_end. - repeat rewrite app_ass; auto. + unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; + try rewrite H0; auto; order. Qed. -Lemma compare_flatten_1 : - forall t1 t2 x e z l, - elements t1 ++ (x,e) :: elements t2 ++ l = - elements (Node t1 x e t2 z) ++ l. +Lemma equal_end_IfEq : forall e2, + IfEq (equal_end e2) nil (flatten_e e2). Proof. - simpl in |- *; unfold elements in |- *; simpl in |- *; intuition. - repeat rewrite elements_app. - repeat rewrite <- app_nil_end. - repeat rewrite app_ass; auto. + destruct e2; red; auto. Qed. -(** key lemma for correctness *) - -Lemma flatten_e_elements : - forall l r x d z e, - elements l ++ flatten_e (More x d r e) = - elements (Node l x d r z) ++ flatten_e e. +Lemma equal_more_IfEq : + forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, + IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) + (flatten_e (More x2 d2 r2 e2)). Proof. - intros; simpl. - apply compare_flatten_1. + unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. + rewrite <-andb_lazy_alt; f_equal; auto. Qed. -Open Local Scope Z_scope. - -(** termination of [compare_aux] *) - -Fixpoint measure_e_t (s : t elt) : Z := match s with - | Leaf => 0 - | Node l _ _ r _ => 1 + measure_e_t l + measure_e_t r - end. - -Fixpoint measure_e (e : enumeration) : Z := match e with - | End => 0 - | More _ _ s r => 1 + measure_e_t s + measure_e r - end. - -Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *. -Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *. - -Lemma measure_e_t_0 : forall s : t elt, measure_e_t s >= 0. +Lemma equal_cont_IfEq : forall m1 cont e2 l, + (forall e, IfEq (cont e) l (flatten_e e)) -> + IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2). Proof. - simple induction s. - simpl in |- *; omega. - intros. - Measure_e_t; omega. + induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto. + rewrite <- elements_node; simpl. + apply Hl1; auto. + clear e2; intros [|x2 d2 r2 e2]. + simpl; red; auto. + apply equal_more_IfEq. + rewrite <- cons_1; auto. Qed. -Ltac Measure_e_t_0 s := generalize (@measure_e_t_0 s); intro. - -Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0. +Lemma equal_IfEq : forall (m1 m2:t elt), + IfEq (equal cmp m1 m2) (elements m1) (elements m2). Proof. - simple induction e. - simpl in |- *; omega. + intros; unfold equal. + rewrite (app_nil_end (elements m1)). + replace (elements m2) with (flatten_e (cons m2 (End _))) + by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). + apply equal_cont_IfEq. intros. - Measure_e; Measure_e_t_0 t; omega. + apply equal_end_IfEq; auto. Qed. -Ltac Measure_e_0 e := generalize (@measure_e_0 e); intro. - -(** Induction principle over the sum of the measures for two lists *) +Definition Equivb m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Definition compare_rec2 : - forall P : enumeration -> enumeration -> Set, - (forall x x' : enumeration, - (forall y y' : enumeration, - measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') -> - P x x') -> - forall x x' : enumeration, P x x'. +Lemma Equivb_elements : forall s s', + Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). Proof. - intros P H x x'. - apply well_founded_induction_type_2 - with (R := fun yy' xx' : enumeration * enumeration => - measure_e (fst yy') + measure_e (snd yy') < - measure_e (fst xx') + measure_e (snd xx')); auto. - apply Wf_nat.well_founded_lt_compat - with (f := fun xx' : enumeration * enumeration => - Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))). - intros; apply Zabs.Zabs_nat_lt. - Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y); - Measure_e_0 (snd y); intros; omega. -Qed. - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. Code: - -let rec cons s e = match s with - | Empty -> e - | Node(l, k, d, r, _) -> cons l (More(k, d, r, e)) -*) - -Definition cons : forall s e, bst s -> sorted_e e -> - (forall x y, MapsTo (fst x) (snd x) s -> In_e y e -> ltk x y) -> - { r : enumeration - | sorted_e r /\ - measure_e r = measure_e_t s + measure_e e /\ - flatten_e r = elements s ++ flatten_e e - }. -Proof. - simple induction s; intuition. - (* s = Leaf *) - exists e; intuition. - (* s = Node t k e t0 z *) - clear H0. - case (H (More k e t0 e0)); clear H; intuition. - inv bst; auto. - constructor; inversion_clear H1; auto. - inversion_clear H0; inv bst; intuition. - destruct y; red; red in H4; simpl in *; intuition. - apply lt_eq with k; eauto. - destruct y; red; simpl in *; intuition. - apply X.lt_trans with k; eauto. - exists x; intuition. - generalize H4; Measure_e; intros; Measure_e_t; omega. - rewrite H5. - apply flatten_e_elements. -Qed. - -Definition equal_aux : - forall (cmp: elt -> elt -> bool)(e1 e2:enumeration), - sorted_e e1 -> sorted_e e2 -> - { L.Equal cmp (flatten_e e1) (flatten_e e2) } + - { ~ L.Equal cmp (flatten_e e1) (flatten_e e2) }. -Proof. - intros cmp e1 e2; pattern e1, e2 in |- *; apply compare_rec2. - simple destruct x; simple destruct x'; intuition. - (* x = x' = End *) - left; unfold L.Equal in |- *; intuition. - inversion H2. - (* x = End x' = More *) - right; simpl in |- *; auto. - destruct 1. - destruct (H2 k). - destruct H5; auto. - exists e; auto. - inversion H5. - (* x = More x' = End *) - right; simpl in |- *; auto. - destruct 1. - destruct (H2 k). - destruct H4; auto. - exists e; auto. - inversion H4. - (* x = More k e t e0, x' = More k0 e3 t0 e4 *) - case (X.compare k k0); intro. - (* k < k0 *) - right. - destruct 1. - clear H3 H. - assert (L.PX.In k (flatten_e (More k0 e3 t0 e4))). - destruct (H2 k). - apply H; simpl; exists e; auto. - destruct H. - generalize (Sort_In_cons_2 (sorted_flatten_e H1) (InA_eqke_eqk H)). - compute. - intuition order. - (* k = k0 *) - case_eq (cmp e e3). - intros EQ. - destruct (@cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto. - destruct (@cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto. - destruct (H c1 c2); clear H; intuition. - Measure_e; omega. - left. - rewrite H4 in e6; rewrite H7 in e6. - simpl; rewrite <- L.equal_cons; auto. - apply (sorted_flatten_e H0). - apply (sorted_flatten_e H1). - right. - simpl; rewrite <- L.equal_cons; auto. - apply (sorted_flatten_e H0). - apply (sorted_flatten_e H1). - swap f. - rewrite H4; rewrite H7; auto. - right. - destruct 1. - rewrite (H4 k) in H2; try discriminate; simpl; auto. - (* k > k0 *) - right. - destruct 1. - clear H3 H. - assert (L.PX.In k0 (flatten_e (More k e t e0))). - destruct (H2 k0). - apply H3; simpl; exists e3; auto. - destruct H. - generalize (Sort_In_cons_2 (sorted_flatten_e H0) (InA_eqke_eqk H)). - compute. - intuition order. -Qed. - -Lemma Equal_elements : forall cmp s s', - Equal cmp s s' <-> L.Equal cmp (elements s) (elements s'). -Proof. -unfold Equal, L.Equal; split; split; intros. +unfold Equivb, L.Equivb; split; split; intros. do 2 rewrite elements_in; firstorder. destruct H. apply (H2 k); rewrite <- elements_mapsto; auto. @@ -1408,95 +1516,46 @@ destruct H. apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. -Definition equal : forall cmp s s', bst s -> bst s' -> - {Equal cmp s s'} + {~ Equal cmp s s'}. +Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> + (equal cmp s s' = true <-> Equivb s s'). Proof. - intros cmp s1 s2 s1_bst s2_bst; simpl. - destruct (@cons s1 End); auto. - inversion_clear 2. - destruct (@cons s2 End); auto. - inversion_clear 2. - simpl in a; rewrite <- app_nil_end in a. - simpl in a0; rewrite <- app_nil_end in a0. - destruct (@equal_aux cmp x x0); intuition. - left. - rewrite H4 in e; rewrite H5 in e. - rewrite Equal_elements; auto. - right. - swap n. - rewrite H4; rewrite H5. - rewrite <- Equal_elements; auto. + intros s s' B B'. + rewrite Equivb_elements, <- equal_IfEq. + split; [apply L.equal_2|apply L.equal_1]; auto. Qed. -End Elt2. - -Section Elts. - -Variable elt elt' elt'' : Set. +End Elt. Section Map. +Variable elt elt' : Type. Variable f : elt -> elt'. -Fixpoint map (m:t elt) {struct m} : t elt' := - match m with - | Leaf => Leaf _ - | Node l v d r h => Node (map l) v (f d) (map r) h - end. - -Lemma map_height : forall m, height (map m) = height m. -Proof. -destruct m; simpl; auto. -Qed. - -Lemma map_avl : forall m, avl m -> avl (map m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto. -Qed. - -Lemma map_1 : forall (m: tree elt)(x:key)(e:elt), - MapsTo x e m -> MapsTo x (f e) (map m). +Lemma map_1 : forall (m: t elt)(x:key)(e:elt), + MapsTo x e m -> MapsTo x (f e) (map f m). Proof. induction m; simpl; inversion_clear 1; auto. Qed. Lemma map_2 : forall (m: t elt)(x:key), - In x (map m) -> In x m. + In x (map f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. Qed. -Lemma map_bst : forall m, bst m -> bst (map m). +Lemma map_bst : forall m, bst m -> bst (map f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto. -red; intros; apply H2; apply map_2; auto. -red; intros; apply H3; apply map_2; auto. +inversion_clear 1; constructor; auto; + red; auto using map_2. Qed. End Map. -Section Mapi. -Variable f : key -> elt -> elt'. - -Fixpoint mapi (m:t elt) {struct m} : t elt' := - match m with - | Leaf => Leaf _ - | Node l v d r h => Node (mapi l) v (f v d) (mapi r) h - end. - -Lemma mapi_height : forall m, height (mapi m) = height m. -Proof. -destruct m; simpl; auto. -Qed. - -Lemma mapi_avl : forall m, avl m -> avl (mapi m). -Proof. -induction m; simpl; auto. -inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto. -Qed. +Section Mapi. +Variable elt elt' : Type. +Variable f : key -> elt -> elt'. Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), - MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi m). + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. exists k; auto. @@ -1507,198 +1566,242 @@ exists x0; intuition. Qed. Lemma mapi_2 : forall (m: t elt)(x:key), - In x (mapi m) -> In x m. + In x (mapi f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. Qed. -Lemma mapi_bst : forall m, bst m -> bst (mapi m). +Lemma mapi_bst : forall m, bst m -> bst (mapi f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto. -red; intros; apply H2; apply mapi_2; auto. -red; intros; apply H3; apply mapi_2; auto. +inversion_clear 1; constructor; auto; + red; auto using mapi_2. Qed. End Mapi. -Section Map2. -Variable f : option elt -> option elt' -> option elt''. - -(* Not exactly pretty nor perfect, but should suffice as a first naive implem. - Anyway, map2 isn't in Ocaml... -*) - -Definition anti_elements (l:list (key*elt'')) := L.fold (@add _) l (empty _). +Section Map_option. +Variable elt elt' : Type. +Variable f : key -> elt -> option elt'. +Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. -Definition map2 (m:t elt)(m':t elt') : t elt'' := - anti_elements (L.map2 f (elements m) (elements m')). - -Lemma anti_elements_avl_aux : forall (l:list (key*elt''))(m:t elt''), - avl m -> avl (L.fold (@add _) l m). +Lemma map_option_2 : forall (m:t elt)(x:key), + In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. Proof. -unfold anti_elements; induction l. -simpl; auto. -simpl; destruct a; intros. -apply IHl. -apply add_avl; auto. +intros m; functional induction (map_option f m); simpl; auto; intros. +inversion H. +rewrite join_in in H; destruct H as [H|[H|H]]. +exists d; split; auto; rewrite (f_compat d H), e0; discriminate. +destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. +destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. +rewrite concat_in in H; destruct H as [H|H]. +destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto. +destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto. Qed. -Lemma anti_elements_avl : forall l, avl (anti_elements l). +Lemma map_option_bst : forall m, bst m -> bst (map_option f m). Proof. -unfold anti_elements, empty; intros; apply anti_elements_avl_aux; auto. -Qed. +intros m; functional induction (map_option f m); simpl; auto; intros; + inv bst. +apply join_bst; auto; intros y H; + destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. +apply concat_bst; auto; intros y y' H H'. +destruct (map_option_2 H) as (d0 & ? & ?). +destruct (map_option_2 H') as (d0' & ? & ?). +eapply X.lt_trans with x; eauto using MapsTo_In. +Qed. +Hint Resolve map_option_bst. + +Ltac nonify e := + replace e with (@None elt) by + (symmetry; rewrite not_find_iff; auto; intro; order). + +Lemma map_option_find : forall (m:t elt)(x:key), + bst m -> + find x (map_option f m) = + match (find x m) with Some d => f x d | None => None end. +Proof. +intros m; functional induction (map_option f m); simpl; auto; intros; + inv bst; rewrite join_find || rewrite concat_find; auto; simpl; + try destruct X.compare; simpl; auto. +rewrite (f_compat d e); auto. +intros y H; + destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. +intros y H; + destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. + +rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. +rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto. +rewrite (f_compat d e); auto. +rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto. + destruct (find x0 (map_option f r)); auto. + +intros y y' H H'. +destruct (map_option_2 H) as (? & ? & ?). +destruct (map_option_2 H') as (? & ? & ?). +eapply X.lt_trans with x; eauto using MapsTo_In. +Qed. + +End Map_option. + +Section Map2_opt. +Variable elt elt' elt'' : Type. +Variable f0 : key -> option elt -> option elt' -> option elt''. +Variable f : key -> elt -> option elt' -> option elt''. +Variable mapl : t elt -> t elt''. +Variable mapr : t elt' -> t elt''. +Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. +Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). +Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). +Hypothesis mapl_f0 : forall x m, bst m -> + find x (mapl m) = + match find x m with Some d => f0 x (Some d) None | None => None end. +Hypothesis mapr_f0 : forall x m', bst m' -> + find x (mapr m') = + match find x m' with Some d' => f0 x None (Some d') | None => None end. +Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. + +Notation map2_opt := (map2_opt f mapl mapr). + +Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> + In y (map2_opt m m') -> In y m \/ In y m'. +Proof. +intros m m'; functional induction (map2_opt m m'); intros; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) + (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst). + +right; apply find_in. +generalize (in_find (mapr_bst H0) H1); rewrite mapr_f0; auto. +destruct (find y m2); auto; intros; discriminate. + +factornode l1 x1 d1 r1 _x as m1. +left; apply find_in. +generalize (in_find (mapl_bst H) H1); rewrite mapl_f0; auto. +destruct (find y m1); auto; intros; discriminate. + +rewrite join_in in H1; destruct H1 as [H'|[H'|H']]; auto. +destruct (IHt1 y H6 H4 H'); intuition. +destruct (IHt0 y H7 H5 H'); intuition. + +rewrite concat_in in H1; destruct H1 as [H'|H']; auto. +destruct (IHt1 y H6 H4 H'); intuition. +destruct (IHt0 y H7 H5 H'); intuition. +Qed. + +Lemma map2_opt_bst : forall m m', bst m -> bst m' -> + bst (map2_opt m m'). +Proof. +intros m m'; functional induction (map2_opt m m'); intros; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; + generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); + rewrite e1; simpl in *; destruct 3. + +apply join_bst; auto. +intros y Hy; specialize H with y. +destruct (map2_opt_2 H1 H6 Hy); intuition. +intros y Hy; specialize H5 with y. +destruct (map2_opt_2 H2 H7 Hy); intuition. + +apply concat_bst; auto. +intros y y' Hy Hy'; specialize H with y; specialize H5 with y'. +apply X.lt_trans with x1. +destruct (map2_opt_2 H1 H6 Hy); intuition. +destruct (map2_opt_2 H2 H7 Hy'); intuition. +Qed. +Hint Resolve map2_opt_bst. + +Ltac map2_aux := + match goal with + | H : In ?x _ \/ In ?x ?m, + H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => + destruct H; [ intuition_in; order | + rewrite <-(find_in_equiv B B' H'); auto ] + end. -Lemma anti_elements_bst_aux : forall (l:list (key*elt''))(m:t elt''), - bst m -> avl m -> bst (L.fold (@add _) l m). -Proof. -induction l. -simpl; auto. -simpl; destruct a; intros. -apply IHl. -apply add_bst; auto. -apply add_avl; auto. -Qed. +Ltac nonify t := + match t with (find ?y (map2_opt ?m ?m')) => + replace t with (@None elt''); + [ | symmetry; rewrite not_find_iff; auto; intro; + destruct (@map2_opt_2 m m' y); auto; order ] + end. -Lemma anti_elements_bst : forall l, bst (anti_elements l). -Proof. -unfold anti_elements, empty; intros; apply anti_elements_bst_aux; auto. -Qed. +Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> + In y m \/ In y m' -> + find y (map2_opt m m') = f0 y (find y m) (find y m'). +Proof. +intros m m'; functional induction (map2_opt m m'); intros; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) + (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) + (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); + rewrite e1; simpl in *; destruct 4; intros; inv bst; + subst o2; rewrite H7, ?join_find, ?concat_find; auto). + +simpl; destruct H1; [ inversion_clear H1 | ]. +rewrite mapr_f0; auto. +generalize (in_find H0 H1); destruct (find y m2); intuition. + +factornode l1 x1 d1 r1 _x as m1. +destruct H1; [ | inversion_clear H1 ]. +rewrite mapl_f0; auto. +generalize (in_find H H1); destruct (find y m1); intuition. + +simpl; destruct X.compare; auto. +apply IHt1; auto; map2_aux. +rewrite (@f0_compat y x1), <- f0_f; auto. +apply IHt0; auto; map2_aux. +intros z Hz; destruct (@map2_opt_2 l1 l2' z); auto. +intros z Hz; destruct (@map2_opt_2 r1 r2' z); auto. + +destruct X.compare. +nonify (find y (map2_opt r1 r2')). +apply IHt1; auto; map2_aux. +nonify (find y (map2_opt r1 r2')). +nonify (find y (map2_opt l1 l2')). +rewrite (@f0_compat y x1), <- f0_f; auto. +nonify (find y (map2_opt l1 l2')). +rewrite IHt0; auto; [ | map2_aux ]. +destruct (f0 y (find y r1) (find y r2')); auto. +intros y1 y2 Hy1 Hy2; apply X.lt_trans with x1. + destruct (@map2_opt_2 l1 l2' y1); auto. + destruct (@map2_opt_2 r1 r2' y2); auto. +Qed. + +End Map2_opt. -Lemma anti_elements_mapsto_aux : forall (l:list (key*elt'')) m k e, - bst m -> avl m -> NoDupA (eqk (elt:=elt'')) l -> - (forall x, L.PX.In x l -> In x m -> False) -> - (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m). -Proof. -induction l. -simpl; auto. -intuition. -inversion H4. -simpl; destruct a; intros. -rewrite IHl; clear IHl. -apply add_bst; auto. -apply add_avl; auto. -inversion H1; auto. -intros. -inversion_clear H1. -assert (~X.eq x k). - swap H5. - destruct H3. - apply InA_eqA with (x,x0); eauto. -apply (H2 x). -destruct H3; exists x0; auto. -revert H4; do 2 rewrite <- In_alt; destruct 1; exists x0; auto. -eapply add_3; eauto. -intuition. -assert (find k0 (add k e m) = Some e0). - apply find_1; auto. - apply add_bst; auto. -clear H4. -rewrite add_spec in H3; auto. -destruct (eq_dec k0 k). -inversion_clear H3; subst; auto. -right; apply find_2; auto. -inversion_clear H4; auto. -compute in H3; destruct H3. -subst; right; apply add_1; auto. -inversion_clear H1. -destruct (eq_dec k0 k). -destruct (H2 k); eauto. -right; apply add_2; auto. -Qed. - -Lemma anti_elements_mapsto : forall l k e, NoDupA (eqk (elt:=elt'')) l -> - (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l). -Proof. -intros. -unfold anti_elements. -rewrite anti_elements_mapsto_aux; auto; unfold empty; auto. -inversion 2. -intuition. -inversion H1. -Qed. +Section Map2. +Variable elt elt' elt'' : Type. +Variable f : option elt -> option elt' -> option elt''. -Lemma map2_avl : forall (m: t elt)(m': t elt'), avl (map2 m m'). +Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). Proof. -unfold map2; intros; apply anti_elements_avl; auto. +unfold map2; intros. +apply map2_opt_bst with (fun _ => f); auto using map_option_bst; + intros; rewrite map_option_find; auto. Qed. -Lemma map2_bst : forall (m: t elt)(m': t elt'), bst (map2 m m'). +Lemma map2_1 : forall m m' y, bst m -> bst m' -> + In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). Proof. -unfold map2; intros; apply anti_elements_bst; auto. -Qed. - -Lemma find_elements : forall (elt:Set)(m: t elt) x, bst m -> - L.find x (elements m) = find x m. -Proof. -intros. -case_eq (find x m); intros. -apply L.find_1. -apply elements_sort; auto. -red; rewrite elements_mapsto. -apply find_2; auto. -case_eq (L.find x (elements m)); auto; intros. -rewrite <- H0; symmetry. -apply find_1; auto. -rewrite <- elements_mapsto. -apply L.find_2; auto. -Qed. - -Lemma find_anti_elements : forall (l: list (key*elt'')) x, sort (@ltk _) l -> - find x (anti_elements l) = L.find x l. -Proof. -intros. -case_eq (L.find x l); intros. -apply find_1. -apply anti_elements_bst; auto. -rewrite anti_elements_mapsto. -apply L.PX.Sort_NoDupA; auto. -apply L.find_2; auto. -case_eq (find x (anti_elements l)); auto; intros. -rewrite <- H0; symmetry. -apply L.find_1; auto. -rewrite <- anti_elements_mapsto. -apply L.PX.Sort_NoDupA; auto. -apply find_2; auto. -Qed. - -Lemma map2_1 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> - In x m \/ In x m' -> find x (map2 m m') = f (find x m) (find x m'). -Proof. unfold map2; intros. -rewrite find_anti_elements; auto. -rewrite <- find_elements; auto. -rewrite <- find_elements; auto. -apply L.map2_1; auto. -apply elements_sort; auto. -apply elements_sort; auto. -do 2 rewrite elements_in; auto. -apply L.map2_sorted; auto. -apply elements_sort; auto. -apply elements_sort; auto. +rewrite (map2_opt_1 (f0:=fun _ => f)); + auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_2 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> - In x (map2 m m') -> In x m \/ In x m'. +Lemma map2_2 : forall m m' y, bst m -> bst m' -> + In y (map2 f m m') -> In y m \/ In y m'. Proof. unfold map2; intros. -do 2 rewrite <- elements_in. -apply L.map2_2 with (f:=f); auto. -apply elements_sort; auto. -apply elements_sort; auto. -revert H1. -rewrite <- In_alt. -destruct 1. -exists x0. -rewrite <- anti_elements_mapsto; auto. -apply L.PX.Sort_NoDupA; auto. -apply L.map2_sorted; auto. -apply elements_sort; auto. -apply elements_sort; auto. +eapply map2_opt_2 with (f0:=fun _ => f); eauto; intros. + apply map_option_bst; auto. + apply map_option_bst; auto. + rewrite map_option_find; auto. + rewrite map_option_find; auto. Qed. End Map2. -End Elts. +End Proofs. End Raw. (** * Encapsulation @@ -1710,178 +1813,184 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. Module Raw := Raw I X. + Import Raw.Proofs. - Record bbst (elt:Set) : Set := - Bbst {this :> Raw.tree elt; is_bst : Raw.bst this; is_avl: Raw.avl this}. + Record bst (elt:Type) := + Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. - Definition t := bbst. + Definition t := bst. Definition key := E.t. Section Elt. - Variable elt elt' elt'': Set. + Variable elt elt' elt'': Type. Implicit Types m : t elt. Implicit Types x y : key. Implicit Types e : elt. - Definition empty : t elt := Bbst (Raw.empty_bst elt) (Raw.empty_avl elt). + Definition empty : t elt := Bst (empty_bst elt). Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := - Bbst (Raw.add_bst x e m.(is_bst) m.(is_avl)) (Raw.add_avl x e m.(is_avl)). - Definition remove x m : t elt := - Bbst (Raw.remove_bst x m.(is_bst) m.(is_avl)) (Raw.remove_avl x m.(is_avl)). + Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). + Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). Definition mem x m : bool := Raw.mem x m.(this). Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := - Bbst (Raw.map_bst f m.(is_bst)) (Raw.map_avl f m.(is_avl)). + Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). Definition mapi (f:key->elt->elt') m : t elt' := - Bbst (Raw.mapi_bst f m.(is_bst)) (Raw.mapi_avl f m.(is_avl)). + Bst (mapi_bst f m.(is_bst)). Definition map2 f m (m':t elt') : t elt'' := - Bbst (Raw.map2_bst f m m') (Raw.map2_avl f m m'). + Bst (map2_bst f m.(is_bst) m'.(is_bst)). Definition elements m : list (key*elt) := Raw.elements m.(this). - Definition fold (A:Set) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := - if (Raw.equal cmp m.(is_bst) m'.(is_bst)) then true else false. + Definition cardinal m := Raw.cardinal m.(this). + Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. + Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). Definition In x m : Prop := Raw.In0 x m.(this). - Definition Empty m : Prop := Raw.Empty m.(this). + Definition Empty m : Prop := Empty m.(this). - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt. + Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. + Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. + Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros m; exact (@Raw.MapsTo_1 _ m.(this)). Qed. + Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. - unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_1; auto. + unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. - unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_2; auto. + unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. Lemma empty_1 : Empty empty. - Proof. exact (@Raw.empty_1 elt). Qed. + Proof. exact (@empty_1 elt). Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. - Proof. intros m; exact (@Raw.is_empty_1 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. - Proof. intros m; exact (@Raw.is_empty_2 _ m.(this)). Qed. + Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). - Proof. intros m x y e; exact (@Raw.add_1 elt _ x y e m.(is_avl)). Qed. + Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. intros m x y e e'; exact (@Raw.add_2 elt _ x y e e' m.(is_avl)). Qed. + Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. intros m x y e e'; exact (@Raw.add_3 elt _ x y e e' m.(is_avl)). Qed. + Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). Proof. - unfold In, remove; intros m x y; rewrite Raw.In_alt; simpl; apply Raw.remove_1; auto. + unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. apply m.(is_bst). - apply m.(is_avl). Qed. Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. intros m x y e; exact (@Raw.remove_2 elt _ x y e m.(is_bst) m.(is_avl)). Qed. + Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. - Proof. intros m x y e; exact (@Raw.remove_3 elt _ x y e m.(is_bst) m.(is_avl)). Qed. + Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. - Proof. intros m x e; exact (@Raw.find_1 elt _ x e m.(is_bst)). Qed. + Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. - Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. + Proof. intros m; exact (@find_2 elt m.(this)). Qed. - Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A), + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. intros m; exact (@Raw.fold_1 elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite Raw.elements_mapsto; auto. + intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. - intros; unfold elements, MapsTo, eq_key_elt; rewrite <- Raw.elements_mapsto; auto. + intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. Lemma elements_3 : forall m, sort lt_key (elements m). - Proof. intros m; exact (@Raw.elements_sort elt m.(this) m.(is_bst)). Qed. + Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Definition Equal cmp m m' := + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equal_Equal : forall cmp m m', Equal cmp m m' <-> Raw.Equal cmp m m'. + Lemma Equivb_Equivb : forall cmp m m', + Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. Proof. - intros; unfold Equal, Raw.Equal, In; intuition. - generalize (H0 k); do 2 rewrite Raw.In_alt; intuition. - generalize (H0 k); do 2 rewrite Raw.In_alt; intuition. - generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition. - generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition. - Qed. + intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + Qed. Lemma equal_1 : forall m m' cmp, - Equal cmp m m' -> equal cmp m m' = true. + Equivb cmp m m' -> equal cmp m m' = true. Proof. - unfold equal; intros m m' cmp; rewrite Equal_Equal. - destruct (@Raw.equal _ cmp m m'); auto. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + intros; simpl in *; rewrite equal_Equivb; auto. Qed. Lemma equal_2 : forall m m' cmp, - equal cmp m m' = true -> Equal cmp m m'. + equal cmp m m' = true -> Equivb cmp m m'. Proof. - unfold equal; intros; rewrite Equal_Equal. - destruct (@Raw.equal _ cmp m m'); auto; try discriminate. - Qed. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + intros; simpl in *; rewrite <-equal_Equivb; auto. + Qed. End Elt. - Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. intros elt elt' m x e f; exact (@Raw.map_1 elt elt' f m.(this) x e). Qed. + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. - Lemma map_2 : forall (elt elt':Set)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite Raw.In_alt; simpl. - apply Raw.map_2; auto. + intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. + apply map_2; auto. Qed. - Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. intros elt elt' m x e f; exact (@Raw.mapi_1 elt elt' f m.(this) x e). Qed. - Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros elt elt' m x f; unfold In in *; do 2 rewrite Raw.In_alt; simpl; apply Raw.mapi_2; auto. - Qed. + intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. + Qed. - Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. - do 2 rewrite Raw.In_alt; intros; simpl; apply Raw.map2_1; auto. + do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). apply m'.(is_bst). Qed. - Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. unfold In, map2; intros elt elt' elt'' m m' x f. - do 3 rewrite Raw.In_alt; intros; simpl in *; eapply Raw.map2_2; eauto. + do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). apply m'.(is_bst). Qed. @@ -1891,158 +2000,185 @@ End IntMake. Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Sord with Module Data := D - with Module MapS.E := X. + with Module MapS.E := X. Module Data := D. - Module MapS := IntMake(I)(X). - Import MapS. + Module Import MapS := IntMake(I)(X). + Module LO := FMapList.Make_ord(X)(D). + Module R := Raw. + Module P := Raw.Proofs. + + Definition t := MapS.t D.t. + + Definition cmp e e' := + match D.compare e e' with EQ _ => true | _ => false end. + + (** One step of comparison of elements *) + + Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := + match e2 with + | R.End => Gt + | R.More x2 d2 r2 e2 => + match X.compare x1 x2 with + | EQ _ => match D.compare d1 d2 with + | EQ _ => cont (R.cons r2 e2) + | LT _ => Lt + | GT _ => Gt + end + | LT _ => Lt + | GT _ => Gt + end + end. - Module MD := OrderedTypeFacts(D). - Import MD. + (** Comparison of left tree, middle element, then right tree *) - Module LO := FMapList.Make_ord(X)(D). + Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := + match s1 with + | R.Leaf => cont e2 + | R.Node l1 x1 d1 r1 _ => + compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 + end. + + (** Initial continuation *) + + Definition compare_end (e2:R.enumeration D.t) := + match e2 with R.End => Eq | _ => Lt end. + + (** The complete comparison *) - Definition t := MapS.t D.t. + Definition compare_pure s1 s2 := + compare_cont s1 compare_end (R.cons s2 (Raw.End _)). - Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. + (** Correctness of this comparison *) - Definition elements (m:t) := - LO.MapS.Build_slist (Raw.elements_sort m.(is_bst)). + Definition Cmp c := + match c with + | Eq => LO.eq_list + | Lt => LO.lt_list + | Gt => (fun l1 l2 => LO.lt_list l2 l1) + end. + + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> D.eq d1 d2 -> + Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). + Proof. + destruct c; simpl; intros; P.MX.elim_comp; auto. + Qed. + Hint Resolve cons_Cmp. + + Lemma compare_end_Cmp : + forall e2, Cmp (compare_end e2) nil (P.flatten_e e2). + Proof. + destruct e2; simpl; auto. + Qed. + + Lemma compare_more_Cmp : forall x1 d1 cont x2 d2 r2 e2 l, + Cmp (cont (R.cons r2 e2)) l (R.elements r2 ++ P.flatten_e e2) -> + Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) + (P.flatten_e (R.More x2 d2 r2 e2)). + Proof. + simpl; intros; destruct X.compare; simpl; + try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. + Qed. + + Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (P.flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). + Proof. + induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto. + rewrite <- P.elements_node; simpl. + apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- P.cons_1; auto. + Qed. + + Lemma compare_Cmp : forall s1 s2, + Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2). + Proof. + intros; unfold compare_pure. + rewrite (app_nil_end (R.elements s1)). + replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by + (rewrite P.cons_1; simpl; rewrite <- app_nil_end; auto). + auto using compare_cont_Cmp, compare_end_Cmp. + Qed. - Definition eq : t -> t -> Prop := - fun m1 m2 => LO.eq (elements m1) (elements m2). + (** The dependent-style [compare] *) - Definition lt : t -> t -> Prop := - fun m1 m2 => LO.lt (elements m1) (elements m2). + Definition eq (m1 m2 : t) := LO.eq_list (elements m1) (elements m2). + Definition lt (m1 m2 : t) := LO.lt_list (elements m1) (elements m2). - Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'. + Definition compare (s s':t) : Compare lt eq s s'. + Proof. + intros (s,b) (s',b'). + generalize (compare_Cmp s s'). + destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. + Defined. + + (* Proofs about [eq] and [lt] *) + + Definition selements (m1 : t) := + LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). + + Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). + Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). + + Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. + Proof. + unfold eq, seq, selements, elements, LO.eq; intuition. + Qed. + + Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. + Proof. + unfold lt, slt, selements, elements, LO.lt; intuition. + Qed. + + Lemma eq_1 : forall (m m' : t), Equivb cmp m m' -> eq m m'. Proof. intros m m'. - unfold eq. - rewrite Equal_Equal. - rewrite Raw.Equal_elements. - intros. - apply LO.eq_1. - auto. + rewrite eq_seq; unfold seq. + rewrite Equivb_Equivb. + rewrite P.Equivb_elements. + auto using LO.eq_1. Qed. - Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'. + Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Proof. intros m m'. - unfold eq. - rewrite Equal_Equal. - rewrite Raw.Equal_elements. + rewrite eq_seq; unfold seq. + rewrite Equivb_Equivb. + rewrite P.Equivb_elements. intros. generalize (LO.eq_2 H). auto. Qed. - + Lemma eq_refl : forall m : t, eq m m. Proof. - unfold eq; intros; apply LO.eq_refl. + intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. - unfold eq; intros; apply LO.eq_sym; auto. + intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Proof. - unfold eq; intros; eapply LO.eq_trans; eauto. + intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. + intros; eapply LO.eq_trans; eauto. Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - unfold lt; intros; eapply LO.lt_trans; eauto. + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - unfold lt, eq; intros; apply LO.lt_not_eq; auto. - Qed. - - Import Raw. - - Definition flatten_slist (e:enumeration D.t)(He:sorted_e e) := - LO.MapS.Build_slist (sorted_flatten_e He). - - Open Local Scope Z_scope. - - Definition compare_aux : - forall (e1 e2:enumeration D.t)(He1:sorted_e e1)(He2: sorted_e e2), - Compare LO.lt LO.eq (flatten_slist He1) (flatten_slist He2). - Proof. - intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2. - simple destruct x; simple destruct x'; intuition. - (* x = x' = End *) - constructor 2. - compute; auto. - (* x = End x' = More *) - constructor 1. - compute; auto. - (* x = More x' = End *) - constructor 3. - compute; auto. - (* x = More k t0 t1 e, x' = More k0 t2 t3 e0 *) - case (X.compare k k0); intro. - (* k < k0 *) - constructor 1. - compute; MX.elim_comp; auto. - (* k = k0 *) - destruct (D.compare t t1). - constructor 1. - compute; MX.elim_comp; auto. - destruct (@cons _ t0 e) as [c1 (H2,(H3,H4))]; try inversion_clear He1; auto. - destruct (@cons _ t2 e0) as [c2 (H5,(H6,H7))]; try inversion_clear He2; auto. - assert (measure_e c1 + measure_e c2 < - measure_e (More k t t0 e) + - measure_e (More k0 t1 t2 e0)). - unfold measure_e in *; fold measure_e in *; omega. - destruct (H c1 c2 H0 H2 H5); clear H. - constructor 1. - unfold flatten_slist, LO.lt in *; simpl; simpl in l. - MX.elim_comp. - right; split; auto. - rewrite <- H7; rewrite <- H4; auto. - constructor 2. - unfold flatten_slist, LO.eq in *; simpl; simpl in e5. - MX.elim_comp. - split; auto. - rewrite <- H7; rewrite <- H4; auto. - constructor 3. - unfold flatten_slist, LO.lt in *; simpl; simpl in l. - MX.elim_comp. - right; split; auto. - rewrite <- H7; rewrite <- H4; auto. - constructor 3. - compute; MX.elim_comp; auto. - (* k > k0 *) - constructor 3. - compute; MX.elim_comp; auto. - Qed. - - Definition compare : forall m1 m2, Compare lt eq m1 m2. - Proof. - intros (m1,m1_bst,m1_avl) (m2,m2_bst,m2_avl); simpl. - destruct (@cons _ m1 (End _)) as [x1 (H1,H11)]; auto. - apply SortedEEnd. - inversion_clear 2. - destruct (@cons _ m2 (End _)) as [x2 (H2,H22)]; auto. - apply SortedEEnd. - inversion_clear 2. - simpl in H11; rewrite <- app_nil_end in H11. - simpl in H22; rewrite <- app_nil_end in H22. - destruct (compare_aux H1 H2); intuition. - constructor 1. - unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *. - rewrite <- H0; rewrite <- H4; auto. - constructor 2. - unfold eq, LO.eq, IntMake_ord.elements, flatten_slist in *; simpl in *. - rewrite <- H0; rewrite <- H4; auto. - constructor 3. - unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *. - rewrite <- H0; rewrite <- H4; auto. + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros; apply LO.lt_not_eq; auto. Qed. End IntMake_ord. @@ -2056,3 +2192,4 @@ Module Make_ord (X: OrderedType)(D: OrderedType) <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). + diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 0105095a..b307efe3 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *) +(* $Id: FMapFacts.v 10782 2008-04-12 16:08:04Z msozeau $ *) (** * Finite maps library *) @@ -15,20 +15,24 @@ different styles: equivalence and boolean equalities. *) -Require Import Bool. -Require Import OrderedType. +Require Import Bool DecidableType DecidableTypeEx OrderedType. Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. -Module Facts (M: S). -Module ME := OrderedTypeFacts M.E. -Import ME. -Import M. -Import Logic. (* to unmask [eq] *) -Import Peano. (* to unmask [lt] *) +(** * Facts about weak maps *) -Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), +Module WFacts (E:DecidableType)(Import M:WSfun E). + +Notation eq_dec := E.eq_dec. +Definition eqb x y := if eq_dec x y then true else false. + +Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true). +Proof. + destruct b; destruct b'; intuition. +Qed. + +Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. intros. @@ -36,19 +40,14 @@ generalize (find_1 H) (find_1 H0); clear H H0. intros; rewrite H in H0; injection H0; auto. Qed. -(** * Specifications written using equivalences *) +(** ** Specifications written using equivalences *) Section IffSpec. -Variable elt elt' elt'': Set. +Variable elt elt' elt'': Type. Implicit Type m: t elt. Implicit Type x y z: key. Implicit Type e: elt. -Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. -split; apply MapsTo_1; auto. -Qed. - Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). Proof. unfold In. @@ -57,12 +56,34 @@ apply (MapsTo_1 H H0); auto. apply (MapsTo_1 (E.eq_sym H) H0); auto. Qed. +Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). +Proof. +split; apply MapsTo_1; auto. +Qed. + +Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. +Proof. +split; [apply mem_1|apply mem_2]. +Qed. + +Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. +Proof. +intros; rewrite mem_in_iff; destruct (mem x m); intuition. +Qed. + +Lemma In_dec : forall m x, { In x m } + { ~ In x m }. +Proof. + intros. + generalize (mem_in_iff m x). + destruct (mem x m); [left|right]; intuition. +Qed. + Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. Proof. split; [apply find_1|apply find_2]. Qed. -Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None. +Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. intros. generalize (find_mapsto_iff m x); destruct (find x m). @@ -74,17 +95,13 @@ intros; intros (e,H1). rewrite H in H1; discriminate. Qed. -Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. +Lemma in_find_iff : forall m x, In x m <-> find x m <> None. Proof. -intros; rewrite mem_in_iff; destruct (mem x m); intuition. +intros; rewrite <- not_find_in_iff, mem_in_iff. +destruct mem; intuition. Qed. -Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true. +Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. Proof. split; [apply equal_1|apply equal_2]. Qed. @@ -114,9 +131,9 @@ intros. intuition. destruct (eq_dec x y); [left|right]. split; auto. -symmetry; apply (MapsTo_fun (e':=e) H); auto. +symmetry; apply (MapsTo_fun (e':=e) H); auto with map. split; auto; apply add_3 with x e; auto. -subst; auto. +subst; auto with map. Qed. Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. @@ -204,33 +221,33 @@ split. case_eq (find x m); intros. exists e. split. -apply (MapsTo_fun (m:=map f m) (x:=x)); auto. -apply find_2; auto. +apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map. +apply find_2; auto with map. assert (In x (map f m)) by (exists b; auto). destruct (map_2 H1) as (a,H2). rewrite (find_1 H2) in H; discriminate. intros (a,(H,H0)). -subst b; auto. +subst b; auto with map. Qed. Lemma map_in_iff : forall m x (f : elt -> elt'), In x (map f m) <-> In x m. Proof. -split; intros; eauto. +split; intros; eauto with map. destruct H as (a,H). -exists (f a); auto. +exists (f a); auto with map. Qed. Lemma mapi_in_iff : forall m x (f:key->elt->elt'), In x (mapi f m) <-> In x m. Proof. -split; intros; eauto. +split; intros; eauto with map. destruct H as (a,H). destruct (mapi_1 f H) as (y,(H0,H1)). exists (f y a); auto. Qed. -(* Unfortunately, we don't have simple equivalences for [mapi] +(** Unfortunately, we don't have simple equivalences for [mapi] and [MapsTo]. The only correct one needs compatibility of [f]. *) Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), @@ -240,9 +257,9 @@ Proof. intros; case_eq (find x m); intros. exists e. destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). -apply find_2; auto. -exists y; repeat split; auto. -apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto. +apply find_2; auto with map. +exists y; repeat split; auto with map. +apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map. assert (In x (mapi f m)) by (exists b; auto). destruct (mapi_2 H1) as (a,H2). rewrite (find_1 H2) in H0; discriminate. @@ -287,11 +304,11 @@ Ltac map_iff := rewrite map_mapsto_iff || rewrite map_in_iff || rewrite mapi_in_iff)). -(** * Specifications written using boolean predicates *) +(** ** Specifications written using boolean predicates *) Section BoolSpec. -Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. +Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. Proof. intros. generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. @@ -303,7 +320,7 @@ destruct H0 as (e,H0). destruct (H e); intuition discriminate. Qed. -Variable elt elt' elt'' : Set. +Variable elt elt' elt'' : Type. Implicit Types m : t elt. Implicit Types x y z : key. Implicit Types e : elt. @@ -345,24 +362,24 @@ Qed. Lemma add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e. Proof. -auto. +auto with map. Qed. Lemma add_neq_o : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m. Proof. intros. -case_eq (find y m); intros; auto. -case_eq (find y (add x e m)); intros; auto. +case_eq (find y m); intros; auto with map. +case_eq (find y (add x e m)); intros; auto with map. rewrite <- H0; symmetry. -apply find_1; apply add_3 with x e; auto. +apply find_1; apply add_3 with x e; auto with map. Qed. -Hint Resolve add_neq_o. +Hint Resolve add_neq_o : map. Lemma add_o : forall m x y e, find y (add x e m) = if eq_dec x y then Some e else find y m. Proof. -intros; destruct (eq_dec x y); auto. +intros; destruct (eq_dec x y); auto with map. Qed. Lemma add_eq_b : forall m x y e, @@ -394,23 +411,23 @@ destruct (find y (remove x m)); auto. destruct 2. exists e; rewrite H0; auto. Qed. -Hint Resolve remove_eq_o. +Hint Resolve remove_eq_o : map. Lemma remove_neq_o : forall m x y, ~ E.eq x y -> find y (remove x m) = find y m. Proof. intros. -case_eq (find y m); intros; auto. -case_eq (find y (remove x m)); intros; auto. +case_eq (find y m); intros; auto with map. +case_eq (find y (remove x m)); intros; auto with map. rewrite <- H0; symmetry. -apply find_1; apply remove_3 with x; auto. +apply find_1; apply remove_3 with x; auto with map. Qed. -Hint Resolve remove_neq_o. +Hint Resolve remove_neq_o : map. Lemma remove_o : forall m x y, find y (remove x m) = if eq_dec x y then None else find y m. Proof. -intros; destruct (eq_dec x y); auto. +intros; destruct (eq_dec x y); auto with map. Qed. Lemma remove_eq_b : forall m x y, @@ -432,7 +449,7 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := +Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := match o with | Some a => Some (f a) | None => None @@ -494,15 +511,15 @@ Proof. intros. case_eq (find x m); intros. rewrite <- H0. -apply map2_1; auto. -left; exists e; auto. +apply map2_1; auto with map. +left; exists e; auto with map. case_eq (find x m'); intros. rewrite <- H0; rewrite <- H1. apply map2_1; auto. -right; exists e; auto. +right; exists e; auto with map. rewrite H. -case_eq (find x (map2 f m m')); intros; auto. -assert (In x (map2 f m m')) by (exists e; auto). +case_eq (find x (map2 f m m')); intros; auto with map. +assert (In x (map2 f m m')) by (exists e; auto with map). destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. rewrite (find_1 H4) in H0; discriminate. rewrite (find_1 H4) in H1; discriminate. @@ -514,21 +531,18 @@ Proof. intros. assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)). intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff. -assert (NoDupA (eq_key (elt:=elt)) (elements m)). - apply SortA_NoDupA with (lt_key (elt:=elt)); unfold eq_key, lt_key; intuition eauto. - destruct y; simpl in *. - apply (E.lt_not_eq H0 H1). - exact (elements_3 m). +assert (H0:=elements_3w m). generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans eq_dec (elements m) x e H0). -unfold eqb. -destruct (find x m); destruct (findA (fun y : E.t => if eq_dec x y then true else false) (elements m)); +fold (eqb x). +destruct (find x m); destruct (findA (eqb x) (elements m)); simpl; auto; intros. symmetry; rewrite <- H1; rewrite <- H; auto. symmetry; rewrite <- H1; rewrite <- H; auto. rewrite H; rewrite H1; auto. Qed. -Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m). +Lemma elements_b : forall m x, + mem x m = existsb (fun p => eqb x (fst p)) (elements m). Proof. intros. generalize (mem_in_iff m x)(elements_in_iff m x) @@ -554,4 +568,1026 @@ Qed. End BoolSpec. +Section Equalities. + +Variable elt:Type. + +(** * Relations between [Equal], [Equiv] and [Equivb]. *) + +(** First, [Equal] is [Equiv] with Leibniz on elements. *) + +Lemma Equal_Equiv : forall (m m' : t elt), + Equal m m' <-> Equiv (@Logic.eq elt) m m'. +Proof. + unfold Equal, Equiv; split; intros. + split; intros. + rewrite in_find_iff, in_find_iff, H; intuition. + rewrite find_mapsto_iff in H0,H1; congruence. + destruct H. + specialize (H y). + specialize (H0 y). + do 2 rewrite in_find_iff in H. + generalize (find_mapsto_iff m y)(find_mapsto_iff m' y). + do 2 destruct find; auto; intros. + f_equal; apply H0; [rewrite H1|rewrite H2]; auto. + destruct H as [H _]; now elim H. + destruct H as [_ H]; now elim H. +Qed. + +(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] + are related. *) + +Section Cmp. +Variable eq_elt : elt->elt->Prop. +Variable cmp : elt->elt->bool. + +Definition compat_cmp := + forall e e', cmp e e' = true <-> eq_elt e e'. + +Lemma Equiv_Equivb : compat_cmp -> + forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. +Proof. + unfold Equivb, Equiv, Cmp; intuition. + red in H; rewrite H; eauto. + red in H; rewrite <-H; eauto. +Qed. +End Cmp. + +(** Composition of the two last results: relation between [Equal] + and [Equivb]. *) + +Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> + forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. +Proof. + intros; rewrite Equal_Equiv. + apply Equiv_Equivb; auto. +Qed. + +Lemma Equal_Equivb_eqdec : + forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), + let cmp := fun e e' => if eq_elt_dec e e' then true else false in + forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. +Proof. +intros; apply Equal_Equivb. +unfold cmp; clear cmp; intros. +destruct eq_elt_dec; now intuition. +Qed. + +End Equalities. + +(** * [Equal] is a setoid equality. *) + +Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. +Proof. red; reflexivity. Qed. + +Lemma Equal_sym : forall (elt:Type)(m m' : t elt), + Equal m m' -> Equal m' m. +Proof. unfold Equal; auto. Qed. + +Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), + Equal m m' -> Equal m' m'' -> Equal m m''. +Proof. unfold Equal; congruence. Qed. + +Definition Equal_ST : forall elt:Type, Setoid_Theory (t elt) (@Equal _). +Proof. +constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. +Qed. + +Add Relation key E.eq + reflexivity proved by E.eq_refl + symmetry proved by E.eq_sym + transitivity proved by E.eq_trans + as KeySetoid. + +Implicit Arguments Equal [[elt]]. + +Add Parametric Relation (elt : Type) : (t elt) Equal + reflexivity proved by (@Equal_refl elt) + symmetry proved by (@Equal_sym elt) + transitivity proved by (@Equal_trans elt) + as EqualSetoid. + +Add Parametric Morphism elt : (@In elt) with signature E.eq ==> Equal ==> iff as In_m. +Proof. +unfold Equal; intros k k' Hk m m' Hm. +rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. +Qed. + +Add Parametric Morphism elt : (@MapsTo elt) + with signature E.eq ==> @Logic.eq _ ==> Equal ==> iff as MapsTo_m. +Proof. +unfold Equal; intros k k' Hk e m m' Hm. +rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; + intuition. +Qed. + +Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. +Proof. +unfold Empty; intros m m' Hm; intuition. +rewrite <-Hm in H0; eauto. +rewrite Hm in H0; eauto. +Qed. + +Add Parametric Morphism elt : (@is_empty elt) with signature Equal ==> @Logic.eq _ as is_empty_m. +Proof. +intros m m' Hm. +rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. +Qed. + +Add Parametric Morphism elt : (@mem elt) with signature E.eq ==> Equal ==> @Logic.eq _ as mem_m. +Proof. +intros k k' Hk m m' Hm. +rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. +Qed. + +Add Parametric Morphism elt : (@find elt) with signature E.eq ==> Equal ==> @Logic.eq _ as find_m. +Proof. +intros k k' Hk m m' Hm. +generalize (find_mapsto_iff m k)(find_mapsto_iff m' k') + (not_find_in_iff m k)(not_find_in_iff m' k'); +do 2 destruct find; auto; intros. +rewrite <- H, Hk, Hm, H0; auto. +rewrite <- H1, Hk, Hm, H2; auto. +symmetry; rewrite <- H2, <-Hk, <-Hm, H1; auto. +Qed. + +Add Parametric Morphism elt : (@add elt) with signature + E.eq ==> @Logic.eq _ ==> Equal ==> Equal as add_m. +Proof. +intros k k' Hk e m m' Hm y. +rewrite add_o, add_o; do 2 destruct eq_dec; auto. +elim n; rewrite <-Hk; auto. +elim n; rewrite Hk; auto. +Qed. + +Add Parametric Morphism elt : (@remove elt) with signature + E.eq ==> Equal ==> Equal as remove_m. +Proof. +intros k k' Hk m m' Hm y. +rewrite remove_o, remove_o; do 2 destruct eq_dec; auto. +elim n; rewrite <-Hk; auto. +elim n; rewrite Hk; auto. +Qed. + +Add Parametric Morphism elt elt' : (@map elt elt') with signature @Logic.eq _ ==> Equal ==> Equal as map_m. +Proof. +intros f m m' Hm y. +rewrite map_o, map_o, Hm; auto. +Qed. + +(* Later: Add Morphism cardinal *) + +(* old name: *) +Notation not_find_mapsto_iff := not_find_in_iff. + +End WFacts. + +(** * Same facts for full maps *) + +Module Facts (M:S). + Module D := OT_as_DT M.E. + Include WFacts D M. End Facts. + +(** * Additional Properties for weak maps + + Results about [fold], [elements], induction principles... +*) + +Module WProperties (E:DecidableType)(M:WSfun E). + Module Import F:=WFacts E M. + Import M. + + Section Elt. + Variable elt:Type. + + Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). + + Notation eqke := (@eq_key_elt elt). + Notation eqk := (@eq_key elt). + + Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. + Proof. + intros. + unfold Empty. + split; intros. + assert (forall a, ~ List.In a (elements m)). + red; intros. + apply (H (fst a) (snd a)). + rewrite elements_mapsto_iff. + rewrite InA_alt; exists a; auto. + split; auto; split; auto. + destruct (elements m); auto. + elim (H0 p); simpl; auto. + red; intros. + rewrite elements_mapsto_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements (@empty elt) = nil. + Proof. + rewrite <-elements_Empty; apply empty_1. + Qed. + + Lemma fold_Empty : forall m (A:Type)(f:key->elt->A->A)(i:A), + Empty m -> fold f m i = i. + Proof. + intros. + rewrite fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. + Qed. + + Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + Proof. + induction 1; auto. + constructor; auto. + contradict H. + destruct x as (x,y). + rewrite InA_alt in *; destruct H as ((a,b),((H1,H2),H3)); simpl in *. + exists (a,b); auto. + Qed. + + Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + transpose eqA (fun y => f (fst y) (snd y)) -> + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). + Proof. + assert (eqke_refl : forall p, eqke p p). + red; auto. + assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). + intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. + assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). + intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. + intuition; eauto; congruence. + intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. + apply fold_right_equivlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + red; intros. + do 2 rewrite InA_rev. + destruct x; do 2 rewrite <- elements_mapsto_iff. + do 2 rewrite find_mapsto_iff. + rewrite H1; split; auto. + Qed. + + Lemma fold_Add : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + transpose eqA (fun y =>f (fst y) (snd y)) -> + ~In x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (f x e (fold f m1 i)). + Proof. + assert (eqke_refl : forall p, eqke p p). + red; auto. + assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). + intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. + assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). + intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. + intuition; eauto; congruence. + 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 *. + change (f x e (fold_right f' i (rev (elements m1)))) + with (f' (x,e) (fold_right f' i (rev (elements m1)))). + apply fold_right_add with (eqA:=eqke)(eqB:=eqA); auto. + apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + rewrite InA_rev. + contradict H1. + exists e. + rewrite elements_mapsto_iff; auto. + intros a. + rewrite InA_cons; do 2 rewrite InA_rev; + destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff. + do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl. + rewrite H2. + rewrite add_o. + destruct (eq_dec x a); intuition. + inversion H3; auto. + f_equal; auto. + elim H1. + exists b; apply MapsTo_1 with a; auto with map. + elim n; auto. + Qed. + + Lemma cardinal_fold : forall m : t elt, + cardinal m = fold (fun _ _ => S) m 0. + Proof. + intros; rewrite cardinal_1, fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + Lemma cardinal_Empty : forall m : t elt, + Empty m <-> cardinal m = 0. + Proof. + intros. + rewrite cardinal_1, elements_Empty. + destruct (elements m); intuition; discriminate. + Qed. + + Lemma Equal_cardinal : forall m m' : t elt, + Equal m m' -> cardinal m = cardinal m'. + Proof. + intros; do 2 rewrite cardinal_fold. + apply fold_Equal with (eqA:=@eq _); auto. + constructor; auto; congruence. + red; auto. + red; auto. + Qed. + + Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. + Proof. + intros; rewrite <- cardinal_Empty; auto. + Qed. + + Lemma cardinal_2 : + forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ _ => S) x e). + apply fold_Add; auto. + constructor; intros; auto; congruence. + red; simpl; auto. + red; simpl; auto. + Qed. + + Lemma cardinal_inv_1 : forall m : t elt, + cardinal m = 0 -> Empty m. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1 : map. + + Lemma cardinal_inv_2 : + forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros; rewrite M.cardinal_1 in *. + generalize (elements_mapsto_iff m). + destruct (elements m); try discriminate. + exists p; auto. + rewrite H0; destruct p; simpl; auto. + constructor; red; auto. + Qed. + + Lemma cardinal_inv_2b : + forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros. + generalize (@cardinal_inv_2 m); destruct cardinal. + elim H;auto. + eauto. + Qed. + + Lemma map_induction : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + apply X; apply cardinal_inv_1; auto. + + destruct (cardinal_inv_2 (sym_eq Heqn)) as ((x,e),H0); simpl in *. + assert (Add x e (remove x m) m). + red; intros. + rewrite add_o; rewrite remove_o; destruct (eq_dec x y); eauto with map. + apply X0 with (remove x m) x e; auto with map. + apply IHn; auto with map. + assert (S n = S (cardinal (remove x m))). + rewrite Heqn; eapply cardinal_2; eauto with map. + inversion H1; auto with map. + Qed. + + (** * Let's emulate some functions not present in the interface *) + + Definition filter (f : key -> elt -> bool)(m : t elt) := + fold (fun k e m => if f k e then add k e m else m) m (empty _). + + Definition for_all (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then b else false) m true. + + Definition exists_ (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then true else b) m false. + + Definition partition (f : key -> elt -> bool)(m : t elt) := + (filter f m, filter (fun k e => negb (f k e))). + + Section Specs. + Variable f : key -> elt -> bool. + Hypothesis Hf : forall e, compat_bool E.eq (fun k => f k e). + + Lemma filter_iff : forall m k e, + MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. + Proof. + unfold filter; intros. + rewrite fold_1. + rewrite <- fold_left_rev_right. + rewrite (elements_mapsto_iff m). + rewrite <- (InA_rev eqke (k,e) (elements m)). + assert (NoDupA eqk (rev (elements m))). + apply NoDupA_rev; auto; try apply elements_3w; auto. + intros (k1,e1); compute; auto. + intros (k1,e1)(k2,e2); compute; auto. + intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. + induction (rev (elements m)); simpl; auto. + + rewrite empty_mapsto_iff. + intuition. + inversion H1. + + destruct a as (k',e'); simpl. + inversion_clear H. + case_eq (f k' e'); intros; simpl; + try rewrite add_mapsto_iff; rewrite IHl; clear IHl; intuition. + constructor; red; auto. + rewrite (Hf e' H2),H4 in H; auto. + inversion_clear H3. + compute in H2; destruct H2; auto. + destruct (E.eq_dec k' k); auto. + elim H0. + rewrite InA_alt in *; destruct H2 as (w,Hw); exists w; intuition. + red in H2; red; simpl in *; intuition. + rewrite e0; auto. + inversion_clear H3; auto. + compute in H2; destruct H2. + rewrite (Hf e H2),H3,H in H4; discriminate. + Qed. + + Lemma for_all_iff : forall m, + for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). + Proof. + cut (forall m : t elt, + for_all f m = true <-> + (forall k e, InA eqke (k,e) (rev (elements m)) -> f k e = true)). + intros; rewrite H; split; intros. + apply H0; rewrite InA_rev, <- elements_mapsto_iff; auto. + apply H0; rewrite InA_rev, <- elements_mapsto_iff in H1; auto. + + unfold for_all; intros. + rewrite fold_1. + rewrite <- fold_left_rev_right. + assert (NoDupA eqk (rev (elements m))). + apply NoDupA_rev; auto; try apply elements_3w; auto. + intros (k1,e1); compute; auto. + intros (k1,e1)(k2,e2); compute; auto. + intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. + induction (rev (elements m)); simpl; auto. + + intuition. + inversion H1. + + destruct a as (k,e); simpl. + inversion_clear H. + case_eq (f k e); intros; simpl; + try rewrite IHl; clear IHl; intuition. + inversion_clear H3; auto. + compute in H4; destruct H4. + rewrite (Hf e0 H3), H4; auto. + rewrite <-H, <-(H2 k e); auto. + constructor; red; auto. + Qed. + + Lemma exists_iff : forall m, + exists_ f m = true <-> + (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). + Proof. + cut (forall m : t elt, + exists_ f m = true <-> + (exists p, InA eqke p (rev (elements m)) + /\ f (fst p) (snd p) = true)). + intros; rewrite H; split; intros. + destruct H0 as ((k,e),Hke); exists (k,e). + rewrite InA_rev, <-elements_mapsto_iff in Hke; auto. + destruct H0 as ((k,e),Hke); exists (k,e). + rewrite InA_rev, <-elements_mapsto_iff; auto. + unfold exists_; intros. + rewrite fold_1. + rewrite <- fold_left_rev_right. + assert (NoDupA eqk (rev (elements m))). + apply NoDupA_rev; auto; try apply elements_3w; auto. + intros (k1,e1); compute; auto. + intros (k1,e1)(k2,e2); compute; auto. + intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. + induction (rev (elements m)); simpl; auto. + + intuition; try discriminate. + destruct H0 as ((k,e),(Hke,_)); inversion Hke. + + destruct a as (k,e); simpl. + inversion_clear H. + case_eq (f k e); intros; simpl; + try rewrite IHl; clear IHl; intuition. + exists (k,e); simpl; split; auto. + constructor; red; auto. + destruct H2 as ((k',e'),(Hke',Hf')); exists (k',e'); simpl; auto. + destruct H2 as ((k',e'),(Hke',Hf')); simpl in *. + inversion_clear Hke'. + compute in H2; destruct H2. + rewrite (Hf e' H2), H3,H in Hf'; discriminate. + exists (k',e'); auto. + Qed. + End Specs. + + (** specialized versions analyzing only keys (resp. elements) *) + + Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). + Definition filter_range (f : elt -> bool) := filter (fun _ => f). + Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). + Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). + Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). + Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). + Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). + Definition partition_range (f : elt -> bool) := partition (fun _ => f). + + End Elt. + + Add Parametric Morphism elt : (@cardinal elt) with signature Equal ==> @Logic.eq _ as cardinal_m. + Proof. intros; apply Equal_cardinal; auto. Qed. + +End WProperties. + +(** * Same Properties for full maps *) + +Module Properties (M:S). + Module D := OT_as_DT M.E. + Include WProperties D M. +End Properties. + +(** * Properties specific to maps with ordered keys *) + +Module OrdProperties (M:S). + Module Import ME := OrderedTypeFacts M.E. + Module Import O:=KeyOrderedType M.E. + Module Import P:=Properties M. + Import F. + Import M. + + Section Elt. + Variable elt:Type. + + Notation eqke := (@eqke elt). + Notation eqk := (@eqk elt). + Notation ltk := (@ltk elt). + Notation cardinal := (@cardinal elt). + Notation Equal := (@Equal elt). + Notation Add := (@Add elt). + + Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. + Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. + + Section Elements. + + Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), + sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto; + unfold O.eqke, O.ltk; simpl; intuition; eauto. + Qed. + + Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. + + Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. + Definition leb p := fun p' => negb (gtb p p'). + + Definition elements_lt p m := List.filter (gtb p) (elements m). + Definition elements_ge p m := List.filter (leb p) (elements m). + + Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. + Proof. + intros (x,e) (y,e'); unfold gtb, O.ltk; simpl. + destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. + Proof. + intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl. + destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma gtb_compat : forall p, compat_bool eqke (gtb p). + Proof. + red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. + unfold O.ltk in *; simpl in *; intros. + symmetry; rewrite H2. + apply ME.eq_lt with a; auto. + rewrite <- H1; auto. + unfold O.ltk in *; simpl in *; intros. + rewrite H1. + apply ME.eq_lt with b; auto. + rewrite <- H2; auto. + Qed. + + Lemma leb_compat : forall p, compat_bool eqke (leb p). + Proof. + red; intros x a b H. + unfold leb; f_equal; apply gtb_compat; auto. + Qed. + + Hint Resolve gtb_compat leb_compat elements_3 : map. + + Lemma elements_split : forall p m, + elements m = elements_lt p m ++ elements_ge p m. + Proof. + unfold elements_lt, elements_ge, leb; intros. + apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with map. + intros; destruct x; destruct y; destruct p. + rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. + assert (~ltk (t1,e0) (k,e1)). + unfold gtb, O.ltk in *; simpl in *. + destruct (E.compare k t1); intuition; try discriminate; ME.order. + unfold O.ltk in *; simpl in *; ME.order. + Qed. + + Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (elements m') + (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). + Proof. + intros; unfold elements_lt, elements_ge. + apply sort_equivlistA_eqlistA; auto with map. + apply (@SortA_app _ eqke); auto with map. + apply (@filter_sort _ eqke); auto with map; clean_eauto. + constructor; auto with map. + apply (@filter_sort _ eqke); auto with map; clean_eauto. + rewrite (@InfA_alt _ eqke); auto with map; try (clean_eauto; fail). + intros. + rewrite filter_InA in H1; auto with map; destruct H1. + rewrite leb_1 in H2. + destruct y; unfold O.ltk in *; simpl in *. + rewrite <- elements_mapsto_iff in H1. + assert (~E.eq x t0). + contradict H. + exists e0; apply MapsTo_1 with t0; auto. + ME.order. + apply (@filter_sort _ eqke); auto with map; clean_eauto. + intros. + rewrite filter_InA in H1; auto with map; destruct H1. + rewrite gtb_1 in H3. + destruct y; destruct x0; unfold O.ltk in *; simpl in *. + inversion_clear H2. + red in H4; simpl in *; destruct H4. + ME.order. + rewrite filter_InA in H4; auto with map; destruct H4. + rewrite leb_1 in H4. + unfold O.ltk in *; simpl in *; ME.order. + red; intros a; destruct a. + rewrite InA_app_iff; rewrite InA_cons. + do 2 (rewrite filter_InA; auto with map). + do 2 rewrite <- elements_mapsto_iff. + rewrite leb_1; rewrite gtb_1. + rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. + rewrite add_mapsto_iff. + unfold O.eqke, O.ltk; simpl. + destruct (E.compare t0 x); intuition. + right; split; auto; ME.order. + ME.order. + elim H. + exists e0; apply MapsTo_1 with t0; auto. + right; right; split; auto; ME.order. + ME.order. + right; split; auto; ME.order. + Qed. + + Lemma elements_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> + eqlistA eqke (elements m') (elements m ++ (x,e)::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with map. + apply (@SortA_app _ eqke); auto with map. + intros. + inversion_clear H2. + destruct x0; destruct y. + rewrite <- elements_mapsto_iff in H1. + unfold O.eqke, O.ltk in *; simpl in *; destruct H3. + apply ME.lt_eq with x; auto. + apply H; firstorder. + inversion H3. + red; intros a; destruct a. + rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. + do 2 rewrite <- elements_mapsto_iff. + rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. + rewrite add_mapsto_iff; unfold O.eqke; simpl. + intuition. + destruct (ME.eq_dec x t0); auto. + elimtype False. + assert (In t0 m). + exists e0; auto. + generalize (H t0 H1). + ME.order. + Qed. + + Lemma elements_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> + eqlistA eqke (elements m') ((x,e)::elements m). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with map. + change (sort ltk (((x,e)::nil) ++ elements m)). + apply (@SortA_app _ eqke); auto with map. + intros. + inversion_clear H1. + destruct y; destruct x0. + rewrite <- elements_mapsto_iff in H2. + unfold O.eqke, O.ltk in *; simpl in *; destruct H3. + apply ME.eq_lt with x; auto. + apply H; firstorder. + inversion H3. + red; intros a; destruct a. + rewrite InA_cons. + do 2 rewrite <- elements_mapsto_iff. + rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. + rewrite add_mapsto_iff; unfold O.eqke; simpl. + intuition. + destruct (ME.eq_dec x t0); auto. + elimtype False. + assert (In t0 m). + exists e0; auto. + generalize (H t0 H1). + ME.order. + Qed. + + Lemma elements_Equal_eqlistA : forall (m m': t elt), + Equal m m' -> eqlistA eqke (elements m) (elements m'). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with map. + red; intros. + destruct x; do 2 rewrite <- elements_mapsto_iff. + do 2 rewrite find_mapsto_iff; rewrite H; split; auto. + Qed. + + End Elements. + + Section Min_Max_Elt. + + (** We emulate two [max_elt] and [min_elt] functions. *) + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None + | (x,e)::nil => Some (x,e) + | (x,e)::l => max_elt_aux l + end. + Definition max_elt m := max_elt_aux (elements m). + + Lemma max_elt_Above : + forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). + Proof. + red; intros. + rewrite remove_in_iff in H0. + destruct H0. + rewrite elements_in_iff in H1. + destruct H1. + unfold max_elt in *. + generalize (elements_3 m). + revert x e H y x0 H0 H1. + induction (elements m). + simpl; intros; try discriminate. + intros. + destruct a; destruct l; simpl in *. + injection H; clear H; intros; subst. + inversion_clear H1. + red in H; simpl in *; intuition. + elim H0; eauto. + inversion H. + change (max_elt_aux (p::l) = Some (x,e)) in H. + generalize (IHl x e H); clear IHl; intros IHl. + inversion_clear H1; [ | inversion_clear H2; eauto ]. + red in H3; simpl in H3; destruct H3. + destruct p as (p1,p2). + destruct (ME.eq_dec p1 x). + apply ME.lt_eq with p1; auto. + inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + apply E.lt_trans with p1; auto. + inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + eapply IHl; eauto. + econstructor; eauto. + red; eauto. + inversion H2; auto. + Qed. + + Lemma max_elt_MapsTo : + forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold max_elt in *. + rewrite elements_mapsto_iff. + induction (elements m). + simpl; try discriminate. + destruct a; destruct l; simpl in *. + injection H; intros; subst; constructor; red; auto. + constructor 2; auto. + Qed. + + Lemma max_elt_Empty : + forall m, max_elt m = None -> Empty m. + Proof. + intros. + unfold max_elt in *. + rewrite elements_Empty. + induction (elements m); auto. + destruct a; destruct l; simpl in *; try discriminate. + assert (H':=IHl H); discriminate. + Qed. + + Definition min_elt m : option (key*elt) := match elements m with + | nil => None + | (x,e)::_ => Some (x,e) + end. + + Lemma min_elt_Below : + forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). + Proof. + unfold min_elt, Below; intros. + rewrite remove_in_iff in H0; destruct H0. + rewrite elements_in_iff in H1. + destruct H1. + generalize (elements_3 m). + destruct (elements m). + try discriminate. + destruct p; injection H; intros; subst. + inversion_clear H1. + red in H2; destruct H2; simpl in *; ME.order. + inversion_clear H4. + rewrite (@InfA_alt _ eqke) in H3; eauto. + apply (H3 (y,x0)); auto. + unfold lt_key; simpl; intuition; eauto. + intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. + intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. + Qed. + + Lemma min_elt_MapsTo : + forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold min_elt in *. + rewrite elements_mapsto_iff. + destruct (elements m). + simpl; try discriminate. + destruct p; simpl in *. + injection H; intros; subst; constructor; red; auto. + Qed. + + Lemma min_elt_Empty : + forall m, min_elt m = None -> Empty m. + Proof. + intros. + unfold min_elt in *. + rewrite elements_Empty. + destruct (elements m); auto. + destruct p; simpl in *; discriminate. + Qed. + + End Min_Max_Elt. + + Section Induction_Principles. + + Lemma map_induction_max : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + apply X; apply cardinal_inv_1; auto. + + case_eq (max_elt m); intros. + destruct p. + assert (Add k e (remove k m) m). + red; intros. + rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. + apply find_1; apply MapsTo_1 with k; auto. + apply max_elt_MapsTo; auto. + apply X0 with (remove k m) k e; auto with map. + apply IHn. + assert (S n = S (cardinal (remove k m))). + rewrite Heqn. + eapply cardinal_2; eauto with map. + inversion H1; auto. + eapply max_elt_Above; eauto. + + apply X; apply max_elt_Empty; auto. + Qed. + + Lemma map_induction_min : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + apply X; apply cardinal_inv_1; auto. + + case_eq (min_elt m); intros. + destruct p. + assert (Add k e (remove k m) m). + red; intros. + rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto. + apply find_1; apply MapsTo_1 with k; auto. + apply min_elt_MapsTo; auto. + apply X0 with (remove k m) k e; auto. + apply IHn. + assert (S n = S (cardinal (remove k m))). + rewrite Heqn. + eapply cardinal_2; eauto with map. + inversion H1; auto. + eapply min_elt_Below; eauto. + + apply X; apply min_elt_Empty; auto. + Qed. + + End Induction_Principles. + + Section Fold_properties. + + (** The following lemma has already been proved on Weak Maps, + but with one additionnal hypothesis (some [transpose] fact). *) + + Lemma fold_Equal : forall s1 s2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + Equal s1 s2 -> + eqA (fold f s1 i) (fold f s2 i). + Proof. + intros. + do 2 rewrite fold_1. + do 2 rewrite <- fold_left_rev_right. + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply eqlistA_rev. + apply elements_Equal_eqlistA; auto. + Qed. + + Lemma fold_Add : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + transpose eqA (fun y =>f (fst y) (snd y)) -> + ~In x s1 -> Add x e s1 s2 -> + eqA (fold f s2 i) (f x e (fold f s1 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 *. + change (f x e (fold_right f' i (rev (elements s1)))) + with (f' (x,e) (fold_right f' i (rev (elements s1)))). + trans_st (fold_right f' i + (rev (elements_lt (x, e) s1 ++ (x,e) :: elements_ge (x, e) s1))). + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply eqlistA_rev. + apply elements_Add; auto. + rewrite distr_rev; simpl. + rewrite app_ass; simpl. + rewrite (elements_split (x,e) s1). + rewrite distr_rev; simpl. + apply fold_right_commutes with (eqA:=eqke) (eqB:=eqA); auto. + Qed. + + Lemma fold_Add_Above : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + Above x s1 -> Add x e s1 s2 -> + eqA (fold f s2 i) (f x e (fold f s1 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 *. + trans_st (fold_right f' i (rev (elements s1 ++ (x,e)::nil))). + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply eqlistA_rev. + apply elements_Add_Above; auto. + rewrite distr_rev; simpl. + refl_st. + Qed. + + Lemma fold_Add_Below : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) + (f:key->elt->A->A)(i:A), + compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> + Below x s1 -> Add x e s1 s2 -> + eqA (fold f s2 i) (fold f s1 (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 *. + trans_st (fold_right f' i (rev (((x,e)::nil)++elements s1))). + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply eqlistA_rev. + simpl; apply elements_Add_Below; auto. + rewrite distr_rev; simpl. + rewrite fold_right_app. + refl_st. + Qed. + + End Fold_properties. + + End Elt. + +End OrdProperties. + + + + + diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v new file mode 100644 index 00000000..57cbbcc4 --- /dev/null +++ b/theories/FSets/FMapFullAVL.v @@ -0,0 +1,823 @@ + +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Finite map library. *) + +(* $Id: FMapFullAVL.v 10748 2008-04-03 18:28:26Z letouzey $ *) + +(** * FMapFullAVL + + This file contains some complements to [FMapAVL]. + + - Functor [AvlProofs] proves that trees of [FMapAVL] are not only + binary search trees, but moreover well-balanced ones. This is done + by proving that all operations preserve the balancing. + + - We then pack the previous elements in a [IntMake] functor + similar to the one of [FMapAVL], but richer. + + - In final [IntMake_ord] functor, the [compare] function is + different from the one in [FMapAVL]: this non-structural + version is closer to the original Ocaml code. + +*) + +Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL. + +Set Implicit Arguments. +Unset Strict Implicit. + +Module AvlProofs (Import I:Int)(X: OrderedType). +Module Import Raw := Raw I X. +Module Import II:=MoreInt(I). +Import Raw.Proofs. +Open Local Scope pair_scope. +Open Local Scope Int_scope. + +Section Elt. +Variable elt : Type. +Implicit Types m r : t elt. + +(** * AVL trees *) + +(** [avl s] : [s] is a properly balanced AVL tree, + i.e. for any node the heights of the two children + differ by at most 2 *) + +Inductive avl : t elt -> Prop := + | RBLeaf : avl (Leaf _) + | RBNode : forall x e l r h, + avl l -> + avl r -> + -(2) <= height l - height r <= 2 -> + h = max (height l) (height r) + 1 -> + avl (Node l x e r h). + + +(** * Automation and dedicated tactics about [avl]. *) + +Hint Constructors avl. + +Lemma height_non_negative : forall (s : t elt), avl s -> + height s >= 0. +Proof. + induction s; simpl; intros; auto with zarith. + inv avl; intuition; omega_max. +Qed. + +Ltac avl_nn_hyp H := + let nz := fresh "nz" in assert (nz := height_non_negative H). + +Ltac avl_nn h := + let t := type of h in + match type of t with + | Prop => avl_nn_hyp h + | _ => match goal with H : avl h |- _ => avl_nn_hyp H end + end. + +(* Repeat the previous tactic. + Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) + +Ltac avl_nns := + match goal with + | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns + | _ => idtac + end. + + +(** * Basic results about [avl], [height] *) + +Lemma avl_node : forall x e l r, avl l -> avl r -> + -(2) <= height l - height r <= 2 -> + avl (Node l x e r (max (height l) (height r) + 1)). +Proof. + intros; auto. +Qed. +Hint Resolve avl_node. + +(** Results about [height] *) + +Lemma height_0 : forall l, avl l -> height l = 0 -> + l = Leaf _. +Proof. + destruct 1; intuition; simpl in *. + avl_nns; simpl in *; elimtype False; omega_max. +Qed. + + +(** * Empty map *) + +Lemma empty_avl : avl (empty elt). +Proof. + unfold empty; auto. +Qed. + + +(** * Helper functions *) + +Lemma create_avl : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + avl (create l x e r). +Proof. + unfold create; auto. +Qed. + +Lemma create_height : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + height (create l x e r) = max (height l) (height r) + 1. +Proof. + unfold create; intros; auto. +Qed. + +Lemma bal_avl : forall l x e r, avl l -> avl r -> + -(3) <= height l - height r <= 3 -> avl (bal l x e r). +Proof. + intros l x e r; functional induction (bal l x e r); intros; clearf; + inv avl; simpl in *; + match goal with |- avl (assert_false _ _ _ _) => avl_nns + | _ => repeat apply create_avl; simpl in *; auto + end; omega_max. +Qed. + +Lemma bal_height_1 : forall l x e r, avl l -> avl r -> + -(3) <= height l - height r <= 3 -> + 0 <= height (bal l x e r) - max (height l) (height r) <= 1. +Proof. + intros l x e r; functional induction (bal l x e r); intros; clearf; + inv avl; avl_nns; simpl in *; omega_max. +Qed. + +Lemma bal_height_2 : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + height (bal l x e r) == max (height l) (height r) +1. +Proof. + intros l x e r; functional induction (bal l x e r); intros; clearf; + inv avl; avl_nns; simpl in *; omega_max. +Qed. + +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => + generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); + omega_max + end. + +(** * Insertion *) + +Lemma add_avl_1 : forall m x e, avl m -> + avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. +Proof. + intros m x e; functional induction (add x e m); intros; inv avl; simpl in *. + intuition; try constructor; simpl; auto; try omega_max. + (* LT *) + destruct IHt; auto. + split. + apply bal_avl; auto; omega_max. + omega_bal. + (* EQ *) + intuition; omega_max. + (* GT *) + destruct IHt; auto. + split. + apply bal_avl; auto; omega_max. + omega_bal. +Qed. + +Lemma add_avl : forall m x e, avl m -> avl (add x e m). +Proof. + intros; generalize (add_avl_1 x e H); intuition. +Qed. +Hint Resolve add_avl. + +(** * Extraction of minimum binding *) + +Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1 /\ + 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. +Proof. + intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. + inv avl; simpl in *; split; auto. + avl_nns; omega_max. + inversion_clear H. + rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. + split; simpl in *. + apply bal_avl; auto; omega_max. + omega_bal. +Qed. + +Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1. +Proof. + intros; generalize (remove_min_avl_1 H); intuition. +Qed. + +(** * Merging two trees *) + +Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> + -(2) <= height m1 - height m2 <= 2 -> + avl (merge m1 m2) /\ + 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. +Proof. + intros m1 m2; functional induction (merge m1 m2); intros; + try factornode _x _x0 _x1 _x2 _x3 as m1. + simpl; split; auto; avl_nns; omega_max. + simpl; split; auto; avl_nns; omega_max. + generalize (remove_min_avl_1 H0). + rewrite e1; destruct 1. + split. + apply bal_avl; auto. + omega_max. + omega_bal. +Qed. + +Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> + -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). +Proof. + intros; generalize (merge_avl_1 H H0 H1); intuition. +Qed. + + +(** * Deletion *) + +Lemma remove_avl_1 : forall m x, avl m -> + avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. +Proof. + intros m x; functional induction (remove x m); intros. + split; auto; omega_max. + (* LT *) + inv avl. + destruct (IHt H0). + split. + apply bal_avl; auto. + omega_max. + omega_bal. + (* EQ *) + inv avl. + generalize (merge_avl_1 H0 H1 H2). + intuition omega_max. + (* GT *) + inv avl. + destruct (IHt H1). + split. + apply bal_avl; auto. + omega_max. + omega_bal. +Qed. + +Lemma remove_avl : forall m x, avl m -> avl (remove x m). +Proof. + intros; generalize (remove_avl_1 x H); intuition. +Qed. +Hint Resolve remove_avl. + + +(** * Join *) + +Lemma join_avl_1 : forall l x d r, avl l -> avl r -> + avl (join l x d r) /\ + 0<= height (join l x d r) - max (height l) (height r) <= 1. +Proof. + join_tac. + + split; simpl; auto. + destruct (add_avl_1 x d H0). + avl_nns; omega_max. + set (l:=Node ll lx ld lr lh) in *. + split; auto. + destruct (add_avl_1 x d H). + simpl (height (Leaf elt)). + avl_nns; omega_max. + + inversion_clear H. + assert (height (Node rl rx rd rr rh) = rh); auto. + set (r := Node rl rx rd rr rh) in *; clearbody r. + destruct (Hlr x d r H2 H0); clear Hrl Hlr. + set (j := join lr x d r) in *; clearbody j. + simpl. + assert (-(3) <= height ll - height j <= 3) by omega_max. + split. + apply bal_avl; auto. + omega_bal. + + inversion_clear H0. + assert (height (Node ll lx ld lr lh) = lh); auto. + set (l := Node ll lx ld lr lh) in *; clearbody l. + destruct (Hrl H H1); clear Hrl Hlr. + set (j := join l x d rl) in *; clearbody j. + simpl. + assert (-(3) <= height j - height rr <= 3) by omega_max. + split. + apply bal_avl; auto. + omega_bal. + + clear Hrl Hlr. + assert (height (Node ll lx ld lr lh) = lh); auto. + assert (height (Node rl rx rd rr rh) = rh); auto. + set (l := Node ll lx ld lr lh) in *; clearbody l. + set (r := Node rl rx rd rr rh) in *; clearbody r. + assert (-(2) <= height l - height r <= 2) by omega_max. + split. + apply create_avl; auto. + rewrite create_height; auto; omega_max. +Qed. + +Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). +Proof. + intros; destruct (join_avl_1 x d H H0); auto. +Qed. +Hint Resolve join_avl. + +(** concat *) + +Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2). +Proof. + intros m1 m2; functional induction (concat m1 m2); auto. + intros; apply join_avl; auto. + generalize (remove_min_avl H0); rewrite e1; simpl; auto. +Qed. +Hint Resolve concat_avl. + +(** split *) + +Lemma split_avl : forall m x, avl m -> + avl (split x m)#l /\ avl (split x m)#r. +Proof. + intros m x; functional induction (split x m); simpl; auto. + rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. + simpl; inversion_clear 1; auto. + rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. +Qed. + +End Elt. +Hint Constructors avl. + +Section Map. +Variable elt elt' : Type. +Variable f : elt -> elt'. + +Lemma map_height : forall m, height (map f m) = height m. +Proof. +destruct m; simpl; auto. +Qed. + +Lemma map_avl : forall m, avl m -> avl (map f m). +Proof. +induction m; simpl; auto. +inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto. +Qed. + +End Map. + +Section Mapi. +Variable elt elt' : Type. +Variable f : key -> elt -> elt'. + +Lemma mapi_height : forall m, height (mapi f m) = height m. +Proof. +destruct m; simpl; auto. +Qed. + +Lemma mapi_avl : forall m, avl m -> avl (mapi f m). +Proof. +induction m; simpl; auto. +inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto. +Qed. + +End Mapi. + +Section Map_option. +Variable elt elt' : Type. +Variable f : key -> elt -> option elt'. + +Lemma map_option_avl : forall m, avl m -> avl (map_option f m). +Proof. +induction m; simpl; auto; intros. +inv avl; destruct (f k e); auto using join_avl, concat_avl. +Qed. + +End Map_option. + +Section Map2_opt. +Variable elt elt' elt'' : Type. +Variable f : key -> elt -> option elt' -> option elt''. +Variable mapl : t elt -> t elt''. +Variable mapr : t elt' -> t elt''. +Hypothesis mapl_avl : forall m, avl m -> avl (mapl m). +Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). + +Notation map2_opt := (map2_opt f mapl mapr). + +Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> + avl (map2_opt m1 m2). +Proof. +intros m1 m2; functional induction (map2_opt m1 m2); auto; +factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; +destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; +auto using join_avl, concat_avl. +Qed. + +End Map2_opt. + +Section Map2. +Variable elt elt' elt'' : Type. +Variable f : option elt -> option elt' -> option elt''. + +Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2). +Proof. +unfold map2; auto using map2_opt_avl, map_option_avl. +Qed. + +End Map2. +End AvlProofs. + +(** * Encapsulation + + We can implement [S] with balanced binary search trees. + When compared to [FMapAVL], we maintain here two invariants + (bst and avl) instead of only bst, which is enough for fulfilling + the FMap interface. +*) + +Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. + + Module E := X. + Module Import AvlProofs := AvlProofs I X. + Import Raw. + Import Raw.Proofs. + + Record bbst (elt:Type) := + Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. + + Definition t := bbst. + Definition key := E.t. + + Section Elt. + Variable elt elt' elt'': Type. + + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). + Definition is_empty m : bool := is_empty m.(this). + Definition add x e m : t elt := + Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). + Definition remove x m : t elt := + Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). + Definition mem x m : bool := mem x m.(this). + Definition find x m : option elt := find x m.(this). + Definition map f m : t elt' := + Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). + Definition mapi (f:key->elt->elt') m : t elt' := + Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). + Definition map2 f m (m':t elt') : t elt'' := + Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). + Definition elements m : list (key*elt) := elements m.(this). + Definition cardinal m := cardinal m.(this). + Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i. + Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this). + + Definition MapsTo x e m : Prop := MapsTo x e m.(this). + Definition In x m : Prop := In0 x m.(this). + Definition Empty m : Prop := Empty m.(this). + + Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. + Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. + Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. + + Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. + Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. + + Lemma mem_1 : forall m x, In x m -> mem x m = true. + Proof. + unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. + apply m.(is_bst). + Qed. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. + Proof. + unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. + Qed. + + Lemma empty_1 : Empty empty. + Proof. exact (@empty_1 elt). Qed. + + Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. + Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed. + Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. + Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed. + + Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m). + Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed. + Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed. + Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed. + + Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m). + Proof. + unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto. + apply m.(is_bst). + Qed. + Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed. + Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. + Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. + + + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. + Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. + Proof. intros m; exact (@find_2 elt m.(this)). Qed. + + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. + + Lemma elements_1 : forall m x e, + MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Proof. + intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. + Qed. + + Lemma elements_2 : forall m x e, + InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Proof. + intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. + Qed. + + Lemma elements_3 : forall m, sort lt_key (elements m). + Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. + + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp := Equiv (Cmp cmp). + + Lemma Equivb_Equivb : forall cmp m m', + Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. + Proof. + intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + Qed. + + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + intros; simpl in *; rewrite equal_Equivb; auto. + Qed. + + Lemma equal_2 : forall m m' cmp, + equal cmp m m' = true -> Equivb cmp m m'. + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + intros; simpl in *; rewrite <-equal_Equivb; auto. + Qed. + + End Elt. + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). + Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. + + Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. + Proof. + intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. + apply map_2; auto. + Qed. + + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) + (f:key->elt->elt'), MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). + Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) + (f:key->elt->elt'), In x (mapi f m) -> In x m. + Proof. + intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto. + Qed. + + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + unfold find, map2, In; intros elt elt' elt'' m m' x f. + do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. + apply m.(is_bst). + apply m'.(is_bst). + Qed. + + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x (map2 f m m') -> In x m \/ In x m'. + Proof. + unfold In, map2; intros elt elt' elt'' m m' x f. + do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. + apply m.(is_bst). + apply m'.(is_bst). + Qed. + +End IntMake. + + +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D + with Module MapS.E := X. + + Module Data := D. + Module Import MapS := IntMake(I)(X). + Import AvlProofs. + Import Raw.Proofs. + Module Import MD := OrderedTypeFacts(D). + Module LO := FMapList.Make_ord(X)(D). + + Definition t := MapS.t D.t. + + Definition cmp e e' := + match D.compare e e' with EQ _ => true | _ => false end. + + Definition elements (m:t) := + LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). + + (** * As comparison function, we propose here a non-structural + version faithful to the code of Ocaml's Map library, instead of + the structural version of FMapAVL *) + + Fixpoint cardinal_e (e:Raw.enumeration D.t) := + match e with + | Raw.End => 0%nat + | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) + end. + + Lemma cons_cardinal_e : forall m e, + cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. + Proof. + induction m; simpl; intros; auto. + rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. + Qed. + + Definition cardinal_e_2 ee := + (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. + + Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) + { measure cardinal_e_2 ee } : comparison := + match ee with + | (Raw.End, Raw.End) => Eq + | (Raw.End, Raw.More _ _ _ _) => Lt + | (Raw.More _ _ _ _, Raw.End) => Gt + | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => + match X.compare x1 x2 with + | EQ _ => match D.compare d1 d2 with + | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) + | LT _ => Lt + | GT _ => Gt + end + | LT _ => Lt + | GT _ => Gt + end + end. + Proof. + intros; unfold cardinal_e_2; simpl; + abstract (do 2 rewrite cons_cardinal_e; romega with * ). + Defined. + + Definition Cmp c := + match c with + | Eq => LO.eq_list + | Lt => LO.lt_list + | Gt => (fun l1 l2 => LO.lt_list l2 l1) + end. + + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> D.eq d1 d2 -> + Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). + Proof. + destruct c; simpl; intros; MX.elim_comp; auto. + Qed. + Hint Resolve cons_Cmp. + + Lemma compare_aux_Cmp : forall e, + Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). + Proof. + intros e; functional induction (compare_aux e); simpl in *; + auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto. + rewrite 2 cons_1 in IHc; auto. + Qed. + + Lemma compare_Cmp : forall m1 m2, + Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) + (Raw.elements m1) (Raw.elements m2). + Proof. + intros. + assert (H1:=cons_1 m1 (Raw.End _)). + assert (H2:=cons_1 m2 (Raw.End _)). + simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. + apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), + Raw.cons m2 (Raw.End _))). + Qed. + + Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2). + Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2). + + Definition compare (s s':t) : Compare lt eq s s'. + Proof. + intros (s,b,a) (s',b',a'). + generalize (compare_Cmp s s'). + destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. + Defined. + + + (* Proofs about [eq] and [lt] *) + + Definition selements (m1 : t) := + LO.MapS.Build_slist (elements_sort m1.(is_bst)). + + Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). + Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2). + + Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. + Proof. + unfold eq, seq, selements, elements, LO.eq; intuition. + Qed. + + Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. + Proof. + unfold lt, slt, selements, elements, LO.lt; intuition. + Qed. + + Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'. + Proof. + intros m m'. + rewrite eq_seq; unfold seq. + rewrite Equivb_Equivb. + rewrite Equivb_elements. + auto using LO.eq_1. + Qed. + + Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'. + Proof. + intros m m'. + rewrite eq_seq; unfold seq. + rewrite Equivb_Equivb. + rewrite Equivb_elements. + intros. + generalize (LO.eq_2 H). + auto. + Qed. + + Lemma eq_refl : forall m : t, eq m m. + Proof. + intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. + Qed. + + Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. + Proof. + intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto. + Qed. + + Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. + Proof. + intros m1 m2 M3; rewrite 3 eq_seq; unfold seq. + intros; eapply LO.eq_trans; eauto. + Qed. + + Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. + Proof. + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros; eapply LO.lt_trans; eauto. + Qed. + + Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. + Proof. + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros; apply LO.lt_not_eq; auto. + Qed. + +End IntMake_ord. + +(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) + +Module Make (X: OrderedType) <: S with Module E := X + :=IntMake(Z_as_Int)(X). + +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D + with Module MapS.E := X + :=IntMake_ord(Z_as_Int)(X)(D). + diff --git a/theories/FSets/FMapIntMap.v b/theories/FSets/FMapIntMap.v deleted file mode 100644 index c7681bd4..00000000 --- a/theories/FSets/FMapIntMap.v +++ /dev/null @@ -1,622 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) - -(* $Id: FMapIntMap.v 8876 2006-05-30 13:43:15Z letouzey $ *) - -Require Import Bool. -Require Import NArith Ndigits Ndec Nnat. -Require Import Allmaps. -Require Import OrderedType. -Require Import OrderedTypeEx. -Require Import FMapInterface FMapList. - - -Set Implicit Arguments. - -(** * An implementation of [FMapInterface.S] based on [IntMap] *) - -(** Keys are of type [N]. The main functions are directly taken from - [IntMap]. Since they have no exact counterpart in [IntMap], functions - [fold], [map2] and [equal] are for now obtained by translation - to sorted lists. *) - -(** [N] is an ordered type, using not the usual order on numbers, - but lexicographic ordering on bits (lower bit considered first). *) - -Module NUsualOrderedType <: UsualOrderedType. - Definition t:=N. - Definition eq:=@eq N. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt p q:= Nless p q = true. - - Definition lt_trans := Nless_trans. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite H0 in H. - red in H. - rewrite Nless_not_refl in H; discriminate. - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros x y. - destruct (Nless_total x y) as [[H|H]|H]. - apply LT; unfold lt; auto. - apply GT; unfold lt; auto. - apply EQ; auto. - Qed. - -End NUsualOrderedType. - - -(** The module of maps over [N] keys based on [IntMap] *) - -Module MapIntMap <: S with Module E:=NUsualOrderedType. - - Module E:=NUsualOrderedType. - Module ME:=OrderedTypeFacts(E). - Module PE:=KeyOrderedType(E). - - Definition key := N. - - Definition t := Map. - - Section A. - Variable A:Set. - - Definition empty : t A := M0 A. - - Definition is_empty (m : t A) : bool := - MapEmptyp _ (MapCanonicalize _ m). - - Definition find (x:key)(m: t A) : option A := MapGet _ m x. - - Definition mem (x:key)(m: t A) : bool := - match find x m with - | Some _ => true - | None => false - end. - - Definition add (x:key)(v:A)(m:t A) : t A := MapPut _ m x v. - - Definition remove (x:key)(m:t A) : t A := MapRemove _ m x. - - Definition elements (m : t A) : list (N*A) := alist_of_Map _ m. - - Definition MapsTo (x:key)(v:A)(m:t A) := find x m = Some v. - - Definition In (x:key)(m:t A) := exists e:A, MapsTo x e m. - - Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m. - - Definition eq_key (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key (p p':key*A) := E.lt (fst p) (fst p'). - - Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None. - Proof. - unfold Empty, MapsTo. - intuition. - generalize (H a). - destruct (find a m); intuition. - elim (H0 a0); auto. - rewrite H in H0; discriminate. - Qed. - - Section Spec. - Variable m m' m'' : t A. - Variable x y z : key. - Variable e e' : A. - - Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - Proof. intros; rewrite <- H; auto. Qed. - - Lemma find_1 : MapsTo x e m -> find x m = Some e. - Proof. unfold MapsTo; auto. Qed. - - Lemma find_2 : find x m = Some e -> MapsTo x e m. - Proof. red; auto. Qed. - - Lemma empty_1 : Empty empty. - Proof. - rewrite Empty_alt; intros; unfold empty, find; simpl; auto. - Qed. - - Lemma is_empty_1 : Empty m -> is_empty m = true. - Proof. - unfold Empty, is_empty, find; intros. - cut (MapCanonicalize _ m = M0 _). - intros; rewrite H0; simpl; auto. - apply mapcanon_unique. - apply mapcanon_exists_2. - constructor. - red; red; simpl; intros. - rewrite <- (mapcanon_exists_1 _ m). - unfold MapsTo, find in *. - generalize (H a). - destruct (MapGet _ m a); auto. - intros; generalize (H0 a0); destruct 1; auto. - Qed. - - Lemma is_empty_2 : is_empty m = true -> Empty m. - Proof. - unfold Empty, is_empty, MapsTo, find; intros. - generalize (MapEmptyp_complete _ _ H); clear H; intros. - rewrite (mapcanon_exists_1 _ m). - rewrite H; simpl; auto. - discriminate. - Qed. - - Lemma mem_1 : In x m -> mem x m = true. - Proof. - unfold In, MapsTo, mem. - destruct (find x m); auto. - destruct 1; discriminate. - Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. - Proof. - unfold In, MapsTo, mem. - intros. - destruct (find x0 m0); auto; try discriminate. - exists a; auto. - Qed. - - Lemma add_1 : E.eq x y -> MapsTo y e (add x e m). - Proof. - unfold MapsTo, find, add. - intro H; rewrite H; clear H. - rewrite MapPut_semantics. - rewrite Neqb_correct; auto. - Qed. - - Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Proof. - unfold MapsTo, find, add. - intros. - rewrite MapPut_semantics. - rewrite H0. - generalize (Neqb_complete x y). - destruct (Neqb x y); auto. - intros. - elim H; auto. - apply H1; auto. - Qed. - - Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - Proof. - unfold MapsTo, find, add. - rewrite MapPut_semantics. - intro H. - generalize (Neqb_complete x y). - destruct (Neqb x y); auto. - intros; elim H; auto. - apply H0; auto. - Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. - unfold In, MapsTo, find, remove. - rewrite MapRemove_semantics. - intro H. - rewrite H; rewrite Neqb_correct. - red; destruct 1; discriminate. - Qed. - - Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Proof. - unfold MapsTo, find, remove. - rewrite MapRemove_semantics. - intros. - rewrite H0. - generalize (Neqb_complete x y). - destruct (Neqb x y); auto. - intros; elim H; apply H1; auto. - Qed. - - Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. - unfold MapsTo, find, remove. - rewrite MapRemove_semantics. - destruct (Neqb x y); intros; auto. - discriminate. - Qed. - - Lemma alist_sorted_sort : forall l, alist_sorted A l=true -> sort lt_key l. - Proof. - induction l. - auto. - simpl. - destruct a. - destruct l. - auto. - destruct p. - intros; destruct (andb_prop _ _ H); auto. - Qed. - - Lemma elements_3 : sort lt_key (elements m). - Proof. - unfold elements. - apply alist_sorted_sort. - apply alist_of_Map_sorts. - Qed. - - Lemma elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Proof. - unfold MapsTo, find, elements. - rewrite InA_alt. - intro H. - exists (x,e). - split. - red; simpl; unfold E.eq; auto. - rewrite alist_of_Map_semantics in H. - generalize H. - set (l:=alist_of_Map A m); clearbody l; clear. - induction l; simpl; auto. - intro; discriminate. - destruct a; simpl; auto. - generalize (Neqb_complete a x). - destruct (Neqb a x); auto. - left. - injection H0; auto. - intros; f_equal; auto. - Qed. - - Lemma elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Proof. - generalize elements_3. - unfold MapsTo, find, elements. - rewrite InA_alt. - intros H ((e0,a),(H0,H1)). - red in H0; simpl in H0; unfold E.eq in H0; destruct H0; subst. - rewrite alist_of_Map_semantics. - generalize H H1; clear H H1. - set (l:=alist_of_Map A m); clearbody l; clear. - induction l; simpl; auto. - intro; contradiction. - intros. - destruct a0; simpl. - inversion H1. - injection H0; intros; subst. - rewrite Neqb_correct; auto. - assert (InA eq_key (e0,a) l). - rewrite InA_alt. - exists (e0,a); split; auto. - red; simpl; auto; red; auto. - generalize (PE.Sort_In_cons_1 H H2). - unfold PE.ltk; simpl. - intros H3; generalize (E.lt_not_eq H3). - generalize (Neqb_complete a0 e0). - destruct (Neqb a0 e0); auto. - destruct 2. - apply H4; auto. - inversion H; auto. - Qed. - - Definition Equal cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - - (** unfortunately, the [MapFold] of [IntMap] isn't compatible with - the FMap interface. We use a naive version for now : *) - - Definition fold (B:Set)(f:key -> A -> B -> B)(m:t A)(i:B) : B := - fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - - Lemma fold_1 : - forall (B:Set) (i : B) (f : key -> A -> B -> B), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - Proof. auto. Qed. - - End Spec. - - Variable B : Set. - - Fixpoint mapi_aux (pf:N->N)(f : N -> A -> B)(m:t A) { struct m }: t B := - match m with - | M0 => M0 _ - | M1 x y => M1 _ x (f (pf x) y) - | M2 m0 m1 => M2 _ (mapi_aux (fun n => pf (Ndouble n)) f m0) - (mapi_aux (fun n => pf (Ndouble_plus_one n)) f m1) - end. - - Definition mapi := mapi_aux (fun n => n). - - Definition map (f:A->B) := mapi (fun _ => f). - - End A. - - Lemma mapi_aux_1 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f (pf y) e) (mapi_aux pf f m). - Proof. - unfold MapsTo; induction m; simpl; auto. - inversion 1. - - intros. - exists x; split; [red; auto|]. - generalize (Neqb_complete a x). - destruct (Neqb a x); try discriminate. - injection H; intros; subst; auto. - rewrite H1; auto. - - intros. - exists x; split; [red;auto|]. - destruct x; simpl in *. - destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')). - rewrite Hy in Hy'; simpl in Hy'; auto. - destruct p; simpl in *. - destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')). - rewrite Hy in Hy'; simpl in Hy'; auto. - destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')). - rewrite Hy in Hy'; simpl in Hy'; auto. - destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')). - rewrite Hy in Hy'; simpl in Hy'; auto. - Qed. - - Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Proof. - intros elt elt' m; exact (mapi_aux_1 (fun n => n)). - Qed. - - Lemma mapi_aux_2 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key) - (f:key->elt->elt'), In x (mapi_aux pf f m) -> In x m. - Proof. - unfold In, MapsTo. - induction m; simpl in *. - intros pf x f (e,He); inversion He. - intros pf x f (e,He). - exists a0. - destruct (Neqb a x); try discriminate; auto. - intros pf x f (e,He). - destruct x; [|destruct p]; eauto. - Qed. - - Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - Proof. - intros elt elt' m; exact (mapi_aux_2 m (fun n => n)). - Qed. - - Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Proof. - unfold map; intros. - destruct (@mapi_1 _ _ m x e (fun _ => f)) as (e',(_,H0)); auto. - Qed. - - Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - Proof. - unfold map; intros. - eapply mapi_2; eauto. - Qed. - - Module L := FMapList.Raw E. - - (** Not exactly pretty nor perfect, but should suffice as a first naive implem. - Anyway, map2 isn't in Ocaml... - *) - - Definition anti_elements (A:Set)(l:list (key*A)) := L.fold (@add _) l (empty _). - - Definition map2 (A B C:Set)(f:option A->option B -> option C)(m:t A)(m':t B) : t C := - anti_elements (L.map2 f (elements m) (elements m')). - - Lemma add_spec : forall (A:Set)(m:t A) x y e, - find x (add y e m) = if ME.eq_dec x y then Some e else find x m. - Proof. - intros. - destruct (ME.eq_dec x y). - apply find_1. - eapply MapsTo_1 with y; eauto. - red; auto. - apply add_1; auto. - red; auto. - case_eq (find x m); intros. - apply find_1. - apply add_2; unfold E.eq in *; auto. - case_eq (find x (add y e m)); auto; intros. - rewrite <- H; symmetry. - apply find_1; auto. - apply (@add_3 _ m y x a e); unfold E.eq in *; auto. - Qed. - - Lemma anti_elements_mapsto_aux : forall (A:Set)(l:list (key*A)) m k e, - NoDupA (eq_key (A:=A)) l -> - (forall x, L.PX.In x l -> In x m -> False) -> - (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m). - Proof. - induction l. - simpl; auto. - intuition. - inversion H2. - simpl; destruct a; intros. - rewrite IHl; clear IHl. - inversion H; auto. - intros. - inversion_clear H. - assert (~E.eq x k). - swap H3. - destruct H1. - apply InA_eqA with (x,x0); eauto. - unfold eq_key, E.eq; eauto. - unfold eq_key, E.eq; congruence. - apply (H0 x). - destruct H1; exists x0; auto. - revert H2. - unfold In. - intros (e',He'). - exists e'; apply (@add_3 _ m k x e' a); unfold E.eq; auto. - intuition. - red in H2. - rewrite add_spec in H2; auto. - destruct (ME.eq_dec k0 k). - inversion_clear H2; subst; auto. - right; apply find_2; auto. - inversion_clear H2; auto. - compute in H1; destruct H1. - subst; right; apply add_1; auto. - red; auto. - inversion_clear H. - destruct (ME.eq_dec k0 k). - unfold E.eq in *; subst. - destruct (H0 k); eauto. - red; eauto. - right; apply add_2; unfold E.eq in *; auto. - Qed. - - Lemma anti_elements_mapsto : forall (A:Set) l k e, NoDupA (eq_key (A:=A)) l -> - (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l). - Proof. - intros. - unfold anti_elements. - rewrite anti_elements_mapsto_aux; auto; unfold empty; auto. - inversion 2. - inversion H2. - intuition. - inversion H1. - Qed. - - Lemma find_anti_elements : forall (A:Set)(l: list (key*A)) x, sort (@lt_key _) l -> - find x (anti_elements l) = L.find x l. - Proof. - intros. - case_eq (L.find x l); intros. - apply find_1. - rewrite anti_elements_mapsto. - apply L.PX.Sort_NoDupA; auto. - apply L.find_2; auto. - case_eq (find x (anti_elements l)); auto; intros. - rewrite <- H0; symmetry. - apply L.find_1; auto. - rewrite <- anti_elements_mapsto. - apply L.PX.Sort_NoDupA; auto. - apply find_2; auto. - Qed. - - Lemma find_elements : forall (A:Set)(m: t A) x, - L.find x (elements m) = find x m. - Proof. - intros. - case_eq (find x m); intros. - apply L.find_1. - apply elements_3; auto. - red; apply elements_1. - apply find_2; auto. - case_eq (L.find x (elements m)); auto; intros. - rewrite <- H; symmetry. - apply find_1; auto. - apply elements_2. - apply L.find_2; auto. - Qed. - - Lemma elements_in : forall (A:Set)(s:t A) x, L.PX.In x (elements s) <-> In x s. - Proof. - intros. - unfold L.PX.In, In. - firstorder. - exists x0. - red; rewrite <- find_elements; auto. - apply L.find_1; auto. - apply elements_3. - exists x0. - apply L.find_2. - rewrite find_elements; auto. - Qed. - - Lemma map2_1 : forall (A B C:Set)(m: t A)(m': t B)(x:key) - (f:option A->option B ->option C), - In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). - Proof. - unfold map2; intros. - rewrite find_anti_elements; auto. - rewrite <- find_elements; auto. - rewrite <- find_elements; auto. - apply L.map2_1; auto. - apply elements_3; auto. - apply elements_3; auto. - do 2 rewrite elements_in; auto. - apply L.map2_sorted; auto. - apply elements_3; auto. - apply elements_3; auto. - Qed. - - Lemma map2_2 : forall (A B C: Set)(m: t A)(m': t B)(x:key) - (f:option A->option B ->option C), - In x (map2 f m m') -> In x m \/ In x m'. - Proof. - unfold map2; intros. - do 2 rewrite <- elements_in. - apply L.map2_2 with (f:=f); auto. - apply elements_3; auto. - apply elements_3; auto. - destruct H. - exists x0. - rewrite <- anti_elements_mapsto; auto. - apply L.PX.Sort_NoDupA; auto. - apply L.map2_sorted; auto. - apply elements_3; auto. - apply elements_3; auto. - Qed. - - (** same trick for [equal] *) - - Definition equal (A:Set)(cmp:A -> A -> bool)(m m' : t A) : bool := - L.equal cmp (elements m) (elements m'). - - Lemma equal_1 : - forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), - Equal cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal, Equal. - intros. - apply L.equal_1. - apply elements_3. - apply elements_3. - unfold L.Equal. - destruct H. - split; intros. - do 2 rewrite elements_in; auto. - apply (H0 k); - red; rewrite <- find_elements; apply L.find_1; auto; - apply elements_3. - Qed. - - Lemma equal_2 : - forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), - equal cmp m m' = true -> Equal cmp m m'. - Proof. - unfold equal, Equal. - intros. - destruct (L.equal_2 (elements_3 m) (elements_3 m') H); clear H. - split. - intros; do 2 rewrite <- elements_in; auto. - intros; apply (H1 k); - apply L.find_2; rewrite find_elements;auto. - Qed. - -End MapIntMap. - diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index dde74a0a..1e475887 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,42 +6,72 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *) +(* $Id: FMapInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) (** * Finite map library *) -(** This file proposes an interface for finite maps *) +(** This file proposes interfaces for finite maps *) -(* begin hide *) +Require Export Bool DecidableType OrderedType. Set Implicit Arguments. Unset Strict Implicit. -Require Import FSetInterface. -(* end hide *) - -(** When compared with Ocaml Map, this signature has been split in two: - - The first part [S] contains the usual operators (add, find, ...) - It only requires a ordered key type, the data type can be arbitrary. - The only function that asks more is [equal], whose first argument should - be an equality on data. - - Then, [Sord] extends [S] with a complete comparison function. For - that, the data type should have a decidable total ordering. + +(** When compared with Ocaml Map, this signature has been split in + several parts : + + - The first parts [WSfun] and [WS] propose signatures for weak + maps, which are maps with no ordering on the key type nor the + data type. [WSfun] and [WS] are almost identical, apart from the + fact that [WSfun] is expressed in a functorial way whereas [WS] + is self-contained. For obtaining an instance of such signatures, + a decidable equality on keys in enough (see for example + [FMapWeakList]). These signatures contain the usual operators + (add, find, ...). The only function that asks for more is + [equal], whose first argument should be a comparison on data. + + - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the + case where the key type is ordered. The main novelty is that + [elements] is required to produce sorted lists. + + - Finally, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering as well. + + If unsure, what you're looking for is probably [S]: apart from [Sord], + all other signatures are subsets of [S]. + + Some additional differences with Ocaml: + + - no [iter] function, useless since Coq is purely functional + - [option] types are used instead of [Not_found] exceptions + - more functions are provided: [elements] and [cardinal] and [map2] + *) -Module Type S. +Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. - Declare Module E : OrderedType. +(** ** Weak signature for maps + + No requirements for an ordering on keys nor elements, only decidability + of equality on keys. First, a functorial signature: *) + +Module Type WSfun (E : EqualityType). + + (** The module E of base objects is meant to be a [DecidableType] + (and used to be so). But requiring only an [EqualityType] here + allows subtyping between weak and ordered maps. *) Definition key := E.t. - Parameter t : Set -> Set. (** the abstract type of maps *) + Parameter t : Type -> Type. + (** the abstract type of maps *) Section Types. - Variable elt:Set. + Variable elt:Type. Parameter empty : t elt. - (** The empty map. *) + (** The empty map. *) Parameter is_empty : t elt -> bool. (** Test whether a map is empty or not. *) @@ -53,8 +83,7 @@ Module Type S. Parameter find : key -> t elt -> option elt. (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. - NB: in Coq, the exception mechanism becomes a option type. *) + or [None] if no such binding exists. *) Parameter remove : key -> t elt -> t elt. (** [remove x m] returns a map containing the same bindings as [m], @@ -64,45 +93,36 @@ Module Type S. (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) - (** Coq comment: [iter] is useless in a purely functional world *) - (** val iter : (key -> 'a -> unit) -> 'a t -> unit *) - (** iter f m applies f to all bindings in map m. f receives the key as - first argument, and the associated value as second argument. - The bindings are passed to f in increasing order with respect to the - ordering over the type of the keys. Only current bindings are - presented to f: bindings hidden by more recent bindings are not - passed to f. *) - - Variable elt' : Set. - Variable elt'': Set. + Variable elt' elt'' : Type. Parameter map : (elt -> elt') -> t elt -> t elt'. (** [map f m] returns a map with same domain as [m], where the associated value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. The bindings are passed to [f] in - increasing order with respect to the ordering over the type of the - keys. *) + application of [f] to [a]. Since Coq is purely functional, the order + in which the bindings are passed to [f] is irrelevant. *) Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [S.map], but the function receives as arguments both the + (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) - Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** Not present in Ocaml. - [map f m m'] creates a new map whose bindings belong to the ones of either - [m] or [m']. The presence and value for a key [k] is determined by [f e e'] - where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) + Parameter map2 : + (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. + (** [map2 f m m'] creates a new map whose bindings belong to the ones + of either [m] or [m']. The presence and value for a key [k] is + determined by [f e e'] where [e] and [e'] are the (optional) bindings + of [k] in [m] and [m']. *) Parameter elements : t elt -> list (key*elt). - (** Not present in Ocaml. - [elements m] returns an assoc list corresponding to the bindings of [m]. - Elements of this list are sorted with respect to their first components. - Useful to specify [fold] ... *) + (** [elements m] returns an assoc list corresponding to the bindings + of [m], in any order. *) - Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A. + Parameter cardinal : t elt -> nat. + (** [cardinal m] returns the number of bindings in [m]. *) + + Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1] ... [kN] are the keys of all bindings in [m] - (in increasing order), and [d1] ... [dN] are the associated data. *) + (in any order), and [d1] ... [dN] are the associated data. *) Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, @@ -127,8 +147,6 @@ Module Type S. Definition eq_key_elt (p p':key*elt) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). - (** Specification of [MapsTo] *) Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. @@ -162,61 +180,123 @@ Module Type S. MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Parameter elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Parameter elements_3 : sort lt_key (elements m). + (** When compared with ordered maps, here comes the only + property that is really weaker: *) + Parameter elements_3w : NoDupA eq_key (elements m). + + (** Specification of [cardinal] *) + Parameter cardinal_1 : cardinal m = length (elements m). (** Specification of [fold] *) Parameter fold_1 : - forall (A : Set) (i : A) (f : key -> elt -> A -> A), + forall (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. + + (** Equality of maps *) - Definition Equal cmp m m' := + (** Caveat: there are at least three distinct equality predicates on maps. + - The simpliest (and maybe most natural) way is to consider keys up to + their equivalence [E.eq], but elements up to Leibniz equality, in + the spirit of [eq_key_elt] above. This leads to predicate [Equal]. + - Unfortunately, this [Equal] predicate can't be used to describe + the [equal] function, since this function (for compatibility with + ocaml) expects a boolean comparison [cmp] that may identify more + elements than Leibniz. So logical specification of [equal] is done + via another predicate [Equivb] + - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], + it can be generalized in a [Equiv] expecting a more general + (possibly non-decidable) equality predicate on elements *) + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - Variable cmp : elt -> elt -> bool. + (** Specification of [equal] *) - (** Specification of [equal] *) - Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. - Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'. + Variable cmp : elt -> elt -> bool. - End Spec. - End Types. + Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. + Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. + + End Spec. + End Types. (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), + Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. (** Specification of [mapi] *) - Parameter mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) + Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) + Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. (** Specification of [map2] *) - Parameter map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). - Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - (* begin hide *) - Hint Immediate MapsTo_1 mem_2 is_empty_2. - - Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1 - remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. - (* end hide *) + Hint Immediate MapsTo_1 mem_2 is_empty_2 + map_2 mapi_2 add_3 remove_3 find_2 + : map. + Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 + remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 + : map. +End WSfun. + + +(** ** Static signature for Weak Maps + + Similar to [WSfun] but expressed in a self-contained way. *) + +Module Type WS. + Declare Module E : EqualityType. + Include Type WSfun E. +End WS. + + + +(** ** Maps on ordered keys, functorial signature *) + +Module Type Sfun (E : OrderedType). + Include Type WSfun E. + Section elt. + Variable elt:Type. + Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). + (* Additional specification of [elements] *) + Parameter elements_3 : forall m, sort lt_key (elements m). + (** Remark: since [fold] is specified via [elements], this stronger + specification of [elements] has an indirect impact on [fold], + which can now be proved to receive elements in increasing order. *) + End elt. +End Sfun. + + + +(** ** Maps on ordered keys, self-contained signature *) + +Module Type S. + Declare Module E : OrderedType. + Include Type Sfun E. End S. + +(** ** Maps with ordering both on keys and datas *) + Module Type Sord. - + Declare Module Data : OrderedType. Declare Module MapS : S. Import MapS. @@ -234,12 +314,11 @@ Module Type Sord. Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. - Parameter eq_1 : forall m m', Equal cmp m m' -> eq m m'. - Parameter eq_2 : forall m m', eq m m' -> Equal cmp m m'. + Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. + Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Parameter compare : forall m1 m2, Compare lt eq m1 m2. - (** Total ordering between maps. The first argument (in Coq: Data.compare) - is a total ordering used to compare data associated with equal keys - in the two maps. *) + (** Total ordering between maps. [Data.compare] is a total ordering + used to compare data associated with equal keys in the two maps. *) -End Sord.
\ No newline at end of file +End Sord. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 067f5a3e..23bf8196 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 9035 2006-07-09 15:42:09Z herbelin $ *) +(* $Id: FMapList.v 10616 2008-03-04 17:33:35Z letouzey $ *) (** * Finite map library *) @@ -14,7 +14,6 @@ [FMapInterface.S] using lists of pairs ordered (increasing) with respect to left projection. *) -Require Import FSetInterface. Require Import FMapInterface. Set Implicit Arguments. @@ -22,26 +21,14 @@ Unset Strict Implicit. Module Raw (X:OrderedType). -Module E := X. -Module MX := OrderedTypeFacts X. -Module PX := KeyOrderedType X. -Import MX. -Import PX. +Module Import MX := OrderedTypeFacts X. +Module Import PX := KeyOrderedType X. Definition key := X.t. -Definition t (elt:Set) := list (X.t * elt). +Definition t (elt:Type) := list (X.t * elt). Section Elt. -Variable elt : Set. - -(* Now in KeyOrderedType: -Definition eqk (p p':key*elt) := X.eq (fst p) (fst p'). -Definition eqke (p p':key*elt) := - X.eq (fst p) (fst p') /\ (snd p) = (snd p'). -Definition ltk (p p':key*elt) := X.lt (fst p) (fst p'). -Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). -Definition In k m := exists e:elt, MapsTo k e m. -*) +Variable elt : Type. Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). @@ -347,15 +334,22 @@ Proof. auto. Qed. +Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). +Proof. + intros. + apply Sort_NoDupA. + apply elements_3; auto. +Qed. + (** * [fold] *) -Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := +Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := match m with | nil => acc | (k,e)::m' => fold f m' (f k e acc) end. -Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A), +Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; functional induction (fold f m i); auto. @@ -374,29 +368,24 @@ Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := | _, _ => false end. -Definition Equal cmp m m' := +Definition Equivb cmp m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equal cmp m m' -> equal cmp m m' = true. + Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal; - intuition; subst; match goal with - | [H: X.compare _ _ = _ |- _ ] => clear H - | _ => idtac - end. - - - + functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; + intuition; subst. + match goal with H: X.compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). apply H1 with x; auto. rewrite cmp_e_e'; simpl. apply IHb; auto. inversion_clear Hm; auto. inversion_clear Hm'; auto. - unfold Equal; intuition. + unfold Equivb; intuition. destruct (H0 k). assert (In k ((x,e) ::l)). destruct H as (e'', hyp); exists e''; auto. @@ -459,14 +448,12 @@ Qed. Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, - equal cmp m m' = true -> Equal cmp m m'. + equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal; - intuition; try discriminate; subst; match goal with - | [H: X.compare _ _ = _ |- _ ] => clear H - | _ => idtac - end. + functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; + intuition; try discriminate; subst; + try match goal with H: X.compare _ _ = _ |- _ => clear H end. inversion H0. @@ -502,13 +489,13 @@ Proof. elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. apply H8 with k; auto. -Qed. +Qed. -(** This lemma isn't part of the spec of [Equal], but is used in [FMapAVL] *) +(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> eqk x y -> cmp (snd x) (snd y) = true -> - (Equal cmp l1 l2 <-> Equal cmp (x :: l1) (y :: l2)). + (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). Proof. intros. inversion H; subst. @@ -527,7 +514,7 @@ Proof. rewrite H2; simpl; auto. Qed. -Variable elt':Set. +Variable elt':Type. (** * [map] and [mapi] *) @@ -548,7 +535,7 @@ Section Elt2. (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) -Variable elt elt' : Set. +Variable elt elt' : Type. (** Specification of [map] *) @@ -684,10 +671,10 @@ Section Elt3. (** * [map2] *) -Variable elt elt' elt'' : Set. +Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l @@ -739,7 +726,7 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' := end end. -Definition fold_right_pair (A B C:Set)(f: A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. Definition map2_alt m m' := @@ -1038,12 +1025,12 @@ Module E := X. Definition key := E.t. -Record slist (elt:Set) : Set := +Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Set) : Set := slist elt. +Definition t (elt:Type) : Type := slist elt. Section Elt. - Variable elt elt' elt'':Set. + Variable elt elt' elt'':Type. Implicit Types m : t elt. Implicit Types x y : key. @@ -1060,13 +1047,19 @@ Section Elt. Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. + Definition cardinal m := length m.(this). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). Definition In x m : Prop := Raw.PX.In x m.(this). Definition Empty m : Prop := Raw.Empty m.(this). - Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. @@ -1113,34 +1106,39 @@ Section Elt. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intros; reflexivity. Qed. - Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A), + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'. + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. End Elt. - Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. - Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. - Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. - Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). @@ -1148,7 +1146,7 @@ Section Elt. intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. - Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. @@ -1229,7 +1227,7 @@ Proof. unfold equal, eq in H6; simpl in H6; auto. Qed. -Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'. +Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Proof. intros. generalize (@equal_1 D.t m m' cmp). @@ -1237,7 +1235,7 @@ Proof. intuition. Qed. -Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'. +Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Proof. intros. generalize (@equal_2 D.t m m' cmp). diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 44724767..9bc2a599 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -11,11 +11,12 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FMapPositive.v 9862 2007-05-25 16:57:06Z letouzey $ *) +(* $Id: FMapPositive.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Import Bool. Require Import ZArith. Require Import OrderedType. +Require Import OrderedTypeEx. Require Import FMapInterface. Set Implicit Arguments. @@ -36,9 +37,12 @@ Open Local Scope positive_scope. usual order (see [OrderedTypeEx]), we use here a lexicographic order over bits, which is more natural here (lower bits are considered first). *) -Module PositiveOrderedTypeBits <: OrderedType. +Module PositiveOrderedTypeBits <: UsualOrderedType. Definition t:=positive. Definition eq:=@eq positive. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. Fixpoint bits_lt (p q:positive) { struct p } : Prop := match p, q with @@ -52,15 +56,6 @@ Module PositiveOrderedTypeBits <: OrderedType. Definition lt:=bits_lt. - Lemma eq_refl : forall x : t, eq x x. - Proof. red; auto. Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. red; auto. Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. red; intros; transitivity y; auto. Qed. - Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. Proof. induction x. @@ -171,17 +166,18 @@ Qed. Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. + Module ME:=KeyOrderedType E. Definition key := positive. - Inductive tree (A : Set) : Set := + Inductive tree (A : Type) := | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. Definition t := tree. Section A. - Variable A:Set. + Variable A:Type. Implicit Arguments Leaf [A]. @@ -280,6 +276,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition elements (m : t A) := xelements m xH. + (** [cardinal] *) + + Fixpoint cardinal (m : t A) : nat := + match m with + | Leaf => 0%nat + | Node l None r => (cardinal l + cardinal r)%nat + | Node l (Some _) r => S (cardinal l + cardinal r) + end. + Section CompcertSpec. Theorem gempty: @@ -560,6 +565,16 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_complete i xH m v H). Qed. + Lemma cardinal_1 : + forall (m: t A), cardinal m = length (elements m). + Proof. + unfold elements. + intros m; set (p:=1); clearbody p; revert m p. + induction m; simpl; auto; intros. + rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto. + destruct o; rewrite app_length; simpl; omega. + Qed. + End CompcertSpec. Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v. @@ -793,11 +808,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply xelements_sort; auto. Qed. + Lemma elements_3w : NoDupA eq_key (elements m). + Proof. + change eq_key with (@ME.eqk A). + apply ME.Sort_NoDupA; apply elements_3; auto. + Qed. + End FMapSpec. (** [map] and [mapi] *) - Variable B : Set. + Variable B : Type. Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive) {struct m} : t B := @@ -815,7 +836,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End A. Lemma xgmapi: - forall (A B: Set) (f: positive -> A -> B) (i j : positive) (m: t A), + forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A), find i (xmapi f m j) = option_map (f (append j i)) (find i m). Proof. induction i; intros; destruct m; simpl; auto. @@ -825,7 +846,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Theorem gmapi: - forall (A B: Set) (f: positive -> A -> B) (i: positive) (m: t A), + forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A), find i (mapi f m) = option_map (f i) (find i m). Proof. intros. @@ -836,7 +857,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma mapi_1 : - forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. @@ -851,7 +872,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma mapi_2 : - forall (elt elt':Set)(m: t elt)(x:key)(f:key->elt->elt'), + forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros. @@ -864,21 +885,21 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl in *; discriminate. Qed. - Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros; unfold map. destruct (mapi_1 (fun _ => f) H); intuition. Qed. - Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros; unfold map in *; eapply mapi_2; eauto. Qed. Section map2. - Variable A B C : Set. + Variable A B C : Type. Variable f : option A -> option B -> option C. Implicit Arguments Leaf [A]. @@ -927,10 +948,10 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End map2. - Definition map2 (elt elt' elt'':Set)(f:option elt->option elt'->option elt'') := + Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). - Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). @@ -946,7 +967,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct H; intuition; try discriminate. Qed. - Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. @@ -962,17 +983,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. - Definition fold (A B : Set) (f: positive -> A -> B -> B) (tr: t A) (v: B) := + Definition fold (A : Type)(B : Type) (f: positive -> A -> B -> B) (tr: t A) (v: B) := List.fold_left (fun a p => f (fst p) (snd p) a) (elements tr) v. Lemma fold_1 : - forall (A:Set)(m:t A)(B:Set)(i : B) (f : key -> A -> B -> B), + forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; unfold fold; auto. Qed. - Fixpoint equal (A:Set)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := + Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := match m1, m2 with | Leaf, _ => is_empty m2 | _, Leaf => is_empty m1 @@ -985,12 +1006,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. && equal cmp l1 l2 && equal cmp r1 r2 end. - Definition Equal (A:Set)(cmp:A->A->bool)(m m':t A) := + Definition Equal (A:Type)(m m':t A) := + forall y, find y m = find y m'. + Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - Lemma equal_1 : forall (A:Set)(m m':t A)(cmp:A->A->bool), - Equal cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + Equivb cmp m m' -> equal cmp m m' = true. Proof. induction m. (* m = Leaf *) @@ -1024,11 +1048,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct H2; red in H2; simpl in H2; discriminate. (* m' = Node *) destruct 1. - assert (Equal cmp m1 m'1). + assert (Equivb cmp m1 m'1). split. intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. - assert (Equal cmp m2 m'2). + assert (Equivb cmp m2 m'2). split. intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. @@ -1043,8 +1067,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply andb_true_intro; split; auto. Qed. - Lemma equal_2 : forall (A:Set)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equal cmp m m'. + Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + equal cmp m m' = true -> Equivb cmp m m'. Proof. induction m. (* m = Leaf *) @@ -1103,7 +1127,7 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: - forall (A:Set)(i j: positive) (x: A) (m: t A), + forall (A:Type)(i j: positive) (x: A) (m: t A), find i (add j x m) = if peq_dec i j then Some x else find i m. Proof. intros. @@ -1112,7 +1136,7 @@ Module PositiveMapAdditionalFacts. (* Not derivable from the Map interface *) Theorem gsident: - forall (A:Set)(i: positive) (m: t A) (v: A), + forall (A:Type)(i: positive) (m: t A) (v: A), find i m = Some v -> add i v m = m. Proof. induction i; intros; destruct m; simpl; simpl in H; try congruence. @@ -1121,7 +1145,7 @@ Module PositiveMapAdditionalFacts. Qed. Lemma xmap2_lr : - forall (A B : Set)(f g: option A -> option A -> option B)(m : t A), + forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), (forall (i j : option A), f i j = g j i) -> xmap2_l f m = xmap2_r g m. Proof. @@ -1132,7 +1156,7 @@ Module PositiveMapAdditionalFacts. Qed. Theorem map2_commut: - forall (A B: Set) (f g: option A -> option A -> option B), + forall (A B: Type) (f g: option A -> option A -> option B), (forall (i j: option A), f i j = g j i) -> forall (m1 m2: t A), _map2 f m1 m2 = _map2 g m2 m1. diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v deleted file mode 100644 index 1ad190a4..00000000 --- a/theories/FSets/FMapWeak.v +++ /dev/null @@ -1,15 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FMapWeak.v 8844 2006-05-22 17:22:36Z letouzey $ *) - -Require Export DecidableType. -Require Export DecidableTypeEx. -Require Export FMapWeakInterface. -Require Export FMapWeakList. -Require Export FMapWeakFacts.
\ No newline at end of file diff --git a/theories/FSets/FMapWeakFacts.v b/theories/FSets/FMapWeakFacts.v deleted file mode 100644 index 18f73a3f..00000000 --- a/theories/FSets/FMapWeakFacts.v +++ /dev/null @@ -1,599 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FMapWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *) - -(** * Finite maps library *) - -(** This functor derives additional facts from [FMapWeakInterface.S]. These - facts are mainly the specifications of [FMapWeakInterface.S] written using - different styles: equivalence and boolean equalities. -*) - -Require Import Bool. -Require Import OrderedType. -Require Export FMapWeakInterface. -Set Implicit Arguments. -Unset Strict Implicit. - -Module Facts (M: S). -Import M. -Import Logic. (* to unmask [eq] *) -Import Peano. (* to unmask [lt] *) - -Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -intros. -generalize (find_1 H) (find_1 H0); clear H H0. -intros; rewrite H in H0; injection H0; auto. -Qed. - -(** * Specifications written using equivalences *) - -Section IffSpec. -Variable elt elt' elt'': Set. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. -split; apply MapsTo_1; auto. -Qed. - -Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m). -Proof. -unfold In. -split; intros (e0,H0); exists e0. -apply (MapsTo_1 H H0); auto. -apply (MapsTo_1 (E.eq_sym H) H0); auto. -Qed. - -Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e. -Proof. -split; [apply find_1|apply find_2]. -Qed. - -Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None. -Proof. -intros. -generalize (find_mapsto_iff m x); destruct (find x m). -split; intros; try discriminate. -destruct H0. -exists e; rewrite H; auto. -split; auto. -intros; intros (e,H1). -rewrite H in H1; discriminate. -Qed. - -Lemma mem_in_iff : forall m x, In x m <-> mem x m = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false. -Proof. -intros; rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma empty_in_iff : forall x, In x (empty elt) <-> False. -Proof. -unfold In. -split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. -Qed. - -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -intros. -intuition. -destruct (E.eq_dec x y); [left|right]. -split; auto. -symmetry; apply (MapsTo_fun (e':=e) H); auto. -split; auto; apply add_3 with x e; auto. -subst; auto. -Qed. - -Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -unfold In; split. -intros (e',H). -destruct (E.eq_dec x y) as [E|E]; auto. -right; exists e'; auto. -apply (add_3 E H). -destruct (E.eq_dec x y) as [E|E]; auto. -intros. -exists e; apply add_1; auto. -intros [H|(e',H)]. -destruct E; auto. -exists e'; apply add_2; auto. -Qed. - -Lemma add_neq_mapsto_iff : forall m x y e e', - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff : forall m x y e, - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -apply (add_3 H H0). -apply add_2; auto. -Qed. - -Lemma remove_mapsto_iff : forall m x y e, - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -intros. -split; intros. -split. -assert (In y (remove x m)) by (exists e; auto). -intro H1; apply (remove_1 H1 H0). -apply remove_3 with x; auto. -apply remove_2; intuition. -Qed. - -Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split. -intros (e,H). -split. -assert (In y (remove x m)) by (exists e; auto). -intro H1; apply (remove_1 H1 H0). -exists e; apply remove_3 with x; auto. -intros (H,(e,H0)); exists e; apply remove_2; auto. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -apply (remove_3 H0). -apply remove_2; auto. -Qed. - -Lemma elements_mapsto_iff : forall m x e, - MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -Lemma elements_in_iff : forall m x, - In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. -unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. -Qed. - -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -split. -case_eq (find x m); intros. -exists e. -split. -apply (MapsTo_fun (m:=map f m) (x:=x)); auto. -apply find_2; auto. -assert (In x (map f m)) by (exists b; auto). -destruct (map_2 H1) as (a,H2). -rewrite (find_1 H2) in H; discriminate. -intros (a,(H,H0)). -subst b; auto. -Qed. - -Lemma map_in_iff : forall m x (f : elt -> elt'), - In x (map f m) <-> In x m. -Proof. -split; intros; eauto. -destruct H as (a,H). -exists (f a); auto. -Qed. - -Lemma mapi_in_iff : forall m x (f:key->elt->elt'), - In x (mapi f m) <-> In x m. -Proof. -split; intros; eauto. -destruct H as (a,H). -destruct (mapi_1 f H) as (y,(H0,H1)). -exists (f y a); auto. -Qed. - -(* Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) - -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> - exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -intros; case_eq (find x m); intros. -exists e. -destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)). -apply find_2; auto. -exists y; repeat split; auto. -apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto. -assert (In x (mapi f m)) by (exists b; auto). -destruct (mapi_2 H1) as (a,H2). -rewrite (find_1 H2) in H0; discriminate. -Qed. - -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. -destruct (mapi_1 f H0) as (y,(H1,H2)). -replace (f x e) with (f y e) by auto. -auto. -Qed. - -Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -split. -intros. -destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))). -exists a; split; auto. -subst b; auto. -intros (a,(H0,H1)). -subst b. -apply mapi_1bis; auto. -Qed. - -(** Things are even worse for [map2] : we don't try to state any - equivalence, see instead boolean results below. *) - -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** * Specifications written using boolean predicates *) - -Section BoolSpec. - -Definition eqb x y := if E.eq_dec x y then true else false. - -Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. -Proof. -intros. -generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. -destruct (find x m); destruct (mem x m); auto. -intros. -rewrite <- H0; exists e; rewrite H; auto. -intuition. -destruct H0 as (e,H0). -destruct (H e); intuition discriminate. -Qed. - -Variable elt elt' elt'' : Set. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. -intros. -generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). -destruct (mem x m); destruct (mem y m); intuition. -Qed. - -Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. -Proof. -intros. -generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H). -destruct (find x m); destruct (find y m); intros. -rewrite <- H0; rewrite H2; rewrite H1; auto. -symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto. -rewrite <- H0; rewrite H2; rewrite H1; auto. -auto. -Qed. - -Lemma empty_o : forall x, find x (empty elt) = None. -Proof. -intros. -case_eq (find x (empty elt)); intros; auto. -generalize (find_2 H). -rewrite empty_mapsto_iff; intuition. -Qed. - -Lemma empty_a : forall x, mem x (empty elt) = false. -Proof. -intros. -case_eq (mem x (empty elt)); intros; auto. -generalize (mem_2 H). -rewrite empty_in_iff; intuition. -Qed. - -Lemma add_eq_o : forall m x y e, - E.eq x y -> find y (add x e m) = Some e. -Proof. -auto. -Qed. - -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. -intros. -case_eq (find y m); intros; auto. -case_eq (find y (add x e m)); intros; auto. -rewrite <- H0; symmetry. -apply find_1; apply add_3 with x e; auto. -Qed. -Hint Resolve add_neq_o. - -Lemma add_o : forall m x y e, - find y (add x e m) = if E.eq_dec x y then Some e else find y m. -Proof. -intros; destruct (E.eq_dec x y); auto. -Qed. - -Lemma add_eq_b : forall m x y e, - E.eq x y -> mem y (add x e m) = true. -Proof. -intros; rewrite mem_find_b; rewrite add_eq_o; auto. -Qed. - -Lemma add_neq_b : forall m x y e, - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. -Qed. - -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. -destruct (E.eq_dec x y); simpl; auto. -Qed. - -Lemma remove_eq_o : forall m x y, - E.eq x y -> find y (remove x m) = None. -Proof. -intros. -generalize (remove_1 (m:=m) H). -generalize (find_mapsto_iff (remove x m) y). -destruct (find y (remove x m)); auto. -destruct 2. -exists e; rewrite H0; auto. -Qed. -Hint Resolve remove_eq_o. - -Lemma remove_neq_o : forall m x y, - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. -intros. -case_eq (find y m); intros; auto. -case_eq (find y (remove x m)); intros; auto. -rewrite <- H0; symmetry. -apply find_1; apply remove_3 with x; auto. -Qed. -Hint Resolve remove_neq_o. - -Lemma remove_o : forall m x y, - find y (remove x m) = if E.eq_dec x y then None else find y m. -Proof. -intros; destruct (E.eq_dec x y); auto. -Qed. - -Lemma remove_eq_b : forall m x y, - E.eq x y -> mem y (remove x m) = false. -Proof. -intros; rewrite mem_find_b; rewrite remove_eq_o; auto. -Qed. - -Lemma remove_neq_b : forall m x y, - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. -Qed. - -Lemma remove_b : forall m x y, - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. -destruct (E.eq_dec x y); auto. -Qed. - -Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := - match o with - | Some a => Some (f a) - | None => None - end. - -Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = option_map f (find x m). -Proof. -intros. -generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) - (fun b => map_mapsto_iff m x b f). -destruct (find x (map f m)); destruct (find x m); simpl; auto; intros. -rewrite <- H; rewrite H1; exists e0; rewrite H0; auto. -destruct (H e) as [_ H2]. -rewrite H1 in H2. -destruct H2 as (a,(_,H2)); auto. -rewrite H0 in H2; discriminate. -rewrite <- H; rewrite H1; exists e; rewrite H0; auto. -Qed. - -Lemma map_b : forall m x (f:elt->elt'), - mem x (map f m) = mem x m. -Proof. -intros; do 2 rewrite mem_find_b; rewrite map_o. -destruct (find x m); simpl; auto. -Qed. - -Lemma mapi_b : forall m x (f:key->elt->elt'), - mem x (mapi f m) = mem x m. -Proof. -intros. -generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f). -destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros. -symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. -rewrite <- H; rewrite H1; rewrite H0; auto. -Qed. - -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> - find x (mapi f m) = option_map (f x) (find x m). -Proof. -intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) - (fun b => mapi_mapsto_iff m x b H). -destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. -rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. -destruct (H0 e) as [_ H3]. -rewrite H2 in H3. -destruct H3 as (a,(_,H3)); auto. -rewrite H1 in H3; discriminate. -rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. -Qed. - -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. -intros. -case_eq (find x m); intros. -rewrite <- H0. -apply map2_1; auto. -left; exists e; auto. -case_eq (find x m'); intros. -rewrite <- H0; rewrite <- H1. -apply map2_1; auto. -right; exists e; auto. -rewrite H. -case_eq (find x (map2 f m m')); intros; auto. -assert (In x (map2 f m m')) by (exists e; auto). -destruct (map2_2 H3) as [(e0,H4)|(e0,H4)]. -rewrite (find_1 H4) in H0; discriminate. -rewrite (find_1 H4) in H1; discriminate. -Qed. - -Fixpoint findA (A B:Set)(f : A -> bool) (l:list (A*B)) : option B := - match l with - | nil => None - | (a,b)::l => if f a then Some b else findA f l - end. - -Lemma findA_NoDupA : - forall (A B:Set) - (eqA:A->A->Prop) - (eqA_sym: forall a b, eqA a b -> eqA b a) - (eqA_trans: forall a b c, eqA a b -> eqA b c -> eqA a c) - (eqA_dec : forall a a', { eqA a a' }+{~eqA a a' }) - (l:list (A*B))(x:A)(e:B), - NoDupA (fun p p' => eqA (fst p) (fst p')) l -> - (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (x,e) l <-> - findA (fun y:A => if eqA_dec x y then true else false) l = Some e). -Proof. -induction l; simpl; intros. -split; intros; try discriminate. -inversion H0. -destruct a as (y,e'). -inversion_clear H. -split; intros. -inversion_clear H. -simpl in *; destruct H2; subst e'. -destruct (eqA_dec x y); intuition. -destruct (eqA_dec x y); simpl. -destruct H0. -generalize e0 H2 eqA_trans eqA_sym; clear. -induction l. -inversion 2. -inversion_clear 2; intros; auto. -destruct a. -compute in H; destruct H. -subst b. -constructor 1; auto. -simpl. -apply eqA_trans with x; auto. -rewrite <- IHl; auto. -destruct (eqA_dec x y); simpl in *. -inversion H; clear H; intros; subst e'; auto. -constructor 2. -rewrite IHl; auto. -Qed. - -Lemma elements_o : forall m x, - find x m = findA (eqb x) (elements m). -Proof. -intros. -assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)). - intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff. -assert (NoDupA (eq_key (elt:=elt)) (elements m)). - exact (elements_3 m). -generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans E.eq_dec (elements m) x e H0). -unfold eqb. -destruct (find x m); destruct (findA (fun y : E.t => if E.eq_dec x y then true else false) (elements m)); - simpl; auto; intros. -symmetry; rewrite <- H1; rewrite <- H; auto. -symmetry; rewrite <- H1; rewrite <- H; auto. -rewrite H; rewrite H1; auto. -Qed. - -Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m). -Proof. -intros. -generalize (mem_in_iff m x)(elements_in_iff m x) - (existsb_exists (fun p => eqb x (fst p)) (elements m)). -destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros. -symmetry; rewrite H1. -destruct H0 as (H0,_). -destruct H0 as (e,He); [ intuition |]. -rewrite InA_alt in He. -destruct He as ((y,e'),(Ha1,Ha2)). -compute in Ha1; destruct Ha1; subst e'. -exists (y,e); split; simpl; auto. -unfold eqb; destruct (E.eq_dec x y); intuition. -rewrite <- H; rewrite H0. -destruct H1 as (H1,_). -destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|]. -simpl in Ha2. -unfold eqb in *; destruct (E.eq_dec x y); auto; try discriminate. -exists e; rewrite InA_alt. -exists (y,e); intuition. -compute; auto. -Qed. - -End BoolSpec. - -End Facts. diff --git a/theories/FSets/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v deleted file mode 100644 index b6df4da5..00000000 --- a/theories/FSets/FMapWeakInterface.v +++ /dev/null @@ -1,201 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FMapWeakInterface.v 8639 2006-03-16 19:21:55Z letouzey $ *) - -(** * Finite map library *) - -(** This file proposes an interface for finite maps over keys with decidable - equality, but no decidable order. *) - -Set Implicit Arguments. -Unset Strict Implicit. -Require Import FSetInterface. -Require Import FSetWeakInterface. - -Module Type S. - - Declare Module E : DecidableType. - - Definition key := E.t. - - Parameter t : Set -> Set. (** the abstract type of maps *) - - Section Types. - - Variable elt:Set. - - Parameter empty : t elt. - (** The empty map. *) - - Parameter is_empty : t elt -> bool. - (** Test whether a map is empty or not. *) - - Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], - its previous binding disappears. *) - - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. - NB: in Coq, the exception mechanism becomes a option type. *) - - Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], - except for [x] which is unbound in the returned map. *) - - Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - (** Coq comment: [iter] is useless in a purely functional world *) - (** val iter : (key -> 'a -> unit) -> 'a t -> unit *) - (** iter f m applies f to all bindings in map m. f receives the key as - first argument, and the associated value as second argument. - The bindings are passed to f in increasing order with respect to the - ordering over the type of the keys. Only current bindings are - presented to f: bindings hidden by more recent bindings are not - passed to f. *) - - Variable elt' : Set. - Variable elt'': Set. - - Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated - value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. The bindings are passed to [f] in - increasing order with respect to the ordering over the type of the - keys. *) - - Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [S.map], but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** Not present in Ocaml. - [map f m m'] creates a new map whose bindings belong to the ones of either - [m] or [m']. The presence and value for a key [k] is determined by [f e e'] - where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) - - Parameter elements : t elt -> list (key*elt). - (** Not present in Ocaml. - [elements m] returns an assoc list corresponding to the bindings of [m]. - Elements of this list are sorted with respect to their first components. - Useful to specify [fold] ... *) - - Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] - (in increasing order), and [d1] ... [dN] are the associated data. *) - - Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated - with the keys. *) - - Section Spec. - - Variable m m' m'' : t elt. - Variable x y z : key. - Variable e e' : elt. - - Parameter MapsTo : key -> elt -> t elt -> Prop. - - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - - Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. - - Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - (** Specification of [MapsTo] *) - Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - - (** Specification of [mem] *) - Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. - - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. - - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. - Parameter is_empty_2 : is_empty m = true -> Empty m. - - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). - Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). - Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. - - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x m). - Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). - Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - - (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. - Parameter find_2 : find x m = Some e -> MapsTo x e m. - - (** Specification of [elements] *) - Parameter elements_1 : - MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : - InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - Parameter elements_3 : NoDupA eq_key (elements m). - - (** Specification of [fold] *) - Parameter fold_1 : - forall (A : Set) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. - - Definition Equal cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - - Variable cmp : elt -> elt -> bool. - - (** Specification of [equal] *) - Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. - Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'. - - End Spec. - End Types. - - (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), - MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. - - (** Specification of [mapi] *) - Parameter mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). - Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) - (f:key->elt->elt'), In x (mapi f m) -> In x m. - - (** Specification of [map2] *) - Parameter map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - - Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x (map2 f m m') -> In x m \/ In x m'. - - Hint Immediate MapsTo_1 mem_2 is_empty_2. - - Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1 - remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. - -End S. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 890485a8..be09e41a 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,39 +6,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapWeakList.v 8985 2006-06-23 16:12:45Z jforest $ *) +(* $Id: FMapWeakList.v 10616 2008-03-04 17:33:35Z letouzey $ *) (** * Finite map library *) (** This file proposes an implementation of the non-dependant interface - [FMapInterface.S] using lists of pairs, unordered but without redundancy. *) + [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) -Require Import FSetInterface. -Require Import FSetWeakInterface. -Require Import FMapWeakInterface. +Require Import FMapInterface. Set Implicit Arguments. Unset Strict Implicit. -Arguments Scope list [type_scope]. - Module Raw (X:DecidableType). -Module PX := KeyDecidableType X. -Import PX. +Module Import PX := KeyDecidableType X. Definition key := X.t. -Definition t (elt:Set) := list (X.t * elt). +Definition t (elt:Type) := list (X.t * elt). Section Elt. -Variable elt : Set. - -(* now in KeyDecidableType: -Definition eqk (p p':key*elt) := X.eq (fst p) (fst p'). -Definition eqke (p p':key*elt) := - X.eq (fst p) (fst p') /\ (snd p) = (snd p'). -*) +Variable elt : Type. Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). @@ -221,10 +210,10 @@ Proof. destruct a as (x',e'). simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. constructor; auto. - swap H. + contradict H. apply InA_eqk with (x,e); auto. constructor; auto. - swap H; apply add_3' with x e; auto. + contradict H; apply add_3' with x e; auto. Qed. (* Not part of the exported specifications, used later for [combine]. *) @@ -272,8 +261,8 @@ Proof. inversion_clear Hm. subst. - swap H0. - destruct H2 as (e,H2); unfold PX.MapsTo in H2. + contradict H0. + destruct H0 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. @@ -323,7 +312,7 @@ Proof. destruct a as (x',e'). simpl; case (X.eq_dec x x'); auto. constructor; auto. - swap H; apply remove_3' with x; auto. + contradict H; apply remove_3' with x; auto. Qed. (** * [elements] *) @@ -340,20 +329,20 @@ Proof. auto. Qed. -Lemma elements_3 : forall m (Hm:NoDupA m), NoDupA (elements m). +Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). Proof. auto. Qed. (** * [fold] *) -Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := +Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := match m with | nil => acc | (k,e)::m' => fold f m' (f k e acc) end. -Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A), +Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros; functional induction (@fold A f m i); auto. @@ -377,7 +366,7 @@ Definition Submap cmp m m' := (forall k, In k m -> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Definition Equal cmp m m' := +Definition Equivb cmp m m' := (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). @@ -444,17 +433,17 @@ Qed. (** Specification of [equal] *) Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equal cmp m m' -> equal cmp m m' = true. + Equivb cmp m m' -> equal cmp m m' = true. Proof. - unfold Equal, equal. + unfold Equivb, equal. intuition. apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. Qed. Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, - equal cmp m m' = true -> Equal cmp m m'. + equal cmp m m' = true -> Equivb cmp m m'. Proof. - unfold Equal, equal. + unfold Equivb, equal. intros. destruct (andb_prop _ _ H); clear H. generalize (submap_2 Hm Hm' H0). @@ -462,7 +451,7 @@ Proof. firstorder. Qed. -Variable elt':Set. +Variable elt':Type. (** * [map] and [mapi] *) @@ -483,7 +472,7 @@ Section Elt2. (* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) -Variable elt elt' : Set. +Variable elt elt' : Type. (** Specification of [map] *) @@ -533,12 +522,12 @@ Proof. destruct a as (x',e'). inversion_clear Hm. constructor; auto. - swap H. + contradict H. (* il faut un map_1 avec eqk au lieu de eqke *) clear IHm H0. induction m; simpl in *; auto. - inversion H1. - destruct a; inversion H1; auto. + inversion H. + destruct a; inversion H; auto. Qed. (** Specification of [mapi] *) @@ -593,17 +582,17 @@ Proof. destruct a as (x',e'). inversion_clear Hm; auto. constructor; auto. - swap H. + contradict H. clear IHm H0. induction m; simpl in *; auto. - inversion_clear H1. - destruct a; inversion_clear H1; auto. + inversion_clear H. + destruct a; inversion_clear H; auto. Qed. End Elt2. Section Elt3. -Variable elt elt' elt'' : Set. +Variable elt elt' elt'' : Type. Notation oee' := (option elt * option elt')%type. @@ -613,7 +602,7 @@ Definition combine_l (m:t elt)(m':t elt') : t oee' := Definition combine_r (m:t elt)(m':t elt') : t oee' := mapi (fun k e' => (find k m, Some e')) m'. -Definition fold_right_pair (A B C:Set)(f:A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. Definition combine (m:t elt)(m':t elt') : t oee' := @@ -737,7 +726,7 @@ Qed. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l @@ -765,13 +754,13 @@ Proof. inversion_clear H1. destruct a; destruct o; simpl; auto. constructor; auto. - swap H. + contradict H. clear IHl1. induction l1. - inversion H1. + inversion H. inversion_clear H0. destruct a; destruct o; simpl in *; auto. - inversion_clear H1; auto. + inversion_clear H; auto. Qed. Definition at_least_one_then_f (o:option elt)(o':option elt') := @@ -807,7 +796,7 @@ Proof. rewrite H2. unfold f'; simpl. destruct (f oo oo'); simpl. - destruct (X.eq_dec x k); try absurd_hyp n; auto. + destruct (X.eq_dec x k); try contradict n; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. elim H0. @@ -817,7 +806,7 @@ Proof. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. - destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (X.eq_dec x k); [ contradict n; auto | auto]. destruct (IHm0 H1) as (H3,_); apply H3; auto. destruct (IHm0 H1) as (H3,_); apply H3; auto. @@ -831,7 +820,7 @@ Proof. (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. - destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (X.eq_dec x k); [ contradict n; auto | auto]. destruct (IHm0 H1) as (_,H4); apply H4; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. Qed. @@ -873,18 +862,18 @@ End Elt3. End Raw. -Module Make (X: DecidableType) <: S with Module E:=X. +Module Make (X: DecidableType) <: WS with Module E:=X. Module Raw := Raw X. Module E := X. Definition key := E.t. - Record slist (elt:Set) : Set := + Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Set) := slist elt. + Definition t (elt:Type) := slist elt. Section Elt. - Variable elt elt' elt'':Set. + Variable elt elt' elt'':Type. Implicit Types m : t elt. Implicit Types x y : key. @@ -901,13 +890,18 @@ Section Elt. Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). - Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. + Definition cardinal m := length m.(this). + Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i. Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). Definition In x m : Prop := Raw.PX.In x m.(this). Definition Empty m : Prop := Raw.Empty m.(this). - Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt. @@ -951,36 +945,39 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3 : forall m, NoDupA eq_key (elements m). - Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(NoDup)). Qed. + Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). + Proof. intros; reflexivity. Qed. - Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A), + Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. - Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'. + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. End Elt. - Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. - Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt) + Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. - Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key) + Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. - Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m'). @@ -988,7 +985,7 @@ Section Elt. intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. - Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v index 72ccad3f..75904202 100644 --- a/theories/FSets/FMaps.v +++ b/theories/FSets/FMaps.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMaps.v 8844 2006-05-22 17:22:36Z letouzey $ *) +(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *) -Require Export OrderedType. -Require Export OrderedTypeEx. -Require Export OrderedTypeAlt. + +Require Export OrderedType OrderedTypeEx OrderedTypeAlt. +Require Export DecidableType DecidableTypeEx. Require Export FMapInterface. -Require Export FMapList. Require Export FMapPositive. -Require Export FMapIntMap. -Require Export FMapFacts.
\ No newline at end of file +Require Export FMapFacts. +Require Export FMapWeakList. +Require Export FMapList. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index d5ce54d9..faa705f6 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -1,4 +1,3 @@ - (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) @@ -12,41 +11,555 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *) +(* $Id: FSetAVL.v 10811 2008-04-17 16:29:49Z letouzey $ *) + +(** * FSetAVL *) (** This module implements sets using AVL trees. - It follows the implementation from Ocaml's standard library. *) + It follows the implementation from Ocaml's standard library, + + All operations given here expect and produce well-balanced trees + (in the ocaml sense: heigths of subtrees shouldn't differ by more + than 2), and hence has low complexities (e.g. add is logarithmic + in the size of the set). But proving these balancing preservations + is in fact not necessary for ensuring correct operational behavior + and hence fulfilling the FSet interface. As a consequence, + balancing results are not part of this file anymore, they can + now be found in [FSetFullAVL]. + + Four operations ([union], [subset], [compare] and [equal]) have + been slightly adapted in order to have only structural recursive + calls. The precise ocaml versions of these operations have also + been formalized (thanks to Function+measure), see [ocaml_union], + [ocaml_subset], [ocaml_compare] and [ocaml_equal] in + [FSetFullAVL]. The structural variants compute faster in Coq, + whereas the other variants produce nicer and/or (slightly) faster + code after extraction. +*) -Require Import FSetInterface. -Require Import FSetList. -Require Import ZArith. -Require Import Int. +Require Import FSetInterface FSetList ZArith Int. -Set Firstorder Depth 3. +Set Implicit Arguments. +Unset Strict Implicit. -Module Raw (I:Int)(X:OrderedType). -Import I. -Module II:=MoreInt(I). -Import II. -Open Local Scope Int_scope. +(** Notations and helper lemma about pairs *) + +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. -Module E := X. -Module MX := OrderedTypeFacts X. +(** * Raw + + Functor of pure functions + a posteriori proofs of invariant + preservation *) + +Module Raw (Import I:Int)(X:OrderedType). +Open Local Scope pair_scope. +Open Local Scope lazy_bool_scope. +Open Local Scope Int_scope. Definition elt := X.t. -(** * Trees *) +(** * Trees -Inductive tree : Set := + The fourth field of [Node] is the height of the tree *) + +Inductive tree := | Leaf : tree | Node : tree -> X.t -> tree -> int -> tree. Notation t := tree. -(** The fourth field of [Node] is the height of the tree *) +(** * Basic functions on trees: height and cardinal *) + +Definition height (s : tree) : int := + match s with + | Leaf => 0 + | Node _ _ _ h => h + end. + +Fixpoint cardinal (s : tree) : nat := + match s with + | Leaf => 0%nat + | Node l _ r _ => S (cardinal l + cardinal r) + end. + +(** * Empty Set *) + +Definition empty := Leaf. + +(** * Emptyness test *) + +Definition is_empty s := + match s with Leaf => true | _ => false end. + +(** * Appartness *) + +(** The [mem] function is deciding appartness. It exploits the + binary search tree invariant to achieve logarithmic complexity. *) + +Fixpoint mem x s := + match s with + | Leaf => false + | Node l y r _ => match X.compare x y with + | LT _ => mem x l + | EQ _ => true + | GT _ => mem x r + end + end. + +(** * Singleton set *) + +Definition singleton x := Node Leaf x Leaf 1. + +(** * Helper functions *) + +(** [create l x r] creates a node, assuming [l] and [r] + to be balanced and [|height l - height r| <= 2]. *) + +Definition create l x r := + Node l x r (max (height l) (height r) + 1). + +(** [bal l x r] acts as [create], but performs one step of + rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) + +Definition assert_false := create. + +Definition bal l x r := + let hl := height l in + let hr := height r in + if gt_le_dec hl (hr+2) then + match l with + | Leaf => assert_false l x r + | Node ll lx lr _ => + if ge_lt_dec (height ll) (height lr) then + create ll lx (create lr x r) + else + match lr with + | Leaf => assert_false l x r + | Node lrl lrx lrr _ => + create (create ll lx lrl) lrx (create lrr x r) + end + end + else + if gt_le_dec hr (hl+2) then + match r with + | Leaf => assert_false l x r + | Node rl rx rr _ => + if ge_lt_dec (height rr) (height rl) then + create (create l x rl) rx rr + else + match rl with + | Leaf => assert_false l x r + | Node rll rlx rlr _ => + create (create l x rll) rlx (create rlr rx rr) + end + end + else + create l x r. + +(** * Insertion *) + +Fixpoint add x s := match s with + | Leaf => Node Leaf x Leaf 1 + | Node l y r h => + match X.compare x y with + | LT _ => bal (add x l) y r + | EQ _ => Node l y r h + | GT _ => bal l y (add x r) + end + end. + +(** * Join + + Same as [bal] but does not assume anything regarding heights + of [l] and [r]. +*) + +Fixpoint join l : elt -> t -> t := + match l with + | Leaf => add + | Node ll lx lr lh => fun x => + fix join_aux (r:t) : t := match r with + | Leaf => add x l + | Node rl rx rr rh => + if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr + else create l x r + end + end. + +(** * Extraction of minimum element + + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). +*) + +Fixpoint remove_min l x r : t*elt := + match l with + | Leaf => (r,x) + | Node ll lx lr lh => + let (l',m) := remove_min ll lx lr in (bal l' x r, m) + end. + +(** * Merging two trees + + [merge t1 t2] builds the union of [t1] and [t2] assuming all elements + of [t1] to be smaller than all elements of [t2], and + [|height t1 - height t2| <= 2]. +*) + +Definition merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 h2 => + let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' +end. + +(** * Deletion *) + +Fixpoint remove x s := match s with + | Leaf => Leaf + | Node l y r h => + match X.compare x y with + | LT _ => bal (remove x l) y r + | EQ _ => merge l r + | GT _ => bal l y (remove x r) + end + end. + +(** * Minimum element *) + +Fixpoint min_elt s := match s with + | Leaf => None + | Node Leaf y _ _ => Some y + | Node l _ _ _ => min_elt l +end. + +(** * Maximum element *) + +Fixpoint max_elt s := match s with + | Leaf => None + | Node _ y Leaf _ => Some y + | Node _ _ r _ => max_elt r +end. + +(** * Any element *) + +Definition choose := min_elt. + +(** * Concatenation + + Same as [merge] but does not assume anything about heights. +*) + +Definition concat s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 _ => + let (s2',m) := remove_min l2 x2 r2 in + join s1 m s2' + end. + +(** * Splitting + + [split x s] returns a triple [(l, present, r)] where + - [l] is the set of elements of [s] that are [< x] + - [r] is the set of elements of [s] that are [> x] + - [present] is [true] if and only if [s] contains [x]. +*) + +Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. +Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). +Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). +Notation "t #b" := (t_in t) (at level 9, format "t '#b'"). +Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). + +Fixpoint split x s : triple := match s with + | Leaf => << Leaf, false, Leaf >> + | Node l y r h => + match X.compare x y with + | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >> + | EQ _ => << l, true, r >> + | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >> + end + end. + +(** * Intersection *) + +Fixpoint inter s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => Leaf + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then join (inter l1 l2') x1 (inter r1 r2') + else concat (inter l1 l2') (inter r1 r2') + end. + +(** * Difference *) + +Fixpoint diff s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then concat (diff l1 l2') (diff r1 r2') + else join (diff l1 l2') x1 (diff r1 r2') +end. + +(** * Union *) + +(** In ocaml, heights of [s1] and [s2] are compared each time in order + to recursively perform the split on the smaller set. + Unfortunately, this leads to a non-structural algorithm. The + following code is a simplification of the ocaml version: no + comparison of heights. It might be slightly slower, but + experimentally all the tests I've made in ocaml have shown this + potential slowdown to be non-significant. Anyway, the exact code + of ocaml has also been formalized thanks to Function+measure, see + [ocaml_union] in [FSetFullAVL]. +*) + +Fixpoint union s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',_,r2') := split x1 s2 in + join (union l1 l2') x1 (union r1 r2') + end. + +(** * Elements *) + +(** [elements_tree_aux acc t] catenates the elements of [t] in infix + order to the list [acc] *) + +Fixpoint elements_aux (acc : list X.t) (t : tree) : list X.t := + match t with + | Leaf => acc + | Node l x r _ => elements_aux (x :: elements_aux acc r) l + end. + +(** then [elements] is an instanciation with an empty [acc] *) + +Definition elements := elements_aux nil. + +(** * Filter *) + +Fixpoint filter_acc (f:elt->bool) acc s := match s with + | Leaf => acc + | Node l x r h => + filter_acc f (filter_acc f (if f x then add x acc else acc) l) r + end. + +Definition filter f := filter_acc f Leaf. + + +(** * Partition *) + +Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := + match s with + | Leaf => acc + | Node l x r _ => + let (acct,accf) := acc in + partition_acc f + (partition_acc f + (if f x then (add x acct, accf) else (acct, add x accf)) l) r + end. + +Definition partition f := partition_acc f (Leaf,Leaf). + +(** * [for_all] and [exists] *) + +Fixpoint for_all (f:elt->bool) s := match s with + | Leaf => true + | Node l x r _ => f x &&& for_all f l &&& for_all f r +end. + +Fixpoint exists_ (f:elt->bool) s := match s with + | Leaf => false + | Node l x r _ => f x ||| exists_ f l ||| exists_ f r +end. + +(** * Fold *) + +Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := + fun a => match s with + | Leaf => a + | Node l x r _ => fold f r (f x (fold f l a)) + end. +Implicit Arguments fold [A]. + + +(** * Subset *) + +(** In ocaml, recursive calls are made on "half-trees" such as + (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these + non-structural calls, we propose here two specialized functions for + these situations. This version should be almost as efficient as + the one of ocaml (closures as arguments may slow things a bit), + it is simply less compact. The exact ocaml version has also been + formalized (thanks to Function+measure), see [ocaml_subset] in + [FSetFullAVL]. + *) + +Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | EQ _ => subset_l1 l2 + | LT _ => subsetl subset_l1 x1 l2 + | GT _ => mem x1 r2 &&& subset_l1 s2 + end + end. + +Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | EQ _ => subset_r1 r2 + | LT _ => mem x1 l2 &&& subset_r1 s2 + | GT _ => subsetr subset_r1 x1 r2 + end + end. + +Fixpoint subset s1 s2 : bool := match s1, s2 with + | Leaf, _ => true + | Node _ _ _ _, Leaf => false + | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | EQ _ => subset l1 l2 &&& subset r1 r2 + | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2 + | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2 + end + end. + +(** * A new comparison algorithm suggested by Xavier Leroy + + Transformation in C.P.S. suggested by Benjamin Grégoire. + The original ocaml code (with non-structural recursive calls) + has also been formalized (thanks to Function+measure), see + [ocaml_compare] in [FSetFullAVL]. The following code with + continuations computes dramatically faster in Coq, and + should be almost as efficient after extraction. +*) + +(** Enumeration of the elements of a tree *) + +Inductive enumeration := + | End : enumeration + | More : elt -> tree -> enumeration -> enumeration. + + +(** [cons t e] adds the elements of tree [t] on the head of + enumeration [e]. *) + +Fixpoint cons s e : enumeration := + match s with + | Leaf => e + | Node l x r h => cons l (More x r e) + end. + +(** One step of comparison of elements *) + +Definition compare_more x1 (cont:enumeration->comparison) e2 := + match e2 with + | End => Gt + | More x2 r2 e2 => + match X.compare x1 x2 with + | EQ _ => cont (cons r2 e2) + | LT _ => Lt + | GT _ => Gt + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := + match s1 with + | Leaf => cont e2 + | Node l1 x1 r1 _ => + compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition compare_end e2 := + match e2 with End => Eq | _ => Lt end. + +(** The complete comparison *) + +Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). + +(** * Equality test *) + +Definition equal s1 s2 : bool := + match compare s1 s2 with + | Eq => true + | _ => false + end. + + + + +(** * Invariants *) + +(** ** Occurrence in a tree *) + +Inductive In (x : elt) : tree -> Prop := + | IsRoot : forall l r h y, X.eq x y -> In x (Node l y r h) + | InLeft : forall l r h y, In x l -> In x (Node l y r h) + | InRight : forall l r h y, In x r -> In x (Node l y r h). + +(** ** Binary search trees *) + +(** [lt_tree x s]: all elements in [s] are smaller than [x] + (resp. greater for [gt_tree]) *) + +Definition lt_tree x s := forall y, In y s -> X.lt y x. +Definition gt_tree x s := forall y, In y s -> X.lt x y. + +(** [bst t] : [t] is a binary search tree *) + +Inductive bst : tree -> Prop := + | BSLeaf : bst Leaf + | BSNode : forall x l r h, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node l x r h). + + + + +(** * Some shortcuts *) + +Definition Equal s s' := forall a : elt, In a s <-> In a s'. +Definition Subset s s' := forall a : elt, In a s -> In a s'. +Definition Empty s := forall a : elt, ~ In a s. +Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. +Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + + +(** * Correctness proofs, isolated in a sub-module *) + +Module Proofs. + Module MX := OrderedTypeFacts X. + Module L := FSetList.Raw X. + +(** * Automation and dedicated tactics *) + +Hint Constructors In bst. +Hint Unfold lt_tree gt_tree. + +Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) + "as" ident(s) := + set (s:=Node l x r h) in *; clearbody s; clear l x r h. (** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node _ _ _ _))] *) + Ltac inv f := match goal with | H:f Leaf |- _ => inversion_clear H; inv f @@ -56,30 +569,18 @@ Ltac inv f := | _ => idtac end. -(** Same, but with a backup of the original hypothesis. *) +Ltac intuition_in := repeat progress (intuition; inv In). -Ltac safe_inv f := match goal with - | H:f (Node _ _ _ _) |- _ => - generalize H; inversion_clear H; safe_inv f - | _ => intros - end. +(** Helper tactic concerning order of elements. *) -(** * Occurrence in a tree *) +Ltac order := match goal with + | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order + | _ => MX.order +end. -Inductive In (x : elt) : tree -> Prop := - | IsRoot : - forall (l r : tree) (h : int) (y : elt), - X.eq x y -> In x (Node l y r h) - | InLeft : - forall (l r : tree) (h : int) (y : elt), - In x l -> In x (Node l y r h) - | InRight : - forall (l r : tree) (h : int) (y : elt), - In x r -> In x (Node l y r h). - -Hint Constructors In. -Ltac intuition_in := repeat progress (intuition; inv In). +(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) (** [In] is compatible with [X.eq] *) @@ -90,48 +591,37 @@ Proof. Qed. Hint Immediate In_1. -(** * Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree (x : elt) (s : tree) := - forall y:elt, In y s -> X.lt y x. -Definition gt_tree (x : elt) (s : tree) := - forall y:elt, In y s -> X.lt x y. - -Hint Unfold lt_tree gt_tree. - -Ltac order := match goal with - | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order - | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order - | _ => MX.order -end. +Lemma In_node_iff : + forall l x r h y, + In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r. +Proof. + intuition_in. +Qed. (** Results about [lt_tree] and [gt_tree] *) Lemma lt_leaf : forall x : elt, lt_tree x Leaf. Proof. - unfold lt_tree in |- *; intros; inversion H. + red; inversion 1. Qed. Lemma gt_leaf : forall x : elt, gt_tree x Leaf. Proof. - unfold gt_tree in |- *; intros; inversion H. + red; inversion 1. Qed. Lemma lt_tree_node : forall (x y : elt) (l r : tree) (h : int), lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). Proof. - unfold lt_tree in *; intuition_in; order. + unfold lt_tree; intuition_in; order. Qed. Lemma gt_tree_node : forall (x y : elt) (l r : tree) (h : int), gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). Proof. - unfold gt_tree in *; intuition_in; order. + unfold gt_tree; intuition_in; order. Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. @@ -145,7 +635,7 @@ Qed. Lemma lt_tree_trans : forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. Proof. - firstorder eauto. + eauto. Qed. Lemma gt_tree_not_in : @@ -157,120 +647,43 @@ Qed. Lemma gt_tree_trans : forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. Proof. - firstorder eauto. + eauto. Qed. Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : - forall (x : elt) (l r : tree) (h : int), - bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x r h). +(** * Inductions principles *) -Hint Constructors bst. +Functional Scheme mem_ind := Induction for mem Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme add_ind := Induction for add Sort Prop. +Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme remove_ind := Induction for remove Sort Prop. +Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. +Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. +Functional Scheme concat_ind := Induction for concat Sort Prop. +Functional Scheme split_ind := Induction for split Sort Prop. +Functional Scheme inter_ind := Induction for inter Sort Prop. +Functional Scheme diff_ind := Induction for diff Sort Prop. +Functional Scheme union_ind := Induction for union Sort Prop. -(** * AVL trees *) -(** [avl s] : [s] is a properly balanced AVL tree, - i.e. for any node the heights of the two children - differ by at most 2 *) - -Definition height (s : tree) : int := - match s with - | Leaf => 0 - | Node _ _ _ h => h - end. - -Inductive avl : tree -> Prop := - | RBLeaf : avl Leaf - | RBNode : - forall (x : elt) (l r : tree) (h : int), - avl l -> - avl r -> - -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> - avl (Node l x r h). - -Hint Constructors avl. - -(** Results about [avl] *) - -Lemma avl_node : - forall (x : elt) (l r : tree), - avl l -> - avl r -> - -(2) <= height l - height r <= 2 -> - avl (Node l x r (max (height l) (height r) + 1)). -Proof. - intros; auto. -Qed. -Hint Resolve avl_node. - -(** The tactics *) +(** * Empty set *) -Lemma height_non_negative : forall s : tree, avl s -> height s >= 0. +Lemma empty_1 : Empty empty. Proof. - induction s; simpl; intros; auto with zarith. - inv avl; intuition; omega_max. + intro; intro. + inversion H. Qed. -Implicit Arguments height_non_negative. - -(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *) - -Ltac avl_nn_hyp H := - let nz := fresh "nz" in assert (nz := height_non_negative H). - -Ltac avl_nn h := - let t := type of h in - match type of t with - | Prop => avl_nn_hyp h - | _ => match goal with H : avl h |- _ => avl_nn_hyp H end - end. - -(* Repeat the previous tactic. - Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) - -Ltac avl_nns := - match goal with - | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns - | _ => idtac - end. - -(** * Some shortcuts. *) - -Definition Equal s s' := forall a : elt, In a s <-> In a s'. -Definition Subset s s' := forall a : elt, In a s -> In a s'. -Definition Empty s := forall a : elt, ~ In a s. -Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - -(** * Empty set *) - -Definition empty := Leaf. Lemma empty_bst : bst empty. Proof. auto. Qed. -Lemma empty_avl : avl empty. -Proof. - auto. -Qed. - -Lemma empty_1 : Empty empty. -Proof. - intro; intro. - inversion H. -Qed. - (** * Emptyness test *) -Definition is_empty (s:t) := match s with Leaf => true | _ => false end. - Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. Proof. destruct s as [|r x l h]; simpl; auto. @@ -282,54 +695,28 @@ Proof. destruct s; simpl; intros; try discriminate; red; auto. Qed. -(** * Appartness *) -(** The [mem] function is deciding appartness. It exploits the [bst] property - to achieve logarithmic complexity. *) -Function mem (x:elt)(s:t) { struct s } : bool := - match s with - | Leaf => false - | Node l y r _ => match X.compare x y with - | LT _ => mem x l - | EQ _ => true - | GT _ => mem x r - end - end. +(** * Appartness *) Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true. -Proof. - intros s x. - functional induction (mem x s); inversion_clear 1; auto. - inversion_clear 1. - inversion_clear 1; auto; absurd (X.lt x y); eauto. - inversion_clear 1; auto; absurd (X.lt y x); eauto. +Proof. + intros s x; functional induction mem x s; auto; intros; try clear e0; + inv bst; intuition_in; order. Qed. Lemma mem_2 : forall s x, mem x s = true -> In x s. Proof. - intros s x. - functional induction (mem x s); auto; intros; try discriminate. + intros s x; functional induction mem x s; auto; intros; discriminate. Qed. -(** * Singleton set *) -Definition singleton (x : elt) := Node Leaf x Leaf 1. - -Lemma singleton_bst : forall x : elt, bst (singleton x). -Proof. - unfold singleton; auto. -Qed. -Lemma singleton_avl : forall x : elt, avl (singleton x). -Proof. - unfold singleton; intro. - constructor; auto; try red; simpl; omega_max. -Qed. +(** * Singleton set *) Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. Proof. - unfold singleton; inversion_clear 1; auto; inversion_clear H0. + unfold singleton; intros; inv In; order. Qed. Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). @@ -337,35 +724,14 @@ Proof. unfold singleton; auto. Qed. -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x r := - Node l x r (max (height l) (height r) + 1). - -Lemma create_bst : - forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> - bst (create l x r). +Lemma singleton_bst : forall x : elt, bst (singleton x). Proof. - unfold create; auto. + unfold singleton; auto. Qed. -Hint Resolve create_bst. -Lemma create_avl : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - avl (create l x r). -Proof. - unfold create; auto. -Qed. -Lemma create_height : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (create l x r) = max (height l) (height r) + 1. -Proof. - unfold create; intros; auto. -Qed. + +(** * Helper functions *) Lemma create_in : forall l x r y, In y (create l x r) <-> X.eq y x \/ In y l \/ In y r. @@ -373,196 +739,69 @@ Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. -(** trick for emulating [assert false] in Coq *) - -Definition assert_false := Leaf. - -(** [bal l x r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition bal l x r := - let hl := height l in - let hr := height r in - if gt_le_dec hl (hr+2) then - match l with - | Leaf => assert_false - | Node ll lx lr _ => - if ge_lt_dec (height ll) (height lr) then - create ll lx (create lr x r) - else - match lr with - | Leaf => assert_false - | Node lrl lrx lrr _ => - create (create ll lx lrl) lrx (create lrr x r) - end - end - else - if gt_le_dec hr (hl+2) then - match r with - | Leaf => assert_false - | Node rl rx rr _ => - if ge_lt_dec (height rr) (height rl) then - create (create l x rl) rx rr - else - match rl with - | Leaf => assert_false - | Node rll rlx rlr _ => - create (create l x rll) rlx (create rlr rx rr) - end - end - else - create l x r. - -Ltac bal_tac := - intros l x r; - unfold bal; - destruct (gt_le_dec (height l) (height r + 2)); - [ destruct l as [ |ll lx lr lh]; - [ | destruct (ge_lt_dec (height ll) (height lr)); - [ | destruct lr ] ] - | destruct (gt_le_dec (height r) (height l + 2)); - [ destruct r as [ |rl rx rr rh]; - [ | destruct (ge_lt_dec (height rr) (height rl)); - [ | destruct rl ] ] - | ] ]; intros. - -Lemma bal_bst : forall l x r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (bal l x r). -Proof. - (* intros l x r; functional induction bal l x r. MARCHE PAS !*) - bal_tac; - inv bst; repeat apply create_bst; auto; unfold create; - apply lt_tree_node || apply gt_tree_node; auto; - eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto. -Qed. - -Lemma bal_avl : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> avl (bal l x r). +Lemma create_bst : + forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> + bst (create l x r). Proof. - bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max. + unfold create; auto. Qed. +Hint Resolve create_bst. -Lemma bal_height_1 : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> - 0 <= height (bal l x r) - max (height l) (height r) <= 1. +Lemma bal_in : forall l x r y, + In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r. Proof. - bal_tac; inv avl; avl_nns; simpl in *; omega_max. + intros l x r; functional induction bal l x r; intros; try clear e0; + rewrite !create_in; intuition_in. Qed. -Lemma bal_height_2 : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (bal l x r) == max (height l) (height r) +1. +Lemma bal_bst : forall l x r, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (bal l x r). Proof. - bal_tac; inv avl; simpl in *; omega_max. + intros l x r; functional induction bal l x r; intros; + inv bst; repeat apply create_bst; auto; unfold create; + (apply lt_tree_node || apply gt_tree_node); auto; + (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. +Hint Resolve bal_bst. -Lemma bal_in : forall l x r y, avl l -> avl r -> - (In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r). -Proof. - bal_tac; - solve [repeat rewrite create_in; intuition_in - |inv avl; avl_nns; simpl in *; false_omega]. -Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => - generalize (bal_height_1 l x r H H') (bal_height_2 l x r H H'); - omega_max - end. (** * Insertion *) -Function add (x:elt)(s:t) { struct s } : t := match s with - | Leaf => Node Leaf x Leaf 1 - | Node l y r h => - match X.compare x y with - | LT _ => bal (add x l) y r - | EQ _ => Node l y r h - | GT _ => bal l y (add x r) - end - end. - -Lemma add_avl_1 : forall s x, avl s -> - avl (add x s) /\ 0 <= height (add x s) - height s <= 1. -Proof. - intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *. - intuition; try constructor; simpl; auto; try omega_max. - (* LT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. - (* EQ *) - intuition; omega_max. - (* GT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. - -Lemma add_avl : forall s x, avl s -> avl (add x s). -Proof. - intros; generalize (add_avl_1 s x H); intuition. -Qed. -Hint Resolve add_avl. - -Lemma add_in : forall s x y, avl s -> - (In y (add x s) <-> X.eq y x \/ In y s). +Lemma add_in : forall s x y, + In y (add x s) <-> X.eq y x \/ In y s. Proof. - intros s x; functional induction (add x s); auto; intros. - intuition_in. - (* LT *) - inv avl. - rewrite bal_in; auto. - rewrite (IHt y0 H0); intuition_in. - (* EQ *) - inv avl. - intuition. + intros s x; functional induction (add x s); auto; intros; + try rewrite bal_in, IHt; intuition_in. eapply In_1; eauto. - (* GT *) - inv avl. - rewrite bal_in; auto. - rewrite (IHt y0 H1); intuition_in. Qed. -Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s). +Lemma add_bst : forall s x, bst s -> bst (add x s). Proof. - intros s x; functional induction (add x s); auto; intros. - inv bst; inv avl; apply bal_bst; auto. + intros s x; functional induction (add x s); auto; intros; + inv bst; apply bal_bst; auto. (* lt_tree -> lt_tree (add ...) *) - red; red in H4. + red; red in H3. intros. - rewrite (add_in l x y0 H) in H0. + rewrite add_in in H. intuition. eauto. - inv bst; inv avl; apply bal_bst; auto. + inv bst; auto using bal_bst. (* gt_tree -> gt_tree (add ...) *) - red; red in H4. + red; red in H3. intros. - rewrite (add_in r x y0 H5) in H0. + rewrite add_in in H. intuition. apply MX.lt_eq with x; auto. Qed. +Hint Resolve add_bst. -(** * Join - Same as [bal] but does not assume anything regarding heights - of [l] and [r]. -*) -Fixpoint join (l:t) : elt -> t -> t := - match l with - | Leaf => add - | Node ll lx lr lh => fun x => - fix join_aux (r:t) : t := match r with - | Leaf => add x l - | Node rl rx rr rh => - if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr - else create l x r - end - end. +(** * Join *) + +(* Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) Ltac join_tac := intro l; induction l as [| ll _ lx lr Hlr lh]; @@ -579,437 +818,200 @@ Ltac join_tac := end | ] ] ] ]; intros. -Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\ - 0<= height (join l x r) - max (height l) (height r) <= 1. -Proof. - (* intros l x r; functional induction join l x r. AUTRE PROBLEME! *) - join_tac. - - split; simpl; auto. - destruct (add_avl_1 r x H0). - avl_nns; omega_max. - split; auto. - set (l:=Node ll lx lr lh) in *. - destruct (add_avl_1 l x H). - simpl (height Leaf). - avl_nns; omega_max. - - inversion_clear H. - assert (height (Node rl rx rr rh) = rh); auto. - set (r := Node rl rx rr rh) in *; clearbody r. - destruct (Hlr x r H2 H0); clear Hrl Hlr. - set (j := join lr x r) in *; clearbody j. - simpl. - assert (-(3) <= height ll - height j <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - inversion_clear H0. - assert (height (Node ll lx lr lh) = lh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - destruct (Hrl H H1); clear Hrl Hlr. - set (j := join l x rl) in *; clearbody j. - simpl. - assert (-(3) <= height j - height rr <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - clear Hrl Hlr. - assert (height (Node ll lx lr lh) = lh); auto. - assert (height (Node rl rx rr rh) = rh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - set (r := Node rl rx rr rh) in *; clearbody r. - assert (-(2) <= height l - height r <= 2) by omega_max. - split. - apply create_avl; auto. - rewrite create_height; auto; omega_max. -Qed. - -Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r). -Proof. - intros; generalize (join_avl_1 l x r H H0); intuition. -Qed. -Hint Resolve join_avl. - -Lemma join_in : forall l x r y, avl l -> avl r -> - (In y (join l x r) <-> X.eq y x \/ In y l \/ In y r). +Lemma join_in : forall l x r y, + In y (join l x r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. simpl. rewrite add_in; intuition_in. - rewrite add_in; intuition_in. - - inv avl. - rewrite bal_in; auto. - rewrite Hlr; clear Hlr Hrl; intuition_in. - - inv avl. - rewrite bal_in; auto. - rewrite Hrl; clear Hlr Hrl; intuition_in. - + rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. + rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. apply create_in. Qed. -Lemma join_bst : forall l x r, bst l -> avl l -> bst r -> avl r -> +Lemma join_bst : forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x r). Proof. - join_tac. - apply add_bst; auto. - apply add_bst; auto. - - inv bst; safe_inv avl. - apply bal_bst; auto. - clear Hrl Hlr H13 H14 H16 H17 z; intro; intros. - set (r:=Node rl rx rr rh) in *; clearbody r. - rewrite (join_in lr x r y) in H13; auto. - intuition. - apply MX.lt_eq with x; eauto. - eauto. - - inv bst; safe_inv avl. - apply bal_bst; auto. - clear Hrl Hlr H13 H14 H16 H17 z; intro; intros. - set (l:=Node ll lx lr lh) in *; clearbody l. - rewrite (join_in l x rl y) in H13; auto. - intuition. - apply MX.eq_lt with x; eauto. - eauto. - - apply create_bst; auto. + join_tac; auto; inv bst; apply bal_bst; auto; + clear Hrl Hlr z; intro; intros; rewrite join_in in *. + intuition; [ apply MX.lt_eq with x | ]; eauto. + intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. +Hint Resolve join_bst. -(** * Extraction of minimum element - morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Function remove_min (l:t)(x:elt)(r:t) { struct l } : t*elt := - match l with - | Leaf => (r,x) - | Node ll lx lr lh => let (l',m) := (remove_min ll lx lr : t*elt) in (bal l' x r, m) - end. - -Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> - avl (fst (remove_min l x r)) /\ - 0 <= height (Node l x r h) - height (fst (remove_min l x r)) <= 1. -Proof. - intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. - inv avl; simpl in *; split; auto. - avl_nns; omega_max. - (* l = Node *) - inversion_clear H. - rewrite e0 in IHp;simpl in IHp;destruct (IHp lh); auto. - split; simpl in *. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. -Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> - avl (fst (remove_min l x r)). -Proof. - intros; generalize (remove_min_avl_1 l x r h H); intuition. -Qed. +(** * Extraction of minimum element *) -Lemma remove_min_in : forall l x r h y, avl (Node l x r h) -> - (In y (Node l x r h) <-> - X.eq y (snd (remove_min l x r)) \/ In y (fst (remove_min l x r))). +Lemma remove_min_in : forall l x r h y, + In y (Node l x r h) <-> + X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1. Proof. intros l x r; functional induction (remove_min l x r); simpl in *; intros. intuition_in. - (* l = Node *) - inversion_clear H. - generalize (remove_min_avl ll lx lr lh H0). - rewrite e0; simpl; intros. - rewrite bal_in; auto. - rewrite e0 in IHp;generalize (IHp lh y H0). - intuition. - inversion_clear H7; intuition. + rewrite bal_in, In_node_iff, IHp, e0; simpl; intuition. Qed. Lemma remove_min_bst : forall l x r h, - bst (Node l x r h) -> avl (Node l x r h) -> bst (fst (remove_min l x r)). + bst (Node l x r h) -> bst (remove_min l x r)#1. Proof. - intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. + intros l x r; functional induction (remove_min l x r); simpl; intros. inv bst; auto. - inversion_clear H; inversion_clear H0. - rewrite_all e0;simpl in *. + inversion_clear H. + specialize IHp with (1:=H0); rewrite e0 in IHp; auto. apply bal_bst; auto. - firstorder. - intro; intros. - generalize (remove_min_in ll lx lr lh y H). - rewrite e0; simpl. - destruct 1. - apply H3; intuition. + intro y; specialize (H2 y). + rewrite remove_min_in, e0 in H2; simpl in H2; intuition. Qed. Lemma remove_min_gt_tree : forall l x r h, - bst (Node l x r h) -> avl (Node l x r h) -> - gt_tree (snd (remove_min l x r)) (fst (remove_min l x r)). + bst (Node l x r h) -> + gt_tree (remove_min l x r)#2 (remove_min l x r)#1. Proof. - intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. + intros l x r; functional induction (remove_min l x r); simpl; intros. inv bst; auto. - inversion_clear H; inversion_clear H0. - intro; intro. - generalize (IHp lh H1 H); clear H6 H7 IHp. - generalize (remove_min_avl ll lx lr lh H). - generalize (remove_min_in ll lx lr lh m H). - rewrite e0; simpl; intros. - rewrite (bal_in l' x r y H7 H5) in H0. - destruct H6. - firstorder. - apply MX.lt_eq with x; auto. - apply X.lt_trans with x; auto. + inversion_clear H. + specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp. + intro y; rewrite bal_in; intuition; + specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; + [ apply MX.lt_eq with x | ]; eauto. Qed. +Hint Resolve remove_min_bst remove_min_gt_tree. -(** * Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) -Function merge (s1 s2 :t) : t:= match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => - let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' -end. -Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> - avl (merge s1 s2) /\ - 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. -Proof. - intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros. - split; auto; avl_nns; omega_max. - split; auto; avl_nns; simpl in *; omega_max. - destruct s1;try contradiction;clear y. - generalize (remove_min_avl_1 l2 x2 r2 h2 H0). - rewrite e1; simpl; destruct 1. - split. - apply bal_avl; auto. - simpl; omega_max. - omega_bal. -Qed. - -Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). -Proof. - intros; generalize (merge_avl_1 s1 s2 H H0 H1); intuition. -Qed. +(** * Merging two trees *) -Lemma merge_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (In y (merge s1 s2) <-> In y s1 \/ In y s2). -Proof. - intros s1 s2; functional induction (merge s1 s2); subst; simpl in *; intros. +Lemma merge_in : forall s1 s2 y, + In y (merge s1 s2) <-> In y s1 \/ In y s2. +Proof. + intros s1 s2; functional induction (merge s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. intuition_in. intuition_in. - destruct s1;try contradiction;clear y. - replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite e1; auto]. - rewrite bal_in; auto. - generalize (remove_min_avl l2 x2 r2 h2); rewrite e1; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 y0); rewrite e1; simpl; intro. - rewrite H3 ; intuition. + rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> +Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (merge s1 s2). + bst (merge s1 s2). Proof. - intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto. - destruct s1;try contradiction;clear y. + intros s1 s2; functional induction (merge s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. apply bal_bst; auto. - generalize (remove_min_bst l2 x2 r2 h2); rewrite e1; simpl in *; auto. - intro; intro. - apply H3; auto. - generalize (remove_min_in l2 x2 r2 h2 m); rewrite e1; simpl; intuition. - generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite e1; simpl; auto. -Qed. + change s2' with ((s2',m)#1); rewrite <-e1; eauto. + intros y Hy. + apply H1; auto. + rewrite remove_min_in, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. +Qed. +Hint Resolve merge_bst. -(** * Deletion *) -Function remove (x:elt)(s:tree) { struct s } : t := match s with - | Leaf => Leaf - | Node l y r h => - match X.compare x y with - | LT _ => bal (remove x l) y r - | EQ _ => merge l r - | GT _ => bal l y (remove x r) - end - end. -Lemma remove_avl_1 : forall s x, avl s -> - avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. -Proof. - intros s x; functional induction (remove x s); subst;simpl; intros. - intuition; omega_max. - (* LT *) - inv avl. - destruct (IHt H0). - split. - apply bal_avl; auto. - omega_max. - omega_bal. - (* EQ *) - inv avl. - generalize (merge_avl_1 l r H0 H1 H2). - intuition omega_max. - (* GT *) - inv avl. - destruct (IHt H1). - split. - apply bal_avl; auto. - omega_max. - omega_bal. -Qed. - -Lemma remove_avl : forall s x, avl s -> avl (remove x s). -Proof. - intros; generalize (remove_avl_1 s x H); intuition. -Qed. -Hint Resolve remove_avl. +(** * Deletion *) -Lemma remove_in : forall s x y, bst s -> avl s -> +Lemma remove_in : forall s x y, bst s -> (In y (remove x s) <-> ~ X.eq y x /\ In y s). Proof. - intros s x; functional induction (remove x s); subst;simpl; intros. + intros s x; functional induction (remove x s); intros; inv bst. intuition_in. - (* LT *) - inv avl; inv bst; clear e0. - rewrite bal_in; auto. - generalize (IHt y0 H0); intuition; [ order | order | intuition_in ]. - (* EQ *) - inv avl; inv bst; clear e0. - rewrite merge_in; intuition; [ order | order | intuition_in ]. - elim H9; eauto. - (* GT *) - inv avl; inv bst; clear e0. - rewrite bal_in; auto. - generalize (IHt y0 H5); intuition; [ order | order | intuition_in ]. + rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. + rewrite merge_in; clear e0; intuition; [order|order|intuition_in]. + elim H4; eauto. + rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. Qed. -Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s). +Lemma remove_bst : forall s x, bst s -> bst (remove x s). Proof. - intros s x; functional induction (remove x s); simpl; intros. + intros s x; functional induction (remove x s); intros; inv bst. auto. (* LT *) - inv avl; inv bst. apply bal_bst; auto. - intro; intro. - rewrite (remove_in l x y0) in H; auto. - destruct H; eauto. + intro z; rewrite remove_in; auto; destruct 1; eauto. (* EQ *) - inv avl; inv bst. - apply merge_bst; eauto. + eauto. (* GT *) - inv avl; inv bst. apply bal_bst; auto. - intro; intro. - rewrite (remove_in r x y0) in H; auto. - destruct H; eauto. + intro z; rewrite remove_in; auto; destruct 1; eauto. Qed. +Hint Resolve remove_bst. - (** * Minimum element *) -Function min_elt (s:t) : option elt := match s with - | Leaf => None - | Node Leaf y _ _ => Some y - | Node l _ _ _ => min_elt l -end. +(** * Minimum element *) Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. Proof. - intro s; functional induction (min_elt s); subst; simpl. - inversion 1. - inversion 1; auto. - intros. - destruct l; auto. + intro s; functional induction (min_elt s); auto; inversion 1; auto. Qed. -Lemma min_elt_2 : forall s x y, bst s -> +Lemma min_elt_2 : forall s x y, bst s -> min_elt s = Some x -> In y s -> ~ X.lt y x. Proof. - intro s; functional induction (min_elt s); subst;simpl. + intro s; functional induction (min_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. inversion_clear 2. inversion_clear 1. inversion 1; subst. inversion_clear 1; auto. inversion_clear H5. - destruct l;try contradiction. inversion_clear 1. simpl. destruct l1. inversion 1; subst. - assert (X.lt x _x) by (apply H2; auto). + assert (X.lt x y) by (apply H2; auto). inversion_clear 1; auto; order. - assert (X.lt t _x) by auto. + assert (X.lt x1 y) by auto. inversion_clear 2; auto; - (assert (~ X.lt t x) by auto); order. + (assert (~ X.lt x1 x) by auto); order. Qed. Lemma min_elt_3 : forall s, min_elt s = None -> Empty s. Proof. - intro s; functional induction (min_elt s); subst;simpl. - red; auto. + intro s; functional induction (min_elt s). + red; red; inversion 2. inversion 1. - destruct l;try contradiction. - clear y;intro H0. - destruct (IHo H0 t); auto. + intro H0. + destruct (IHo H0 _x2); auto. Qed. -(** * Maximum element *) -Function max_elt (s:t) : option elt := match s with - | Leaf => None - | Node _ y Leaf _ => Some y - | Node _ _ r _ => max_elt r -end. +(** * Maximum element *) Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. Proof. - intro s; functional induction (max_elt s); subst;simpl. - inversion 1. - inversion 1; auto. - destruct r;try contradiction; auto. + intro s; functional induction (max_elt s); auto; inversion 1; auto. Qed. Lemma max_elt_2 : forall s x y, bst s -> max_elt s = Some x -> In y s -> ~ X.lt x y. Proof. - intro s; functional induction (max_elt s); subst;simpl. + intro s; functional induction (max_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. inversion_clear 2. inversion_clear 1. inversion 1; subst. inversion_clear 1; auto. inversion_clear H5. - destruct r;try contradiction. inversion_clear 1. -(* inversion 1; subst. *) -(* assert (X.lt y x) by (apply H4; auto). *) -(* inversion_clear 1; auto; order. *) - assert (X.lt _x0 t) by auto. + assert (X.lt y x1) by auto. inversion_clear 2; auto; - (assert (~ X.lt x t) by auto); order. + (assert (~ X.lt x x1) by auto); order. Qed. Lemma max_elt_3 : forall s, max_elt s = None -> Empty s. Proof. - intro s; functional induction (max_elt s); subst;simpl. + intro s; functional induction (max_elt s). red; auto. inversion 1. - destruct r;try contradiction. - intros H0; destruct (IHo H0 t); auto. + intros H0; destruct (IHo H0 _x2); auto. Qed. -(** * Any element *) -Definition choose := min_elt. + +(** * Any element *) Lemma choose_1 : forall s x, choose s = Some x -> In x s. Proof. @@ -1021,353 +1023,215 @@ Proof. exact min_elt_3. Qed. -(** * Concatenation +Lemma choose_3 : forall s s', bst s -> bst s' -> + forall x x', choose s = Some x -> choose s' = Some x' -> + Equal s s' -> X.eq x x'. +Proof. + unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_2 with s'; auto. + rewrite <-H; auto using min_elt_1. + assert (~X.lt x' x). + apply min_elt_2 with s; auto. + rewrite H; auto using min_elt_1. + destruct (X.compare x x'); intuition. +Qed. - Same as [merge] but does not assume anything about heights. -*) -Function concat (s1 s2 : t) : t := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => - let (s2',m) := remove_min l2 x2 r2 in - join s1 m s2' - end. +(** * Concatenation *) -Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2). +Lemma concat_in : forall s1 s2 y, + In y (concat s1 s2) <-> In y s1 \/ In y s2. Proof. - intros s1 s2; functional induction (concat s1 s2); subst;auto. - destruct s1;try contradiction;clear y. - intros; apply join_avl; auto. - generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite e1; simpl; auto. + intros s1 s2; functional induction (concat s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + intuition_in. + intuition_in. + rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma concat_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> +Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> bst (concat s1 s2). Proof. - intros s1 s2; functional induction (concat s1 s2); subst ;auto. - destruct s1;try contradiction;clear y. - intros; apply join_bst; auto. - generalize (remove_min_bst l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto. - generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 m H2); rewrite e1; simpl; auto. - destruct 1; intuition. - generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto. -Qed. - -Lemma concat_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - (In y (concat s1 s2) <-> In y s1 \/ In y s2). -Proof. - intros s1 s2; functional induction (concat s1 s2);subst;simpl. - intuition. - inversion_clear H5. - destruct s1;try contradiction;clear y;intuition. - inversion_clear H5. - destruct s1;try contradiction;clear y; intros. - rewrite (join_in (Node s1_1 t s1_2 i) m s2' y H0). - generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 y H2); rewrite e1; simpl. - intro EQ; rewrite EQ; intuition. + intros s1 s2; functional induction (concat s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. + apply join_bst; auto. + change (bst (s2',m)#1); rewrite <-e1; eauto. + intros y Hy. + apply H1; auto. + rewrite remove_min_in, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. Qed. +Hint Resolve concat_bst. -(** * Splitting - [split x s] returns a triple [(l, present, r)] where - - [l] is the set of elements of [s] that are [< x] - - [r] is the set of elements of [s] that are [> x] - - [present] is [true] if and only if [s] contains [x]. -*) +(** * Splitting *) -Function split (x:elt)(s:t) {struct s} : t * (bool * t) := match s with - | Leaf => (Leaf, (false, Leaf)) - | Node l y r h => - match X.compare x y with - | LT _ => match split x l with - | (ll,(pres,rl)) => (ll, (pres, join rl y r)) - end - | EQ _ => (l, (true, r)) - | GT _ => match split x r with - | (rl,(pres,rr)) => (join l y rl, (pres, rr)) - end - end - end. - -Lemma split_avl : forall s x, avl s -> - avl (fst (split x s)) /\ avl (snd (snd (split x s))). -Proof. - intros s x; functional induction (split x s);subst;simpl in *. - auto. - rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition. - simpl; inversion_clear 1; auto. - rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition. -Qed. - -Lemma split_in_1 : forall s x y, bst s -> avl s -> - (In y (fst (split x s)) <-> In y s /\ X.lt y x). -Proof. - intros s x; functional induction (split x s);subst;simpl in *. - intuition; try inversion_clear H1. - (* LT *) - rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite (IHp y0 H0 H4); clear IHp e0. - intuition. - inversion_clear H6; auto; order. - (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0. - intuition. - order. +Lemma split_in_1 : forall s x y, bst s -> + (In y (split x s)#l <-> In y s /\ X.lt y x). +Proof. + intros s x; functional induction (split x s); simpl; intros; + inv bst; try clear e0. + intuition_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. intuition_in; order. - (* GT *) - rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite join_in; auto. - generalize (split_avl r x H5); rewrite e1; simpl; intuition. - rewrite (IHp y0 H1 H5); clear e1. - intuition; [ eauto | eauto | intuition_in ]. + rewrite join_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_2 : forall s x y, bst s -> avl s -> - (In y (snd (snd (split x s))) <-> In y s /\ X.lt x y). +Lemma split_in_2 : forall s x y, bst s -> + (In y (split x s)#r <-> In y s /\ X.lt x y). Proof. - intros s x; functional induction (split x s);subst;simpl in *. - intuition; try inversion_clear H1. - (* LT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite join_in; auto. - generalize (split_avl l x H4); rewrite e1; simpl; intuition. - rewrite (IHp y0 H0 H4); clear IHp e0. - intuition; [ order | order | intuition_in ]. - (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0. - intuition; [ order | intuition_in; order ]. - (* GT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite (IHp y0 H1 H5); clear IHp e0. - intuition; intuition_in; order. + intros s x; functional induction (split x s); subst; simpl; intros; + inv bst; try clear e0. + intuition_in. + rewrite join_in. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. + intuition_in; order. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_3 : forall s x, bst s -> avl s -> - (fst (snd (split x s)) = true <-> In x s). +Lemma split_in_3 : forall s x, bst s -> + ((split x s)#b = true <-> In x s). Proof. - intros s x; functional induction (split x s);subst;simpl in *. - intuition; try inversion_clear H1. - (* LT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite IHp; auto. - intuition_in; absurd (X.lt x y); eauto. - (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; intuition. - (* GT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. - rewrite IHp; auto. - intuition_in; absurd (X.lt y x); eauto. + intros s x; functional induction (split x s); subst; simpl; intros; + inv bst; try clear e0. + intuition_in; try discriminate. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. + intuition. + rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_bst : forall s x, bst s -> avl s -> - bst (fst (split x s)) /\ bst (snd (snd (split x s))). +Lemma split_bst : forall s x, bst s -> + bst (split x s)#l /\ bst (split x s)#r. Proof. - intros s x; functional induction (split x s);subst;simpl in *. - intuition. - (* LT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. - intuition. - apply join_bst; auto. - generalize (split_avl l x H4); rewrite e1; simpl; intuition. - intro; intro. - generalize (split_in_2 l x y0 H0 H4); rewrite e1; simpl; intuition. - (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; intuition. - (* GT *) - rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. - intuition. - apply join_bst; auto. - generalize (split_avl r x H5); rewrite e1; simpl; intuition. - intro; intro. - generalize (split_in_1 r x y0 H1 H5); rewrite e1; simpl; intuition. + intros s x; functional induction (split x s); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; + apply join_bst; auto. + intros y0. + generalize (split_in_2 x y0 H0); rewrite e1; simpl; intuition. + intros y0. + generalize (split_in_1 x y0 H1); rewrite e1; simpl; intuition. Qed. -(** * Intersection *) -Fixpoint inter (s1 s2 : t) {struct s1} : t := match s1, s2 with - | Leaf,_ => Leaf - | _,Leaf => Leaf - | Node l1 x1 r1 h1, _ => - match split x1 s2 with - | (l2',(true,r2')) => join (inter l1 l2') x1 (inter r1 r2') - | (l2',(false,r2')) => concat (inter l1 l2') (inter r1 r2') - end - end. -Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). -Proof. - (* intros s1 s2; functional induction inter s1 s2; auto. BOF BOF *) - induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto. - destruct s2 as [ | l2 x2 r2 h2]; intros; auto. - generalize H0; inv avl. - set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. - destruct (split_avl r x1 H8). - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct b; [ apply join_avl | apply concat_avl ]; auto. -Qed. +(** * Intersection *) -Lemma inter_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> +Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. - induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto. - intuition; inversion_clear H3. - destruct s2 as [ | l2 x2 r2 h2]; intros. - simpl; intuition; inversion_clear H3. - generalize H1 H2; inv avl; inv bst. - set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. - destruct (split_avl r x1 H17). - destruct (split_bst r x1 H16 H17). - split. - (* bst *) - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct (Hl1 l2'); auto. - destruct (Hr1 r2'); auto. - destruct b. +Proof. + intros s1 s2; functional induction inter s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; + generalize (split_bst x1 B2); + rewrite e1; simpl; destruct 1; inv bst; + destruct IHt as (IHb1,IHi1); auto; + destruct IHt0 as (IHb2,IHi2); auto; + generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) + (split_in_3 x1 B2)(split_bst x1 B2); + rewrite e1; simpl; split; intros. (* bst join *) - apply join_bst; try apply inter_avl; firstorder. - (* bst concat *) - apply concat_bst; try apply inter_avl; auto. - intros; generalize (H22 y1) (H24 y2); intuition eauto. - (* in *) - intros. - destruct (split_in_1 r x1 y H16 H17). - destruct (split_in_2 r x1 y H16 H17). - destruct (split_in_3 r x1 H16 H17). - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct (Hl1 l2'); auto. - destruct (Hr1 r2'); auto. - destruct b. - (* in join *) - rewrite join_in; try apply inter_avl; auto. - rewrite H30. - rewrite H28. - intuition_in. + apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) + rewrite join_in, IHi1, IHi2, H5, H6; intuition_in. apply In_1 with x1; auto. - (* in concat *) - rewrite concat_in; try apply inter_avl; auto. - intros. - intros; generalize (H28 y1) (H30 y2); intuition eauto. - rewrite H30. - rewrite H28. + (* bst concat *) + apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* In concat *) + rewrite concat_in, IHi1, IHi2, H5, H6; auto. + assert (~In x1 s2) by (rewrite <- H7; auto). intuition_in. - generalize (H26 (In_1 _ _ _ H22 H35)); intro; discriminate. + elim H9. + apply In_1 with y; auto. Qed. -Lemma inter_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - bst (inter s1 s2). +Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> + (In y (inter s1 s2) <-> In y s1 /\ In y s2). Proof. - intros; generalize (inter_bst_in s1 s2); intuition. + intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto. Qed. -Lemma inter_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (In y (inter s1 s2) <-> In y s1 /\ In y s2). +Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2). Proof. - intros; generalize (inter_bst_in s1 s2); firstorder. + intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto. Qed. -(** * Difference *) - -Fixpoint diff (s1 s2 : t) { struct s1 } : t := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - match split x1 s2 with - | (l2',(true,r2')) => concat (diff l1 l2') (diff r1 r2') - | (l2',(false,r2')) => join (diff l1 l2') x1 (diff r1 r2') - end -end. -Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). -Proof. - (* intros s1 s2; functional induction diff s1 s2; auto. BOF BOF *) - induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto. - destruct s2 as [ | l2 x2 r2 h2]; intros; auto. - generalize H0; inv avl. - set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. - destruct (split_avl r x1 H8). - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct b; [ apply concat_avl | apply join_avl ]; auto. -Qed. +(** * Difference *) -Lemma diff_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> +Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. - induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto. - intuition; inversion_clear H3. - destruct s2 as [ | l2 x2 r2 h2]; intros; auto. - intuition; inversion_clear H4. - generalize H1 H2; inv avl; inv bst. - set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. - destruct (split_avl r x1 H17). - destruct (split_bst r x1 H16 H17). - split. - (* bst *) - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct (Hl1 l2'); auto. - destruct (Hr1 r2'); auto. - destruct b. +Proof. + intros s1 s2; functional induction diff s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; + generalize (split_bst x1 B2); + rewrite e1; simpl; destruct 1; + inv avl; inv bst; + destruct IHt as (IHb1,IHi1); auto; + destruct IHt0 as (IHb2,IHi2); auto; + generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) + (split_in_3 x1 B2)(split_bst x1 B2); + rewrite e1; simpl; split; intros. (* bst concat *) - apply concat_bst; try apply diff_avl; auto. - intros; generalize (H22 y1) (H24 y2); intuition eauto. + apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* In concat *) + rewrite concat_in, IHi1, IHi2, H5, H6; intuition_in. + elim H13. + apply In_1 with x1; auto. (* bst join *) - apply join_bst; try apply diff_avl; firstorder. - (* in *) - intros. - destruct (split_in_1 r x1 y H16 H17). - destruct (split_in_2 r x1 y H16 H17). - destruct (split_in_3 r x1 H16 H17). - destruct (split x1 r) as [l2' (b,r2')]; simpl in *. - destruct (Hl1 l2'); auto. - destruct (Hr1 r2'); auto. - destruct b. - (* in concat *) - rewrite concat_in; try apply diff_avl; auto. - intros. - intros; generalize (H28 y1) (H30 y2); intuition eauto. - rewrite H30. - rewrite H28. + apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) + rewrite join_in, IHi1, IHi2, H5, H6; auto. + assert (~In x1 s2) by (rewrite <- H7; auto). intuition_in. - elim H35; apply In_1 with x1; auto. - (* in join *) - rewrite join_in; try apply diff_avl; auto. - rewrite H30. - rewrite H28. - intuition_in. - generalize (H26 (In_1 _ _ _ H34 H24)); intro; discriminate. + elim H9. + apply In_1 with y; auto. Qed. -Lemma diff_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - bst (diff s1 s2). +Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> + (In y (diff s1 s2) <-> In y s1 /\ ~In y s2). Proof. - intros; generalize (diff_bst_in s1 s2); intuition. + intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto. Qed. -Lemma diff_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - (In y (diff s1 s2) <-> In y s1 /\ ~In y s2). +Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). Proof. - intros; generalize (diff_bst_in s1 s2); firstorder. + intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto. Qed. -(** * Elements *) -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) +(** * Union *) -Fixpoint elements_aux (acc : list X.t) (t : tree) {struct t} : list X.t := - match t with - | Leaf => acc - | Node l x r _ => elements_aux (x :: elements_aux acc r) l - end. +Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> + (In y (union s1 s2) <-> In y s1 \/ In y s2). +Proof. + intros s1 s2; functional induction union s1 s2; intros y B1 B2. + intuition_in. + intuition_in. + factornode _x0 _x1 _x2 _x3 as s2. + generalize (split_in_1 x1 y B2)(split_in_2 x1 y B2)(split_bst x1 B2). + rewrite e1; simpl. + destruct 3; inv bst. + rewrite join_in, IHt, IHt0, H, H0; auto. + case (X.compare y x1); intuition_in. +Qed. -(** then [elements] is an instanciation with an empty [acc] *) +Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> + bst (union s1 s2). +Proof. + intros s1 s2; functional induction union s1 s2; intros B1 B2; auto. + factornode _x0 _x1 _x2 _x3 as s2. + generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)(split_bst x1 B2). + rewrite e1; simpl; destruct 3. + inv bst. + apply join_bst; auto. + intro y; rewrite union_in, H; intuition_in. + intro y; rewrite union_in, H0; intuition_in. +Qed. -Definition elements := elements_aux nil. + +(** * Elements *) Lemma elements_aux_in : forall s acc x, InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc. @@ -1411,246 +1275,190 @@ Proof. Qed. Hint Resolve elements_sort. -(** * Filter *) - -Section F. -Variable f : elt -> bool. +Lemma elements_nodup : forall s : tree, bst s -> NoDupA X.eq (elements s). +Proof. + auto. +Qed. -Fixpoint filter_acc (acc:t)(s:t) { struct s } : t := match s with - | Leaf => acc - | Node l x r h => - filter_acc (filter_acc (if f x then add x acc else acc) l) r - end. +Lemma elements_aux_cardinal : + forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). +Proof. + simple induction s; simpl in |- *; intuition. + rewrite <- H. + simpl in |- *. + rewrite <- H0; omega. +Qed. -Definition filter := filter_acc Leaf. +Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). +Proof. + exact (fun s => elements_aux_cardinal s nil). +Qed. -Lemma filter_acc_avl : forall s acc, avl s -> avl acc -> - avl (filter_acc acc s). +Lemma elements_app : + forall s acc, elements_aux acc s = elements s ++ acc. Proof. - induction s; simpl; auto. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); auto. -Qed. -Hint Resolve filter_acc_avl. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. +Qed. -Lemma filter_acc_bst : forall s acc, bst s -> avl s -> bst acc -> avl acc -> - bst (filter_acc acc s). +Lemma elements_node : + forall l x r h acc, + elements l ++ x :: elements r ++ acc = + elements (Node l x r h) ++ acc. Proof. - induction s; simpl; auto. - intros. - inv avl; inv bst. - destruct (f t); auto. - apply IHs2; auto. - apply IHs1; auto. - apply add_bst; auto. -Qed. + unfold elements; simpl; intros; auto. + rewrite !elements_app, <- !app_nil_end, !app_ass; auto. +Qed. + -Lemma filter_acc_in : forall s acc, avl s -> avl acc -> +(** * Filter *) + +Section F. +Variable f : elt -> bool. + +Lemma filter_acc_in : forall s acc, compat_bool X.eq f -> forall x : elt, - In x (filter_acc acc s) <-> In x acc \/ In x s /\ f x = true. + In x (filter_acc f acc s) <-> In x acc \/ In x s /\ f x = true. Proof. induction s; simpl; intros. intuition_in. - inv bst; inv avl. - rewrite IHs2; auto. - destruct (f t); auto. - rewrite IHs1; auto. - destruct (f t); auto. + rewrite IHs2, IHs1 by (destruct (f t); auto). case_eq (f t); intros. rewrite (add_in); auto. intuition_in. - rewrite (H1 _ _ H8). + rewrite (H _ _ H2). intuition. intuition_in. - rewrite (H1 _ _ H8) in H9. - rewrite H in H9; discriminate. -Qed. - -Lemma filter_avl : forall s, avl s -> avl (filter s). -Proof. - unfold filter; intros; apply filter_acc_avl; auto. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. Qed. -Lemma filter_bst : forall s, bst s -> avl s -> bst (filter s). +Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> + bst (filter_acc f acc s). Proof. - unfold filter; intros; apply filter_acc_bst; auto. + induction s; simpl; auto. + intros. + inv bst. + destruct (f t); auto. Qed. -Lemma filter_in : forall s, avl s -> +Lemma filter_in : forall s, compat_bool X.eq f -> forall x : elt, - In x (filter s) <-> In x s /\ f x = true. + In x (filter f s) <-> In x s /\ f x = true. Proof. unfold filter; intros; rewrite filter_acc_in; intuition_in. -Qed. - -(** * Partition *) - -Fixpoint partition_acc (acc : t*t)(s : t) { struct s } : t*t := - match s with - | Leaf => acc - | Node l x r _ => - let (acct,accf) := acc in - partition_acc - (partition_acc - (if f x then (add x acct, accf) else (acct, add x accf)) l) r - end. - -Definition partition := partition_acc (Leaf,Leaf). +Qed. -Lemma partition_acc_avl_1 : forall s acc, avl s -> - avl (fst acc) -> avl (fst (partition_acc acc s)). +Lemma filter_bst : forall s, bst s -> bst (filter f s). Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. + unfold filter; intros; apply filter_acc_bst; auto. +Qed. -Lemma partition_acc_avl_2 : forall s acc, avl s -> - avl (snd acc) -> avl (snd (partition_acc acc s)). -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. -Hint Resolve partition_acc_avl_1 partition_acc_avl_2. -Lemma partition_acc_bst_1 : forall s acc, bst s -> avl s -> - bst (fst acc) -> avl (fst acc) -> - bst (fst (partition_acc acc s)). -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl; inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. - apply add_bst; auto. - apply partition_acc_avl_1; simpl; auto. -Qed. -Lemma partition_acc_bst_2 : forall s acc, bst s -> avl s -> - bst (snd acc) -> avl (snd acc) -> - bst (snd (partition_acc acc s)). -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl; inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. - apply add_bst; auto. - apply partition_acc_avl_2; simpl; auto. -Qed. +(** * Partition *) -Lemma partition_acc_in_1 : forall s acc, avl s -> avl (fst acc) -> +Lemma partition_acc_in_1 : forall s acc, compat_bool X.eq f -> forall x : elt, - In x (fst (partition_acc acc s)) <-> - In x (fst acc) \/ In x s /\ f x = true. + In x (partition_acc f acc s)#1 <-> + In x acc#1 \/ In x s /\ f x = true. Proof. induction s; simpl; intros. intuition_in. destruct acc as [acct accf]; simpl in *. - inv bst; inv avl. - rewrite IHs2; auto. - destruct (f t); auto. - apply partition_acc_avl_1; simpl; auto. - rewrite IHs1; auto. - destruct (f t); simpl; auto. + rewrite IHs2 by + (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto). + rewrite IHs1 by (destruct (f t); simpl; auto). case_eq (f t); simpl; intros. rewrite (add_in); auto. intuition_in. - rewrite (H1 _ _ H8). + rewrite (H _ _ H2). intuition. intuition_in. - rewrite (H1 _ _ H8) in H9. - rewrite H in H9; discriminate. -Qed. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. +Qed. -Lemma partition_acc_in_2 : forall s acc, avl s -> avl (snd acc) -> +Lemma partition_acc_in_2 : forall s acc, compat_bool X.eq f -> forall x : elt, - In x (snd (partition_acc acc s)) <-> - In x (snd acc) \/ In x s /\ f x = false. + In x (partition_acc f acc s)#2 <-> + In x acc#2 \/ In x s /\ f x = false. Proof. induction s; simpl; intros. intuition_in. destruct acc as [acct accf]; simpl in *. - inv bst; inv avl. - rewrite IHs2; auto. - destruct (f t); auto. - apply partition_acc_avl_2; simpl; auto. - rewrite IHs1; auto. - destruct (f t); simpl; auto. + rewrite IHs2 by + (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto). + rewrite IHs1 by (destruct (f t); simpl; auto). case_eq (f t); simpl; intros. intuition. intuition_in. - rewrite (H1 _ _ H8) in H9. - rewrite H in H9; discriminate. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. rewrite (add_in); auto. intuition_in. - rewrite (H1 _ _ H8). + rewrite (H _ _ H2). intuition. +Qed. + +Lemma partition_in_1 : forall s, + compat_bool X.eq f -> forall x : elt, + In x (partition f s)#1 <-> In x s /\ f x = true. +Proof. + unfold partition; intros; rewrite partition_acc_in_1; + simpl in *; intuition_in. Qed. -Lemma partition_avl_1 : forall s, avl s -> avl (fst (partition s)). +Lemma partition_in_2 : forall s, + compat_bool X.eq f -> forall x : elt, + In x (partition f s)#2 <-> In x s /\ f x = false. Proof. - unfold partition; intros; apply partition_acc_avl_1; auto. + unfold partition; intros; rewrite partition_acc_in_2; + simpl in *; intuition_in. +Qed. + +Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> + bst (partition_acc f acc s)#1. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. + inv bst. + destruct (f t); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto. Qed. -Lemma partition_avl_2 : forall s, avl s -> avl (snd (partition s)). +Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> + bst (partition_acc f acc s)#2. Proof. - unfold partition; intros; apply partition_acc_avl_2; auto. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. + inv bst. + destruct (f t); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto. Qed. -Lemma partition_bst_1 : forall s, bst s -> avl s -> - bst (fst (partition s)). +Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. Proof. unfold partition; intros; apply partition_acc_bst_1; auto. Qed. -Lemma partition_bst_2 : forall s, bst s -> avl s -> - bst (snd (partition s)). +Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. Proof. unfold partition; intros; apply partition_acc_bst_2; auto. Qed. -Lemma partition_in_1 : forall s, avl s -> - compat_bool X.eq f -> forall x : elt, - In x (fst (partition s)) <-> In x s /\ f x = true. -Proof. - unfold partition; intros; rewrite partition_acc_in_1; - simpl in *; intuition_in. -Qed. - -Lemma partition_in_2 : forall s, avl s -> - compat_bool X.eq f -> forall x : elt, - In x (snd (partition s)) <-> In x s /\ f x = false. -Proof. - unfold partition; intros; rewrite partition_acc_in_2; - simpl in *; intuition_in. -Qed. -(** [for_all] and [exists] *) -Fixpoint for_all (s:t) : bool := match s with - | Leaf => true - | Node l x r _ => f x && for_all l && for_all r -end. +(** * [for_all] and [exists] *) -Lemma for_all_1 : forall s, compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all s = true. +Lemma for_all_1 : forall s, compat_bool X.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. Proof. induction s; simpl; auto. intros. @@ -1660,8 +1468,8 @@ Proof. destruct (f t); simpl; auto. Qed. -Lemma for_all_2 : forall s, compat_bool E.eq f -> - for_all s = true -> For_all (fun x => f x = true) s. +Lemma for_all_2 : forall s, compat_bool X.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. Proof. induction s; simpl; auto; intros; red; intros; inv In. destruct (andb_prop _ _ H0); auto. @@ -1673,52 +1481,40 @@ Proof. destruct (andb_prop _ _ H0); auto. Qed. -Fixpoint exists_ (s:t) : bool := match s with - | Leaf => false - | Node l x r _ => f x || exists_ l || exists_ r -end. - -Lemma exists_1 : forall s, compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ s = true. +Lemma exists_1 : forall s, compat_bool X.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true. Proof. - induction s; simpl; destruct 2 as (x,(U,V)); inv In. + induction s; simpl; destruct 2 as (x,(U,V)); inv In; rewrite <- ?orb_lazy_alt. rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto. apply orb_true_intro; left. - apply orb_true_intro; right; apply IHs1; firstorder. - apply orb_true_intro; right; apply IHs2; firstorder. + apply orb_true_intro; right; apply IHs1; auto; exists x; auto. + apply orb_true_intro; right; apply IHs2; auto; exists x; auto. Qed. -Lemma exists_2 : forall s, compat_bool E.eq f -> - exists_ s = true -> Exists (fun x => f x = true) s. +Lemma exists_2 : forall s, compat_bool X.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s. Proof. - induction s; simpl; intros. + induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. discriminate. destruct (orb_true_elim _ _ H0) as [H1|H1]. destruct (orb_true_elim _ _ H1) as [H2|H2]. exists t; auto. - destruct (IHs1 H H2); firstorder. - destruct (IHs2 H H1); firstorder. -Qed. + destruct (IHs1 H H2); auto; exists x; intuition. + destruct (IHs2 H H1); auto; exists x; intuition. +Qed. End F. -(** * Fold *) -Module L := FSetList.Raw X. -Fixpoint fold (A : Set) (f : elt -> A -> A)(s : tree) {struct s} : A -> A := - fun a => match s with - | Leaf => a - | Node l x r _ => fold A f r (f x (fold A f l a)) - end. -Implicit Arguments fold [A]. +(** * Fold *) -Definition fold' (A : Set) (f : elt -> A -> A)(s : tree) := +Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := L.fold f (elements s). Implicit Arguments fold' [A]. Lemma fold_equiv_aux : - forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt), + forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt), L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). Proof. simple induction s. @@ -1730,7 +1526,7 @@ Proof. Qed. Lemma fold_equiv : - forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A), + forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. unfold fold', elements in |- *. @@ -1741,7 +1537,7 @@ Proof. Qed. Lemma fold_1 : - forall (s:t)(Hs:bst s)(A : Set)(f : elt -> A -> A)(i : A), + forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. intros. @@ -1752,416 +1548,168 @@ Proof. apply elements_sort; auto. Qed. -(** * Cardinal *) - -Fixpoint cardinal (s : tree) : nat := - match s with - | Leaf => 0%nat - | Node l _ r _ => S (cardinal l + cardinal r) - end. +(** * Subset *) -Lemma cardinal_elements_aux_1 : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). +Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2, + bst (Node l1 x1 Leaf h1) -> bst s2 -> + (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> + (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). Proof. - simple induction s; simpl in |- *; intuition. - rewrite <- H. - simpl in |- *. - rewrite <- H0; omega. -Qed. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': In x1 Leaf) by auto; inversion H'. + inversion_clear H0. + specialize (IHl2 H H2 H1). + specialize (IHr2 H H3 H1). + inv bst. clear H8. + destruct X.compare. + + rewrite IHl2; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Lemma cardinal_elements_1 : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => cardinal_elements_aux_1 s nil). -Qed. + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -(** NB: the remaining functions (union, subset, compare) are still defined - in a dependent style, due to the use of well-founded induction. *) + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (H':=mem_2 H6); apply In_1 with x1; auto. + apply mem_1; auto. + assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. -(** Induction over cardinals *) -Lemma sorted_subset_cardinal : forall l' l : list X.t, - sort X.lt l -> sort X.lt l' -> - (forall x : elt, InA X.eq x l -> InA X.eq x l') -> (length l <= length l')%nat. +Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2, + bst (Node Leaf x1 r1 h1) -> bst s2 -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). Proof. - simple induction l'; simpl in |- *; intuition. - destruct l; trivial; intros. - absurd (InA X.eq t nil); intuition. - inversion_clear H2. - inversion_clear H1. - destruct l0; simpl in |- *; intuition. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': In x1 Leaf) by auto; inversion H'. inversion_clear H0. - apply le_n_S. - case (X.compare t a); intro. - absurd (InA X.eq t (a :: l)). - intro. - inversion_clear H0. - order. - assert (X.lt a t). - apply MX.Sort_Inf_In with l; auto. - order. - firstorder. - apply H; auto. - intros. - assert (InA X.eq x (a :: l)). - apply H2; auto. - inversion_clear H6; auto. - assert (X.lt t x). - apply MX.Sort_Inf_In with l0; auto. - order. - apply le_trans with (length (t :: l0)). - simpl in |- *; omega. - apply (H (t :: l0)); auto. - intros. - assert (InA X.eq x (a :: l)); firstorder. - inversion_clear H6; auto. - assert (X.lt a x). - apply MX.Sort_Inf_In with (t :: l0); auto. - elim (X.lt_not_eq (x:=a) (y:=x)); auto. -Qed. - -Lemma cardinal_subset : forall a b : tree, bst a -> bst b -> - (forall y : elt, In y a -> In y b) -> - (cardinal a <= cardinal b)%nat. -Proof. - intros. - do 2 rewrite cardinal_elements_1. - apply sorted_subset_cardinal; auto. - intros. - generalize (elements_in a x) (elements_in b x). - intuition. + specialize (IHl2 H H2 H1). + specialize (IHr2 H H3 H1). + inv bst. clear H7. + destruct X.compare. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (H':=mem_2 H1); apply In_1 with x1; auto. + apply mem_1; auto. + assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite IHr2; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. Qed. -Lemma cardinal_left : forall (l r : tree) (x : elt) (h : int), - (cardinal l < cardinal (Node l x r h))%nat. -Proof. - simpl in |- *; intuition. -Qed. -Lemma cardinal_right : - forall (l r : tree) (x : elt) (h : int), - (cardinal r < cardinal (Node l x r h))%nat. +Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> + (subset s1 s2 = true <-> Subset s1 s2). Proof. - simpl in |- *; intuition. -Qed. + induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. + unfold Subset; intuition_in. + destruct s2 as [|l2 x2 r2 h2]; simpl; intros. + unfold Subset; intuition_in; try discriminate. + assert (H': In x1 Leaf) by auto; inversion H'. + inv bst. + destruct X.compare. + + rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. + rewrite (@subsetl_12 (subset l1) l1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. + rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. -Lemma cardinal_rec2 : forall P : tree -> tree -> Set, - (forall s1 s2 : tree, - (forall t1 t2 : tree, - (cardinal t1 + cardinal t2 < cardinal s1 + cardinal s2)%nat -> P t1 t2) - -> P s1 s2) -> - forall s1 s2 : tree, P s1 s2. -Proof. - intros P H s1 s2. - apply well_founded_induction_type_2 - with (R := fun yy' xx' : tree * tree => - (cardinal (fst yy') + cardinal (snd yy') < - cardinal (fst xx') + cardinal (snd xx'))%nat); auto. - apply (Wf_nat.well_founded_ltof _ - (fun xx' : tree * tree => (cardinal (fst xx') + cardinal (snd xx'))%nat)). -Qed. - -Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf. -Proof. - destruct 1; intuition; simpl in *. - avl_nns; simpl in *; false_omega_max. -Qed. - -(** * Union - - [union s1 s2] does an induction over the sum of the cardinals of - [s1] and [s2]. Code is -<< - let rec union s1 s2 = - match (s1, s2) with - (Empty, t2) -> t2 - | (t1, Empty) -> t1 - | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> - if h1 >= h2 then - if h2 = 1 then add v2 s1 else begin - let (l2', _, r2') = split v1 s2 in - join (union l1 l2') v1 (union r1 r2') - end - else - if h1 = 1 then add v1 s2 else begin - let (l1', _, r1') = split v2 s1 in - join (union l1' l2) v2 (union r1' r2) - end ->> -*) -Definition union : - forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> - {s' : t | bst s' /\ avl s' /\ forall x : elt, In x s' <-> In x s1 \/ In x s2}. -Proof. - intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2. - destruct s1 as [| l1 x1 r1 h1]; intros. - (* s = Leaf *) - clear H. - exists s2; intuition_in. - (* s1 = Node l1 x1 r1 *) - destruct s2 as [| l2 x2 r2 h2]; simpl in |- *. - (* s2 = Leaf *) - clear H. - exists (Node l1 x1 r1 h1); simpl; intuition_in. - (* x' = Node l2 x2 r2 *) - case (ge_lt_dec h1 h2); intro. - (* h1 >= h2 *) - case (eq_dec h2 1); intro. - (* h2 = 1 *) - clear H. - exists (add x2 (Node l1 x1 r1 h1)); auto. - inv avl; inv bst. - avl_nn l2; avl_nn r2. - rewrite (height_0 _ H); [ | omega_max]. - rewrite (height_0 _ H4); [ | omega_max]. - split; [apply add_bst; auto|]. - split; [apply add_avl; auto|]. - intros. - rewrite (add_in (Node l1 x1 r1 h1) x2 x); intuition_in. - (* h2 <> 1 *) - (* split x1 s2 = l2',_,r2' *) - case_eq (split x1 (Node l2 x2 r2 h2)); intros l2' (b,r2') EqSplit. - set (s2 := Node l2 x2 r2 h2) in *; clearbody s2. - generalize (split_avl s2 x1 H3); rewrite EqSplit; simpl in *; intros (A,B). - generalize (split_bst s2 x1 H2 H3); rewrite EqSplit; simpl in *; intros (C,D). - generalize (split_in_1 s2 x1); rewrite EqSplit; simpl in *; intros. - generalize (split_in_2 s2 x1); rewrite EqSplit; simpl in *; intros. - (* union l1 l2' = l0 *) - destruct (H l1 l2') as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto. - assert (cardinal l2' <= cardinal s2)%nat. - apply cardinal_subset; trivial. - intros y; rewrite (H4 y); intuition. - omega. - (* union r1 r2' = r0 *) - destruct (H r1 r2') as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto. - assert (cardinal r2' <= cardinal s2)%nat. - apply cardinal_subset; trivial. - intros y; rewrite (H5 y); intuition. - omega. - exists (join l0 x1 r0). - inv avl; inv bst; clear H. - split. - apply join_bst; auto. - red; intros. - rewrite (H9 y) in H. - destruct H; auto. - rewrite (H4 y) in H; intuition. - red; intros. - rewrite (H12 y) in H. - destruct H; auto. - rewrite (H5 y) in H; intuition. - split. - apply join_avl; auto. - intros. - rewrite join_in; auto. - rewrite H9. - rewrite H12. - rewrite H4; auto. - rewrite H5; auto. - intuition_in. - case (X.compare x x1); intuition. - (* h1 < h2 *) - case (eq_dec h1 1); intro. - (* h1 = 1 *) - exists (add x1 (Node l2 x2 r2 h2)); auto. - inv avl; inv bst. - avl_nn l1; avl_nn r1. - rewrite (height_0 _ H3); [ | omega_max]. - rewrite (height_0 _ H8); [ | omega_max]. - split; [apply add_bst; auto|]. - split; [apply add_avl; auto|]. - intros. - rewrite (add_in (Node l2 x2 r2 h2) x1 x); intuition_in. - (* h1 <> 1 *) - (* split x2 s1 = l1',_,r1' *) - case_eq (split x2 (Node l1 x1 r1 h1)); intros l1' (b,r1') EqSplit. - set (s1 := Node l1 x1 r1 h1) in *; clearbody s1. - generalize (split_avl s1 x2 H1); rewrite EqSplit; simpl in *; intros (A,B). - generalize (split_bst s1 x2 H0 H1); rewrite EqSplit; simpl in *; intros (C,D). - generalize (split_in_1 s1 x2); rewrite EqSplit; simpl in *; intros. - generalize (split_in_2 s1 x2); rewrite EqSplit; simpl in *; intros. - (* union l1' l2 = l0 *) - destruct (H l1' l2) as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto. - assert (cardinal l1' <= cardinal s1)%nat. - apply cardinal_subset; trivial. - intros y; rewrite (H4 y); intuition. - omega. - (* union r1' r2 = r0 *) - destruct (H r1' r2) as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto. - assert (cardinal r1' <= cardinal s1)%nat. - apply cardinal_subset; trivial. - intros y; rewrite (H5 y); intuition. - omega. - exists (join l0 x2 r0). - inv avl; inv bst; clear H. - split. - apply join_bst; auto. - red; intros. - rewrite (H9 y) in H. - destruct H; auto. - rewrite (H4 y) in H; intuition. - red; intros. - rewrite (H12 y) in H. - destruct H; auto. - rewrite (H5 y) in H; intuition. - split. - apply join_avl; auto. - intros. - rewrite join_in; auto. - rewrite H9. - rewrite H12. - rewrite H4; auto. - rewrite H5; auto. - intuition_in. - case (X.compare x x2); intuition. -Qed. - - -(** * Subset -<< - let rec subset s1 s2 = - match (s1, s2) with - Empty, _ -> true - | _, Empty -> false - | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> - let c = Ord.compare v1 v2 in - if c = 0 then - subset l1 l2 && subset r1 r2 - else if c < 0 then - subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 - else - subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 ->> -*) - -Definition subset : forall s1 s2 : t, bst s1 -> bst s2 -> - {Subset s1 s2} + {~ Subset s1 s2}. -Proof. - intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2. - destruct s1 as [| l1 x1 r1 h1]; intros. - (* s1 = Leaf *) - left; red; intros; inv In. - (* s1 = Node l1 x1 r1 h1 *) - destruct s2 as [| l2 x2 r2 h2]. - (* s2 = Leaf *) - right; intros; intro. - assert (In x1 Leaf); auto. - inversion_clear H3. - (* s2 = Node l2 x2 r2 h2 *) - case (X.compare x1 x2); intro. - (* x1 < x2 *) - case (H (Node l1 x1 Leaf 0) l2); inv bst; auto; intros. - simpl in |- *; omega. - case (H r1 (Node l2 x2 r2 h2)); inv bst; auto; intros. - simpl in |- *; omega. - clear H; left; red; intuition. - generalize (s a) (s0 a); clear s s0; intuition_in. - clear H; right; red; firstorder. - clear H; right; red; inv bst; intuition. - apply n; red; intros. - assert (In a (Node l2 x2 r2 h2)) by (inv In; auto). - intuition_in; order. - (* x1 = x2 *) - case (H l1 l2); inv bst; auto; intros. - simpl in |- *; omega. - case (H r1 r2); inv bst; auto; intros. - simpl in |- *; omega. - clear H; left; red; intuition_in; eauto. - clear H; right; red; inv bst; intuition. - apply n; red; intros. - assert (In a (Node l2 x2 r2 h2)) by auto. - intuition_in; order. - clear H; right; red; inv bst; intuition. - apply n; red; intros. - assert (In a (Node l2 x2 r2 h2)) by auto. - intuition_in; order. - (* x1 > x2 *) - case (H (Node Leaf x1 r1 0) r2); inv bst; auto; intros. - simpl in |- *; omega. - intros; case (H l1 (Node l2 x2 r2 h2)); inv bst; auto; intros. - simpl in |- *; omega. - clear H; left; red; intuition. - generalize (s a) (s0 a); clear s s0; intuition_in. - clear H; right; red; firstorder. - clear H; right; red; inv bst; intuition. - apply n; red; intros. - assert (In a (Node l2 x2 r2 h2)) by (inv In; auto). - intuition_in; order. -Qed. (** * Comparison *) (** ** Relations [eq] and [lt] over trees *) -Definition eq : t -> t -> Prop := Equal. +Definition eq := Equal. +Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2). -Lemma eq_refl : forall s : t, eq s s. +Lemma eq_refl : forall s : t, Equal s s. Proof. - unfold eq, Equal in |- *; intuition. + unfold Equal; intuition. Qed. -Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. +Lemma eq_sym : forall s s' : t, Equal s s' -> Equal s' s. Proof. - unfold eq, Equal in |- *; firstorder. + unfold Equal; intros s s' H x; destruct (H x); split; auto. Qed. -Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. +Lemma eq_trans : forall s s' s'' : t, + Equal s s' -> Equal s' s'' -> Equal s s''. Proof. - unfold eq, Equal in |- *; firstorder. + unfold Equal; intros s s' s'' H1 H2 x; + destruct (H1 x); destruct (H2 x); split; auto. Qed. Lemma eq_L_eq : - forall s s' : t, eq s s' -> L.eq (elements s) (elements s'). + forall s s' : t, Equal s s' -> L.eq (elements s) (elements s'). Proof. - unfold eq, Equal, L.eq, L.Equal in |- *; intros. - generalize (elements_in s a) (elements_in s' a). - firstorder. + unfold Equal, L.eq, L.Equal; intros; do 2 rewrite elements_in; auto. Qed. Lemma L_eq_eq : - forall s s' : t, L.eq (elements s) (elements s') -> eq s s'. + forall s s' : t, L.eq (elements s) (elements s') -> Equal s s'. Proof. - unfold eq, Equal, L.eq, L.Equal in |- *; intros. - generalize (elements_in s a) (elements_in s' a). - firstorder. + unfold Equal, L.eq, L.Equal; intros; do 2 rewrite <-elements_in; auto. Qed. Hint Resolve eq_L_eq L_eq_eq. -Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2). - Definition lt_trans (s s' s'' : t) (h : lt s s') (h' : lt s' s'') : lt s s'' := L.lt_trans h h'. -Lemma lt_not_eq : forall s s' : t, bst s -> bst s' -> lt s s' -> ~ eq s s'. +Lemma lt_not_eq : forall s s' : t, + bst s -> bst s' -> lt s s' -> ~ Equal s s'. Proof. unfold lt in |- *; intros; intro. apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto. Qed. -(** A new comparison algorithm suggested by Xavier Leroy: - -type enumeration = End | More of elt * t * enumeration - -let rec cons s e = match s with - | Empty -> e - | Node(l, v, r, _) -> cons l (More(v, r, e)) - -let rec compare_aux e1 e2 = match (e1, e2) with - | (End, End) -> 0 - | (End, More _) -> -1 - | (More _, End) -> 1 - | (More(v1, r1, k1), More(v2, r2, k2)) -> - let c = Ord.compare v1 v2 in - if c <> 0 then c else compare_aux (cons r1 k1) (cons r2 k2) - -let compare s1 s2 = compare_aux (cons s1 End) (cons s2 End) -*) +Lemma L_eq_cons : + forall (l1 l2 : list elt) (x y : elt), + X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2). +Proof. + unfold L.eq, L.Equal in |- *; intuition. + inversion_clear H1; generalize (H0 a); clear H0; intuition. + apply InA_eqA with x; eauto. + inversion_clear H1; generalize (H0 a); clear H0; intuition. + apply InA_eqA with y; eauto. +Qed. +Hint Resolve L_eq_cons. -(** ** Enumeration of the elements of a tree *) -Inductive enumeration : Set := - | End : enumeration - | More : elt -> tree -> enumeration -> enumeration. +(** * A new comparison algorithm suggested by Xavier Leroy *) (** [flatten_e e] returns the list of elements of [e] i.e. the list of elements actually compared *) @@ -2171,462 +1719,166 @@ Fixpoint flatten_e (e : enumeration) : list elt := match e with | More x t r => x :: elements t ++ flatten_e r end. -(** [sorted_e e] expresses that elements in the enumeration [e] are - sorted, and that all trees in [e] are binary search trees. *) - -Inductive In_e (x:elt) : enumeration -> Prop := - | InEHd1 : - forall (y : elt) (s : tree) (e : enumeration), - X.eq x y -> In_e x (More y s e) - | InEHd2 : - forall (y : elt) (s : tree) (e : enumeration), - In x s -> In_e x (More y s e) - | InETl : - forall (y : elt) (s : tree) (e : enumeration), - In_e x e -> In_e x (More y s e). - -Hint Constructors In_e. - -Inductive sorted_e : enumeration -> Prop := - | SortedEEnd : sorted_e End - | SortedEMore : - forall (x : elt) (s : tree) (e : enumeration), - bst s -> - (gt_tree x s) -> - sorted_e e -> - (forall y : elt, In_e y e -> X.lt x y) -> - (forall y : elt, - In y s -> forall z : elt, In_e z e -> X.lt y z) -> - sorted_e (More x s e). - -Hint Constructors sorted_e. - -Lemma in_app : - forall (x : elt) (l1 l2 : list elt), - InA X.eq x (l1 ++ l2) -> InA X.eq x l1 \/ InA X.eq x l2. -Proof. - simple induction l1; simpl in |- *; intuition. - inversion_clear H0; auto. - elim (H l2 H1); auto. -Qed. - -Lemma in_flatten_e : - forall (x : elt) (e : enumeration), InA X.eq x (flatten_e e) -> In_e x e. -Proof. - simple induction e; simpl in |- *; intuition. - inversion_clear H. - inversion_clear H0; auto. - elim (in_app x _ _ H1); auto. - destruct (elements_in t x); auto. -Qed. - -Lemma sort_app : - forall l1 l2 : list elt, sort X.lt l1 -> sort X.lt l2 -> - (forall x y : elt, InA X.eq x l1 -> InA X.eq y l2 -> X.lt x y) -> - sort X.lt (l1 ++ l2). -Proof. - simple induction l1; simpl in |- *; intuition. - apply cons_sort; auto. - apply H; auto. - inversion_clear H0; trivial. - induction l as [| a0 l Hrecl]; simpl in |- *; intuition. - induction l2 as [| a0 l2 Hrecl2]; simpl in |- *; intuition. - inversion_clear H0; inversion_clear H4; auto. -Qed. - -Lemma sorted_flatten_e : - forall e : enumeration, sorted_e e -> sort X.lt (flatten_e e). -Proof. - simple induction e; simpl in |- *; intuition. - apply cons_sort. - apply sort_app; inversion H0; auto. - intros; apply H8; auto. - destruct (elements_in t x0); auto. - apply in_flatten_e; auto. - apply L.MX.ListIn_Inf. - inversion_clear H0. - intros; elim (in_app_or _ _ _ H0); intuition. - destruct (elements_in t y); auto. - apply H4; apply in_flatten_e; auto. -Qed. - -Lemma elements_app : - forall (s : tree) (acc : list elt), elements_aux acc s = elements s ++ acc. -Proof. - simple induction s; simpl in |- *; intuition. - rewrite H0. - rewrite H. - unfold elements; simpl. - do 2 rewrite H. - rewrite H0. - repeat rewrite <- app_nil_end. - repeat rewrite app_ass; auto. -Qed. - -Lemma compare_flatten_1 : - forall (t0 t2 : tree) (t1 : elt) (z : int) (l : list elt), - elements t0 ++ t1 :: elements t2 ++ l = - elements (Node t0 t1 t2 z) ++ l. +Lemma flatten_e_elements : + forall l x r h e, + elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. Proof. - simpl in |- *; unfold elements in |- *; simpl in |- *; intuition. - repeat rewrite elements_app. - repeat rewrite <- app_nil_end. - repeat rewrite app_ass; auto. + intros; simpl; apply elements_node. Qed. -(** key lemma for correctness *) - -Lemma flatten_e_elements : - forall (x : elt) (l r : tree) (z : int) (e : enumeration), - elements l ++ flatten_e (More x r e) = elements (Node l x r z) ++ flatten_e e. +Lemma cons_1 : forall s e, + flatten_e (cons s e) = elements s ++ flatten_e e. Proof. - intros; simpl. - apply compare_flatten_1. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements. Qed. -(** termination of [compare_aux] *) +(** Correctness of this comparison *) -Open Local Scope Z_scope. - -Fixpoint measure_e_t (s : tree) : Z := match s with - | Leaf => 0 - | Node l _ r _ => 1 + measure_e_t l + measure_e_t r - end. - -Fixpoint measure_e (e : enumeration) : Z := match e with - | End => 0 - | More _ s r => 1 + measure_e_t s + measure_e r +Definition Cmp c := + match c with + | Eq => L.eq + | Lt => L.lt + | Gt => (fun l1 l2 => L.lt l2 l1) end. -Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *. -Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *. - -Lemma measure_e_t_0 : forall s : tree, measure_e_t s >= 0. +Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 -> + Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). Proof. - simple induction s. - simpl in |- *; omega. - intros. - Measure_e_t; omega. (* BUG Simpl! *) + destruct c; simpl; auto. Qed. +Hint Resolve cons_Cmp. -Ltac Measure_e_t_0 s := generalize (measure_e_t_0 s); intro. - -Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0. +Lemma compare_end_Cmp : + forall e2, Cmp (compare_end e2) nil (flatten_e e2). Proof. - simple induction e. - simpl in |- *; omega. - intros. - Measure_e; Measure_e_t_0 t; omega. + destruct e2; simpl; auto. + apply L.eq_refl. Qed. -Ltac Measure_e_0 e := generalize (measure_e_0 e); intro. - -(** Induction principle over the sum of the measures for two lists *) - -Definition compare_rec2 : - forall P : enumeration -> enumeration -> Set, - (forall x x' : enumeration, - (forall y y' : enumeration, - measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') -> - P x x') -> - forall x x' : enumeration, P x x'. +Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) + (flatten_e (More x2 r2 e2)). Proof. - intros P H x x'. - apply well_founded_induction_type_2 - with (R := fun yy' xx' : enumeration * enumeration => - measure_e (fst yy') + measure_e (snd yy') < - measure_e (fst xx') + measure_e (snd xx')); auto. - apply Wf_nat.well_founded_lt_compat - with (f := fun xx' : enumeration * enumeration => - Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))). - intros; apply Zabs.Zabs_nat_lt. - Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y); - Measure_e_0 (snd y); intros; omega. -Qed. - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. Code: - -let rec cons s e = match s with - | Empty -> e - | Node(l, v, r, _) -> cons l (More(v, r, e)) -*) - -Definition cons : forall (s : tree) (e : enumeration), bst s -> sorted_e e -> - (forall (x y : elt), In x s -> In_e y e -> X.lt x y) -> - { r : enumeration - | sorted_e r /\ - measure_e r = measure_e_t s + measure_e e /\ - flatten_e r = elements s ++ flatten_e e - }. -Proof. - simple induction s; intuition. - (* s = Leaf *) - exists e; intuition. - (* s = Node t t0 t1 z *) - clear H0. - case (H (More t0 t1 e)); clear H; intuition. - inv bst; auto. - constructor; inversion_clear H1; auto. - inversion_clear H0; inv bst; intuition; order. - exists x; intuition. - generalize H4; Measure_e; intros; Measure_e_t; omega. - rewrite H5. - apply flatten_e_elements. + simpl; intros; destruct X.compare; simpl; auto. Qed. -Lemma l_eq_cons : - forall (l1 l2 : list elt) (x y : elt), - X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2). +Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). Proof. - unfold L.eq, L.Equal in |- *; intuition. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with x; eauto. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with y; eauto. + induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. + rewrite <- elements_node; simpl. + apply Hl1; auto. clear e2. intros [|x2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- cons_1; auto. Qed. -Definition compare_aux : - forall e1 e2 : enumeration, sorted_e e1 -> sorted_e e2 -> - Compare L.lt L.eq (flatten_e e1) (flatten_e e2). -Proof. - intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2. - simple destruct x; simple destruct x'; intuition. - (* x = x' = End *) - constructor 2; unfold L.eq, L.Equal in |- *; intuition. - (* x = End x' = More *) - constructor 1; simpl in |- *; auto. - (* x = More x' = End *) - constructor 3; simpl in |- *; auto. - (* x = More e t e0, x' = More e3 t0 e4 *) - case (X.compare e e3); intro. - (* e < e3 *) - constructor 1; simpl; auto. - (* e = e3 *) - destruct (cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto. - destruct (cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto. - destruct (H c1 c2); clear H; intuition. - Measure_e; omega. - constructor 1; simpl. - apply L.lt_cons_eq; auto. - rewrite H4 in l; rewrite H7 in l; auto. - constructor 2; simpl. - apply l_eq_cons; auto. - rewrite H4 in e6; rewrite H7 in e6; auto. - constructor 3; simpl. - apply L.lt_cons_eq; auto. - rewrite H4 in l; rewrite H7 in l; auto. - (* e > e3 *) - constructor 3; simpl; auto. -Qed. - -Definition compare : forall s1 s2, bst s1 -> bst s2 -> Compare lt eq s1 s2. -Proof. - intros s1 s2 s1_bst s2_bst; unfold lt, eq; simpl. - destruct (cons s1 End); intuition. - inversion_clear H0. - destruct (cons s2 End); intuition. - inversion_clear H3. - simpl in H2; rewrite <- app_nil_end in H2. - simpl in H5; rewrite <- app_nil_end in H5. - destruct (compare_aux x x0); intuition. - constructor 1; simpl in |- *. - rewrite H2 in l; rewrite H5 in l; auto. - constructor 2; apply L_eq_eq; simpl in |- *. - rewrite H2 in e; rewrite H5 in e; auto. - constructor 3; simpl in |- *. - rewrite H2 in l; rewrite H5 in l; auto. +Lemma compare_Cmp : forall s1 s2, + Cmp (compare s1 s2) (elements s1) (elements s2). +Proof. + intros; unfold compare. + rewrite (app_nil_end (elements s1)). + replace (elements s2) with (flatten_e (cons s2 End)) by + (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). + apply compare_cont_Cmp; auto. + intros. + apply compare_end_Cmp; auto. Qed. (** * Equality test *) -Definition equal : forall s s' : t, bst s -> bst s' -> {Equal s s'} + {~ Equal s s'}. +Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 -> + Equal s1 s2 -> equal s1 s2 = true. Proof. - intros s s' Hs Hs'; case (compare s s'); auto; intros. - right; apply lt_not_eq; auto. - right; intro; apply (lt_not_eq s' s); auto; apply eq_sym; auto. -Qed. - -(** We provide additionally a different implementation for union, subset and - equal, which is less efficient, but uses structural induction, hence computes - within Coq. *) - -(** Alternative union based on fold. - Complexity : [min(|s|,|s'|)*log(max(|s|,|s'|))] *) - -Definition union' s s' := - if ge_lt_dec (height s) (height s') then fold add s' s else fold add s s'. - -Lemma fold_add_avl : forall s s', avl s -> avl s' -> avl (fold add s s'). -Proof. - induction s; simpl; intros; inv avl; auto. -Qed. -Hint Resolve fold_add_avl. - -Lemma union'_avl : forall s s', avl s -> avl s' -> avl (union' s s'). -Proof. - unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); auto. -Qed. - -Lemma fold_add_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> - bst (fold add s s'). -Proof. - induction s; simpl; intros; inv avl; inv bst; auto. - apply IHs2; auto. - apply add_bst; auto. -Qed. - -Lemma union'_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> - bst (union' s s'). -Proof. - unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); - apply fold_add_bst; auto. +unfold equal; intros s1 s2 B1 B2 E. +generalize (compare_Cmp s1 s2). +destruct (compare s1 s2); simpl in *; auto; intros. +elim (lt_not_eq B1 B2 H E); auto. +elim (lt_not_eq B2 B1 H (eq_sym E)); auto. Qed. -Lemma fold_add_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> - (In y (fold add s s') <-> In y s \/ In y s'). -Proof. - induction s; simpl; intros; inv avl; inv bst; auto. - intuition_in. - rewrite IHs2; auto. - apply add_bst; auto. - apply fold_add_bst; auto. - rewrite add_in; auto. - rewrite IHs1; auto. - intuition_in. -Qed. - -Lemma union'_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> - (In y (union' s s') <-> In y s \/ In y s'). +Lemma equal_2 : forall s1 s2, + equal s1 s2 = true -> Equal s1 s2. Proof. - unfold union'; intros; destruct (ge_lt_dec (height s) (height s')). - rewrite fold_add_in; intuition. - apply fold_add_in; auto. -Qed. - -(** Alternative subset based on diff. *) - -Definition subset' s s' := is_empty (diff s s'). - -Lemma subset'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' -> - Subset s s' -> subset' s s' = true. -Proof. - unfold subset', Subset; intros; apply is_empty_1; red; intros. - rewrite (diff_in); intuition. +unfold equal; intros s1 s2 E. +generalize (compare_Cmp s1 s2); + destruct compare; auto; discriminate. Qed. -Lemma subset'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' -> - subset' s s' = true -> Subset s s'. -Proof. - unfold subset', Subset; intros; generalize (is_empty_2 _ H3 a); unfold Empty. - rewrite (diff_in); intuition. - generalize (mem_2 s' a) (mem_1 s' a); destruct (mem a s'); intuition. -Qed. +End Proofs. -(** Alternative equal based on subset *) +End Raw. -Definition equal' s s' := subset' s s' && subset' s' s. -Lemma equal'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' -> - Equal s s' -> equal' s s' = true. -Proof. - unfold equal', Equal; intros. - rewrite subset'_1; firstorder; simpl. - apply subset'_1; firstorder. -Qed. - -Lemma equal'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' -> - equal' s s' = true -> Equal s s'. -Proof. - unfold equal', Equal; intros; destruct (andb_prop _ _ H3); split; - apply subset'_2; auto. -Qed. - -End Raw. (** * Encapsulation Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of balanced binary search trees. *) + need to encapsulate everything into a type of binary search trees. + They also happen to be well-balanced, but this has no influence + on the correctness of operations, so we won't state this here, + see [FSetFullAVL] if you need more than just the FSet interface. +*) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. - Module Raw := Raw I X. + Module Raw := Raw I X. + Import Raw.Proofs. - Record bbst : Set := Bbst {this :> Raw.t; is_bst : Raw.bst this; is_avl: Raw.avl this}. - Definition t := bbst. + Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}. + Definition t := bst. Definition elt := E.t. - Definition In (x : elt) (s : t) : Prop := Raw.In x s. - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x. - + Definition In (x : elt) (s : t) := Raw.In x s. + Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'. + Definition Subset (s s':t) := forall a : elt, In a s -> In a s'. + Definition Empty (s:t) := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) (s:t) := exists x, In x s /\ P x. + Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. - Proof. intro s; exact (Raw.In_1 s). Qed. + Proof. intro s; exact (@In_1 s). Qed. Definition mem (x:elt)(s:t) : bool := Raw.mem x s. - Definition empty : t := Bbst _ Raw.empty_bst Raw.empty_avl. + Definition empty : t := Bst empty_bst. Definition is_empty (s:t) : bool := Raw.is_empty s. - Definition singleton (x:elt) : t := Bbst _ (Raw.singleton_bst x) (Raw.singleton_avl x). - Definition add (x:elt)(s:t) : t := - Bbst _ (Raw.add_bst s x (is_bst s) (is_avl s)) - (Raw.add_avl s x (is_avl s)). - Definition remove (x:elt)(s:t) : t := - Bbst _ (Raw.remove_bst s x (is_bst s) (is_avl s)) - (Raw.remove_avl s x (is_avl s)). - Definition inter (s s':t) : t := - Bbst _ (Raw.inter_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - (Raw.inter_avl _ _ (is_avl s) (is_avl s')). - Definition diff (s s':t) : t := - Bbst _ (Raw.diff_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - (Raw.diff_avl _ _ (is_avl s) (is_avl s')). + Definition singleton (x:elt) : t := Bst (singleton_bst x). + Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). + Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)). + Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')). + Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')). + Definition diff (s s':t) : t := Bst (diff_bst (is_bst s) (is_bst s')). Definition elements (s:t) : list elt := Raw.elements s. Definition min_elt (s:t) : option elt := Raw.min_elt s. Definition max_elt (s:t) : option elt := Raw.max_elt s. Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Set) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. + Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. Definition cardinal (s:t) : nat := Raw.cardinal s. Definition filter (f : elt -> bool) (s:t) : t := - Bbst _ (Raw.filter_bst f _ (is_bst s) (is_avl s)) - (Raw.filter_avl f _ (is_avl s)). + Bst (filter_bst f (is_bst s)). Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s. Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s. Definition partition (f : elt -> bool) (s:t) : t * t := let p := Raw.partition f s in - (Bbst (fst p) (Raw.partition_bst_1 f _ (is_bst s) (is_avl s)) - (Raw.partition_avl_1 f _ (is_avl s)), - Bbst (snd p) (Raw.partition_bst_2 f _ (is_bst s) (is_avl s)) - (Raw.partition_avl_2 f _ (is_avl s))). - - Definition union (s s':t) : t := - let (u,p) := Raw.union _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s') in - let (b,p) := p in - let (a,_) := p in - Bbst u b a. - - Definition union' (s s' : t) : t := - Bbst _ (Raw.union'_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - (Raw.union'_avl _ _ (is_avl s) (is_avl s')). - - Definition equal (s s': t) : bool := if Raw.equal _ _ (is_bst s) (is_bst s') then true else false. - Definition equal' (s s':t) : bool := Raw.equal' s s'. + (@Bst (fst p) (partition_bst_1 f (is_bst s)), + @Bst (snd p) (partition_bst_2 f (is_bst s))). - Definition subset (s s':t) : bool := if Raw.subset _ _ (is_bst s) (is_bst s') then true else false. - Definition subset' (s s':t) : bool := Raw.subset' s s'. + Definition equal (s s':t) : bool := Raw.equal s s'. + Definition subset (s s':t) : bool := Raw.subset s s'. - Definition eq (s s':t) : Prop := Raw.eq s s'. - Definition lt (s s':t) : Prop := Raw.lt s s'. + Definition eq (s s':t) : Prop := Raw.Equal s s'. + Definition lt (s s':t) : Prop := Raw.Proofs.lt s s'. - Definition compare (s s':t) : Compare lt eq s s'. + Definition compare (s s':t) : Compare lt eq s s'. Proof. - intros; elim (Raw.compare _ _ (is_bst s) (is_bst s')); - [ constructor 1 | constructor 2 | constructor 3 ]; - auto. + intros (s,b) (s',b'). + generalize (compare_Cmp s s'). + destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. (* specs *) @@ -2634,260 +1886,164 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Variable s s' s'': t. Variable x y : elt. - Hint Resolve is_bst is_avl. + Hint Resolve is_bst. Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (Raw.mem_1 s x (is_bst s)). Qed. + Proof. exact (mem_1 (is_bst s)). Qed. Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (Raw.mem_2 s x). Qed. + Proof. exact (@mem_2 s x). Qed. Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. - unfold equal; destruct (Raw.equal s s'); simpl; auto. - Qed. - + Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. - unfold equal; destruct (Raw.equal s s'); simpl; intuition; discriminate. - Qed. + Proof. exact (@equal_2 s s'). Qed. - Lemma equal'_1 : Equal s s' -> equal' s s' = true. - Proof. exact (Raw.equal'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed. - Lemma equal'_2 : equal' s s' = true -> Equal s s'. - Proof. exact (Raw.equal'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed. + Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. - unfold subset; destruct (Raw.subset s s'); simpl; intuition. - Qed. - + Proof. wrap subset subset_12. Qed. Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. - unfold subset; destruct (Raw.subset s s'); simpl; intuition discriminate. - Qed. - - Lemma subset'_1 : Subset s s' -> subset' s s' = true. - Proof. exact (Raw.subset'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed. - Lemma subset'_2 : subset' s s' = true -> Subset s s'. - Proof. exact (Raw.subset'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed. + Proof. wrap subset subset_12. Qed. Lemma empty_1 : Empty empty. - Proof. exact Raw.empty_1. Qed. + Proof. exact empty_1. Qed. Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (Raw.is_empty_1 s). Qed. + Proof. exact (@is_empty_1 s). Qed. Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (Raw.is_empty_2 s). Qed. + Proof. exact (@is_empty_2 s). Qed. Lemma add_1 : E.eq x y -> In y (add x s). - Proof. - unfold add, In; simpl; rewrite Raw.add_in; auto. - Qed. - + Proof. wrap add add_in. Qed. Lemma add_2 : In y s -> In y (add x s). - Proof. - unfold add, In; simpl; rewrite Raw.add_in; auto. - Qed. - + Proof. wrap add add_in. Qed. Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. - unfold add, In; simpl; rewrite Raw.add_in; intuition. - elim H; auto. - Qed. + Proof. wrap add add_in. elim H; auto. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. - unfold remove, In; simpl; rewrite Raw.remove_in; intuition. - Qed. - + Proof. wrap remove remove_in. Qed. Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. - unfold remove, In; simpl; rewrite Raw.remove_in; intuition. - Qed. - + Proof. wrap remove remove_in. Qed. Lemma remove_3 : In y (remove x s) -> In y s. - Proof. - unfold remove, In; simpl; rewrite Raw.remove_in; intuition. - Qed. + Proof. wrap remove remove_in. Qed. Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (Raw.singleton_1 x y). Qed. + Proof. exact (@singleton_1 x y). Qed. Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (Raw.singleton_2 x y). Qed. + Proof. exact (@singleton_2 x y). Qed. Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. - unfold union, In; simpl. - destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - as (u,(b,(a,i))). - simpl in *; rewrite i; auto. - Qed. - + Proof. wrap union union_in. Qed. Lemma union_2 : In x s -> In x (union s s'). - Proof. - unfold union, In; simpl. - destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - as (u,(b,(a,i))). - simpl in *; rewrite i; auto. - Qed. - + Proof. wrap union union_in. Qed. Lemma union_3 : In x s' -> In x (union s s'). - Proof. - unfold union, In; simpl. - destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - as (u,(b,(a,i))). - simpl in *; rewrite i; auto. - Qed. - - Lemma union'_1 : In x (union' s s') -> In x s \/ In x s'. - Proof. - unfold union', In; simpl; rewrite Raw.union'_in; intuition. - Qed. - - Lemma union'_2 : In x s -> In x (union' s s'). - Proof. - unfold union', In; simpl; rewrite Raw.union'_in; intuition. - Qed. - - Lemma union'_3 : In x s' -> In x (union' s s'). - Proof. - unfold union', In; simpl; rewrite Raw.union'_in; intuition. - Qed. + Proof. wrap union union_in. Qed. Lemma inter_1 : In x (inter s s') -> In x s. - Proof. - unfold inter, In; simpl; rewrite Raw.inter_in; intuition. - Qed. - + Proof. wrap inter inter_in. Qed. Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. - unfold inter, In; simpl; rewrite Raw.inter_in; intuition. - Qed. - + Proof. wrap inter inter_in. Qed. Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. - unfold inter, In; simpl; rewrite Raw.inter_in; intuition. - Qed. + Proof. wrap inter inter_in. Qed. Lemma diff_1 : In x (diff s s') -> In x s. - Proof. - unfold diff, In; simpl; rewrite Raw.diff_in; intuition. - Qed. - + Proof. wrap diff diff_in. Qed. Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. - unfold diff, In; simpl; rewrite Raw.diff_in; intuition. - Qed. - + Proof. wrap diff diff_in. Qed. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. - unfold diff, In; simpl; rewrite Raw.diff_in; intuition. - Qed. + Proof. wrap diff diff_in. Qed. - Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), - fold A f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements; intros; apply Raw.fold_1; auto. - Qed. + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. unfold fold, elements; intros; apply fold_1; auto. Qed. Lemma cardinal_1 : cardinal s = length (elements s). Proof. - unfold cardinal, elements; intros; apply Raw.cardinal_elements_1; auto. + unfold cardinal, elements; intros; apply elements_cardinal; auto. Qed. Section Filter. Variable f : elt -> bool. Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. - intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition. - Qed. - + Proof. intro. wrap filter filter_in. Qed. Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. - intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition. - Qed. - + Proof. intro. wrap filter filter_in. Qed. Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition. - Qed. + Proof. intro. wrap filter filter_in. Qed. Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (Raw.for_all_1 f s). Qed. + Proof. exact (@for_all_1 f s). Qed. Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (Raw.for_all_2 f s). Qed. + Proof. exact (@for_all_2 f s). Qed. Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (Raw.exists_1 f s). Qed. + Proof. exact (@exists_1 f s). Qed. Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (Raw.exists_2 f s). Qed. + Proof. exact (@exists_2 f s). Qed. Lemma partition_1 : compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite Raw.partition_in_1; auto. - rewrite Raw.filter_in; intuition. + rewrite partition_in_1, filter_in; intuition. Qed. Lemma partition_2 : compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite Raw.partition_in_2; auto. - rewrite Raw.filter_in; intuition. - red; intros. - f_equal; auto. - destruct (f a); auto. + rewrite partition_in_2, filter_in; intuition. + rewrite H2; auto. destruct (f a); auto. + red; intros; f_equal. + rewrite (H _ _ H0); auto. Qed. End Filter. Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. - unfold elements, In; rewrite Raw.elements_in; auto. - Qed. - + Proof. wrap elements elements_in. Qed. Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. - unfold elements, In; rewrite Raw.elements_in; auto. - Qed. - + Proof. wrap elements elements_in. Qed. Lemma elements_3 : sort E.lt (elements s). - Proof. exact (Raw.elements_sort _ (is_bst s)). Qed. + Proof. exact (elements_sort (is_bst s)). Qed. + Lemma elements_3w : NoDupA E.eq (elements s). + Proof. exact (elements_nodup (is_bst s)). Qed. Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (Raw.min_elt_1 s x). Qed. + Proof. exact (@min_elt_1 s x). Qed. Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (Raw.min_elt_2 s x y (is_bst s)). Qed. + Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (Raw.min_elt_3 s). Qed. + Proof. exact (@min_elt_3 s). Qed. Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (Raw.max_elt_1 s x). Qed. + Proof. exact (@max_elt_1 s x). Qed. Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (Raw.max_elt_2 s x y (is_bst s)). Qed. + Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (Raw.max_elt_3 s). Qed. + Proof. exact (@max_elt_3 s). Qed. Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (Raw.choose_1 s x). Qed. + Proof. exact (@choose_1 s x). Qed. Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (Raw.choose_2 s). Qed. + Proof. exact (@choose_2 s). Qed. + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. + Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. Lemma eq_refl : eq s s. - Proof. exact (Raw.eq_refl s). Qed. + Proof. exact (eq_refl s). Qed. Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (Raw.eq_sym s s'). Qed. + Proof. exact (@eq_sym s s'). Qed. Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (Raw.eq_trans s s' s''). Qed. + Proof. exact (@eq_trans s s' s''). Qed. Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (Raw.lt_trans s s' s''). Qed. + Proof. exact (@lt_trans s s' s''). Qed. Lemma lt_not_eq : lt s s' -> ~eq s s'. - Proof. exact (Raw.lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. + Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. End Specs. End IntMake. @@ -2897,4 +2053,3 @@ End IntMake. Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). - diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 08985cfc..0622451f 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 8834 2006-05-20 00:41:35Z letouzey $ *) +(* $Id: FSetBridge.v 10601 2008-02-28 00:20:33Z letouzey $ *) (** * Finite sets library *) @@ -27,7 +27,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. Definition empty : {s : t | Empty s}. Proof. - exists empty; auto. + exists empty; auto with set. Qed. Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. @@ -66,12 +66,12 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. - absurd (In x (remove x s)); auto. + absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. elim (ME.eq_dec x y); intros; auto. - absurd (In x (remove x s)); auto. + absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. - eauto. + eauto with set. Qed. Definition union : @@ -83,14 +83,14 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. Definition inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. Proof. - intros; exists (inter s s'); intuition; eauto. + intros; exists (inter s s'); intuition; eauto with set. Qed. Definition diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Proof. - intros; exists (diff s s'); intuition; eauto. - absurd (In x s'); eauto. + intros; exists (diff s s'); intuition; eauto with set. + absurd (In x s'); eauto with set. Qed. Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. @@ -115,7 +115,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. Defined. Definition fold : - forall (A : Set) (f : elt -> A -> A) (s : t) (i : A), + forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Proof. @@ -150,7 +150,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. exists (filter (fdec Pdec) s). intro H; assert (compat_bool E.eq (fdec Pdec)); auto. intuition. - eauto. + eauto with set. generalize (filter_2 H0 H1). unfold fdec in |- *. case (Pdec x); intuition. @@ -226,7 +226,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. generalize H4; unfold For_all, Equal in |- *; intuition. elim (H0 x); intros. assert (fdec Pdec x = true). - eauto. + eapply filter_2; eauto with set. generalize H8; unfold fdec in |- *; case (Pdec x); intuition. inversion H9. generalize H; unfold For_all, Equal in |- *; intuition. @@ -238,8 +238,8 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. set (b := fdec Pdec x) in *; generalize (refl_equal b); pattern b at -1 in |- *; case b; unfold b in |- *; [ left | right ]. - elim (H4 x); intros _ B; apply B; auto. - elim (H x); intros _ B; apply B; auto. + elim (H4 x); intros _ B; apply B; auto with set. + elim (H x); intros _ B; apply B; auto with set. apply filter_3; auto. rewrite H5; auto. eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; @@ -247,12 +247,63 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. Qed. + Definition choose_aux: forall s : t, + { x : elt | M.choose s = Some x } + { M.choose s = None }. + Proof. + intros. + destruct (M.choose s); [left | right]; auto. + exists e; auto. + Qed. + Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. - Proof. - intros. - generalize (choose_1 (s:=s)) (choose_2 (s:=s)). - case (choose s); [ left | right ]; auto. - exists e; auto. + Proof. + intros; destruct (choose_aux s) as [(x,Hx)|H]. + left; exists x; apply choose_1; auto. + right; apply choose_2; auto. + Defined. + + Lemma choose_ok1 : + forall s x, M.choose s = Some x <-> exists H:In x s, + choose s = inleft _ (exist (fun x => In x s) x H). + Proof. + intros s x. + unfold choose; split; intros. + destruct (choose_aux s) as [(y,Hy)|H']; try congruence. + replace x with y in * by congruence. + exists (choose_1 Hy); auto. + destruct H. + destruct (choose_aux s) as [(y,Hy)|H']; congruence. + Qed. + + Lemma choose_ok2 : + forall s, M.choose s = None <-> exists H:Empty s, + choose s = inright _ H. + Proof. + intros s. + unfold choose; split; intros. + destruct (choose_aux s) as [(y,Hy)|H']; try congruence. + exists (choose_2 H'); auto. + destruct H. + destruct (choose_aux s) as [(y,Hy)|H']; congruence. + Qed. + + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | inleft (exist x _), inleft (exist x' _) => E.eq x x' + | inright _, inright _ => True + | _, _ => False + end. + Proof. + intros. + generalize (@M.choose_1 s)(@M.choose_2 s) + (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s') + (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s'). + destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros. + apply H4; auto. + rewrite H5; exists Hx; auto. + rewrite H7; exists Hx'; auto. + apply Hx' with x; unfold Equal in H; rewrite <-H; auto. + apply Hx with x'; unfold Equal in H; rewrite H; auto. Qed. Definition min_elt : @@ -391,6 +442,15 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intro s; unfold choose in |- *; case (M.choose s); auto. simple destruct s0; intros; discriminate H. Qed. + + Lemma choose_3 : forall s s' x x', + choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. + Proof. + unfold choose; intros. + generalize (M.choose_equal H1); clear H1. + destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; + simpl; auto; congruence. + Qed. Definition elements (s : t) : list elt := let (l, _) := elements s in l. @@ -408,6 +468,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. + Hint Resolve elements_3. + + Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). + Proof. auto. Qed. Definition min_elt (s : t) : option elt := match min_elt s with @@ -578,11 +642,11 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. destruct (M.elements s); auto. Qed. - Definition fold (B : Set) (f : elt -> B -> B) (i : t) + Definition fold (B : Type) (f : elt -> B -> B) (i : t) (s : B) : B := let (fold, _) := fold f i s in fold. Lemma fold_1 : - forall (s : t) (A : Set) (i : A) (f : elt -> A -> A), + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v new file mode 100644 index 00000000..0639c1f1 --- /dev/null +++ b/theories/FSets/FSetDecide.v @@ -0,0 +1,841 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id: FSetDecide.v 11064 2008-06-06 17:00:52Z letouzey $ *) + +(**************************************************************) +(* FSetDecide.v *) +(* *) +(* Author: Aaron Bohannon *) +(**************************************************************) + +(** This file implements a decision procedure for a certain + class of propositions involving finite sets. *) + +Require Import Decidable DecidableTypeEx FSetFacts. + +(** First, a version for Weak Sets *) + +Module WDecide (E : DecidableType)(Import M : WSfun E). + Module F := FSetFacts.WFacts E M. + +(** * Overview + This functor defines the tactic [fsetdec], which will + solve any valid goal of the form +<< + forall s1 ... sn, + forall x1 ... xm, + P1 -> ... -> Pk -> P +>> + where [P]'s are defined by the grammar: +<< + +P ::= +| Q +| Empty F +| Subset F F' +| Equal F F' + +Q ::= +| E.eq X X' +| In X F +| Q /\ Q' +| Q \/ Q' +| Q -> Q' +| Q <-> Q' +| ~ Q +| True +| False + +F ::= +| S +| empty +| singleton X +| add X F +| remove X F +| union F F' +| inter F F' +| diff F F' + +X ::= x1 | ... | xm +S ::= s1 | ... | sn + +>> + +The tactic will also work on some goals that vary slightly from +the above form: +- The variables and hypotheses may be mixed in any order and may + have already been introduced into the context. Moreover, + there may be additional, unrelated hypotheses mixed in (these + will be ignored). +- A conjunction of hypotheses will be handled as easily as + separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff + [P1 -> P2 -> P] can be solved. +- [fsetdec] should solve any goal if the FSet-related hypotheses + are contradictory. +- [fsetdec] will first perform any necessary zeta and beta + reductions and will invoke [subst] to eliminate any Coq + equalities between finite sets or their elements. +- If [E.eq] is convertible with Coq's equality, it will not + matter which one is used in the hypotheses or conclusion. +- The tactic can solve goals where the finite sets or set + elements are expressed by Coq terms that are more complicated + than variables. However, non-local definitions are not + expanded, and Coq equalities between non-variable terms are + not used. For example, this goal will be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2) +>> + This one will not be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2) +>> +*) + + (** * Facts and Tactics for Propositional Logic + These lemmas and tactics are in a module so that they do + not affect the namespace if you import the enclosing + module [Decide]. *) + Module FSetLogicalFacts. + Require Export Decidable. + Require Export Setoid. + + (** ** Lemmas and Tactics About Decidable Propositions *) + + (** ** Propositional Equivalences Involving Negation + These are all written with the unfolded form of + negation, since I am not sure if setoid rewriting will + always perform conversion. *) + + (** ** Tactics for Negations *) + + Tactic Notation "fold" "any" "not" := + repeat ( + match goal with + | H: context [?P -> False] |- _ => + fold (~ P) in H + | |- context [?P -> False] => + fold (~ P) + end). + + (** [push not using db] will pushes all negations to the + leaves of propositions in the goal, using the lemmas in + [db] to assist in checking the decidability of the + propositions involved. If [using db] is omitted, then + [core] will be used. Additional versions are provided + to manipulate the hypotheses or the hypotheses and goal + together. + + XXX: This tactic and the similar subsequent ones should + have been defined using [autorewrite]. However, dealing + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit + analysis of goals. *) + + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || + (rewrite (or_not_l_iff_2 P Q) by tac). + + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || + (rewrite (or_not_r_iff_2 P Q) by tac). + + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || + (rewrite (or_not_l_iff_2 P Q) in H by tac). + + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || + (rewrite (or_not_r_iff_2 P Q) in H by tac). + + Tactic Notation "push" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) + | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) + | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec + end); + fold any not. + + Tactic Notation "push" "not" := + push not using core. + + Tactic Notation + "push" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H + | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H + | H: context [(?P -> ?Q) -> False] |- _ => + rewrite (not_imp_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "push" "not" "in" "*" "|-" := + push not in * |- using core. + + Tactic Notation "push" "not" "in" "*" "using" ident(db) := + push not using db; push not in * |- using db. + Tactic Notation "push" "not" "in" "*" := + push not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_push : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ ((R -> P) \/ (Q -> R))) -> + (~ (P /\ R)) -> + (~ (P -> R)) -> + True. + Proof. + intros. push not in *. + (* note that ~(R->P) remains (since R isnt decidable) *) + tauto. + Qed. + + (** [pull not using db] will pull as many negations as + possible toward the top of the propositions in the goal, + using the lemmas in [db] to assist in checking the + decidability of the propositions involved. If [using + db] is omitted, then [core] will be used. Additional + versions are provided to manipulate the hypotheses or + the hypotheses and goal together. *) + + Tactic Notation "pull" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [(?P -> False) /\ (?Q -> False)] => + rewrite <- (not_or_iff P Q) + | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) + | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec + | |- context [(?Q -> False) /\ ?P] => + rewrite <- (not_imp_rev_iff P Q) by dec + end); + fold any not. + + Tactic Notation "pull" "not" := + pull not using core. + + Tactic Notation + "pull" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [(?P -> False) /\ (?Q -> False)] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_and_iff P Q) in H + | H: context [?P /\ (?Q -> False)] |- _ => + rewrite <- (not_imp_iff P Q) in H by dec + | H: context [(?Q -> False) /\ ?P] |- _ => + rewrite <- (not_imp_rev_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "pull" "not" "in" "*" "|-" := + pull not in * |- using core. + + Tactic Notation "pull" "not" "in" "*" "using" ident(db) := + pull not using db; pull not in * |- using db. + Tactic Notation "pull" "not" "in" "*" := + pull not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_pull : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ (R -> P) /\ ~ (Q -> R)) -> + (~ P \/ ~ R) -> + (P /\ ~ R) -> + (~ R /\ P) -> + True. + Proof. + intros. pull not in *. tauto. + Qed. + + End FSetLogicalFacts. + Import FSetLogicalFacts. + + (** * Auxiliary Tactics + Again, these lemmas and tactics are in a module so that + they do not affect the namespace if you import the + enclosing module [Decide]. *) + Module FSetDecideAuxiliary. + + (** ** Generic Tactics + We begin by defining a few generic, useful tactics. *) + + (** [if t then t1 else t2] executes [t] and, if it does not + fail, then [t1] will be applied to all subgoals + produced. If [t] fails, then [t2] is executed. *) + Tactic Notation + "if" tactic(t) + "then" tactic(t1) + "else" tactic(t2) := + first [ t; first [ t1 | fail 2 ] | t2 ]. + + (** [prop P holds by t] succeeds (but does not modify the + goal or context) if the proposition [P] can be proved by + [t] in the current context. Otherwise, the tactic + fails. *) + Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := + let H := fresh in + assert P as H by t; + clear H. + + (** This tactic acts just like [assert ... by ...] but will + fail if the context already contains the proposition. *) + Tactic Notation "assert" "new" constr(e) "by" tactic(t) := + match goal with + | H: e |- _ => fail 1 + | _ => assert e by t + end. + + (** [subst++] is similar to [subst] except that + - it never fails (as [subst] does on recursive + equations), + - it substitutes locally defined variable for their + definitions, + - it performs beta reductions everywhere, which may + arise after substituting a locally defined function + for its definition. + *) + Tactic Notation "subst" "++" := + repeat ( + match goal with + | x : _ |- _ => subst x + end); + cbv zeta beta in *. + + (** [decompose records] calls [decompose record H] on every + relevant hypothesis [H]. *) + Tactic Notation "decompose" "records" := + repeat ( + match goal with + | H: _ |- _ => progress (decompose record H); clear H + end). + + (** ** Discarding Irrelevant Hypotheses + We will want to clear the context of any + non-FSet-related hypotheses in order to increase the + speed of the tactic. To do this, we will need to be + able to decide which are relevant. We do this by making + a simple inductive definition classifying the + propositions of interest. *) + + Inductive FSet_elt_Prop : Prop -> Prop := + | eq_Prop : forall (S : Set) (x y : S), + FSet_elt_Prop (x = y) + | eq_elt_prop : forall x y, + FSet_elt_Prop (E.eq x y) + | In_elt_prop : forall x s, + FSet_elt_Prop (In x s) + | True_elt_prop : + FSet_elt_Prop True + | False_elt_prop : + FSet_elt_Prop False + | conj_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P /\ Q) + | disj_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P \/ Q) + | impl_elt_prop : forall P Q, + FSet_elt_Prop P -> + FSet_elt_Prop Q -> + FSet_elt_Prop (P -> Q) + | not_elt_prop : forall P, + FSet_elt_Prop P -> + FSet_elt_Prop (~ P). + + Inductive FSet_Prop : Prop -> Prop := + | elt_FSet_Prop : forall P, + FSet_elt_Prop P -> + FSet_Prop P + | Empty_FSet_Prop : forall s, + FSet_Prop (Empty s) + | Subset_FSet_Prop : forall s1 s2, + FSet_Prop (Subset s1 s2) + | Equal_FSet_Prop : forall s1 s2, + FSet_Prop (Equal s1 s2). + + (** Here is the tactic that will throw away hypotheses that + are not useful (for the intended scope of the [fsetdec] + tactic). *) + Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. + Ltac discard_nonFSet := + decompose records; + repeat ( + match goal with + | H : ?P |- _ => + if prop (FSet_Prop P) holds by + (auto 100 with FSet_Prop) + then fail + else clear H + end). + + (** ** Turning Set Operators into Propositional Connectives + The lemmas from [FSetFacts] will be used to break down + set operations into propositional formulas built over + the predicates [In] and [E.eq] applied only to + variables. We are going to use them with [autorewrite]. + *) + + Hint Rewrite + F.empty_iff F.singleton_iff F.add_iff F.remove_iff + F.union_iff F.inter_iff F.diff_iff + : set_simpl. + + (** ** Decidability of FSet Propositions *) + + (** [In] is decidable. *) + Lemma dec_In : forall x s, + decidable (In x s). + Proof. + red; intros; generalize (F.mem_iff s x); case (mem x s); intuition. + Qed. + + (** [E.eq] is decidable. *) + Lemma dec_eq : forall (x y : E.t), + decidable (E.eq x y). + Proof. + red; intros x y; destruct (E.eq_dec x y); auto. + Qed. + + (** The hint database [FSet_decidability] will be given to + the [push_neg] tactic from the module [Negation]. *) + Hint Resolve dec_In dec_eq : FSet_decidability. + + (** ** Normalizing Propositions About Equality + We have to deal with the fact that [E.eq] may be + convertible with Coq's equality. Thus, we will find the + following tactics useful to replace one form with the + other everywhere. *) + + (** The next tactic, [Logic_eq_to_E_eq], mentions the term + [E.t]; thus, we must ensure that [E.t] is used in favor + of any other convertible but syntactically distinct + term. *) + Ltac change_to_E_t := + repeat ( + match goal with + | H : ?T |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). + + (** These two tactics take us from Coq's built-in equality + to [E.eq] (and vice versa) when possible. *) + + Ltac Logic_eq_to_E_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change (@Logic.eq E.t) with E.eq in H) + | |- _ => + progress (change (@Logic.eq E.t) with E.eq) + end). + + Ltac E_eq_to_Logic_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change E.eq with (@Logic.eq E.t) in H) + | |- _ => + progress (change E.eq with (@Logic.eq E.t)) + end). + + (** This tactic works like the built-in tactic [subst], but + at the level of set element equality (which may not be + the convertible with Coq's equality). *) + Ltac substFSet := + repeat ( + match goal with + | H: E.eq ?x ?y |- _ => rewrite H in *; clear H + end). + + (** ** Considering Decidability of Base Propositions + This tactic adds assertions about the decidability of + [E.eq] and [In] to the context. This is necessary for + the completeness of the [fsetdec] tactic. However, in + order to minimize the cost of proof search, we should be + careful to not add more than we need. Once negations + have been pushed to the leaves of the propositions, we + only need to worry about decidability for those base + propositions that appear in a negated form. *) + Ltac assert_decidability := + (** We actually don't want these rules to fire if the + syntactic context in the patterns below is trivially + empty, but we'll just do some clean-up at the + afterward. *) + repeat ( + match goal with + | H: context [~ E.eq ?x ?y] |- _ => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | H: context [~ In ?x ?s] |- _ => + assert new (In x s \/ ~ In x s) by (apply dec_In) + | |- context [~ E.eq ?x ?y] => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | |- context [~ In ?x ?s] => + assert new (In x s \/ ~ In x s) by (apply dec_In) + end); + (** Now we eliminate the useless facts we added (because + they would likely be very harmful to performance). *) + repeat ( + match goal with + | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H + end). + + (** ** Handling [Empty], [Subset], and [Equal] + This tactic instantiates universally quantified + hypotheses (which arise from the unfolding of [Empty], + [Subset], and [Equal]) for each of the set element + expressions that is involved in some membership or + equality fact. Then it throws away those hypotheses, + which should no longer be needed. *) + Ltac inst_FSet_hypotheses := + repeat ( + match goal with + | H : forall a : E.t, _, + _ : context [ In ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ In ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq _ ?x ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq _ ?x ] => + let P := type of (H x) in + assert new P by (exact (H x)) + end); + repeat ( + match goal with + | H : forall a : E.t, _ |- _ => + clear H + end). + + (** ** The Core [fsetdec] Auxiliary Tactics *) + + (** Here is the crux of the proof search. Recursion through + [intuition]! (This will terminate if I correctly + understand the behavior of [intuition].) *) + Ltac fsetdec_rec := + try (match goal with + | H: E.eq ?x ?x -> False |- _ => destruct H + end); + (reflexivity || + contradiction || + (progress substFSet; intuition fsetdec_rec)). + + (** If we add [unfold Empty, Subset, Equal in *; intros;] to + the beginning of this tactic, it will satisfy the same + specification as the [fsetdec] tactic; however, it will + be much slower than necessary without the pre-processing + done by the wrapper tactic [fsetdec]. *) + Ltac fsetdec_body := + inst_FSet_hypotheses; + autorewrite with set_simpl in *; + push not in * using FSet_decidability; + substFSet; + assert_decidability; + auto using E.eq_refl; + (intuition fsetdec_rec) || + fail 1 + "because the goal is beyond the scope of this tactic". + + End FSetDecideAuxiliary. + Import FSetDecideAuxiliary. + + (** * The [fsetdec] Tactic + Here is the top-level tactic (the only one intended for + clients of this library). It's specification is given at + the top of the file. *) + Ltac fsetdec := + (** We first unfold any occurrences of [iff]. *) + unfold iff in *; + (** We fold occurrences of [not] because it is better for + [intros] to leave us with a goal of [~ P] than a goal of + [False]. *) + fold any not; intros; + (** Now we decompose conjunctions, which will allow the + [discard_nonFSet] and [assert_decidability] tactics to + do a much better job. *) + decompose records; + discard_nonFSet; + (** We unfold these defined propositions on finite sets. If + our goal was one of them, then have one more item to + introduce now. *) + unfold Empty, Subset, Equal in *; intros; + (** We now want to get rid of all uses of [=] in favor of + [E.eq]. However, the best way to eliminate a [=] is in + the context is with [subst], so we will try that first. + In fact, we may as well convert uses of [E.eq] into [=] + when possible before we do [subst] so that we can even + more mileage out of it. Then we will convert all + remaining uses of [=] back to [E.eq] when possible. We + use [change_to_E_t] to ensure that we have a canonical + name for set elements, so that [Logic_eq_to_E_eq] will + work properly. *) + change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; + (** The next optimization is to swap a negated goal with a + negated hypothesis when possible. Any swap will improve + performance by eliminating the total number of + negations, but we will get the maximum benefit if we + swap the goal with a hypotheses mentioning the same set + element, so we try that first. If we reach the fourth + branch below, we attempt any swap. However, to maintain + completeness of this tactic, we can only perform such a + swap with a decidable proposition; hence, we first test + whether the hypothesis is an [FSet_elt_Prop], noting + that any [FSet_elt_Prop] is decidable. *) + pull not using FSet_decidability; + unfold not in *; + match goal with + | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => + contradict H; fsetdec_body + | H: ?P -> False |- ?Q -> False => + if prop (FSet_elt_Prop P) holds by + (auto 100 with FSet_Prop) + then (contradict H; fsetdec_body) + else fsetdec_body + | |- _ => + fsetdec_body + end. + + (** * Examples *) + + Module FSetDecideTestCases. + + Lemma test_eq_trans_1 : forall x y z s, + E.eq x y -> + ~ ~ E.eq z y -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_trans_2 : forall x y z r s, + In x (singleton y) -> + ~ In z r -> + ~ ~ In z (add y r) -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_1 : forall w x y z s, + E.eq x w -> + ~ ~ E.eq x y -> + ~ E.eq y z -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, + In x (singleton w) -> + ~ In x r1 -> + In x (add y r1) -> + In y r2 -> + In y (remove z r2) -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_In_singleton : forall x, + In x (singleton x). + Proof. fsetdec. Qed. + + Lemma test_Subset_add_remove : forall x s, + s [<=] (add x (remove x s)). + Proof. fsetdec. Qed. + + Lemma test_eq_disjunction : forall w x y z, + In w (add x (add y (singleton z))) -> + E.eq w x \/ E.eq w y \/ E.eq w z. + Proof. fsetdec. Qed. + + Lemma test_not_In_disj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ (In x s1 \/ In x s4 \/ E.eq y x). + Proof. fsetdec. Qed. + + Lemma test_not_In_conj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. + Proof. fsetdec. Qed. + + Lemma test_iff_conj : forall a x s s', + (In a s' <-> E.eq x a \/ In a s) -> + (In a s' <-> In a (add x s)). + Proof. fsetdec. Qed. + + Lemma test_set_ops_1 : forall x q r s, + (singleton x) [<=] s -> + Empty (union q r) -> + Empty (inter (diff s q) (diff s r)) -> + ~ In x s. + Proof. fsetdec. Qed. + + Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, + Empty s1 -> + In x2 (add x1 s1) -> + In x3 s2 -> + ~ In x3 (remove x2 s2) -> + ~ In x4 s3 -> + In x4 (add x3 s3) -> + In x1 s4 -> + Subset (add x4 s4) s4. + Proof. fsetdec. Qed. + + Lemma test_too_complex : forall x y z r s, + E.eq x y -> + (In x (singleton y) -> r [<=] s) -> + In z r -> + In z s. + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until s; intros Heq H Hr; lapply H; fsetdec. + Qed. + + Lemma function_test_1 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2). + Proof. fsetdec. Qed. + + Lemma function_test_2 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2). + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. + Qed. + + End FSetDecideTestCases. + +End WDecide. + +Require Import FSetInterface. + +(** Now comes a special version dedicated to full sets. For this + one, only one argument [(M:S)] is necessary. *) + +Module Decide (M : S). + Module D:=OT_as_DT M.E. + Module WD := WDecide D M. + Ltac fsetdec := WD.fsetdec. +End Decide.
\ No newline at end of file diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index d7062d5a..a397cc28 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *) +(* $Id: FSetEqProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) (** * Finite sets library *) @@ -17,21 +17,12 @@ [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) +Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. -Require Import FSetProperties. -Require Import Zerob. -Require Import Sumbool. -Require Import Omega. - -Module EqProperties (M:S). +Module WEqProperties (Import E:DecidableType)(M:WSfun E). +Module Import MP := WProperties E M. +Import FM Dec.F. Import M. -Import Logic. (* to unmask [eq] *) -Import Peano. (* to unmask [lt] *) - -Module ME := OrderedTypeFacts E. -Module MP := Properties M. -Import MP. -Import MP.FM. Definition Add := MP.Add. @@ -76,7 +67,7 @@ Qed. Lemma empty_mem: mem x empty=false. Proof. -rewrite <- not_mem_iff; auto. +rewrite <- not_mem_iff; auto with set. Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. @@ -88,17 +79,17 @@ Qed. Lemma choose_mem_1: choose s=Some x -> mem x s=true. Proof. -auto. +auto with set. Qed. Lemma choose_mem_2: choose s=None -> is_empty s=true. Proof. -auto. +auto with set. Qed. Lemma add_mem_1: mem x (add x s)=true. Proof. -auto. +auto with set. Qed. Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. @@ -108,7 +99,7 @@ Qed. Lemma remove_mem_1: mem x (remove x s)=false. Proof. -rewrite <- not_mem_iff; auto. +rewrite <- not_mem_iff; auto with set. Qed. Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. @@ -216,7 +207,7 @@ Proof. intros. generalize (@choose_1 s) (@choose_2 s). destruct (choose s);intros. -exists e;auto. +exists e;auto with set. generalize (H1 (refl_equal None)); clear H1. intros; rewrite (is_empty_1 H1) in H; discriminate. Qed. @@ -233,7 +224,7 @@ Qed. Lemma add_mem_3: mem y s=true -> mem y (add x s)=true. Proof. -auto. +auto with set. Qed. Lemma add_equal: @@ -260,7 +251,7 @@ Qed. Lemma add_remove: mem x s=true -> equal (add x (remove x s)) s=true. Proof. -intros; apply equal_1; apply add_remove; auto. +intros; apply equal_1; apply add_remove; auto with set. Qed. Lemma remove_add: @@ -275,9 +266,9 @@ Qed. Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). Proof. intros; apply bool_1; split; intros. -rewrite cardinal_1; simpl; auto. +rewrite MP.cardinal_1; simpl; auto with set. assert (cardinal s = 0) by (apply zerob_true_elim; auto). -auto. +auto with set. Qed. (** Properties of [singleton] *) @@ -290,12 +281,12 @@ Qed. Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. Proof. intros; rewrite singleton_b. -unfold ME.eqb; destruct (ME.eq_dec x y); intuition. +unfold eqb; destruct (eq_dec x y); intuition. Qed. Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. Proof. -auto. +intros; apply singleton_1; auto with set. Qed. (** Properties of [union] *) @@ -358,7 +349,7 @@ Lemma union_subset_3: subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true. Proof. -intros; apply subset_1; apply union_subset_3; auto. +intros; apply subset_1; apply union_subset_3; auto with set. Qed. (** Properties of [inter] *) @@ -433,7 +424,7 @@ Lemma inter_subset_3: subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true. Proof. -intros; apply subset_1; apply inter_subset_3; auto. +intros; apply subset_1; apply inter_subset_3; auto with set. Qed. (** Properties of [diff] *) @@ -478,45 +469,37 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 add_mem_3 add_equal remove_mem_3 remove_equal : set. -(** General recursion principes based on [cardinal] *) +(** General recursion principle *) -Lemma cardinal_set_rec: forall (P:t->Type), +Lemma set_rec: forall (P:t->Type), (forall s s', equal s s'=true -> P s -> P s') -> (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall n s, cardinal s=n -> P s. + P empty -> forall s, P s. Proof. intros. -apply cardinal_induction with n; auto; intros. +apply set_induction; auto; intros. apply X with empty; auto with set. apply X with (add x s0); auto with set. -apply equal_1; intro a; rewrite add_iff; rewrite (H1 a); tauto. +apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. apply X0; auto with set; apply mem_3; auto. Qed. -Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> - P empty -> forall s, P s. -Proof. -intros;apply cardinal_set_rec with (cardinal s);auto. -Qed. - (** Properties of [fold] *) Lemma exclusive_set : forall s s' x, - ~In x s\/~In x s' <-> mem x s && mem x s'=false. + ~(In x s/\In x s') <-> mem x s && mem x s'=false. Proof. -intros; do 2 rewrite not_mem_iff. +intros; do 2 rewrite mem_iff. destruct (mem x s); destruct (mem x s'); intuition. Qed. Section Fold. -Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). +Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). -Lemma fold_empty: eqA (fold f empty i) i. +Lemma fold_empty: (fold f empty i) = i. Proof. apply fold_empty; auto. Qed. @@ -524,7 +507,7 @@ Qed. Lemma fold_equal: equal s s'=true -> eqA (fold f s i) (fold f s' i). Proof. -intros; apply fold_equal with (eqA:=eqA); auto. +intros; apply fold_equal with (eqA:=eqA); auto with set. Qed. Lemma fold_add: @@ -537,13 +520,13 @@ Qed. Lemma add_fold: mem x s=true -> eqA (fold f (add x s) i) (fold f s i). Proof. -intros; apply add_fold with (eqA:=eqA); auto. +intros; apply add_fold with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_1: mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. -intros; apply remove_fold_1 with (eqA:=eqA); auto. +intros; apply remove_fold_1 with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_2: @@ -581,13 +564,13 @@ Qed. Lemma remove_cardinal_1: forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. Proof. -intros; apply remove_cardinal_1; auto. +intros; apply remove_cardinal_1; auto with set. Qed. Lemma remove_cardinal_2: forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. Proof. -auto with set. +intros; apply Equal_cardinal; apply equal_2; auto with set. Qed. Lemma union_cardinal: @@ -601,7 +584,7 @@ Qed. Lemma subset_cardinal: forall s s', subset s s'=true -> cardinal s<=cardinal s'. Proof. -intros; apply subset_cardinal; auto. +intros; apply subset_cardinal; auto with set. Qed. Section Bool. @@ -644,7 +627,7 @@ Proof. intros; apply bool_1; split; intros. destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). apply bool_6. -red; intros; apply (@is_empty_2 _ H0 a); auto. +red; intros; apply (@is_empty_2 _ H0 a); auto with set. generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). destruct (choose (filter f s)). intros H0 _; apply exists_1; auto. @@ -656,13 +639,30 @@ Qed. Lemma partition_filter_1: forall s, equal (fst (partition f s)) (filter f s)=true. Proof. -auto. +auto with set. Qed. Lemma partition_filter_2: forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. Proof. -auto. +auto with set. +Qed. + +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). +Proof. +red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +rewrite <- H; apply Comp; auto. +Qed. + +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. +Proof. +red; intros; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +assert (f x = f a) by (apply Comp; auto). +rewrite H in H1; rewrite H2 in H1; discriminate. Qed. Lemma add_filter_1 : forall s s' x, @@ -837,6 +837,8 @@ Section Sum. (** Adding a valuation function on all elements of a set. *) Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Notation compat_opL := (compat_op E.eq (@Logic.eq _)). +Notation transposeL := (transpose (@Logic.eq _)). Lemma sum_plus : forall f g, compat_nat E.eq f -> compat_nat E.eq g -> @@ -844,12 +846,12 @@ Lemma sum_plus : Proof. unfold sum. intros f g Hf Hg. -assert (fc : compat_op E.eq (@eq _) (fun x:elt =>plus (f x))). auto. -assert (ft : transpose (@eq _) (fun x:elt =>plus (f x))). red; intros; omega. -assert (gc : compat_op E.eq (@eq _) (fun x:elt => plus (g x))). auto. -assert (gt : transpose (@eq _) (fun x:elt =>plus (g x))). red; intros; omega. -assert (fgc : compat_op E.eq (@eq _) (fun x:elt =>plus ((f x)+(g x)))). auto. -assert (fgt : transpose (@eq _) (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. +assert (fc : compat_opL (fun x:elt =>plus (f x))). auto. +assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. +assert (gc : compat_opL (fun x:elt => plus (g x))). auto. +assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. +assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto. +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. assert (st := gen_st nat). intros s;pattern s; apply set_rec. intros. @@ -858,7 +860,7 @@ rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. intros; do 3 (rewrite (fold_add _ _ st);auto). rewrite H0;simpl;omega. -intros; do 3 rewrite (fold_empty _ _ st);auto. +do 3 rewrite fold_empty;auto. Qed. Lemma sum_filter : forall f, (compat_bool E.eq f) -> @@ -866,11 +868,11 @@ Lemma sum_filter : forall f, (compat_bool E.eq f) -> Proof. unfold sum; intros f Hf. assert (st := gen_st nat). -assert (cc : compat_op E.eq (@eq _) (fun x => plus (if f x then 1 else 0))). - unfold compat_op; intros. +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). + red; intros. rewrite (Hf x x' H); auto. -assert (ct : transpose (@eq _) (fun x => plus (if f x then 1 else 0))). - unfold transpose; intros; omega. +assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). + red; intros; omega. intros s;pattern s; apply set_rec. intros. change elt with E.t. @@ -883,14 +885,14 @@ assert (~ In x (filter f s0)). case (f x); simpl; intros. rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto. rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto. -intros; rewrite (fold_empty _ _ st);auto. +intros; rewrite fold_empty;auto. rewrite MP.cardinal_1; auto. unfold Empty; intros. rewrite filter_iff; auto; set_iff; tauto. Qed. Lemma fold_compat : - forall (A:Set)(eqA:A->A->Prop)(st:(Setoid_Theory _ eqA)) + forall (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA) (f g:elt->A->A), (compat_op E.eq eqA f) -> (transpose eqA f) -> (compat_op E.eq eqA g) -> (transpose eqA g) -> @@ -903,26 +905,35 @@ trans_st (fold f s0 i). apply fold_equal with (eqA:=eqA); auto. rewrite equal_sym; auto. trans_st (fold g s0 i). -apply H0; intros; apply H1; auto. -elim (equal_2 H x); auto; intros. -apply fold_equal with (eqA:=eqA); auto. +apply H0; intros; apply H1; auto with set. +elim (equal_2 H x); auto with set; intros. +apply fold_equal with (eqA:=eqA); auto with set. trans_st (f x (fold f s0 i)). -apply fold_add with (eqA:=eqA); auto. -trans_st (g x (fold f s0 i)). -trans_st (g x (fold g s0 i)). +apply fold_add with (eqA:=eqA); auto with set. +trans_st (g x (fold f s0 i)); auto with set. +trans_st (g x (fold g s0 i)); auto with set. sym_st; apply fold_add with (eqA:=eqA); auto. -trans_st i; [idtac | sym_st ]; apply fold_empty; auto. +do 2 rewrite fold_empty; refl_st. Qed. Lemma sum_compat : forall f g, compat_nat E.eq f -> compat_nat E.eq g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. -unfold sum; apply (fold_compat _ (@eq nat)); auto. -unfold transpose; intros; omega. -unfold transpose; intros; omega. +unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto. +red; intros; omega. +red; intros; omega. Qed. End Sum. -End EqProperties. +End WEqProperties. + + +(** Now comes a special version dedicated to full sets. For this + one, only one argument [(M:S)] is necessary. *) + +Module EqProperties (M:S). + Module D := OT_as_DT M.E. + Include WEqProperties D M. +End EqProperties. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index aa57f066..b4b834b1 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *) +(* $Id: FSetFacts.v 10765 2008-04-08 16:15:23Z msozeau $ *) (** * Finite sets library *) @@ -16,16 +16,19 @@ Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. *) +Require Import DecidableTypeEx. Require Export FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -Module Facts (M: S). -Module ME := OrderedTypeFacts M.E. -Import ME. -Import M. -Import Logic. (* to unmask [eq] *) -Import Peano. (* to unmask [lt] *) +(** First, a functor for Weak Sets. Since the signature [WS] includes + an EqualityType and not a stronger DecidableType, this functor + should take two arguments in order to compensate this. *) + +Module WFacts (Import E : DecidableType)(Import M : WSfun E). + +Notation eq_dec := E.eq_dec. +Definition eqb x y := if eq_dec x y then true else false. (** * Specifications written using equivalences *) @@ -259,6 +262,8 @@ symmetry. rewrite H0; intros. destruct H1 as (_,H1). apply H1; auto. +rewrite H2. +rewrite InA_alt; eauto. Qed. Lemma exists_b : compat_bool E.eq f -> @@ -271,7 +276,8 @@ destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. rewrite <- H1; intros. destruct H0 as (H0,_). destruct H0 as (a,(Ha1,Ha2)); auto. -exists a; auto. +exists a; split; auto. +rewrite H2; rewrite InA_alt; eauto. symmetry. rewrite H0. destruct H1 as (_,H1). @@ -289,17 +295,25 @@ End BoolSpec. Definition E_ST : Setoid_Theory elt E.eq. Proof. -constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. +constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. -Add Setoid elt E.eq E_ST as EltSetoid. - Definition Equal_ST : Setoid_Theory t Equal. Proof. -constructor; [apply eq_refl | apply eq_sym | apply eq_trans]. +constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. -Add Setoid t Equal Equal_ST as EqualSetoid. +Add Relation elt E.eq + reflexivity proved by E.eq_refl + symmetry proved by E.eq_sym + transitivity proved by E.eq_trans + as EltSetoid. + +Add Relation t Equal + reflexivity proved by eq_refl + symmetry proved by eq_sym + transitivity proved by eq_trans + as EqualSetoid. Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. Proof. @@ -325,7 +339,7 @@ exact (H1 (refl_equal true) _ Ha). Qed. Add Morphism Empty with signature Equal ==> iff as Empty_m. -Proof. +Proof. intros; do 2 rewrite is_empty_iff; rewrite H; intuition. Qed. @@ -340,7 +354,9 @@ Qed. Add Morphism singleton : singleton_m. Proof. unfold Equal; intros x y H a. -do 2 rewrite singleton_iff; split; order. +do 2 rewrite singleton_iff; split; intros. +apply E.eq_trans with x; auto. +apply E.eq_trans with y; auto. Qed. Add Morphism add : add_m. @@ -396,6 +412,63 @@ rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. Qed. + +(* [Subset] is a setoid order *) + +Lemma Subset_refl : forall s, s[<=]s. +Proof. red; auto. Defined. + +Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. +Proof. unfold Subset; eauto. Defined. + +Add Relation t Subset + reflexivity proved by Subset_refl + transitivity proved by Subset_trans + as SubsetSetoid. +(* NB: for the moment, it is important to use Defined and not Qed in + the two previous lemmas, in order to allow conversion of + SubsetSetoid coming from separate Facts modules. See bug #1738. *) + +Instance In_s_m : Morphism (E.eq ==> Subset ++> impl) In | 1. +Proof. + simpl_relation. eauto with set. +Qed. + +Add Morphism Empty with signature Subset --> impl as Empty_s_m. +Proof. +unfold Subset, Empty, impl; firstorder. +Qed. + +Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m. +Proof. +unfold Subset; intros x y H s s' H0 a. +do 2 rewrite add_iff; rewrite H; intuition. +Qed. + +Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m. +Proof. +unfold Subset; intros x y H s s' H0 a. +do 2 rewrite remove_iff; rewrite H; intuition. +Qed. + +Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m. +Proof. +unfold Equal; intros s s' H s'' s''' H0 a. +do 2 rewrite union_iff; intuition. +Qed. + +Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m. +Proof. +unfold Equal; intros s s' H s'' s''' H0 a. +do 2 rewrite inter_iff; intuition. +Qed. + +Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m. +Proof. +unfold Subset; intros s s' H s'' s''' H0 a. +do 2 rewrite diff_iff; intuition. +Qed. + (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) @@ -405,6 +478,12 @@ Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. Qed. +Lemma filter_subset : forall f, compat_bool E.eq f -> + forall s s', s[<=]s' -> filter f s [<=] filter f s'. +Proof. +unfold Subset; intros; rewrite filter_iff in *; intuition. +Qed. + (* For [elements], [min_elt], [max_elt] and [choose], we would need setoid structures on [list elt] and [option elt]. *) @@ -412,4 +491,15 @@ Qed. Add Morphism cardinal ; cardinal_m. *) +End WFacts. + + +(** Now comes a special version dedicated to full sets. For this + one, only one argument [(M:S)] is necessary. *) + +Module Facts (Import M:S). + Module D:=OT_as_DT M.E. + Include WFacts D M. + End Facts. + diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v new file mode 100644 index 00000000..1fc109f3 --- /dev/null +++ b/theories/FSets/FSetFullAVL.v @@ -0,0 +1,1125 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre + * Institution: LRI, CNRS UMR 8623 - Université Paris Sud + * 91405 Orsay, France *) + +(* $Id: FSetFullAVL.v 10739 2008-04-01 14:45:20Z herbelin $ *) + +(** * FSetFullAVL + + This file contains some complements to [FSetAVL]. + + - Functor [AvlProofs] proves that trees of [FSetAVL] are not only + binary search trees, but moreover well-balanced ones. This is done + by proving that all operations preserve the balancing. + + - Functor [OcamlOps] contains variants of [union], [subset], + [compare] and [equal] that are faithful to the original ocaml codes, + while the versions in FSetAVL have been adapted to perform only + structural recursive code. + + - Finally, we pack the previous elements in a [Make] functor + similar to the one of [FSetAVL], but richer. +*) + +Require Import Recdef FSetInterface FSetList ZArith Int FSetAVL. + +Set Implicit Arguments. +Unset Strict Implicit. + +Module AvlProofs (Import I:Int)(X:OrderedType). +Module Import Raw := Raw I X. +Import Raw.Proofs. +Module Import II := MoreInt I. +Open Local Scope pair_scope. +Open Local Scope Int_scope. + +(** * AVL trees *) + +(** [avl s] : [s] is a properly balanced AVL tree, + i.e. for any node the heights of the two children + differ by at most 2 *) + +Inductive avl : tree -> Prop := + | RBLeaf : avl Leaf + | RBNode : forall x l r h, avl l -> avl r -> + -(2) <= height l - height r <= 2 -> + h = max (height l) (height r) + 1 -> + avl (Node l x r h). + +(** * Automation and dedicated tactics *) + +Hint Constructors avl. + +(** A tactic for cleaning hypothesis after use of functional induction. *) + +Ltac clearf := + match goal with + | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf + | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf + | _ => idtac + end. + +(** Tactics about [avl] *) + +Lemma height_non_negative : forall s : tree, avl s -> height s >= 0. +Proof. + induction s; simpl; intros; auto with zarith. + inv avl; intuition; omega_max. +Qed. +Implicit Arguments height_non_negative. + +(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *) + +Ltac avl_nn_hyp H := + let nz := fresh "nz" in assert (nz := height_non_negative H). + +Ltac avl_nn h := + let t := type of h in + match type of t with + | Prop => avl_nn_hyp h + | _ => match goal with H : avl h |- _ => avl_nn_hyp H end + end. + +(* Repeat the previous tactic. + Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) + +Ltac avl_nns := + match goal with + | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns + | _ => idtac + end. + +(** Results about [height] *) + +Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf. +Proof. + destruct 1; intuition; simpl in *. + avl_nns; simpl in *; elimtype False; omega_max. +Qed. + +(** * Results about [avl] *) + +Lemma avl_node : + forall x l r, avl l -> avl r -> + -(2) <= height l - height r <= 2 -> + avl (Node l x r (max (height l) (height r) + 1)). +Proof. + intros; auto. +Qed. +Hint Resolve avl_node. + + +(** empty *) + +Lemma empty_avl : avl empty. +Proof. + auto. +Qed. + +(** singleton *) + +Lemma singleton_avl : forall x : elt, avl (singleton x). +Proof. + unfold singleton; intro. + constructor; auto; try red; simpl; omega_max. +Qed. + +(** create *) + +Lemma create_avl : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + avl (create l x r). +Proof. + unfold create; auto. +Qed. + +Lemma create_height : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + height (create l x r) = max (height l) (height r) + 1. +Proof. + unfold create; auto. +Qed. + +(** bal *) + +Lemma bal_avl : forall l x r, avl l -> avl r -> + -(3) <= height l - height r <= 3 -> avl (bal l x r). +Proof. + intros l x r; functional induction bal l x r; intros; clearf; + inv avl; simpl in *; + match goal with |- avl (assert_false _ _ _) => avl_nns + | _ => repeat apply create_avl; simpl in *; auto + end; omega_max. +Qed. + +Lemma bal_height_1 : forall l x r, avl l -> avl r -> + -(3) <= height l - height r <= 3 -> + 0 <= height (bal l x r) - max (height l) (height r) <= 1. +Proof. + intros l x r; functional induction bal l x r; intros; clearf; + inv avl; avl_nns; simpl in *; omega_max. +Qed. + +Lemma bal_height_2 : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> + height (bal l x r) == max (height l) (height r) +1. +Proof. + intros l x r; functional induction bal l x r; intros; clearf; + inv avl; simpl in *; omega_max. +Qed. + +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => + generalize (bal_height_1 x H H') (bal_height_2 x H H'); + omega_max + end. + +(** add *) + +Lemma add_avl_1 : forall s x, avl s -> + avl (add x s) /\ 0 <= height (add x s) - height s <= 1. +Proof. + intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *. + intuition; try constructor; simpl; auto; try omega_max. + (* LT *) + destruct IHt; auto. + split. + apply bal_avl; auto; omega_max. + omega_bal. + (* EQ *) + intuition; omega_max. + (* GT *) + destruct IHt; auto. + split. + apply bal_avl; auto; omega_max. + omega_bal. +Qed. + +Lemma add_avl : forall s x, avl s -> avl (add x s). +Proof. + intros; destruct (add_avl_1 x H); auto. +Qed. +Hint Resolve add_avl. + +(** join *) + +Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\ + 0<= height (join l x r) - max (height l) (height r) <= 1. +Proof. + join_tac. + + split; simpl; auto. + destruct (add_avl_1 x H0). + avl_nns; omega_max. + set (l:=Node ll lx lr lh) in *. + split; auto. + destruct (add_avl_1 x H). + simpl (height Leaf). + avl_nns; omega_max. + + inversion_clear H. + assert (height (Node rl rx rr rh) = rh); auto. + set (r := Node rl rx rr rh) in *; clearbody r. + destruct (Hlr x r H2 H0); clear Hrl Hlr. + set (j := join lr x r) in *; clearbody j. + simpl. + assert (-(3) <= height ll - height j <= 3) by omega_max. + split. + apply bal_avl; auto. + omega_bal. + + inversion_clear H0. + assert (height (Node ll lx lr lh) = lh); auto. + set (l := Node ll lx lr lh) in *; clearbody l. + destruct (Hrl H H1); clear Hrl Hlr. + set (j := join l x rl) in *; clearbody j. + simpl. + assert (-(3) <= height j - height rr <= 3) by omega_max. + split. + apply bal_avl; auto. + omega_bal. + + clear Hrl Hlr. + assert (height (Node ll lx lr lh) = lh); auto. + assert (height (Node rl rx rr rh) = rh); auto. + set (l := Node ll lx lr lh) in *; clearbody l. + set (r := Node rl rx rr rh) in *; clearbody r. + assert (-(2) <= height l - height r <= 2) by omega_max. + split. + apply create_avl; auto. + rewrite create_height; auto; omega_max. +Qed. + +Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r). +Proof. + intros; destruct (join_avl_1 x H H0); auto. +Qed. +Hint Resolve join_avl. + +(** remove_min *) + +Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> + avl (remove_min l x r)#1 /\ + 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1. +Proof. + intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. + inv avl; simpl in *; split; auto. + avl_nns; omega_max. + inversion_clear H. + rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. + split; simpl in *. + apply bal_avl; auto; omega_max. + omega_bal. +Qed. + +Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> + avl (remove_min l x r)#1. +Proof. + intros; destruct (remove_min_avl_1 H); auto. +Qed. + +(** merge *) + +Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> + -(2) <= height s1 - height s2 <= 2 -> + avl (merge s1 s2) /\ + 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. +Proof. + intros s1 s2; functional induction (merge s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + simpl; split; auto; avl_nns; omega_max. + simpl; split; auto; avl_nns; simpl in *; omega_max. + generalize (remove_min_avl_1 H0). + rewrite e1; destruct 1. + split. + apply bal_avl; auto. + simpl; omega_max. + simpl in *; omega_bal. +Qed. + +Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> + -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). +Proof. + intros; destruct (merge_avl_1 H H0 H1); auto. +Qed. + + +(** remove *) + +Lemma remove_avl_1 : forall s x, avl s -> + avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. +Proof. + intros s x; functional induction (remove x s); intros. + intuition; omega_max. + (* LT *) + inv avl. + destruct (IHt H0). + split. + apply bal_avl; auto. + omega_max. + omega_bal. + (* EQ *) + inv avl. + generalize (merge_avl_1 H0 H1 H2). + intuition omega_max. + (* GT *) + inv avl. + destruct (IHt H1). + split. + apply bal_avl; auto. + omega_max. + omega_bal. +Qed. + +Lemma remove_avl : forall s x, avl s -> avl (remove x s). +Proof. + intros; destruct (remove_avl_1 x H); auto. +Qed. +Hint Resolve remove_avl. + +(** concat *) + +Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2). +Proof. + intros s1 s2; functional induction (concat s1 s2); auto. + intros; apply join_avl; auto. + generalize (remove_min_avl H0); rewrite e1; simpl; auto. +Qed. +Hint Resolve concat_avl. + +(** split *) + +Lemma split_avl : forall s x, avl s -> + avl (split x s)#l /\ avl (split x s)#r. +Proof. + intros s x; functional induction (split x s); simpl; auto. + rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. + simpl; inversion_clear 1; auto. + rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. +Qed. + +(** inter *) + +Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). +Proof. + intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + inv avl; auto. +Qed. + +(** diff *) + +Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). +Proof. + intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + inv avl; auto. +Qed. + +(** union *) + +Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2). +Proof. + intros s1 s2; functional induction union s1 s2; auto; intros A1 A2; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + inv avl; auto. +Qed. + +(** filter *) + +Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> + avl (filter_acc f acc s). +Proof. + induction s; simpl; auto. + intros. + inv avl. + destruct (f t); auto. +Qed. +Hint Resolve filter_acc_avl. + +Lemma filter_avl : forall f s, avl s -> avl (filter f s). +Proof. + unfold filter; intros; apply filter_acc_avl; auto. +Qed. + +(** partition *) + +Lemma partition_acc_avl_1 : forall f s acc, avl s -> + avl acc#1 -> avl (partition_acc f acc s)#1. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. + inv avl. + apply IHs2; auto. + apply IHs1; auto. + destruct (f t); simpl; auto. +Qed. + +Lemma partition_acc_avl_2 : forall f s acc, avl s -> + avl acc#2 -> avl (partition_acc f acc s)#2. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. + inv avl. + apply IHs2; auto. + apply IHs1; auto. + destruct (f t); simpl; auto. +Qed. + +Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. +Proof. + unfold partition; intros; apply partition_acc_avl_1; auto. +Qed. + +Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. +Proof. + unfold partition; intros; apply partition_acc_avl_2; auto. +Qed. + +End AvlProofs. + + +Module OcamlOps (Import I:Int)(X:OrderedType). +Module Import AvlProofs := AvlProofs I X. +Import Raw. +Import Raw.Proofs. +Import II. +Open Local Scope pair_scope. +Open Local Scope nat_scope. + +(** Properties of cardinal *) + +Lemma bal_cardinal : forall l x r, + cardinal (bal l x r) = S (cardinal l + cardinal r). +Proof. + intros l x r; functional induction bal l x r; intros; clearf; + simpl; auto with arith; romega with *. +Qed. + +Lemma add_cardinal : forall x s, + cardinal (add x s) <= S (cardinal s). +Proof. + intros; functional induction add x s; simpl; auto with arith; + rewrite bal_cardinal; romega with *. +Qed. + +Lemma join_cardinal : forall l x r, + cardinal (join l x r) <= S (cardinal l + cardinal r). +Proof. + join_tac; auto with arith. + simpl; apply add_cardinal. + simpl; destruct X.compare; simpl; auto with arith. + generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); + romega with *. + generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); + romega with *. + generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh))) + (Hlr x (Node rl rx rr rh)); simpl; romega with *. + simpl S in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr). + romega with *. +Qed. + +Lemma split_cardinal_1 : forall x s, + (cardinal (split x s)#l <= cardinal s)%nat. +Proof. + intros x s; functional induction split x s; simpl; auto. + rewrite e1 in IHt; simpl in *. + romega with *. + romega with *. + rewrite e1 in IHt; simpl in *. + generalize (@join_cardinal l y rl); romega with *. +Qed. + +Lemma split_cardinal_2 : forall x s, + (cardinal (split x s)#r <= cardinal s)%nat. +Proof. + intros x s; functional induction split x s; simpl; auto. + rewrite e1 in IHt; simpl in *. + generalize (@join_cardinal rl y r); romega with *. + romega with *. + rewrite e1 in IHt; simpl in *; romega with *. +Qed. + +(** * [ocaml_union], an union faithful to the original ocaml code *) + +Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat. + +Ltac ocaml_union_tac := + intros; unfold cardinal2; simpl fst in *; simpl snd in *; + match goal with H: split ?x ?s = _ |- _ => + generalize (split_cardinal_1 x s) (split_cardinal_2 x s); + rewrite H; simpl; romega with * + end. + +Import Logic. (* Unhide eq, otherwise Function complains. *) + +Function ocaml_union (s : t * t) { measure cardinal2 s } : t := + match s with + | (Leaf, Leaf) => s#2 + | (Leaf, Node _ _ _ _) => s#2 + | (Node _ _ _ _, Leaf) => s#1 + | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => + if ge_lt_dec h1 h2 then + if eq_dec h2 1%I then add x2 s#1 else + let (l2',_,r2') := split x1 s#2 in + join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2')) + else + if eq_dec h1 1%I then add x1 s#2 else + let (l1',_,r1') := split x2 s#1 in + join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2)) + end. +Proof. +abstract ocaml_union_tac. +abstract ocaml_union_tac. +abstract ocaml_union_tac. +abstract ocaml_union_tac. +Defined. + +Lemma ocaml_union_in : forall s y, + bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> + (In y (ocaml_union s) <-> In y s#1 \/ In y s#2). +Proof. + intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; + simpl fst in *; simpl snd in *; try clear e0 e1. + intuition_in. + intuition_in. + intuition_in. + (* add x2 s#1 *) + inv avl. + rewrite (height_0 H); [ | avl_nn l2; omega_max]. + rewrite (height_0 H0); [ | avl_nn r2; omega_max]. + rewrite add_in; intuition_in. + (* join (union (l1,l2')) x1 (union (r1,r2')) *) + generalize + (split_avl x1 A2) (split_bst x1 B2) + (split_in_1 x1 y B2) (split_in_2 x1 y B2). + rewrite e2; simpl. + destruct 1; destruct 1; inv avl; inv bst. + rewrite join_in, IHt, IHt0; auto. + do 2 (intro Eq; rewrite Eq; clear Eq). + case (X.compare y x1); intuition_in. + (* add x1 s#2 *) + inv avl. + rewrite (height_0 H3); [ | avl_nn l1; omega_max]. + rewrite (height_0 H4); [ | avl_nn r1; omega_max]. + rewrite add_in; auto; intuition_in. + (* join (union (l1',l2)) x1 (union (r1',r2)) *) + generalize + (split_avl x2 A1) (split_bst x2 B1) + (split_in_1 x2 y B1) (split_in_2 x2 y B1). + rewrite e2; simpl. + destruct 1; destruct 1; inv avl; inv bst. + rewrite join_in, IHt, IHt0; auto. + do 2 (intro Eq; rewrite Eq; clear Eq). + case (X.compare y x2); intuition_in. +Qed. + +Lemma ocaml_union_bst : forall s, + bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s). +Proof. + intros s; functional induction ocaml_union s; intros B1 A1 B2 A2; + simpl fst in *; simpl snd in *; try clear e0 e1; + try apply add_bst; auto. + (* join (union (l1,l2')) x1 (union (r1,r2')) *) + clear _x _x0; factornode l2 x2 r2 h2 as s2. + generalize (split_avl x1 A2) (split_bst x1 B2) + (@split_in_1 s2 x1)(@split_in_2 s2 x1). + rewrite e2; simpl. + destruct 1; destruct 1; intros. + inv bst; inv avl. + apply join_bst; auto. + intro y; rewrite ocaml_union_in, H3; intuition_in. + intro y; rewrite ocaml_union_in, H4; intuition_in. + (* join (union (l1',l2)) x1 (union (r1',r2)) *) + clear _x _x0; factornode l1 x1 r1 h1 as s1. + generalize (split_avl x2 A1) (split_bst x2 B1) + (@split_in_1 s1 x2)(@split_in_2 s1 x2). + rewrite e2; simpl. + destruct 1; destruct 1; intros. + inv bst; inv avl. + apply join_bst; auto. + intro y; rewrite ocaml_union_in, H3; intuition_in. + intro y; rewrite ocaml_union_in, H4; intuition_in. +Qed. + +Lemma ocaml_union_avl : forall s, + avl s#1 -> avl s#2 -> avl (ocaml_union s). +Proof. + intros s; functional induction ocaml_union s; + simpl fst in *; simpl snd in *; auto. + intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl. + inv avl; destruct 1; auto. + intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl. + inv avl; destruct 1; auto. +Qed. + +Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> + Equal (ocaml_union s) (union s#1 s#2). +Proof. + red; intros; rewrite ocaml_union_in, union_in; simpl; intuition. +Qed. + + +(** * [ocaml_subset], a subset faithful to the original ocaml code *) + +Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool := + match s with + | (Leaf, _) => true + | (Node _ _ _ _, Leaf) => false + | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => + match X.compare x1 x2 with + | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2) + | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2) + | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2) + end + end. + +Proof. + intros; unfold cardinal2; simpl; abstract romega with *. + intros; unfold cardinal2; simpl; abstract romega with *. + intros; unfold cardinal2; simpl; abstract romega with *. + intros; unfold cardinal2; simpl; abstract romega with *. + intros; unfold cardinal2; simpl; abstract romega with *. + intros; unfold cardinal2; simpl; abstract romega with *. +Defined. + +Lemma ocaml_subset_12 : forall s, + bst s#1 -> bst s#2 -> + (ocaml_subset s = true <-> Subset s#1 s#2). +Proof. + intros s; functional induction ocaml_subset s; simpl; + intros B1 B2; try clear e0. + intuition. + red; auto; inversion 1. + split; intros; try discriminate. + assert (H': In _x0 Leaf) by auto; inversion H'. + (**) + simpl in *; inv bst. + rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. + unfold Subset; intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + (**) + simpl in *; inv bst. + rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. + unfold Subset; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + (**) + simpl in *; inv bst. + rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. + unfold Subset; intuition_in. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + +Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> + ocaml_subset s = subset s#1 s#2. +Proof. + intros. + generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto. + destruct ocaml_subset; destruct subset; intuition. +Qed. + + + +(** [ocaml_compare], a compare faithful to the original ocaml code *) + +(** termination of [compare_aux] *) + +Fixpoint cardinal_e e := match e with + | End => 0 + | More _ s r => S (cardinal s + cardinal_e r) + end. + +Lemma cons_cardinal_e : forall s e, + cardinal_e (cons s e) = cardinal s + cardinal_e e. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith. +Qed. + +Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2. + +Function ocaml_compare_aux + (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := + match e with + | (End,End) => Eq + | (End,More _ _ _) => Lt + | (More _ _ _, End) => Gt + | (More x1 r1 e1, More x2 r2 e2) => + match X.compare x1 x2 with + | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2) + | LT _ => Lt + | GT _ => Gt + end + end. + +Proof. +intros; unfold cardinal_e_2; simpl; +abstract (do 2 rewrite cons_cardinal_e; romega with *). +Defined. + +Definition ocaml_compare s1 s2 := + ocaml_compare_aux (cons s1 End, cons s2 End). + +Lemma ocaml_compare_aux_Cmp : forall e, + Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2). +Proof. + intros e; functional induction ocaml_compare_aux e; simpl; intros; + auto; try discriminate. + apply L.eq_refl. + simpl in *. + apply cons_Cmp; auto. + rewrite <- 2 cons_1; auto. +Qed. + +Lemma ocaml_compare_Cmp : forall s1 s2, + Cmp (ocaml_compare s1 s2) (elements s1) (elements s2). +Proof. + unfold ocaml_compare; intros. + assert (H1:=cons_1 s1 End). + assert (H2:=cons_1 s2 End). + simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. + apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)). +Qed. + +Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> + ocaml_compare s1 s2 = compare s1 s2. +Proof. + intros s1 s2 B1 B2. + generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). + unfold Cmp. + destruct ocaml_compare; destruct compare; auto; intros; elimtype False. + elim (lt_not_eq B1 B2 H0); auto. + elim (lt_not_eq B2 B1 H0); auto. + apply eq_sym; auto. + elim (lt_not_eq B1 B2 H); auto. + elim (lt_not_eq B1 B1). + red; eapply L.lt_trans; eauto. + apply eq_refl. + elim (lt_not_eq B2 B1 H); auto. + apply eq_sym; auto. + elim (lt_not_eq B1 B2 H0); auto. + elim (lt_not_eq B1 B1). + red; eapply L.lt_trans; eauto. + apply eq_refl. +Qed. + + +(** * Equality test *) + +Definition ocaml_equal s1 s2 : bool := + match ocaml_compare s1 s2 with + | Eq => true + | _ => false + end. + +Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 -> + Equal s1 s2 -> ocaml_equal s1 s2 = true. +Proof. +unfold ocaml_equal; intros s1 s2 B1 B2 E. +generalize (ocaml_compare_Cmp s1 s2). +destruct (ocaml_compare s1 s2); auto; intros. +elim (lt_not_eq B1 B2 H E); auto. +elim (lt_not_eq B2 B1 H (eq_sym E)); auto. +Qed. + +Lemma ocaml_equal_2 : forall s1 s2, + ocaml_equal s1 s2 = true -> Equal s1 s2. +Proof. +unfold ocaml_equal; intros s1 s2 E. +generalize (ocaml_compare_Cmp s1 s2); + destruct ocaml_compare; auto; discriminate. +Qed. + +Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> + ocaml_equal s1 s2 = equal s1 s2. +Proof. +intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto. +Qed. + +End OcamlOps. + + + +(** * Encapsulation + + We can implement [S] with balanced binary search trees. + When compared to [FSetAVL], we maintain here two invariants + (bst and avl) instead of only bst, which is enough for fulfilling + the FSet interface. + + This encapsulation propose the non-structural variants + [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal]. +*) + +Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. + + Module E := X. + Module Import OcamlOps := OcamlOps I X. + Import AvlProofs. + Import Raw. + Import Raw.Proofs. + + Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}. + Definition t := bbst. + Definition elt := E.t. + + Definition In (x : elt) (s : t) : Prop := In x s. + Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. + Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. + Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x. + + Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. + Proof. intro s; exact (@In_1 s). Qed. + + Definition mem (x:elt)(s:t) : bool := mem x s. + + Definition empty : t := Bbst empty_bst empty_avl. + Definition is_empty (s:t) : bool := is_empty s. + Definition singleton (x:elt) : t := + Bbst (singleton_bst x) (singleton_avl x). + Definition add (x:elt)(s:t) : t := + Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). + Definition remove (x:elt)(s:t) : t := + Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)). + Definition inter (s s':t) : t := + Bbst (inter_bst (is_bst s) (is_bst s')) + (inter_avl (is_avl s) (is_avl s')). + Definition union (s s':t) : t := + Bbst (union_bst (is_bst s) (is_bst s')) + (union_avl (is_avl s) (is_avl s')). + Definition ocaml_union (s s':t) : t := + Bbst (@ocaml_union_bst (s.(this),s'.(this)) + (is_bst s) (is_avl s) (is_bst s') (is_avl s')) + (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')). + Definition diff (s s':t) : t := + Bbst (diff_bst (is_bst s) (is_bst s')) + (diff_avl (is_avl s) (is_avl s')). + Definition elements (s:t) : list elt := elements s. + Definition min_elt (s:t) : option elt := min_elt s. + Definition max_elt (s:t) : option elt := max_elt s. + Definition choose (s:t) : option elt := choose s. + Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. + Definition cardinal (s:t) : nat := cardinal s. + Definition filter (f : elt -> bool) (s:t) : t := + Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)). + Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s. + Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s. + Definition partition (f : elt -> bool) (s:t) : t * t := + let p := partition f s in + (@Bbst (fst p) (partition_bst_1 f (is_bst s)) + (partition_avl_1 f (is_avl s)), + @Bbst (snd p) (partition_bst_2 f (is_bst s)) + (partition_avl_2 f (is_avl s))). + + Definition equal (s s':t) : bool := equal s s'. + Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'. + Definition subset (s s':t) : bool := subset s s'. + Definition ocaml_subset (s s':t) : bool := + ocaml_subset (s.(this),s'.(this)). + + Definition eq (s s':t) : Prop := Equal s s'. + Definition lt (s s':t) : Prop := lt s s'. + + Definition compare (s s':t) : Compare lt eq s s'. + Proof. + intros (s,b,a) (s',b',a'). + generalize (compare_Cmp s s'). + destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. + change (Raw.Equal s s'); auto. + Defined. + + Definition ocaml_compare (s s':t) : Compare lt eq s s'. + Proof. + intros (s,b,a) (s',b',a'). + generalize (ocaml_compare_Cmp s s'). + destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto. + change (Raw.Equal s s'); auto. + Defined. + + (* specs *) + Section Specs. + Variable s s' s'': t. + Variable x y : elt. + + Hint Resolve is_bst is_avl. + + Lemma mem_1 : In x s -> mem x s = true. + Proof. exact (mem_1 (is_bst s)). Qed. + Lemma mem_2 : mem x s = true -> In x s. + Proof. exact (@mem_2 s x). Qed. + + Lemma equal_1 : Equal s s' -> equal s s' = true. + Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. + Lemma equal_2 : equal s s' = true -> Equal s s'. + Proof. exact (@equal_2 s s'). Qed. + + Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'. + Proof. + destruct s; destruct s'; unfold ocaml_equal, equal; simpl. + apply ocaml_equal_alt; auto. + Qed. + + Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true. + Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed. + Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'. + Proof. exact (@ocaml_equal_2 s s'). Qed. + + Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. + + Lemma subset_1 : Subset s s' -> subset s s' = true. + Proof. wrap subset subset_12. Qed. + Lemma subset_2 : subset s s' = true -> Subset s s'. + Proof. wrap subset subset_12. Qed. + + Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'. + Proof. + destruct s; destruct s'; unfold ocaml_subset, subset; simpl. + rewrite ocaml_subset_alt; auto. + Qed. + + Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true. + Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. + Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'. + Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. + + Lemma empty_1 : Empty empty. + Proof. exact empty_1. Qed. + + Lemma is_empty_1 : Empty s -> is_empty s = true. + Proof. exact (@is_empty_1 s). Qed. + Lemma is_empty_2 : is_empty s = true -> Empty s. + Proof. exact (@is_empty_2 s). Qed. + + Lemma add_1 : E.eq x y -> In y (add x s). + Proof. wrap add add_in. Qed. + Lemma add_2 : In y s -> In y (add x s). + Proof. wrap add add_in. Qed. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Proof. wrap add add_in. elim H; auto. Qed. + + Lemma remove_1 : E.eq x y -> ~ In y (remove x s). + Proof. wrap remove remove_in. Qed. + Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). + Proof. wrap remove remove_in. Qed. + Lemma remove_3 : In y (remove x s) -> In y s. + Proof. wrap remove remove_in. Qed. + + Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Proof. exact (@singleton_1 x y). Qed. + Lemma singleton_2 : E.eq x y -> In y (singleton x). + Proof. exact (@singleton_2 x y). Qed. + + Lemma union_1 : In x (union s s') -> In x s \/ In x s'. + Proof. wrap union union_in. Qed. + Lemma union_2 : In x s -> In x (union s s'). + Proof. wrap union union_in. Qed. + Lemma union_3 : In x s' -> In x (union s s'). + Proof. wrap union union_in. Qed. + + Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s'). + Proof. + unfold ocaml_union, union, Equal, In. + destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl. + exact (@ocaml_union_alt (s0,s0') b a b' a'). + Qed. + + Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'. + Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. + Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s'). + Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. + Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s'). + Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. + + Lemma inter_1 : In x (inter s s') -> In x s. + Proof. wrap inter inter_in. Qed. + Lemma inter_2 : In x (inter s s') -> In x s'. + Proof. wrap inter inter_in. Qed. + Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). + Proof. wrap inter inter_in. Qed. + + Lemma diff_1 : In x (diff s s') -> In x s. + Proof. wrap diff diff_in. Qed. + Lemma diff_2 : In x (diff s s') -> ~ In x s'. + Proof. wrap diff diff_in. Qed. + Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). + Proof. wrap diff diff_in. Qed. + + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + unfold fold, elements; intros; apply fold_1; auto. + Qed. + + Lemma cardinal_1 : cardinal s = length (elements s). + Proof. + unfold cardinal, elements; intros; apply elements_cardinal; auto. + Qed. + + Section Filter. + Variable f : elt -> bool. + + Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Proof. intro. wrap filter filter_in. Qed. + Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Proof. intro. wrap filter filter_in. Qed. + Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + Proof. intro. wrap filter filter_in. Qed. + + Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. + Proof. exact (@for_all_1 f s). Qed. + Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. + Proof. exact (@for_all_2 f s). Qed. + + Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. exact (@exists_1 f s). Qed. + Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. exact (@exists_2 f s). Qed. + + Lemma partition_1 : compat_bool E.eq f -> + Equal (fst (partition f s)) (filter f s). + Proof. + unfold partition, filter, Equal, In; simpl ;intros H a. + rewrite partition_in_1, filter_in; intuition. + Qed. + + Lemma partition_2 : compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter, Equal, In; simpl ;intros H a. + rewrite partition_in_2, filter_in; intuition. + rewrite H2; auto. + destruct (f a); auto. + red; intros; f_equal. + rewrite (H _ _ H0); auto. + Qed. + + End Filter. + + Lemma elements_1 : In x s -> InA E.eq x (elements s). + Proof. wrap elements elements_in. Qed. + Lemma elements_2 : InA E.eq x (elements s) -> In x s. + Proof. wrap elements elements_in. Qed. + Lemma elements_3 : sort E.lt (elements s). + Proof. exact (elements_sort (is_bst s)). Qed. + Lemma elements_3w : NoDupA E.eq (elements s). + Proof. exact (elements_nodup (is_bst s)). Qed. + + Lemma min_elt_1 : min_elt s = Some x -> In x s. + Proof. exact (@min_elt_1 s x). Qed. + Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. + Lemma min_elt_3 : min_elt s = None -> Empty s. + Proof. exact (@min_elt_3 s). Qed. + + Lemma max_elt_1 : max_elt s = Some x -> In x s. + Proof. exact (@max_elt_1 s x). Qed. + Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. + Lemma max_elt_3 : max_elt s = None -> Empty s. + Proof. exact (@max_elt_3 s). Qed. + + Lemma choose_1 : choose s = Some x -> In x s. + Proof. exact (@choose_1 s x). Qed. + Lemma choose_2 : choose s = None -> Empty s. + Proof. exact (@choose_2 s). Qed. + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. + Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. + + Lemma eq_refl : eq s s. + Proof. exact (eq_refl s). Qed. + Lemma eq_sym : eq s s' -> eq s' s. + Proof. exact (@eq_sym s s'). Qed. + Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. + Proof. exact (@eq_trans s s' s''). Qed. + + Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. + Proof. exact (@lt_trans s s' s''). Qed. + Lemma lt_not_eq : lt s s' -> ~eq s s'. + Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. + + End Specs. +End IntMake. + +(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) + +Module Make (X: OrderedType) <: S with Module E := X + :=IntMake(Z_as_Int)(X). + diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 64ad234b..1255fcc8 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,40 +6,53 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *) +(* $Id: FSetInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) (** * Finite set library *) -(** Set interfaces *) - -(* begin hide *) -Require Export Bool. -Require Export OrderedType. +(** Set interfaces, inspired by the one of Ocaml. When compared with + Ocaml, the main differences are: + - the lack of [iter] function, useless since Coq is purely functional + - the use of [option] types instead of [Not_found] exceptions + - the use of [nat] instead of [int] for the [cardinal] function + + Several variants of the set interfaces are available: + - [WSfun] : functorial signature for weak sets, non-dependent style + - [WS] : self-contained version of [WSfun] + - [Sfun] : functorial signature for ordered sets, non-dependent style + - [S] : self-contained version of [Sfun] + - [Sdep] : analog of [S] written using dependent style + + If unsure, [S] is probably what you're looking for: other signatures + are subsets of it, apart from [Sdep] which is isomorphic to [S] (see + [FSetBridge]). +*) + +Require Export Bool OrderedType DecidableType. Set Implicit Arguments. Unset Strict Implicit. -(* end hide *) -(** Compatibility of a boolean function with respect to an equality. *) -Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) := - forall x y : A, eqA x y -> f x = f y. +(** * Non-dependent signatures -(** Compatibility of a predicate with respect to an equality. *) -Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) := - forall x y : A, eqA x y -> P x -> P y. + The following signatures presents sets as purely informative + programs together with axioms *) -Hint Unfold compat_bool compat_P. -(** * Non-dependent signature - Signature [S] presents sets as purely informative programs - together with axioms *) +(** ** Functorial signature for weak sets -Module Type S. + Weak sets are sets without ordering on base elements, only + a decidable equality. *) + +Module Type WSfun (E : EqualityType). + + (** The module E of base objects is meant to be a [DecidableType] + (and used to be so). But requiring only an [EqualityType] here + allows subtyping between weak and ordered sets *) - Declare Module E : OrderedType. Definition elt := E.t. - Parameter t : Set. (** the abstract type of sets *) + Parameter t : Type. (** the abstract type of sets *) (** Logical predicates *) Parameter In : elt -> t -> Prop. @@ -82,10 +95,12 @@ Module Type S. (** Set difference. *) Definition eq : t -> t -> Prop := Equal. - Parameter lt : t -> t -> Prop. - Parameter compare : forall s s' : t, Compare lt eq s s'. - (** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. *) + (** In order to have the subtyping WS < S between weak and ordered + sets, we do not require here an [eq_dec]. This interface is hence + not compatible with [DecidableType], but only with [EqualityType], + so in general it may not possible to form weak sets of weak sets. + Some particular implementations may allow this nonetheless, in + particular [FSetWeakList.Make]. *) Parameter equal : t -> t -> bool. (** [equal s1 s2] tests whether the sets [s1] and [s2] are @@ -95,15 +110,11 @@ Module Type S. (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2]. *) - (** Coq comment: [iter] is useless in a purely functional world *) - (** iter: (elt -> unit) -> set -> unit. i*) - (** [iter f s] applies [f] in turn to all elements of [s]. - The order in which the elements of [s] are presented to [f] - is unspecified. *) - - Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A. + Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s], in increasing order. *) + where [x1 ... xN] are the elements of [s]. + The order in which elements of [s] are presented to [f] is + unspecified. *) Parameter for_all : (elt -> bool) -> t -> bool. (** [for_all p s] checks if all elements of the set @@ -125,59 +136,39 @@ Module Type S. Parameter cardinal : t -> nat. (** Return the number of elements of a set. *) - (** Coq comment: nat instead of int ... *) Parameter elements : t -> list elt. - (** Return the list of all elements of the given set. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Set.Make}. *) - - Parameter min_elt : t -> option elt. - (** Return the smallest element of the given set - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the set is empty. *) - (** Coq comment: [Not_found] is represented by the option type *) - - Parameter max_elt : t -> option elt. - (** Same as {!Set.S.min_elt}, but returns the largest element of the - given set. *) - (** Coq comment: [Not_found] is represented by the option type *) + (** Return the list of all elements of the given set, in any order. *) Parameter choose : t -> option elt. - (** Return one element of the given set, or raise [Not_found] if - the set is empty. Which element is chosen is unspecified, - but equal elements will be chosen for equal sets. *) - (** Coq comment: [Not_found] is represented by the option type *) + (** Return one element of the given set, or [None] if + the set is empty. Which element is chosen is unspecified. + Equal sets could return different elements. *) Section Spec. - Variable s s' s'' : t. + Variable s s' s'': t. Variable x y : elt. (** Specification of [In] *) Parameter In_1 : E.eq x y -> In x s -> In y s. - + (** Specification of [eq] *) Parameter eq_refl : eq s s. Parameter eq_sym : eq s s' -> eq s' s. Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. - - (** Specification of [lt] *) - Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Parameter lt_not_eq : lt s s' -> ~ eq s s'. (** Specification of [mem] *) Parameter mem_1 : In x s -> mem x s = true. Parameter mem_2 : mem x s = true -> In x s. (** Specification of [equal] *) - Parameter equal_1 : s[=]s' -> equal s s' = true. - Parameter equal_2 : equal s s' = true ->s[=]s'. + Parameter equal_1 : Equal s s' -> equal s s' = true. + Parameter equal_2 : equal s s' = true -> Equal s s'. (** Specification of [subset] *) - Parameter subset_1 : s[<=]s' -> subset s s' = true. - Parameter subset_2 : subset s s' = true -> s[<=]s'. + Parameter subset_1 : Subset s s' -> subset s s' = true. + Parameter subset_2 : subset s s' = true -> Subset s s'. (** Specification of [empty] *) Parameter empty_1 : Empty empty. @@ -216,7 +207,7 @@ Module Type S. Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). (** Specification of [fold] *) - Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), + Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. (** Specification of [cardinal] *) @@ -249,18 +240,93 @@ Module Type S. exists_ f s = true -> Exists (fun x => f x = true) s. (** Specification of [partition] *) - Parameter partition_1 : compat_bool E.eq f -> - fst (partition f s) [=] filter f s. - Parameter partition_2 : compat_bool E.eq f -> - snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter partition_1 : + compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). + Parameter partition_2 : + compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). End Filter. (** Specification of [elements] *) Parameter elements_1 : In x s -> InA E.eq x (elements s). Parameter elements_2 : InA E.eq x (elements s) -> In x s. + (** When compared with ordered sets, here comes the only + property that is really weaker: *) + Parameter elements_3w : NoDupA E.eq (elements s). + + (** Specification of [choose] *) + Parameter choose_1 : choose s = Some x -> In x s. + Parameter choose_2 : choose s = None -> Empty s. + + End Spec. + + Hint Resolve mem_1 equal_1 subset_1 empty_1 + is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 + remove_2 singleton_2 union_1 union_2 union_3 + inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 + partition_1 partition_2 elements_1 elements_3w + : set. + Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 + remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 + : set. + +End WSfun. + + + +(** ** Static signature for weak sets + + Similar to the functorial signature [SW], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type WS. + Declare Module E : EqualityType. + Include Type WSfun E. +End WS. + + + +(** ** Functorial signature for sets on ordered elements + + Based on [WSfun], plus ordering on sets and [min_elt] and [max_elt] + and some stronger specifications for other functions. *) + +Module Type Sfun (E : OrderedType). + Include Type WSfun E. + + Parameter lt : t -> t -> Prop. + Parameter compare : forall s s' : t, Compare lt eq s s'. + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + Parameter min_elt : t -> option elt. + (** Return the smallest element of the given set + (with respect to the [E.compare] ordering), + or [None] if the set is empty. *) + + Parameter max_elt : t -> option elt. + (** Same as [min_elt], but returns the largest element of the + given set. *) + + Section Spec. + + Variable s s' s'' : t. + Variable x y : elt. + + (** Specification of [lt] *) + Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. + Parameter lt_not_eq : lt s s' -> ~ eq s s'. + + (** Additional specification of [elements] *) Parameter elements_3 : sort E.lt (elements s). + (** Remark: since [fold] is specified via [elements], this stronger + specification of [elements] has an indirect impact on [fold], + which can now be proved to receive elements in increasing order. + *) + (** Specification of [min_elt] *) Parameter min_elt_1 : min_elt s = Some x -> In x s. Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. @@ -271,37 +337,56 @@ Module Type S. Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Parameter max_elt_3 : max_elt s = None -> Empty s. - (** Specification of [choose] *) - Parameter choose_1 : choose s = Some x -> In x s. - Parameter choose_2 : choose s = None -> Empty s. -(* Parameter choose_equal: - (equal s s')=true -> E.eq (choose s) (choose s'). *) + (** Additional specification of [choose] *) + Parameter choose_3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. End Spec. - (* begin hide *) - Hint Immediate In_1. - - Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1 - is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1 - remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1 - inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1 - for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2 - elements_3 min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3. - (* end hide *) + Hint Resolve elements_3 : set. + Hint Immediate + min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. + +End Sfun. + +(** ** Static signature for sets on ordered elements + + Similar to the functorial signature [Sfun], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type S. + Declare Module E : OrderedType. + Include Type Sfun E. End S. + +(** ** Some subtyping tests +<< +WSfun ---> WS + | | + | | + V V +Sfun ---> S + + +Module S_WS (M : S) <: SW := M. +Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M. +Module S_Sfun (E:OrderedType)(M : S with Module E:=E) <: Sfun E := M. +Module WS_WSfun (E:EqualityType)(M : WS with Module E:=E) <: WSfun E := M. +>> +*) + (** * Dependent signature - Signature [Sdep] presents sets using dependent types *) + Signature [Sdep] presents ordered sets using dependent types *) Module Type Sdep. Declare Module E : OrderedType. Definition elt := E.t. - Parameter t : Set. + Parameter t : Type. Parameter In : elt -> t -> Prop. Definition Equal s s' := forall a : elt, In a s <-> In a s'. @@ -397,7 +482,7 @@ Module Type Sdep. Parameter fold : - forall (A : Set) (f : elt -> A -> A) (s : t) (i : A), + forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. @@ -418,4 +503,14 @@ Module Type Sdep. Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. + (** The [choose_3] specification of [S] cannot be packed + in the dependent version of [choose], so we leave it separate. *) + Parameter choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | inleft (exist x _), inleft (exist x' _) => E.eq x x' + | inright _, inright _ => True + | _, _ => False + end. + End Sdep. + diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index f6205542..a205d5b0 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 8834 2006-05-20 00:41:35Z letouzey $ *) +(* $Id: FSetList.v 10616 2008-03-04 17:33:35Z letouzey $ *) (** * Finite sets library *) @@ -25,7 +25,6 @@ Unset Strict Implicit. Module Raw (X: OrderedType). - Module E := X. Module MX := OrderedTypeFacts X. Import MX. @@ -145,7 +144,7 @@ Module Raw (X: OrderedType). | _, _ => false end. - Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : + Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : B -> B := fun i => match s with | nil => i | x :: l => fold f l (f x i) @@ -649,6 +648,11 @@ Module Raw (X: OrderedType). unfold elements; auto. Qed. + Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s). + Proof. + unfold elements; auto. + Qed. + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intro s; case s; simpl; intros; inversion H; auto. @@ -718,8 +722,21 @@ Module Raw (X: OrderedType). Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3. + Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x', + choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. + Proof. + unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_2 with s'; auto. + rewrite <-H; auto using min_elt_1. + assert (~X.lt x' x). + apply min_elt_2 with s; auto. + rewrite H; auto using min_elt_1. + destruct (X.compare x x'); intuition. + Qed. + Lemma fold_1 : - forall (s : t) (Hs : Sort s) (A : Set) (i : A) (f : elt -> A -> A), + forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. induction s. @@ -1037,7 +1054,7 @@ Module Make (X: OrderedType) <: S with Module E := X. Module Raw := Raw X. Module E := X. - Record slist : Set := {this :> Raw.t; sorted : sort E.lt this}. + Record slist := {this :> Raw.t; sorted : sort E.lt this}. Definition t := slist. Definition elt := E.t. @@ -1066,7 +1083,7 @@ Module Make (X: OrderedType) <: S with Module E := X. Definition min_elt (s : t) : option elt := Raw.min_elt s. Definition max_elt (s : t) : option elt := Raw.max_elt s. Definition choose (s : t) : option elt := Raw.choose s. - Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. + Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. Definition cardinal (s : t) : nat := Raw.cardinal s. Definition filter (f : elt -> bool) (s : t) : t := Build_slist (Raw.filter_sort (sorted s) f). @@ -1149,7 +1166,7 @@ Module Make (X: OrderedType) <: S with Module E := X. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed. - Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. exact (Raw.fold_1 s.(sorted)). Qed. @@ -1202,6 +1219,8 @@ Module Make (X: OrderedType) <: S with Module E := X. Proof. exact (fun H => Raw.elements_2 H). Qed. Lemma elements_3 : sort E.lt (elements s). Proof. exact (Raw.elements_3 s.(sorted)). Qed. + Lemma elements_3w : NoDupA E.eq (elements s). + Proof. exact (Raw.elements_3w s.(sorted)). Qed. Lemma min_elt_1 : min_elt s = Some x -> In x s. Proof. exact (fun H => Raw.min_elt_1 H). Qed. @@ -1221,6 +1240,9 @@ Module Make (X: OrderedType) <: S with Module E := X. Proof. exact (fun H => Raw.choose_1 H). Qed. Lemma choose_2 : choose s = None -> Empty s. Proof. exact (fun H => Raw.choose_2 H). Qed. + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. + Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed. Lemma eq_refl : eq s s. Proof. exact (Raw.eq_refl s). Qed. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 6e93a546..7413b06b 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *) +(* $Id: FSetProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) (** * Finite sets library *) @@ -16,414 +16,259 @@ [In x s] instead of [mem x s=true], [Equal s s'] instead of [equal s s'=true], etc. *) -Require Export FSetInterface. -Require Import FSetFacts. +Require Export FSetInterface. +Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op compat_nat. +Hint Unfold transpose compat_op. Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. -Module Properties (M: S). - Module ME:=OrderedTypeFacts(M.E). - Import ME. (* for ME.eq_dec *) - Import M.E. - Import M. - Import Logic. (* to unmask [eq] *) - Import Peano. (* to unmask [lt] *) - - (** Results about lists without duplicates *) +(** First, a functor for Weak Sets. Since the signature [WS] includes + an EqualityType and not a stronger DecidableType, this functor + should take two arguments in order to compensate this. *) - Module FM := Facts M. - Import FM. - - Definition Add (x : elt) (s s' : t) := - forall y : elt, In y s' <-> E.eq x y \/ In y s. +Module WProperties (Import E : DecidableType)(M : WSfun E). + Module Import Dec := WDecide E M. + Module Import FM := Dec.F (* FSetFacts.WFacts E M *). + Import M. Lemma In_dec : forall x s, {In x s} + {~ In x s}. Proof. intros; generalize (mem_iff s x); case (mem x s); intuition. Qed. - Section BasicProperties. - - (** properties of [Equal] *) + Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. - Lemma equal_refl : forall s, s[=]s. + Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. Proof. - unfold Equal; intuition. - Qed. - - Lemma equal_sym : forall s s', s[=]s' -> s'[=]s. - Proof. - unfold Equal; intros. - rewrite H; intuition. + unfold Add. + split; intros. + red; intros. + rewrite H; clear H. + fsetdec. + fsetdec. Qed. + + Ltac expAdd := repeat rewrite Add_Equal. - Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. - unfold Equal; intros. - rewrite H; exact (H0 a). - Qed. + Section BasicProperties. Variable s s' s'' s1 s2 s3 : t. Variable x x' : elt. - (** properties of [Subset] *) - - Lemma subset_refl : s[<=]s. - Proof. - unfold Subset; intuition. - Qed. + Lemma equal_refl : s[=]s. + Proof. fsetdec. Qed. - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. - unfold Subset, Equal; intuition. - Qed. + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. fsetdec. Qed. + + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. fsetdec. Qed. + + Lemma subset_refl : s[<=]s. + Proof. fsetdec. Qed. Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. - unfold Subset; intuition. - Qed. + Proof. fsetdec. Qed. + + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. fsetdec. Qed. Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. - unfold Subset, Equal; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma subset_empty : empty[<=]s. - Proof. - unfold Subset; intros a; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. - + Proof. fsetdec. Qed. + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. - unfold Subset; intros H H0 a; set_iff; intuition. - rewrite <- H2; auto. - Qed. + Proof. fsetdec. Qed. Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. - unfold Subset; intuition. - Qed. + Proof. fsetdec. Qed. Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. - unfold Subset; intuition. - Qed. + Proof. fsetdec. Qed. Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. - unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition. - Qed. - - (** properties of [empty] *) + Proof. intuition fsetdec. Qed. Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. - unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. - unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. - Qed. - - (** properties of [add] *) + Proof. fsetdec. Qed. Lemma add_equal : In x s -> add x s [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite <- H1; auto. - Qed. + Proof. fsetdec. Qed. Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - (** properties of [remove] *) + Proof. fsetdec. Qed. Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite H1 in H; auto. - Qed. + Proof. fsetdec. Qed. Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - (** properties of [add] and [remove] *) + Proof. fsetdec. Qed. Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. - unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. - rewrite <- H1; auto. - Qed. + Proof. fsetdec. Qed. Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. - unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. - rewrite H1 in H; auto. - Qed. - - (** properties of [singleton] *) + Proof. fsetdec. Qed. Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. - - (** properties of [union] *) + Proof. fsetdec. Qed. Lemma union_sym : union s s' [=] union s' s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. - unfold Subset, Equal; intros; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. + Proof. fsetdec. Qed. Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. + Proof. fsetdec. Qed. Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. + + Lemma union_remove_add_1 : + union (remove x s) (add x s') [=] union (add x s) (remove x s'). + Proof. fsetdec. Qed. + + Lemma union_remove_add_2 : In x s -> + union (remove x s) (add x s') [=] union s s'. + Proof. fsetdec. Qed. Lemma union_subset_1 : s [<=] union s s'. - Proof. - unfold Subset; intuition. - Qed. + Proof. fsetdec. Qed. Lemma union_subset_2 : s' [<=] union s s'. - Proof. - unfold Subset; intuition. - Qed. + Proof. fsetdec. Qed. Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. - unfold Subset; intros H H0 a; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. - unfold Equal, Empty; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. - unfold Equal, Empty; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. - intros; set_iff; intuition. - Qed. - - (** properties of [inter] *) + Proof. fsetdec. Qed. Lemma inter_sym : inter s s' [=] inter s' s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. + Proof. fsetdec. Qed. Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. + Proof. fsetdec. Qed. Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite <- H1; auto. - Qed. + Proof. fsetdec. Qed. Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. - unfold Equal; intros; set_iff; intuition. - destruct H; rewrite H0; auto. - Qed. + Proof. fsetdec. Qed. Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. - unfold Empty; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. - unfold Empty; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma inter_subset_1 : inter s s' [<=] s. - Proof. - unfold Subset; intro a; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. - unfold Subset; intro a; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma inter_subset_3 : s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. - unfold Subset; intros H H' a; set_iff; intuition. - Qed. - - (** properties of [diff] *) + Proof. fsetdec. Qed. Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. - unfold Empty, Equal; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. - unfold Empty, Equal; intros; set_iff; firstorder. - Qed. + Proof. fsetdec. Qed. Lemma diff_subset : diff s s' [<=] s. - Proof. - unfold Subset; intros a; set_iff; tauto. - Qed. + Proof. fsetdec. Qed. Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. - unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto. - Qed. + Proof. fsetdec. Qed. Lemma remove_diff_singleton : remove x s [=] diff s (singleton x). - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. + Proof. fsetdec. Qed. Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. - unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto. - Qed. + Proof. fsetdec. Qed. Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - elim (In_dec a s'); auto. - Qed. - - (** properties of [Add] *) + Proof. fsetdec. Qed. Lemma Add_add : Add x s (add x s). - Proof. - unfold Add; intros; set_iff; intuition. - Qed. + Proof. expAdd; fsetdec. Qed. Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. - unfold Add; intros; set_iff; intuition. - elim (eq_dec x y); auto. - rewrite <- H1; auto. - Qed. + Proof. expAdd; fsetdec. Qed. Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. - unfold Add; intros; set_iff; rewrite H; tauto. - Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add : In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. - unfold Add; intros; set_iff; rewrite H0; intuition. - rewrite <- H2; auto. - Qed. + Proof. expAdd; fsetdec. Qed. Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. - unfold Add, Equal; intros; set_iff; rewrite H0; intuition. - rewrite <- H1; auto. - Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. - unfold Add, Equal; intros; set_iff; rewrite H0; intuition. - destruct H; rewrite H1; auto. - Qed. + Proof. expAdd; fsetdec. Qed. End BasicProperties. - Hint Immediate equal_sym: set. - Hint Resolve equal_refl equal_trans : set. - - Hint Immediate add_remove remove_add union_sym inter_sym: set. - Hint Resolve subset_refl subset_equal subset_antisym + Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal remove_equal singleton_equal_add union_subset_equal union_equal_1 @@ -436,6 +281,31 @@ Module Properties (M: S). remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove Equal_remove add_add : set. + (** * Properties of elements *) + + Lemma elements_Empty : forall s, Empty s <-> elements s = nil. + Proof. + intros. + unfold Empty. + split; intros. + assert (forall a, ~ List.In a (elements s)). + red; intros. + apply (H a). + rewrite elements_iff. + rewrite InA_alt; exists a; auto. + destruct (elements s); auto. + elim (H0 e); simpl; auto. + red; intros. + rewrite elements_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements empty = nil. + Proof. + rewrite <-elements_Empty; auto with set. + Qed. + (** * Alternative (weaker) specifications for [fold] *) Section Old_Spec_Now_Properties. @@ -447,14 +317,14 @@ Module Properties (M: S). *) Lemma fold_0 : - forall s (A : Set) (i : A) (f : elt -> A -> A), + forall s (A : Type) (i : A) (f : elt -> A -> A), exists l : list elt, NoDup l /\ (forall x : elt, In x s <-> InA E.eq x l) /\ fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. - apply NoDupA_rev; auto. + apply NoDupA_rev; auto with set. exact E.eq_trans. split; intros. rewrite elements_iff; do 2 rewrite InA_alt. @@ -468,7 +338,7 @@ Module Properties (M: S). [fold_2]. *) Lemma fold_1 : - forall s (A : Set) (eqA : A -> A -> Prop) + forall s (A : Type) (eqA : A -> A -> Prop) (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), Empty s -> eqA (fold f s i) i. Proof. @@ -481,7 +351,7 @@ Module Properties (M: S). Qed. Lemma fold_2 : - forall s s' x (A : Set) (eqA : A -> A -> Prop) + forall s s' x (A : Type) (eqA : A -> A -> Prop) (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> transpose eqA f -> @@ -492,9 +362,21 @@ Module Properties (M: S). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. eauto. - exact eq_dec. rewrite <- Hl1; auto. - intros; rewrite <- Hl1; rewrite <- Hl'1; auto. + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + rewrite (H2 a); intuition. + Qed. + + (** In fact, [fold] on empty sets is more than equivalent to + the initial element, it is Leibniz-equal to it. *) + + Lemma fold_1b : + forall s (A : Type)(i : A) (f : elt -> A -> A), + Empty s -> (fold f s i) = i. + Proof. + intros. + rewrite M.fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. Qed. (** Similar specifications for [cardinal]. *) @@ -531,41 +413,46 @@ Module Properties (M: S). (** * Induction principle over sets *) + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, M.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros s; rewrite M.cardinal_1; intros H a; red. - rewrite elements_iff. - destruct (elements s); simpl in *; discriminate || inversion 1. + Proof. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1. Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. + intros; rewrite M.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. Qed. - Lemma Equal_cardinal_aux : - forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'. + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. - simple induction n; intros. - rewrite H; symmetry . - apply cardinal_1. - rewrite <- H0; auto. - destruct (cardinal_inv_2 H0) as (x,H2). - revert H0. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set. - rewrite H1 in H2; auto with set. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. Qed. Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. Proof. - intros; apply Equal_cardinal_aux with (cardinal s); auto. - Qed. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + apply cardinal_1; rewrite <- H; auto. + destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. + Qed. Add Morphism cardinal : cardinal_m. Proof. @@ -574,40 +461,33 @@ Module Properties (M: S). Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. - Lemma cardinal_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall n s, cardinal s = n -> P s. - Proof. - simple induction n; intros; auto. - destruct (cardinal_inv_2 H) as (x,H0). - apply X0 with (remove x s) x; auto. - apply X1; auto. - rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto. - Qed. - Lemma set_induction : forall P : t -> Type, (forall s : t, Empty s -> P s) -> (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') -> forall s : t, P s. Proof. - intros; apply cardinal_induction with (cardinal s); auto. - Qed. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + destruct (cardinal_inv_2 (sym_eq Heqn)) as (x,H0). + apply X0 with (remove x s) x; auto with set. + apply IHn; auto. + assert (S n = S (cardinal (remove x s))). + rewrite Heqn; apply cardinal_2 with x; auto with set. + inversion H; auto. + Qed. (** Other properties of [fold]. *) Section Fold. - Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Section Fold_1. Variable i i':A. - Lemma fold_empty : eqA (fold f empty i) i. + Lemma fold_empty : (fold f empty i) = i. Proof. - apply fold_1; auto. + apply fold_1b; auto with set. Qed. Lemma fold_equal : @@ -642,7 +522,7 @@ Module Properties (M: S). Proof. intros. sym_st. - apply fold_2 with (eqA:=eqA); auto. + apply fold_2 with (eqA:=eqA); auto with set. Qed. Lemma remove_fold_2: forall s x, ~In x s -> @@ -742,7 +622,8 @@ Module Properties (M: S). apply fold_1; auto with set. Qed. - Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') -> + Lemma fold_union: forall s s', + (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros. @@ -760,8 +641,8 @@ Module Properties (M: S). forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. Proof. assert (st := gen_st nat). - assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). - assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto). + assert (fe : compat_op E.eq (@Logic.eq _) (fun _ => S)) by (unfold compat_op; auto). + assert (fp : transpose (@Logic.eq _) (fun _:elt => S)) by (unfold transpose; auto). intros s p; pattern s; apply set_induction; clear s; intros. rewrite (fold_1 st p (fun _ => S) H). rewrite (fold_1 st 0 (fun _ => S) H); trivial. @@ -774,11 +655,11 @@ Module Properties (M: S). simpl; auto. Qed. - (** properties of [cardinal] *) + (** more properties of [cardinal] *) Lemma empty_cardinal : cardinal empty = 0. Proof. - rewrite cardinal_fold; apply fold_1; auto. + rewrite cardinal_fold; apply fold_1; auto with set. Qed. Hint Immediate empty_cardinal cardinal_1 : set. @@ -798,11 +679,11 @@ Module Properties (M: S). Proof. intros; do 3 rewrite cardinal_fold. rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@eq nat); auto. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. Qed. Lemma union_cardinal: - forall s s', (forall x, ~In x s\/~In x s') -> + forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; do 3 rewrite cardinal_fold. @@ -841,7 +722,7 @@ Module Properties (M: S). intros. do 4 rewrite cardinal_fold. do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@eq nat); auto. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto. Qed. Lemma union_cardinal_inter : @@ -872,7 +753,7 @@ Module Properties (M: S). intros. do 2 rewrite cardinal_fold. change S with ((fun _ => S) x); - apply fold_add with (eqA:=@eq nat); auto. + apply fold_add with (eqA:=@Logic.eq nat); auto. Qed. Lemma remove_cardinal_1 : @@ -881,7 +762,7 @@ Module Properties (M: S). intros. do 2 rewrite cardinal_fold. change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@eq nat); auto. + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. Qed. Lemma remove_cardinal_2 : @@ -892,4 +773,295 @@ Module Properties (M: S). Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. +End WProperties. + + +(** A clone of [WProperties] working on full sets. *) + +Module Properties (M:S). + Module D := OT_as_DT M.E. + Include WProperties D M. End Properties. + + +(** Now comes some properties specific to the element ordering, + invalid for Weak Sets. *) + +Module OrdProperties (M:S). + Module ME:=OrderedTypeFacts(M.E). + Module Import P := Properties M. + Import FM. + Import M.E. + Import M. + + (** First, a specialized version of SortA_equivlistA_eqlistA: *) + Lemma sort_equivlistA_eqlistA : forall l l' : list elt, + sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto. + Qed. + + Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. + Definition leb x := fun y => negb (gtb x y). + + Definition elements_lt x s := List.filter (gtb x) (elements s). + Definition elements_ge x s := List.filter (leb x) (elements s). + + Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. + Proof. + intros; unfold gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. + Proof. + intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. + Qed. + + Lemma gtb_compat : forall x, compat_bool E.eq (gtb x). + Proof. + red; intros x a b H. + generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. + intros. + symmetry; rewrite H1. + apply ME.eq_lt with a; auto. + rewrite <- H0; auto. + intros. + rewrite H0. + apply ME.eq_lt with b; auto. + rewrite <- H1; auto. + Qed. + + Lemma leb_compat : forall x, compat_bool E.eq (leb x). + Proof. + red; intros x a b H; unfold leb. + f_equal; apply gtb_compat; auto. + Qed. + Hint Resolve gtb_compat leb_compat. + + Lemma elements_split : forall x s, + elements s = elements_lt x s ++ elements_ge x s. + Proof. + unfold elements_lt, elements_ge, leb; intros. + eapply (@filter_split _ E.eq); eauto with set. ME.order. ME.order. ME.order. + intros. + rewrite gtb_1 in H. + assert (~E.lt y x). + unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order. + ME.order. + Qed. + + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Proof. + intros; unfold elements_ge, elements_lt. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto. + apply (@filter_sort _ E.eq); auto with set; eauto with set. + constructor; auto. + apply (@filter_sort _ E.eq); auto with set; eauto with set. + rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with set). + intros. + rewrite filter_InA in H1; auto; destruct H1. + rewrite leb_1 in H2. + rewrite <- elements_iff in H1. + assert (~E.eq x y). + contradict H; rewrite H; auto. + ME.order. + intros. + rewrite filter_InA in H1; auto; destruct H1. + rewrite gtb_1 in H3. + inversion_clear H2. + ME.order. + rewrite filter_InA in H4; auto; destruct H4. + rewrite leb_1 in H4. + ME.order. + red; intros a. + rewrite InA_app_iff; rewrite InA_cons. + do 2 (rewrite filter_InA; auto). + do 2 rewrite <- elements_iff. + rewrite leb_1; rewrite gtb_1. + rewrite (H0 a); intuition. + destruct (E.compare a x); intuition. + right; right; split; auto. + ME.order. + Qed. + + Definition Above x s := forall y, In y s -> E.lt y x. + Definition Below x s := forall y, In y s -> E.lt x y. + + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements s ++ x::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto with set. + intros. + inversion_clear H2. + rewrite <- elements_iff in H1. + apply ME.lt_eq with x; auto. + inversion H3. + red; intros a. + rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. + do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. + Qed. + + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> + eqlistA E.eq (elements s') (x::elements s). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + change (sort E.lt ((x::nil) ++ elements s)). + apply (@SortA_app _ E.eq); auto with set. + intros. + inversion_clear H1. + rewrite <- elements_iff in H2. + apply ME.eq_lt with x; auto. + inversion H3. + red; intros a. + rewrite InA_cons. + do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. + Qed. + + (** Two other induction principles on sets: we can be more restrictive + on the element we add at each step. *) + + Lemma set_induction_max : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (max_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@max_elt_2 s e y H H0); ME.order. + + assert (H0:=max_elt_3 H). + rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. + Qed. + + Lemma set_induction_min : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (min_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@min_elt_2 s e y H H0); ME.order. + + assert (H0:=min_elt_3 H). + rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. + Qed. + + (** More properties of [fold] : behavior with respect to Above/Below *) + + Lemma fold_3 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + compat_op E.eq eqA f -> + Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros. + do 2 rewrite M.fold_1. + do 2 rewrite <- fold_left_rev_right. + change (f x (fold_right f i (rev (elements s)))) with + (fold_right f i (rev (x::nil)++rev (elements s))). + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + rewrite <- distr_rev. + apply eqlistA_rev. + apply elements_Add_Above; auto. + Qed. + + Lemma fold_4 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + compat_op E.eq eqA f -> + Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). + Proof. + intros. + do 2 rewrite 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. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply elements_Add_Below; auto. + Qed. + + (** The following results have already been proved earlier, + but we can now prove them with one hypothesis less: + no need for [(transpose eqA f)]. *) + + Section FoldOpt. + Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros; do 2 rewrite M.fold_1. + do 2 rewrite <- fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply sort_equivlistA_eqlistA; auto with set. + red; intro a; do 2 rewrite <- elements_iff; auto. + Qed. + + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros; do 2 rewrite M.fold_1. + do 2 rewrite <- fold_left_rev_right. + induction (rev (elements s)); simpl; auto. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + End FoldOpt. + + (** An alternative version of [choose_3] *) + + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | Some x, Some x' => E.eq x x' + | None, None => True + | _, _ => False + end. + Proof. + intros s s' H; + generalize (@choose_1 s)(@choose_2 s) + (@choose_1 s')(@choose_2 s')(@choose_3 s s'); + destruct (choose s); destruct (choose s'); simpl; intuition. + apply H5 with e; rewrite <-H; auto. + apply H5 with e; rewrite H; auto. + Qed. + +End OrdProperties. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 8cf85efe..ae51d905 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -11,16 +11,16 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetToFiniteSet.v 8876 2006-05-30 13:43:15Z letouzey $ *) +(* $Id: FSetToFiniteSet.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Import Ensembles Finite_sets. -Require Import FSetInterface FSetProperties OrderedTypeEx. +Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. -(** * Going from [FSets] with usual equality - to the old [Ensembles] and [Finite_sets] theory. *) +(** * Going from [FSets] with usual Leibniz equality + to the good old [Ensembles] and [Finite_sets] theory. *) -Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U). - Module MP:= Properties(M). +Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). + Module MP:= WProperties U M. Import M MP FM Ensembles Finite_sets. Definition mkEns : M.t -> Ensemble M.elt := @@ -82,7 +82,7 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U). Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. Proof. unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; unfold E.eq; auto with sets. + split; intro; set_iff; inversion 1; auto with sets. inversion H0. constructor 2; constructor. constructor 1; auto. @@ -97,7 +97,7 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U). inversion H0. constructor 2; constructor. constructor 1; auto. - red in H; rewrite H; unfold E.eq in *. + red in H; rewrite H. inversion H0; auto. inversion H1; auto. Qed. @@ -105,10 +105,10 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U). Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. Proof. unfold Same_set, Included, mkEns, In. - split; intro; set_iff; inversion 1; unfold E.eq in *; auto with sets. + split; intro; set_iff; inversion 1; auto with sets. split; auto. - swap H1. - inversion H2; auto. + contradict H1. + inversion H1; auto. Qed. Lemma mkEns_Finite : forall s, Finite _ (!!s). @@ -136,4 +136,28 @@ Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U). apply Add_Add; auto. Qed. + (** we can even build a function from Finite Ensemble to FSet + ... at least in Prop. *) + + Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> + exists s:M.t, !!s === e. + Proof. + induction 1. + exists M.empty. + apply empty_Empty_Set. + destruct IHFinite as (s,Hs). + exists (M.add x s). + apply Extensionality_Ensembles in Hs. + rewrite <- Hs. + apply add_Add. + Qed. + +End WS_to_Finite_set. + + +Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U). + Module D := OT_as_DT U. + Include WS_to_Finite_set D M. End S_to_Finite_set. + + diff --git a/theories/FSets/FSetWeak.v b/theories/FSets/FSetWeak.v deleted file mode 100644 index c88a7869..00000000 --- a/theories/FSets/FSetWeak.v +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FSetWeak.v 9278 2006-10-25 13:43:17Z letouzey $ *) - -Require Export DecidableType. -Require Export DecidableTypeEx. -Require Export FSetWeakInterface. -Require Export FSetWeakFacts. -Require Export FSetWeakProperties. -Require Export FSetWeakList. diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v deleted file mode 100644 index 61797a95..00000000 --- a/theories/FSets/FSetWeakFacts.v +++ /dev/null @@ -1,421 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FSetWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *) - -(** * Finite sets library *) - -(** This functor derives additional facts from [FSetInterface.S]. These - facts are mainly the specifications of [FSetInterface.S] written using - different styles: equivalence and boolean equalities. - Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. -*) - -Require Export FSetWeakInterface. -Set Implicit Arguments. -Unset Strict Implicit. - -Module Facts (M: S). -Import M.E. -Import M. -Import Logic. (* to unmask [eq] *) - -(** * Specifications written using equivalences *) - -Section IffSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). -Proof. -split; apply In_1; auto. -Qed. - -Lemma mem_iff : In x s <-> mem x s = true. -Proof. -split; [apply mem_1|apply mem_2]. -Qed. - -Lemma not_mem_iff : ~In x s <-> mem x s = false. -Proof. -rewrite mem_iff; destruct (mem x s); intuition. -Qed. - -Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. -split; [apply equal_1|apply equal_2]. -Qed. - -Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. -split; [apply subset_1|apply subset_2]. -Qed. - -Lemma empty_iff : In x empty <-> False. -Proof. -intuition; apply (empty_1 H). -Qed. - -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. -split; [apply is_empty_1|apply is_empty_2]. -Qed. - -Lemma singleton_iff : In y (singleton x) <-> E.eq x y. -Proof. -split; [apply singleton_1|apply singleton_2]. -Qed. - -Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. -split; [ | destruct 1; [apply add_1|apply add_2]]; auto. -destruct (eq_dec x y) as [E|E]; auto. -intro H; right; exact (add_3 E H). -Qed. - -Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. -Proof. -split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. -intro. -apply (remove_1 H0 H). -Qed. - -Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. -Proof. -split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. -Qed. - -Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. -Proof. -split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. -Qed. - -Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. -Proof. -split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. -Qed. - -Variable f : elt->bool. - -Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. -Qed. - -Lemma for_all_iff : compat_bool E.eq f -> - (For_all (fun x => f x = true) s <-> for_all f s = true). -Proof. -split; [apply for_all_1 | apply for_all_2]; auto. -Qed. - -Lemma exists_iff : compat_bool E.eq f -> - (Exists (fun x => f x = true) s <-> exists_ f s = true). -Proof. -split; [apply exists_1 | apply exists_2]; auto. -Qed. - -Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. -split; [apply elements_1 | apply elements_2]. -Qed. - -End IffSpec. - -(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := - repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff - || rewrite union_iff || rewrite inter_iff || rewrite diff_iff - || rewrite empty_iff)). - -(** * Specifications written using boolean predicates *) - -Definition eqb x y := if eq_dec x y then true else false. - -Section BoolSpec. -Variable s s' s'' : t. -Variable x y z : elt. - -Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. -intros. -generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). -destruct (mem x s); destruct (mem y s); intuition. -Qed. - -Lemma empty_b : mem y empty = false. -Proof. -generalize (empty_iff y)(mem_iff empty y). -destruct (mem y empty); intuition. -Qed. - -Lemma add_b : mem y (add x s) = eqb x y || mem y s. -Proof. -generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. -Proof. -intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). -destruct (mem y s); destruct (mem y (add x s)); intuition. -Qed. - -Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). -Proof. -generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. -Qed. - -Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. -Proof. -intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). -destruct (mem y s); destruct (mem y (remove x s)); intuition. -Qed. - -Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. -generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. -destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. -Qed. - -Lemma union_b : mem x (union s s') = mem x s || mem x s'. -Proof. -generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. -Qed. - -Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. -Proof. -generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. -Qed. - -Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). -Proof. -generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). -destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. -Qed. - -Lemma elements_b : mem x s = existsb (eqb x) (elements s). -Proof. -generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). -rewrite InA_alt. -destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. -symmetry. -rewrite H1. -destruct H0 as (H0,_). -destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. -exists a; intuition. -unfold eqb; destruct (eq_dec x a); auto. -rewrite <- H. -rewrite H0. -destruct H1 as (H1,_). -destruct H1 as (a,(Ha1,Ha2)); [intuition|]. -exists a; intuition. -unfold eqb in *; destruct (eq_dec x a); auto; discriminate. -Qed. - -Variable f : elt->bool. - -Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. -intros. -generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). -destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. -Qed. - -Lemma for_all_b : compat_bool E.eq f -> - for_all f s = forallb f (elements s). -Proof. -intros. -generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). -unfold For_all. -destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. -rewrite <- H1; intros. -destruct H0 as (H0,_). -rewrite (H2 x0) in H3. -rewrite (InA_alt E.eq x0 (elements s)) in H3. -destruct H3 as (a,(Ha1,Ha2)). -rewrite (H _ _ Ha1). -apply H0; auto. -symmetry. -rewrite H0; intros. -destruct H1 as (_,H1). -apply H1; auto. -rewrite H2. -rewrite InA_alt; eauto. -Qed. - -Lemma exists_b : compat_bool E.eq f -> - exists_ f s = existsb f (elements s). -Proof. -intros. -generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). -unfold Exists. -destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. -rewrite <- H1; intros. -destruct H0 as (H0,_). -destruct H0 as (a,(Ha1,Ha2)); auto. -exists a; auto. -split; auto. -rewrite H2; rewrite InA_alt; eauto. -symmetry. -rewrite H0. -destruct H1 as (_,H1). -destruct H1 as (a,(Ha1,Ha2)); auto. -rewrite (H2 a) in Ha1. -rewrite (InA_alt E.eq a (elements s)) in Ha1. -destruct Ha1 as (b,(Hb1,Hb2)). -exists b; auto. -rewrite <- (H _ _ Hb1); auto. -Qed. - -End BoolSpec. - -(** * [E.eq] and [Equal] are setoid equalities *) - -Definition E_ST : Setoid_Theory elt E.eq. -Proof. -constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. -Qed. - -Add Setoid elt E.eq E_ST as EltSetoid. - -Definition Equal_ST : Setoid_Theory t Equal. -Proof. -constructor; unfold Equal; firstorder. -Qed. - -Add Setoid t Equal Equal_ST as EqualSetoid. - -Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. -Proof. -unfold Equal; intros x y H s s' H0. -rewrite (In_eq_iff s H); auto. -Qed. - -Add Morphism is_empty : is_empty_m. -Proof. -unfold Equal; intros s s' H. -generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); - unfold Empty; auto; intros. -symmetry. -rewrite <- H1; intros a Ha. -rewrite <- (H a) in Ha. -destruct H0 as (_,H0). -exact (H0 (refl_equal true) _ Ha). -rewrite <- H0; intros a Ha. -rewrite (H a) in Ha. -destruct H1 as (_,H1). -exact (H1 (refl_equal true) _ Ha). -Qed. - -Add Morphism Empty with signature Equal ==> iff as Empty_m. -Proof. -intros; do 2 rewrite is_empty_iff; rewrite H; intuition. -Qed. - -Add Morphism mem : mem_m. -Proof. -unfold Equal; intros x y H s s' H0. -generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). -generalize (mem_iff s x)(mem_iff s' y). -destruct (mem x s); destruct (mem y s'); intuition. -Qed. - -Add Morphism singleton : singleton_m. -Proof. -unfold Equal; intros x y H a. -do 2 rewrite singleton_iff; split. -intros; apply E.eq_trans with x; auto. -intros; apply E.eq_trans with y; auto. -Qed. - -Add Morphism add : add_m. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. -Qed. - -Add Morphism remove : remove_m. -Proof. -unfold Equal; intros x y H s s' H0 a. -do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. -Qed. - -Add Morphism union : union_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. -Qed. - -Add Morphism inter : inter_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. -Qed. - -Add Morphism diff : diff_m. -Proof. -unfold Equal; intros s s' H s'' s''' H0 a. -do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. -Qed. - -Add Morphism Subset with signature Equal ==> Equal ==> iff as Subset_m. -Proof. -unfold Equal, Subset; firstorder. -Qed. - -Add Morphism subset : subset_m. -Proof. -intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). -destruct (subset s s''); destruct (subset s' s'''); auto; intros. -rewrite H in H1; rewrite H0 in H1; intuition. -rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - -Add Morphism equal : equal_m. -Proof. -intros s s' H s'' s''' H0. -generalize (equal_iff s s'') (equal_iff s' s'''). -destruct (equal s s''); destruct (equal s' s'''); auto; intros. -rewrite H in H1; rewrite H0 in H1; intuition. -rewrite H in H1; rewrite H0 in H1; intuition. -Qed. - -(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism - without additional hypothesis on [f]. For instance: *) - -Lemma filter_equal : forall f, compat_bool E.eq f -> - forall s s', s[=]s' -> filter f s [=] filter f s'. -Proof. -unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. -Qed. - -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid - structures on [list elt] and [option elt]. *) - -(* Later: -Add Morphism cardinal ; cardinal_m. -*) - -End Facts. diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v deleted file mode 100644 index a281ce22..00000000 --- a/theories/FSets/FSetWeakInterface.v +++ /dev/null @@ -1,251 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FSetWeakInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *) - -(** * Finite sets library *) - -(** Set interfaces for types with only a decidable equality, but no ordering *) - -Require Export Bool. -Require Export DecidableType. -Set Implicit Arguments. -Unset Strict Implicit. - -(** Compatibility of a boolean function with respect to an equality. *) -Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) := - forall x y : A, eqA x y -> f x = f y. - -(** Compatibility of a predicate with respect to an equality. *) -Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) := - forall x y : A, eqA x y -> P x -> P y. - -Hint Unfold compat_bool compat_P. - -(** * Non-dependent signature - - Signature [S] presents sets as purely informative programs - together with axioms *) - -Module Type S. - - Declare Module E : DecidableType. - Definition elt := E.t. - - Parameter t : Set. (** the abstract type of sets *) - - (** Logical predicates *) - Parameter In : elt -> t -> Prop. - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Notation "s [=] t" := (Equal s t) (at level 70, no associativity). - Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). - - Parameter empty : t. - (** The empty set. *) - - Parameter is_empty : t -> bool. - (** Test whether a set is empty or not. *) - - Parameter mem : elt -> t -> bool. - (** [mem x s] tests whether [x] belongs to the set [s]. *) - - Parameter add : elt -> t -> t. - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) - - Parameter singleton : elt -> t. - (** [singleton x] returns the one-element set containing only [x]. *) - - Parameter remove : elt -> t -> t. - (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) - - Parameter union : t -> t -> t. - (** Set union. *) - - Parameter inter : t -> t -> t. - (** Set intersection. *) - - Parameter diff : t -> t -> t. - (** Set difference. *) - - Parameter equal : t -> t -> bool. - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) - - Parameter subset : t -> t -> bool. - (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) - - (** Coq comment: [iter] is useless in a purely functional world *) - (** iter: (elt -> unit) -> set -> unit. i*) - (** [iter f s] applies [f] in turn to all elements of [s]. - The order in which the elements of [s] are presented to [f] - is unspecified. *) - - Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A. - (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s]. - The order in which elements of [s] are presented to [f] is - unspecified. *) - - Parameter for_all : (elt -> bool) -> t -> bool. - (** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. *) - - Parameter exists_ : (elt -> bool) -> t -> bool. - (** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. *) - - Parameter filter : (elt -> bool) -> t -> t. - (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. *) - - Parameter partition : (elt -> bool) -> t -> t * t. - (** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. *) - - Parameter cardinal : t -> nat. - (** Return the number of elements of a set. *) - (** Coq comment: nat instead of int ... *) - - Parameter elements : t -> list elt. - (** Return the list of all elements of the given set, in any order. *) - - Parameter choose : t -> option elt. - (** Return one element of the given set, or raise [Not_found] if - the set is empty. Which element is chosen is unspecified. - Equal sets could return different elements. *) - (** Coq comment: [Not_found] is represented by the option type *) - - Section Spec. - - Variable s s' : t. - Variable x y : elt. - - (** Specification of [In] *) - Parameter In_1 : E.eq x y -> In x s -> In y s. - - (** Specification of [mem] *) - Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) - Parameter equal_1 : Equal s s' -> equal s s' = true. - Parameter equal_2 : equal s s' = true -> Equal s s'. - - (** Specification of [subset] *) - Parameter subset_1 : Subset s s' -> subset s s' = true. - Parameter subset_2 : subset s s' = true -> Subset s s'. - - (** Specification of [empty] *) - Parameter empty_1 : Empty empty. - - (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. - Parameter is_empty_2 : is_empty s = true -> Empty s. - - (** Specification of [add] *) - Parameter add_1 : E.eq x y -> In y (add x s). - Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - - (** Specification of [remove] *) - Parameter remove_1 : E.eq x y -> ~ In y (remove x s). - Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Parameter remove_3 : In y (remove x s) -> In y s. - - (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). - - (** Specification of [union] *) - Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). - Parameter union_3 : In x s' -> In x (union s s'). - - (** Specification of [inter] *) - Parameter inter_1 : In x (inter s s') -> In x s. - Parameter inter_2 : In x (inter s s') -> In x s'. - Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). - - (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. - Parameter diff_2 : In x (diff s s') -> ~ In x s'. - Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) - Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - - (** Specification of [cardinal] *) - Parameter cardinal_1 : cardinal s = length (elements s). - - Section Filter. - - Variable f : elt -> bool. - - (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Parameter filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - - (** Specification of [for_all] *) - Parameter for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Parameter for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - - (** Specification of [exists] *) - Parameter exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Parameter exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - - (** Specification of [partition] *) - Parameter partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Parameter partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - - End Filter. - - (** Specification of [elements] *) - Parameter elements_1 : In x s -> InA E.eq x (elements s). - Parameter elements_2 : InA E.eq x (elements s) -> In x s. - Parameter elements_3 : NoDupA E.eq (elements s). - - (** Specification of [choose] *) - Parameter choose_1 : choose s = Some x -> In x s. - Parameter choose_2 : choose s = None -> Empty s. - - End Spec. - - Hint Immediate In_1. - - Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1 - is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1 - remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1 - inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1 - for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2 - elements_3. - -End S. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 97080b7a..71a0d584 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 8834 2006-05-20 00:41:35Z letouzey $ *) +(* $Id: FSetWeakList.v 10631 2008-03-06 18:17:24Z msozeau $ *) (** * Finite sets library *) (** This file proposes an implementation of the non-dependant interface [FSetWeakInterface.S] using lists without redundancy. *) -Require Import FSetWeakInterface. +Require Import FSetInterface. Set Implicit Arguments. Unset Strict Implicit. @@ -24,8 +24,6 @@ Unset Strict Implicit. And the functions returning sets are proved to preserve this invariant. *) Module Raw (X: DecidableType). - - Module E := X. Definition elt := X.t. Definition t := list elt. @@ -59,7 +57,7 @@ Module Raw (X: DecidableType). if X.eq_dec x y then l else y :: remove x l end. - Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : + Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : B -> B := fun i => match s with | nil => i | x :: l => fold f l (f x i) @@ -127,7 +125,7 @@ Module Raw (X: DecidableType). Lemma In_eq : forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s. Proof. - intros s x y; do 2 setoid_rewrite InA_alt; firstorder eauto. + intros s x y; setoid_rewrite InA_alt; firstorder eauto. Qed. Hint Immediate In_eq. @@ -287,13 +285,13 @@ Module Raw (X: DecidableType). unfold elements; auto. Qed. - Lemma elements_3 : forall (s : t) (Hs : NoDup s), NoDup (elements s). + Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s). Proof. unfold elements; auto. Qed. Lemma fold_1 : - forall (s : t) (Hs : NoDup s) (A : Set) (i : A) (f : elt -> A -> A), + forall (s : t) (Hs : NoDup s) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. induction s; simpl; auto; intros. @@ -732,22 +730,68 @@ Module Raw (X: DecidableType). generalize (Hrec H0 f). case (f x); case (partition f l); simpl; auto. Qed. - + Definition eq : t -> t -> Prop := Equal. - Lemma eq_refl : forall s : t, eq s s. - Proof. - unfold eq, Equal; intuition. - Qed. + Lemma eq_refl : forall s, eq s s. + Proof. firstorder. Qed. - Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. - Proof. - unfold eq, Equal; firstorder. - Qed. + Lemma eq_sym : forall s s', eq s s' -> eq s' s. + Proof. firstorder. Qed. - Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. - Proof. - unfold eq, Equal; firstorder. + Lemma eq_trans : + forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. + Proof. firstorder. Qed. + + Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), + { eq s s' }+{ ~eq s s' }. + Proof. + unfold eq. + induction s; intros s'. + (* nil *) + destruct s'; [left|right]. + firstorder. + unfold not, Equal. + intros H; generalize (H e); clear H. + rewrite InA_nil, InA_cons; intuition. + (* cons *) + intros. + case_eq (mem a s'); intros H; + [ destruct (IHs (remove a s')) as [H'|H']; + [ | | left|right]|right]; + clear IHs. + inversion_clear Hs; auto. + apply remove_unique; auto. + (* In a s' /\ s [=] remove a s' *) + generalize (mem_2 H); clear H; intro H. + unfold Equal in *; intros b. + rewrite InA_cons; split. + destruct 1. + apply In_eq with a; auto. + rewrite H' in H0. + apply remove_3 with a; auto. + destruct (X.eq_dec b a); [left|right]; auto. + rewrite H'. + apply remove_2; auto. + (* In a s' /\ ~ s [=] remove a s' *) + generalize (mem_2 H); clear H; intro H. + contradict H'. + unfold Equal in *; intros b. + split; intros. + apply remove_2; auto. + inversion_clear Hs. + contradict H1; apply In_eq with b; auto. + rewrite <- H'; rewrite InA_cons; auto. + assert (In b s') by (apply remove_3 with a; auto). + rewrite <- H', InA_cons in H1; destruct H1; auto. + elim (remove_1 Hs' (X.eq_sym H1) H0). + (* ~ In a s' *) + assert (~In a s'). + red; intro H'; rewrite (mem_1 H') in H; discriminate. + contradict H0. + unfold Equal in *. + rewrite <- H0. + rewrite InA_cons; auto. Qed. End ForNotations. @@ -758,12 +802,12 @@ End Raw. Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of lists without redundancy. *) -Module Make (X: DecidableType) <: S with Module E := X. +Module Make (X: DecidableType) <: WS with Module E := X. Module Raw := Raw X. Module E := X. - Record slist : Set := {this :> Raw.t; unique : NoDupA E.eq this}. + Record slist := {this :> Raw.t; unique : NoDupA E.eq this}. Definition t := slist. Definition elt := E.t. @@ -791,7 +835,7 @@ Module Make (X: DecidableType) <: S with Module E := X. Definition is_empty (s : t) : bool := Raw.is_empty s. Definition elements (s : t) : list elt := Raw.elements s. Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. + Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. Definition cardinal (s : t) : nat := Raw.cardinal s. Definition filter (f : elt -> bool) (s : t) : t := Build_slist (Raw.filter_unique (unique s) f). @@ -872,7 +916,7 @@ Module Make (X: DecidableType) <: S with Module E := X. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed. - Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. exact (Raw.fold_1 s.(unique)). Qed. @@ -923,8 +967,8 @@ Module Make (X: DecidableType) <: S with Module E := X. Proof. exact (fun H => Raw.elements_1 H). Qed. Lemma elements_2 : InA E.eq x (elements s) -> In x s. Proof. exact (fun H => Raw.elements_2 H). Qed. - Lemma elements_3 : NoDupA E.eq (elements s). - Proof. exact (Raw.elements_3 s.(unique)). Qed. + Lemma elements_3w : NoDupA E.eq (elements s). + Proof. exact (Raw.elements_3w s.(unique)). Qed. Lemma choose_1 : choose s = Some x -> In x s. Proof. exact (fun H => Raw.choose_1 H). Qed. @@ -933,4 +977,22 @@ Module Make (X: DecidableType) <: S with Module E := X. End Spec. + Definition eq : t -> t -> Prop := Equal. + + Lemma eq_refl : forall s, eq s s. + Proof. firstorder. Qed. + + Lemma eq_sym : forall s s', eq s s' -> eq s' s. + Proof. firstorder. Qed. + + Lemma eq_trans : + forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. + Proof. firstorder. Qed. + + Definition eq_dec : forall (s s':t), + { eq s s' }+{ ~eq s s' }. + Proof. + intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). + Qed. + End Make. diff --git a/theories/FSets/FSetWeakProperties.v b/theories/FSets/FSetWeakProperties.v deleted file mode 100644 index a0054d36..00000000 --- a/theories/FSets/FSetWeakProperties.v +++ /dev/null @@ -1,896 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: FSetWeakProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *) - -(** * Finite sets library *) - -(** NB: this file is a clone of [FSetProperties] for weak sets - and should remain so until we find a way to share the two. *) - -(** This functor derives additional properties from [FSetWeakInterface.S]. - Contrary to the functor in [FSetWeakEqProperties] it uses - predicates over sets instead of sets operations, i.e. - [In x s] instead of [mem x s=true], - [Equal s s'] instead of [equal s s'=true], etc. *) - -Require Export FSetWeakInterface. -Require Import FSetWeakFacts. -Set Implicit Arguments. -Unset Strict Implicit. - -Hint Unfold transpose compat_op. -Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. - -Module Properties (M: S). - Import M.E. - Import M. - Import Logic. (* to unmask [eq] *) - Import Peano. (* to unmask [lt] *) - - (** Results about lists without duplicates *) - - Module FM := Facts M. - Import FM. - - Definition Add (x : elt) (s s' : t) := - forall y : elt, In y s' <-> E.eq x y \/ In y s. - - Lemma In_dec : forall x s, {In x s} + {~ In x s}. - Proof. - intros; generalize (mem_iff s x); case (mem x s); intuition. - Qed. - - Section BasicProperties. - - (** properties of [Equal] *) - - Lemma equal_refl : forall s, s[=]s. - Proof. - unfold Equal; intuition. - Qed. - - Lemma equal_sym : forall s s', s[=]s' -> s'[=]s. - Proof. - unfold Equal; intros. - rewrite H; intuition. - Qed. - - Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3. - Proof. - unfold Equal; intros. - rewrite H; exact (H0 a). - Qed. - - Variable s s' s'' s1 s2 s3 : t. - Variable x x' : elt. - - (** properties of [Subset] *) - - Lemma subset_refl : s[<=]s. - Proof. - unfold Subset; intuition. - Qed. - - Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. - Proof. - unfold Subset, Equal; intuition. - Qed. - - Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. - Proof. - unfold Subset; intuition. - Qed. - - Lemma subset_equal : s[=]s' -> s[<=]s'. - Proof. - unfold Subset, Equal; firstorder. - Qed. - - Lemma subset_empty : empty[<=]s. - Proof. - unfold Subset; intros a; set_iff; intuition. - Qed. - - Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. - - Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. - - Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. - Proof. - unfold Subset; intros H H0 a; set_iff; intuition. - rewrite <- H2; auto. - Qed. - - Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. - Proof. - unfold Subset; intuition. - Qed. - - Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. - Proof. - unfold Subset; intuition. - Qed. - - Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. - Proof. - unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition. - Qed. - - (** properties of [empty] *) - - Lemma empty_is_empty_1 : Empty s -> s[=]empty. - Proof. - unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. - Qed. - - Lemma empty_is_empty_2 : s[=]empty -> Empty s. - Proof. - unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. - Qed. - - (** properties of [add] *) - - Lemma add_equal : In x s -> add x s [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite <- H1; auto. - Qed. - - Lemma add_add : add x (add x' s) [=] add x' (add x s). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - (** properties of [remove] *) - - Lemma remove_equal : ~ In x s -> remove x s [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite H1 in H; auto. - Qed. - - Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - (** properties of [add] and [remove] *) - - Lemma add_remove : In x s -> add x (remove x s) [=] s. - Proof. - unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. - rewrite <- H1; auto. - Qed. - - Lemma remove_add : ~In x s -> remove x (add x s) [=] s. - Proof. - unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. - rewrite H1 in H; auto. - Qed. - - (** properties of [singleton] *) - - Lemma singleton_equal_add : singleton x [=] add x empty. - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. - - (** properties of [union] *) - - Lemma union_sym : union s s' [=] union s' s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. - Proof. - unfold Subset, Equal; intros; set_iff; intuition. - Qed. - - Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma add_union_singleton : add x s [=] union (singleton x) s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma union_add : union (add x s) s' [=] add x (union s s'). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma union_subset_1 : s [<=] union s s'. - Proof. - unfold Subset; intuition. - Qed. - - Lemma union_subset_2 : s' [<=] union s s'. - Proof. - unfold Subset; intuition. - Qed. - - Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. - Proof. - unfold Subset; intros H H0 a; set_iff; intuition. - Qed. - - Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. - - Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. - unfold Subset; intros H a; set_iff; intuition. - Qed. - - Lemma empty_union_1 : Empty s -> union s s' [=] s'. - Proof. - unfold Equal, Empty; intros; set_iff; firstorder. - Qed. - - Lemma empty_union_2 : Empty s -> union s' s [=] s'. - Proof. - unfold Equal, Empty; intros; set_iff; firstorder. - Qed. - - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). - Proof. - intros; set_iff; intuition. - Qed. - - (** properties of [inter] *) - - Lemma inter_sym : inter s s' [=] inter s' s. - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. - - Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. - Proof. - intros; rewrite H; apply equal_refl. - Qed. - - Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). - Proof. - unfold Equal; intros; set_iff; tauto. - Qed. - - Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). - Proof. - unfold Equal; intros; set_iff; intuition. - rewrite <- H1; auto. - Qed. - - Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. - Proof. - unfold Equal; intros; set_iff; intuition. - destruct H; rewrite H0; auto. - Qed. - - Lemma empty_inter_1 : Empty s -> Empty (inter s s'). - Proof. - unfold Empty; intros; set_iff; firstorder. - Qed. - - Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). - Proof. - unfold Empty; intros; set_iff; firstorder. - Qed. - - Lemma inter_subset_1 : inter s s' [<=] s. - Proof. - unfold Subset; intro a; set_iff; tauto. - Qed. - - Lemma inter_subset_2 : inter s s' [<=] s'. - Proof. - unfold Subset; intro a; set_iff; tauto. - Qed. - - Lemma inter_subset_3 : - s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. - Proof. - unfold Subset; intros H H' a; set_iff; intuition. - Qed. - - (** properties of [diff] *) - - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). - Proof. - unfold Empty, Equal; intros; set_iff; firstorder. - Qed. - - Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. - Proof. - unfold Empty, Equal; intros; set_iff; firstorder. - Qed. - - Lemma diff_subset : diff s s' [<=] s. - Proof. - unfold Subset; intros a; set_iff; tauto. - Qed. - - Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. - Proof. - unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto. - Qed. - - Lemma remove_diff_singleton : - remove x s [=] diff s (singleton x). - Proof. - unfold Equal; intros; set_iff; intuition. - Qed. - - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. - Proof. - unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto. - Qed. - - Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. - Proof. - unfold Equal; intros; set_iff; intuition. - elim (In_dec a s'); auto. - Qed. - - (** properties of [Add] *) - - Lemma Add_add : Add x s (add x s). - Proof. - unfold Add; intros; set_iff; intuition. - Qed. - - Lemma Add_remove : In x s -> Add x (remove x s) s. - Proof. - unfold Add; intros; set_iff; intuition. - elim (eq_dec x y); auto. - rewrite <- H1; auto. - Qed. - - Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. - unfold Add; intros; set_iff; rewrite H; tauto. - Qed. - - Lemma inter_Add : - In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. - unfold Add; intros; set_iff; rewrite H0; intuition. - rewrite <- H2; auto. - Qed. - - Lemma union_Equal : - In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. - unfold Add, Equal; intros; set_iff; rewrite H0; intuition. - rewrite <- H1; auto. - Qed. - - Lemma inter_Add_2 : - ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. - Proof. - unfold Add, Equal; intros; set_iff; rewrite H0; intuition. - destruct H; rewrite H1; auto. - Qed. - - End BasicProperties. - - Hint Immediate equal_sym: set. - Hint Resolve equal_refl equal_trans : set. - - Hint Immediate add_remove remove_add union_sym inter_sym: set. - Hint Resolve subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 - subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 - union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 - inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal - remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove - Equal_remove add_add : set. - - (** * Alternative (weaker) specifications for [fold] *) - - Section Old_Spec_Now_Properties. - - Notation NoDup := (NoDupA E.eq). - - (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] - takes the set elements was unspecified. This specification reflects this fact: - *) - - Lemma fold_0 : - forall s (A : Set) (i : A) (f : elt -> A -> A), - exists l : list elt, - NoDup l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - fold f s i = fold_right f i l. - Proof. - intros; exists (rev (elements s)); split. - apply NoDupA_rev; auto. - exact E.eq_trans. - 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. - Qed. - - (** An alternate (and previous) specification for [fold] was based on - the recursive structure of a set. It is now lemmas [fold_1] and - [fold_2]. *) - - Lemma fold_1 : - forall s (A : Set) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), - Empty s -> eqA (fold f s i) i. - Proof. - unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). - rewrite H3; clear H3. - generalize H H2; clear H H2; case l; simpl; intros. - refl_st. - elim (H e). - elim (H2 e); intuition. - Qed. - - Lemma fold_2 : - forall s s' x (A : Set) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), - compat_op E.eq eqA f -> - transpose eqA f -> - ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). - Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); - destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). - rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. - eauto. - exact eq_dec. - rewrite <- Hl1; auto. - intros; rewrite <- Hl1; rewrite <- Hl'1; auto. - Qed. - - (** Similar specifications for [cardinal]. *) - - Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. - Proof. - intros; rewrite cardinal_1; rewrite M.fold_1. - symmetry; apply fold_left_length; auto. - Qed. - - Lemma cardinal_0 : - forall s, exists l : list elt, - NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ - cardinal s = length l. - Proof. - intros; exists (elements s); intuition; apply cardinal_1. - Qed. - - Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. - Proof. - intros; rewrite cardinal_fold; apply fold_1; auto. - Qed. - - Lemma cardinal_2 : - forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). - Proof. - intros; do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x). - apply fold_2; auto. - Qed. - - End Old_Spec_Now_Properties. - - (** * Induction principle over sets *) - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros s; rewrite M.cardinal_1; intros H a; red. - rewrite elements_iff. - destruct (elements s); simpl in *; discriminate || inversion 1. - Qed. - Hint Resolve cardinal_inv_1. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. - Qed. - - Lemma Equal_cardinal_aux : - forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'. - Proof. - simple induction n; intros. - rewrite H; symmetry . - apply cardinal_1. - rewrite <- H0; auto. - destruct (cardinal_inv_2 H0) as (x,H2). - revert H0. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set. - rewrite H1 in H2; auto with set. - Qed. - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - intros; apply Equal_cardinal_aux with (cardinal s); auto. - Qed. - - Add Morphism cardinal : cardinal_m. - Proof. - exact Equal_cardinal. - Qed. - - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. - - Lemma cardinal_induction : - forall P : t -> Type, - (forall s, Empty s -> P s) -> - (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> - forall n s, cardinal s = n -> P s. - Proof. - simple induction n; intros; auto. - destruct (cardinal_inv_2 H) as (x,H0). - apply X0 with (remove x s) x; auto. - apply X1; auto. - rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto. - Qed. - - Lemma set_induction : - forall P : t -> Type, - (forall s : t, Empty s -> P s) -> - (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') -> - forall s : t, P s. - Proof. - intros; apply cardinal_induction with (cardinal s); auto. - Qed. - - (** Other properties of [fold]. *) - - Section Fold. - Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - - Section Fold_1. - Variable i i':A. - - Lemma fold_empty : eqA (fold f empty i) i. - Proof. - apply fold_1; auto. - Qed. - - Lemma fold_equal : - forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. - intros s; pattern s; apply set_induction; clear s; intros. - trans_st i. - apply fold_1; auto. - sym_st; apply fold_1; auto. - rewrite <- H0; auto. - trans_st (f x (fold f s i)). - apply fold_2 with (eqA := eqA); auto. - sym_st; apply fold_2 with (eqA := eqA); auto. - unfold Add in *; intros. - rewrite <- H2; auto. - Qed. - - Lemma fold_add : forall s x, ~In x s -> - eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. - intros; apply fold_2 with (eqA := eqA); auto. - Qed. - - Lemma add_fold : forall s x, In x s -> - eqA (fold f (add x s) i) (fold f s i). - Proof. - intros; apply fold_equal; auto with set. - Qed. - - Lemma remove_fold_1: forall s x, In x s -> - eqA (f x (fold f (remove x s) i)) (fold f s i). - Proof. - intros. - sym_st. - apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma remove_fold_2: forall s x, ~In x s -> - eqA (fold f (remove x s) i) (fold f s i). - Proof. - intros. - apply fold_equal; auto with set. - Qed. - - Lemma fold_commutes : forall s x, - eqA (fold f s (f x i)) (f x (fold f s i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - trans_st (f x i). - apply fold_1; auto. - sym_st. - apply Comp; auto. - apply fold_1; auto. - trans_st (f x0 (fold f s (f x i))). - apply fold_2 with (eqA:=eqA); auto. - trans_st (f x0 (f x (fold f s i))). - trans_st (f x (f x0 (fold f s i))). - apply Comp; auto. - sym_st. - apply fold_2 with (eqA:=eqA); auto. - Qed. - - Lemma fold_init : forall s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - trans_st i. - apply fold_1; auto. - trans_st i'. - sym_st; apply fold_1; auto. - trans_st (f x (fold f s i)). - apply fold_2 with (eqA:=eqA); auto. - trans_st (f x (fold f s i')). - sym_st; apply fold_2 with (eqA:=eqA); auto. - Qed. - - End Fold_1. - Section Fold_2. - Variable i:A. - - Lemma fold_union_inter : forall s s', - eqA (fold f (union s s') (fold f (inter s s') i)) - (fold f s (fold f s' i)). - Proof. - intros; pattern s; apply set_induction; clear s; intros. - trans_st (fold f s' (fold f (inter s s') i)). - apply fold_equal; auto with set. - trans_st (fold f s' i). - apply fold_init; auto. - apply fold_1; auto with set. - sym_st; apply fold_1; auto. - rename s'0 into s''. - destruct (In_dec x s'). - (* In x s' *) - trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. - apply fold_init; auto. - apply fold_2 with (eqA:=eqA); auto with set. - rewrite inter_iff; intuition. - trans_st (f x (fold f s (fold f s' i))). - trans_st (fold f (union s s') (f x (fold f (inter s s') i))). - apply fold_equal; auto. - apply equal_sym; apply union_Equal with x; auto with set. - trans_st (f x (fold f (union s s') (fold f (inter s s') i))). - apply fold_commutes; auto. - sym_st; apply fold_2 with (eqA:=eqA); auto. - (* ~(In x s') *) - trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))). - apply fold_2 with (eqA:=eqA); auto with set. - trans_st (f x (fold f (union s s') (fold f (inter s s') i))). - apply Comp;auto. - apply fold_init;auto. - apply fold_equal;auto. - apply equal_sym; apply inter_Add_2 with x; auto with set. - trans_st (f x (fold f s (fold f s' i))). - sym_st; apply fold_2 with (eqA:=eqA); auto. - Qed. - - End Fold_2. - Section Fold_3. - Variable i:A. - - Lemma fold_diff_inter : forall s s', - eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). - Proof. - intros. - trans_st (fold f (union (diff s s') (inter s s')) - (fold f (inter (diff s s') (inter s s')) i)). - sym_st; apply fold_union_inter; auto. - trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)). - apply fold_equal; auto with set. - apply fold_init; auto. - apply fold_1; auto with set. - Qed. - - Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') -> - eqA (fold f (union s s') i) (fold f s (fold f s' i)). - Proof. - intros. - trans_st (fold f (union s s') (fold f (inter s s') i)). - apply fold_init; auto. - sym_st; apply fold_1; auto with set. - unfold Empty; intro a; generalize (H a); set_iff; tauto. - apply fold_union_inter; auto. - Qed. - - End Fold_3. - End Fold. - - Lemma fold_plus : - forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. - Proof. - assert (st := gen_st nat). - assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). - assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto). - intros s p; pattern s; apply set_induction; clear s; intros. - rewrite (fold_1 st p (fun _ => S) H). - rewrite (fold_1 st 0 (fun _ => S) H); trivial. - assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)). - change S with ((fun _ => S) x). - intros; apply fold_2; auto. - rewrite H2; auto. - rewrite (H2 0); auto. - rewrite H. - simpl; auto. - Qed. - - (** properties of [cardinal] *) - - Lemma empty_cardinal : cardinal empty = 0. - Proof. - rewrite cardinal_fold; apply fold_1; auto. - Qed. - - Hint Immediate empty_cardinal cardinal_1 : set. - - Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. - Proof. - intros. - rewrite (singleton_equal_add x). - replace 0 with (cardinal empty); auto with set. - apply cardinal_2 with x; auto with set. - Qed. - - Hint Resolve singleton_cardinal: set. - - Lemma diff_inter_cardinal : - forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_diff_inter with (eqA:=@eq nat); auto. - Qed. - - Lemma union_cardinal: - forall s s', (forall x, ~In x s\/~In x s') -> - cardinal (union s s')=cardinal s+cardinal s'. - Proof. - intros; do 3 rewrite cardinal_fold. - rewrite <- fold_plus. - apply fold_union; auto. - Qed. - - Lemma subset_cardinal : - forall s s', s[<=]s' -> cardinal s <= cardinal s' . - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H); auto with arith. - Qed. - - Lemma subset_cardinal_lt : - forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. - intros. - rewrite <- (diff_inter_cardinal s' s). - rewrite (inter_sym s' s). - rewrite (inter_subset_equal H). - generalize (@cardinal_inv_1 (diff s' s)). - destruct (cardinal (diff s' s)). - intro H2; destruct (H2 (refl_equal _) x). - set_iff; auto. - intros _. - change (0 + cardinal s < S n + cardinal s). - apply Plus.plus_lt_le_compat; auto with arith. - Qed. - - Theorem union_inter_cardinal : - forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . - Proof. - intros. - do 4 rewrite cardinal_fold. - do 2 rewrite <- fold_plus. - apply fold_union_inter with (eqA:=@eq nat); auto. - Qed. - - Lemma union_cardinal_inter : - forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). - Proof. - intros. - rewrite <- union_inter_cardinal. - rewrite Plus.plus_comm. - auto with arith. - Qed. - - Lemma union_cardinal_le : - forall s s', cardinal (union s s') <= cardinal s + cardinal s'. - Proof. - intros; generalize (union_inter_cardinal s s'). - intros; rewrite <- H; auto with arith. - Qed. - - Lemma add_cardinal_1 : - forall s x, In x s -> cardinal (add x s) = cardinal s. - Proof. - auto with set. - Qed. - - Lemma add_cardinal_2 : - forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ => S) x); - apply fold_add with (eqA:=@eq nat); auto. - Qed. - - Lemma remove_cardinal_1 : - forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. - Proof. - intros. - do 2 rewrite cardinal_fold. - change S with ((fun _ =>S) x). - apply remove_fold_1 with (eqA:=@eq nat); auto. - Qed. - - Lemma remove_cardinal_2 : - forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. - auto with set. - Qed. - - Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. - -End Properties. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index b0402db6..a73c1da7 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -6,13 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSets.v 8897 2006-06-05 21:04:10Z letouzey $ *) +(* $Id: FSets.v 10699 2008-03-19 20:56:43Z letouzey $ *) Require Export OrderedType. Require Export OrderedTypeEx. Require Export OrderedTypeAlt. +Require Export DecidableType. +Require Export DecidableTypeEx. Require Export FSetInterface. Require Export FSetBridge. +Require Export FSetFacts. +Require Export FSetDecide. Require Export FSetProperties. Require Export FSetEqProperties. +Require Export FSetWeakList. Require Export FSetList. +Require Export FSetAVL.
\ No newline at end of file diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v index f966cd4d..c56a24cf 100644 --- a/theories/FSets/OrderedType.v +++ b/theories/FSets/OrderedType.v @@ -6,32 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedType.v 8834 2006-05-20 00:41:35Z letouzey $ *) +(* $Id: OrderedType.v 10616 2008-03-04 17:33:35Z letouzey $ *) Require Export SetoidList. Set Implicit Arguments. Unset Strict Implicit. -(* TODO concernant la tactique order: - * propagate_lt n'est sans doute pas complet - * un propagate_le - * exploiter les hypotheses negatives restant a la fin - * faire que ca marche meme quand une hypothese depend d'un eq ou lt. -*) - (** * Ordered types *) -Inductive Compare (X : Set) (lt eq : X -> X -> Prop) (x y : X) : Set := +Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := | LT : lt x y -> Compare lt eq x y | EQ : eq x y -> Compare lt eq x y | GT : lt y x -> Compare lt eq x y. Module Type OrderedType. - Parameter t : Set. + Parameter Inline t : Type. - Parameter eq : t -> t -> Prop. - Parameter lt : t -> t -> Prop. + Parameter Inline eq : t -> t -> Prop. + Parameter Inline lt : t -> t -> Prop. Axiom eq_refl : forall x : t, eq x x. Axiom eq_sym : forall x y : t, eq x y -> eq y x. @@ -122,6 +115,13 @@ Module OrderedTypeFacts (O: OrderedType). intuition. Qed. +(* TODO concernant la tactique order: + * propagate_lt n'est sans doute pas complet + * un propagate_le + * exploiter les hypotheses negatives restant a la fin + * faire que ca marche meme quand une hypothese depend d'un eq ou lt. +*) + Ltac abstraction := match goal with (* First, some obvious simplifications *) | H : False |- _ => elim H @@ -137,9 +137,9 @@ Ltac abstraction := match goal with | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction (* Then, we generalize all interesting facts *) - | H : lt ?x ?y |- _ => revert H; abstraction - | H : ~lt ?x ?y |- _ => revert H; abstraction | H : ~eq ?x ?y |- _ => revert H; abstraction + | H : ~lt ?x ?y |- _ => revert H; abstraction + | H : lt ?x ?y |- _ => revert H; abstraction | H : eq ?x ?y |- _ => revert H; abstraction | _ => idtac end. @@ -192,7 +192,7 @@ Ltac do_lt x y LT := match goal with | |- lt ?z x -> _ => let H := fresh "H" in (intro H; generalize (lt_trans H LT); intro); do_lt x y LT | |- lt _ _ -> _ => intro; do_lt x y LT - (* Ge *) + (* GE *) | |- ~lt y x -> _ => intros _; do_lt x y LT | |- ~lt x ?z -> _ => let H := fresh "H" in (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT @@ -296,12 +296,12 @@ Ltac false_order := elimtype False; order. Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof. intros; elim (compare x y); [ right | left | right ]; auto. - Qed. + Defined. Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. intros; elim (compare x y); [ left | right | right ]; auto. - Qed. + Defined. Definition eqb x y : bool := if eq_dec x y then true else false. @@ -361,7 +361,7 @@ Module KeyOrderedType(O:OrderedType). Import MO. Section Elt. - Variable elt : Set. + Variable elt : Type. Notation key:=t. Definition eqk (p p':key*elt) := eq (fst p) (fst p'). diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v index 9bcfbfc7..516df0f0 100644 --- a/theories/FSets/OrderedTypeAlt.v +++ b/theories/FSets/OrderedTypeAlt.v @@ -11,19 +11,19 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeAlt.v 8773 2006-04-29 14:31:32Z letouzey $ *) +(* $Id: OrderedTypeAlt.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Import OrderedType. (** * An alternative (but equivalent) presentation for an Ordered Type inferface. *) -(** NB: [comparison], defined in [theories/Init/datatypes.v] is [Eq|Lt|Gt] -whereas [compare], defined in [theories/FSets/OrderedType.v] is [EQ _ | LT _ | GT _ ] +(** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt] +whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] *) Module Type OrderedTypeAlt. - Parameter t : Set. + Parameter t : Type. Parameter compare : t -> t -> comparison. @@ -103,24 +103,16 @@ Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. Lemma compare_sym : forall x y, (y?=x) = CompOpp (x?=y). Proof. - intros x y. - unfold compare. - destruct (O.compare y x); elim_comp; simpl; auto. + intros x y; unfold compare. + destruct O.compare; elim_comp; simpl; auto. Qed. Lemma compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. intros c x y z. - destruct c; unfold compare. - destruct (O.compare x y); intros; try discriminate. - destruct (O.compare y z); intros; try discriminate. - elim_comp; auto. - destruct (O.compare x y); intros; try discriminate. - destruct (O.compare y z); intros; try discriminate. - elim_comp; auto. - destruct (O.compare x y); intros; try discriminate. - destruct (O.compare y z); intros; try discriminate. + destruct c; unfold compare; + do 2 (destruct O.compare; intros; try discriminate); elim_comp; auto. Qed. diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v index 28a5705d..03171396 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/FSets/OrderedTypeEx.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeEx.v 9940 2007-07-05 12:32:47Z letouzey $ *) +(* $Id: OrderedTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Import OrderedType. Require Import ZArith. @@ -25,9 +25,9 @@ Require Import Compare_dec. the equality is the usual one of Coq. *) Module Type UsualOrderedType. - Parameter t : Set. + Parameter Inline t : Type. Definition eq := @eq t. - Parameter lt : t -> t -> Prop. + Parameter Inline lt : t -> t -> Prop. Definition eq_refl := @refl_equal t. Definition eq_sym := @sym_eq t. Definition eq_trans := @trans_eq t. @@ -154,16 +154,16 @@ Module N_as_OT <: UsualOrderedType. Definition eq_sym := @sym_eq t. Definition eq_trans := @trans_eq t. - Definition lt p q:= Nle q p = false. + Definition lt p q:= Nleb q p = false. - Definition lt_trans := Nlt_trans. + Definition lt_trans := Nltb_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 Nle_refl in H; discriminate. + rewrite Nleb_refl in H; discriminate. Qed. Definition compare : forall x y : t, Compare lt eq x y. @@ -172,16 +172,15 @@ Module N_as_OT <: UsualOrderedType. case_eq ((x ?= y)%N); intros. apply EQ; apply Ncompare_Eq_eq; auto. apply LT; unfold lt; auto. - generalize (Nle_Ncompare y x). - destruct (Nle y x); auto. - rewrite <- Ncompare_antisym. + generalize (Nleb_Nle y x). + unfold Nle; rewrite <- Ncompare_antisym. destruct (x ?= y)%N; simpl; try discriminate. - intros (H0,_); elim H0; auto. + clear H; intros H. + destruct (Nleb y x); intuition. apply GT; unfold lt. - generalize (Nle_Ncompare x y). - destruct (Nle x y); auto. - destruct (x ?= y)%N; simpl; try discriminate. - intros (H0,_); elim H0; auto. + generalize (Nleb_Nle x y). + unfold Nle; destruct (x ?= y)%N; simpl; try discriminate. + destruct (Nleb x y); intuition. Defined. End N_as_OT. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 56dc7e95..e5e6fd23 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Datatypes.v 11073 2008-06-08 20:24:51Z herbelin $ i*) Set Implicit Arguments. @@ -26,6 +26,52 @@ Inductive bool : Set := Add Printing If bool. +Delimit Scope bool_scope with bool. + +Bind Scope bool_scope with bool. + +(** Basic boolean operators *) + +Definition andb (b1 b2:bool) : bool := if b1 then b2 else false. + +Definition orb (b1 b2:bool) : bool := if b1 then true else b2. + +Definition implb (b1 b2:bool) : bool := if b1 then b2 else true. + +Definition xorb (b1 b2:bool) : bool := + match b1, b2 with + | true, true => false + | true, false => true + | false, true => true + | false, false => false + end. + +Definition negb (b:bool) := if b then false else true. + +Infix "||" := orb : bool_scope. +Infix "&&" := andb : bool_scope. + +(*******************************) +(** * Properties of [andb] *) +(*******************************) + +Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. +Proof. + destruct a; destruct b; intros; split; try (reflexivity || discriminate). +Qed. +Hint Resolve andb_prop: bool v62. + +Lemma andb_true_intro : + forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. +Proof. + destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. +Qed. +Hint Resolve andb_true_intro: bool v62. + +(** Interpretation of booleans as propositions *) + +Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. + (** [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; @@ -70,7 +116,7 @@ Definition option_map (A B:Type) (f:A->B) o := end. (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) -(* Syntax defined in Specif.v *) + Inductive sum (A B:Type) : Type := | inl : A -> sum A B | inr : B -> sum A B. @@ -82,6 +128,7 @@ Notation "x + y" := (sum x y) : type_scope. Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. + Add Printing Let prod. Notation "x * y" := (prod x y) : type_scope. @@ -135,6 +182,13 @@ Definition CompOpp (r:comparison) := | Gt => Lt end. +(** Identity *) + +Definition ID := forall A:Type, A -> A. +Definition id : ID := fun A x => x. + +(* begin hide *) + (* Compatibility *) Notation prodT := prod (only parsing). @@ -146,3 +200,5 @@ Notation fstT := fst (only parsing). Notation sndT := snd (only parsing). Notation prodT_uncurry := prod_uncurry (only parsing). Notation prodT_curry := prod_curry (only parsing). + +(* end hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8b487432..6a636ccc 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Logic.v 10304 2007-11-08 17:06:32Z emakarov $ i*) Set Implicit Arguments. @@ -16,10 +16,10 @@ Require Import Notations. (** [True] is the always true proposition *) Inductive True : Prop := - I : True. + I : True. (** [False] is the always false proposition *) -Inductive False : Prop :=. +Inductive False : Prop :=. (** [not A], written [~A], is the negation of [A] *) Definition not (A:Prop) := A -> False. @@ -30,14 +30,14 @@ Hint Unfold not: core. (** [and A B], written [A /\ B], is the conjunction of [A] and [B] - [conj p q] is a proof of [A /\ B] as soon as + [conj p q] is a proof of [A /\ B] as soon as [p] is a proof of [A] and [q] a proof of [B] [proj1] and [proj2] are first and second projections of a conjunction *) Inductive and (A B:Prop) : Prop := - conj : A -> B -> A /\ B - + conj : A -> B -> A /\ B + where "A /\ B" := (and A B) : type_scope. Section Conjunction. @@ -60,7 +60,7 @@ End Conjunction. Inductive or (A B:Prop) : Prop := | or_introl : A -> A \/ B - | or_intror : B -> A \/ B + | or_intror : B -> A \/ B where "A \/ B" := (or A B) : type_scope. @@ -89,6 +89,67 @@ Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A). End Equivalence. +Hint Unfold iff: extcore. + +(** Some equivalences *) + +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. +Qed. + +Theorem and_cancel_l : forall A B C : Prop, + (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)). +Proof. +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. +Qed. + +Theorem or_cancel_l : forall A B C : Prop, + (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)). +Proof. +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. +Qed. + +(** Backward direction of the equivalences above does not need assumptions *) + +Theorem and_iff_compat_l : forall A B C : Prop, + (B <-> C) -> (A /\ B <-> A /\ C). +Proof. +intros; tauto. +Qed. + +Theorem and_iff_compat_r : forall A B C : Prop, + (B <-> C) -> (B /\ A <-> C /\ A). +Proof. +intros; tauto. +Qed. + +Theorem or_iff_compat_l : forall A B C : Prop, + (B <-> C) -> (A \/ B <-> A \/ C). +Proof. +intros; tauto. +Qed. + +Theorem or_iff_compat_r : forall A B C : Prop, + (B <-> C) -> (B \/ A <-> C \/ A). +Proof. +intros; tauto. +Qed. + (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes either [P] and [Q], or [~P] and [Q] *) @@ -103,7 +164,7 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) expresses the existence of an [x] of some type [A] in [Set] which satisfies the predicate [P]. This is existential quantification. - [ex2 P Q], or simply [exists2 x, P x & Q x], or also + [ex2 P Q], or simply [exists2 x, P x & Q x], or also [exists2 x:A, P x & Q x], expresses the existence of an [x] of type [A] which satisfies both predicates [P] and [Q]. @@ -123,14 +184,14 @@ Inductive ex (A:Type) (P:A -> Prop) : Prop := Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop := ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q. -Definition all (A:Type) (P:A -> Prop) := forall x:A, P x. +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, + (at level 200, x ident, right associativity, format "'[' 'exists' '/ ' x : t , '/ ' p ']'") : type_scope. @@ -165,14 +226,14 @@ End universal_quantification. (** [eq x y], or simply [x=y] expresses the equality of [x] and [y]. Both [x] and [y] must belong to the same type [A]. The definition is inductive and states the reflexivity of the equality. - The others properties (symmetry, transitivity, replacement of + The others properties (symmetry, transitivity, replacement of equals by equals) are proved below. The type of [x] and [y] can be made explicit using the notation [x = y :> A]. This is Leibniz equality as it expresses that [x] and [y] are equal iff every property on [A] which is true of [x] is also true of [y] *) Inductive eq (A:Type) (x:A) : A -> Prop := - refl_equal : x = x :>A + refl_equal : x = x :>A where "x = y :> A" := (@eq A x y) : type_scope. @@ -222,7 +283,7 @@ Section Logic_lemmas. Proof. red in |- *; intros h1 h2; apply h1; destruct h2; trivial. Qed. - + Definition sym_equal := sym_eq. Definition sym_not_equal := sym_not_eq. Definition trans_equal := trans_eq. @@ -233,12 +294,12 @@ Section Logic_lemmas. forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. intros A x P H y H0; elim sym_eq with (1 := H0); assumption. Defined. - + Definition eq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y. intros A x P H y H0; elim sym_eq with (1 := H0); assumption. Defined. - + Definition eq_rect_r : forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y. intros A x P H y H0; elim sym_eq with (1 := H0); assumption. @@ -246,14 +307,14 @@ Section Logic_lemmas. End Logic_lemmas. Theorem f_equal2 : - forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) + 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. Proof. destruct 1; destruct 1; reflexivity. Qed. Theorem f_equal3 : - forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) + forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3. Proof. @@ -261,7 +322,7 @@ Proof. Qed. Theorem f_equal4 : - forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) + forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4), x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4. Proof. @@ -295,7 +356,7 @@ Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y. 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" := +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. @@ -305,15 +366,47 @@ Lemma unique_existence : forall (A:Type) (P:A->Prop), Proof. intros A P; split. intros ((x,Hx),Huni); exists x; red; auto. - intros (x,(Hx,Huni)); split. + intros (x,(Hx,Huni)); split. exists x; assumption. intros x' x'' Hx' Hx''; transitivity x. symmetry; auto. auto. Qed. -(** Being inhabited *) +(** * Being inhabited *) + +(** The predicate [inhabited] can be used in different contexts. If [A] is + thought as a type, [inhabited A] states that [A] is inhabited. If [A] is + thought as a computationally relevant proposition, then + [inhabited A] weakens [A] so as to hide its computational meaning. + The so-weakened proof remains computationally relevant but only in + a propositional context. +*) Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A. Hint Resolve inhabits: core. + +Lemma exists_inhabited : forall (A:Type) (P:A->Prop), + (exists x, P x) -> inhabited A. +Proof. + destruct 1; auto. +Qed. + +(** Declaration of stepl and stepr for eq and iff *) + +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. +Qed. + +Declare Left Step eq_stepl. +Declare Right Step trans_eq. + +Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B). +Proof. +intros; tauto. +Qed. + +Declare Left Step iff_stepl. +Declare Right Step iff_trans. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index dbe944b0..c4e5f6c7 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic_Type.v 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id: Logic_Type.v 10840 2008-04-23 21:29:34Z herbelin $ i*) (** This module defines type constructors for types in [Type] ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *) @@ -32,17 +32,17 @@ Section identity_is_a_congruence. Lemma sym_id : identity x y -> identity y x. Proof. destruct 1; trivial. - Qed. + Defined. Lemma trans_id : identity x y -> identity y z -> identity x z. Proof. destruct 2; trivial. - Qed. + Defined. Lemma congr_id : identity x y -> identity (f x) (f y). Proof. destruct 1; trivial. - Qed. + Defined. Lemma sym_not_id : notT (identity x y) -> notT (identity y x). Proof. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 416647b4..3dc6385d 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Notations.v 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id: Notations.v 11073 2008-06-08 20:24:51Z herbelin $ i*) (** These are the notations whose level and associativity are imposed by Coq *) @@ -19,13 +19,13 @@ Reserved Notation "~ x" (at level 75, right associativity). (** Notations for equality and inequalities *) -Reserved Notation "x = y :> T" +Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x = y" (at level 70, no associativity). Reserved Notation "x = y = z" (at level 70, no associativity, y at next level). -Reserved Notation "x <> y :> T" +Reserved Notation "x <> y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x <> y" (at level 70, no associativity). @@ -49,6 +49,11 @@ Reserved Notation "- x" (at level 35, right associativity). Reserved Notation "/ x" (at level 35, right associativity). Reserved Notation "x ^ y" (at level 30, right associativity). +(** Notations for booleans *) + +Reserved Notation "x || y" (at level 50, left associativity). +Reserved Notation "x && y" (at level 40, left associativity). + (** Notations for pairs *) Reserved Notation "( x , y , .. , z )" (at level 0). diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 3df2b566..9ef63cc8 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Peano.v 11115 2008-06-12 16:03:32Z werner $ i*) (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) @@ -40,7 +40,7 @@ Hint Resolve (f_equal (A:=nat)): core. (** The predecessor function *) Definition pred (n:nat) : nat := match n with - | O => 0 + | O => n | S u => u end. Hint Resolve (f_equal pred): v62. @@ -123,6 +123,11 @@ Proof. auto. Qed. +(** Standard associated names *) + +Notation plus_0_r_reverse := plus_n_O (only parsing). +Notation plus_succ_r_reverse := plus_n_Sm (only parsing). + (** Multiplication *) Fixpoint mult (n m:nat) {struct n} : nat := @@ -149,12 +154,21 @@ Proof. Qed. Hint Resolve mult_n_Sm: core v62. +(** Standard associated names *) + +Notation mult_0_r_reverse := mult_n_O (only parsing). +Notation mult_succ_r_reverse := mult_n_Sm (only parsing). + (** Truncated subtraction: [m-n] is [0] if [n>=m] *) Fixpoint minus (n m:nat) {struct n} : nat := match n, m with - | O, _ => 0 - | S k, O => S k + | O, _ => n + | S k, O => n +(*======= + + | O, _ => n + | S k, O => S k *) | S k, S l => k - l end @@ -211,5 +225,3 @@ Proof. induction n; auto. destruct m as [| n0]; auto. Qed. - -(** Notations *) diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 5f6f1eab..6492c948 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Prelude.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id: Prelude.v 10064 2007-08-08 15:32:36Z msozeau $ i*) Require Export Notations. Require Export Logic. Require Export Datatypes. Require Export Specif. Require Export Peano. -Require Export Wf. -Require Export Tactics. +Require Export Coq.Init.Wf. +Require Export Coq.Init.Tactics. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index dd2f7697..c0f5c42a 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Specif.v 8866 2006-05-28 16:21:04Z herbelin $ i*) +(*i $Id: Specif.v 10923 2008-05-12 18:25:06Z herbelin $ i*) (** Basic specifications : sets that may contain logical information *) @@ -46,12 +46,12 @@ Arguments Scope sigT [type_scope type_scope]. Arguments Scope sigT2 [type_scope type_scope type_scope]. Notation "{ x | P }" := (sig (fun x => P)) : type_scope. -Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. +Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope. Notation "{ x : A | P }" := (sig (fun x:A => P)) : type_scope. -Notation "{ x : A | P & Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) : +Notation "{ x : A | P & Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) : type_scope. -Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. -Notation "{ x : A & P & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) : +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Notation "{ x : A & P & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) : type_scope. Add Printing Let sig. @@ -107,6 +107,16 @@ Section Projections. End Projections. +(** [sigT] of a predicate is equivalent to [sig] *) + +Lemma sig_of_sigT : forall (A:Type) (P:A->Prop), sigT P -> sig P. +Proof. destruct 1 as (x,H); exists x; trivial. Defined. + +Lemma sigT_of_sig : forall (A:Type) (P:A->Prop), sig P -> sigT P. +Proof. destruct 1 as (x,H); exists x; trivial. Defined. + +Coercion sigT_of_sig : sig >-> sigT. +Coercion sig_of_sigT : sigT >-> sig. (** [sumbool] is a boolean type equipped with the justification of their value *) @@ -201,6 +211,7 @@ Proof. Qed. Hint Resolve left right inleft inright: core v62. +Hint Resolve exist exist2 existT existT2: core. (* Compatibility *) diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index ba210dd6..afe8297e 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -6,59 +6,143 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 9268 2006-10-24 12:56:16Z herbelin $ i*) +(*i $Id: Tactics.v 11072 2008-06-08 16:13:37Z herbelin $ i*) Require Import Notations. Require Import Logic. -(** Useful tactics *) +(** * Useful tactics *) + +(** A tactic for proof by contradiction. With contradict H, + - H:~A |- B gives |- A + - H:~A |- ~B gives H: B |- A + - H: A |- B gives |- ~A + - H: A |- ~B gives H: B |- ~A + - H:False leads to a resolved subgoal. + Moreover, negations may be in unfolded forms, + and A or B may live in Type *) + +Ltac contradict H := + let save tac H := let x:=fresh in intro x; tac H; rename x into H + in + let negpos H := case H; clear H + in + let negneg H := save negpos H + in + let pospos H := + let A := type of H in (elimtype False; revert H; try fold (~A)) + in + let posneg H := save pospos H + in + let neg H := match goal with + | |- (~_) => negneg H + | |- (_->False) => negneg H + | |- _ => negpos H + end in + let pos H := match goal with + | |- (~_) => posneg H + | |- (_->False) => posneg H + | |- _ => pospos H + end in + match type of H with + | (~_) => neg H + | (_->False) => neg H + | _ => (elim H;fail) || pos H + end. -(* A shorter name for generalize + clear, can be seen as an anti-intro *) +(* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*) -Tactic Notation "revert" ne_hyp_list(l) := generalize l; clear l. +Ltac swap H := + idtac "swap is OBSOLETE: use contradict instead."; + intro; apply H; clear H. -(* to contradict an hypothesis without copying its type. *) +(* To contradict an hypothesis without copying its type. *) -Ltac absurd_hyp h := - let T := type of h in +Ltac absurd_hyp H := + idtac "absurd_hyp is OBSOLETE: use contradict instead."; + let T := type of H in absurd T. -(* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*) +(* A useful complement to contradict. Here H:A while G allows to conclude ~A *) -Ltac swap H := intro; apply H; clear H. +Ltac false_hyp H G := + let T := type of H in absurd T; [ apply G | assumption ]. (* A case with no loss of information. *) Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. -(* A tactic for easing the use of lemmas f_equal, f_equal2, ... *) - -Ltac f_equal := - let cg := try congruence in - let r := try reflexivity in - match goal with - | |- ?f ?a = ?f' ?a' => cut (a=a'); [cg|r] - | |- ?f ?a ?b = ?f' ?a' ?b' => - cut (b=b');[cut (a=a');[cg|r]|r] - | |- ?f ?a ?b ?c = ?f' ?a' ?b' ?c'=> - cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r] - | |- ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d'=> - cut (d=d');[cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r]|r] - | |- ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e'=> - cut (e=e');[cut (d=d');[cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r]|r]|r] - | _ => idtac - end. - (* Rewriting in all hypothesis several times everywhere *) Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *. Tactic Notation "rewrite_all" "<-" constr(eq) := repeat rewrite <- eq in *. -(* Keeping a copy of an expression *) - -Ltac remembertac x a := - let x := fresh x in - let H := fresh "Heq" x in - (set (x:=a) in *; assert (H: x=a) by reflexivity; clearbody x). - -Tactic Notation "remember" constr(c) "as" ident(x) := remembertac x c. +(** Tactics for applying equivalences. + +The following code provides tactics "apply -> t", "apply <- t", +"apply -> t in H" and "apply <- t in H". Here t is a term whose type +consists of nested dependent and nondependent products with an +equivalence A <-> B as the conclusion. The tactics with "->" in their +names apply A -> B while those with "<-" in the name apply B -> A. *) + +(* The idea of the tactics is to first provide a term in the context +whose type is the implication (in one of the directions), and then +apply it. The first idea is to produce a statement "forall ..., A -> +B" (call this type T) and then do "assert (H : T)" for a fresh H. +Thus, T can be proved from the original equivalence and then used to +perform the application. However, currently in Ltac it is difficult +to produce such T from the original formula. + +Therefore, we first pose the original equivalence as H. If the type of +H is a dependent product, we create an existential variable and apply +H to this variable. If the type of H has the form C -> D, then we do a +cut on C. Once we eliminate all products, we split (i.e., destruct) +the conjunction into two parts and apply the relevant one. *) + +Ltac find_equiv H := +let T := type of H in +lazymatch T with +| ?A -> ?B => + let H1 := fresh in + let H2 := fresh in + cut A; + [intro H1; pose proof (H H1) as H2; clear H H1; + rename H2 into H; find_equiv H | + clear H] +| forall x : ?t, _ => + let a := fresh "a" with + H1 := fresh "H" in + evar (a : t); pose proof (H a) as H1; unfold a in H1; + clear a; clear H; rename H1 into H; find_equiv H +| ?A <-> ?B => idtac +| _ => fail "The given statement does not seem to end with an equivalence" +end. + +Ltac bapply lemma todo := +let H := fresh in + pose proof lemma as H; + find_equiv H; [todo H; clear H | .. ]. + +Tactic Notation "apply" "->" constr(lemma) := +bapply lemma ltac:(fun H => destruct H as [H _]; apply H). + +Tactic Notation "apply" "<-" constr(lemma) := +bapply lemma ltac:(fun H => destruct H as [_ H]; apply H). + +Tactic Notation "apply" "->" constr(lemma) "in" ident(J) := +bapply lemma ltac:(fun H => destruct H as [H _]; apply H in J). + +Tactic Notation "apply" "<-" constr(lemma) "in" ident(J) := +bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J). + +(** A tactic simpler than auto that is useful for ending proofs "in one step" *) +Tactic Notation "now" tactic(t) := +t; +match goal with +| H : _ |- _ => solve [inversion H] +| _ => solve [trivial | reflexivity | symmetry; trivial | discriminate | split] +| _ => fail 1 "Cannot solve this goal" +end. + +(** 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 4e0f3745..f46b2b11 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -6,12 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf.v 8988 2006-06-25 22:15:32Z letouzey $ i*) +(*i $Id: Wf.v 10712 2008-03-23 11:38:38Z herbelin $ i*) -(** This module proves the validity of - - well-founded recursion (also called course of values) +(** * This module proves the validity of + - well-founded recursion (also known as course of values) - well-founded induction - from a well-founded ordering on a given set *) Set Implicit Arguments. @@ -40,6 +39,7 @@ Section Well_founded. [let Acc_rec F = let rec wf x = F x wf in wf] *) Section AccRecType. + Variable P : A -> Type. Variable F : forall x:A, (forall y:A, R y x -> Acc y) -> (forall y:A, R y x -> P y) -> P x. @@ -51,17 +51,6 @@ Section Well_founded. Definition Acc_rec (P:A -> Set) := Acc_rect P. - (** A simplified version of [Acc_rect] *) - - Section AccIter. - Variable P : A -> Type. - Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x. - - Fixpoint Acc_iter (x:A) (a:Acc x) {struct a} : P x := - F (fun (y:A) (h:R y x) => Acc_iter (Acc_inv a h)). - - End AccIter. - (** A relation is well-founded if every element is accessible *) Definition well_founded := forall a:A, Acc a. @@ -74,7 +63,7 @@ Section Well_founded. forall P:A -> Type, (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a. Proof. - intros; apply (Acc_iter P); auto. + intros; apply Acc_rect; auto. Defined. Theorem well_founded_induction : @@ -91,16 +80,26 @@ Section Well_founded. exact (fun P:A -> Prop => well_founded_induction_type P). Defined. -(** Building fixpoints *) +(** Well-founded fixpoints *) Section FixPoint. Variable P : A -> Type. Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x. - Notation Fix_F := (Acc_iter P F) (only parsing). (* alias *) + Fixpoint Fix_F (x:A) (a:Acc x) {struct a} : P x := + F (fun (y:A) (h:R y x) => Fix_F (Acc_inv a h)). + + Scheme Acc_inv_dep := Induction for Acc Sort Prop. + + Lemma Fix_F_eq : + forall (x:A) (r:Acc x), + F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r. + Proof. + destruct r using Acc_inv_dep; auto. + Qed. - Definition Fix (x:A) := Acc_iter P F (Rwf x). + Definition Fix (x:A) := Fix_F (Rwf x). (** Proof that [well_founded_induction] satisfies the fixpoint equation. It requires an extra property of the functional *) @@ -110,16 +109,7 @@ Section Well_founded. forall (x:A) (f g:forall y:A, R y x -> P y), (forall (y:A) (p:R y x), f y p = g y p) -> F f = F g. - Scheme Acc_inv_dep := Induction for Acc Sort Prop. - - Lemma Fix_F_eq : - forall (x:A) (r:Acc x), - F (fun (y:A) (p:R y x) => Fix_F y (Acc_inv r p)) = Fix_F x r. - Proof. - destruct r using Acc_inv_dep; auto. - Qed. - - Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F x r = Fix_F x s. + Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s. Proof. intro x; induction (Rwf x); intros. rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros. @@ -129,7 +119,7 @@ Section Well_founded. Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y). Proof. intro x; unfold Fix in |- *. - rewrite <- (Fix_F_eq (x:=x)). + rewrite <- Fix_F_eq. apply F_ext; intros. apply Fix_F_inv. Qed. @@ -138,27 +128,29 @@ Section Well_founded. End Well_founded. -(** A recursor over pairs *) +(** Well-founded fixpoints over pairs *) Section Well_founded_2. - Variables A B : Set. + Variables A B : Type. Variable R : A * B -> A * B -> Prop. Variable P : A -> B -> Type. - Section Acc_iter_2. + Section FixPoint_2. + Variable F : forall (x:A) (x':B), (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'. - Fixpoint Acc_iter_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : + Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : P x x' := F (fun (y:A) (y':B) (h:R (y, y') (x, x')) => - Acc_iter_2 (x:=y) (x':=y') (Acc_inv a (y, y') h)). - End Acc_iter_2. + Fix_F_2 (x:=y) (x':=y') (Acc_inv a (y,y') h)). + + End FixPoint_2. Hypothesis Rwf : well_founded R. @@ -167,9 +159,10 @@ Section Well_founded_2. (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x') -> forall (a:A) (b:B), P a b. Proof. - intros; apply Acc_iter_2; auto. + intros; apply Fix_F_2; auto. Defined. End Well_founded_2. -Notation Fix_F := Acc_iter (only parsing). (* compatibility *) +Notation Acc_iter := Fix_F (only parsing). (* compatibility *) +Notation Acc_iter_2 := Fix_F_2 (only parsing). (* compatibility *) diff --git a/theories/IntMap/.depend b/theories/IntMap/.depend deleted file mode 100644 index 8c90ac99..00000000 --- a/theories/IntMap/.depend +++ /dev/null @@ -1,48 +0,0 @@ -Mapsubset.vo: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo -Mapsubset.vi: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo -Maplists.vo: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo -Maplists.vi: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo -Mapiter.vo: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo -Mapiter.vi: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo -Mapfold.vo: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo -Mapfold.vi: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo -Mapcard.vo: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo -Mapcard.vi: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo -Mapcanon.vo: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo -Mapcanon.vi: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo -Mapc.vo: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo -Mapc.vi: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo -Mapaxioms.vo: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo -Mapaxioms.vi: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo -Map.vo: Map.v Addr.vo Adist.vo Addec.vo -Map.vi: Map.v Addr.vo Adist.vo Addec.vo -Lsort.vo: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo -Lsort.vi: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo -Fset.vo: Fset.v Addr.vo Adist.vo Addec.vo Map.vo -Fset.vi: Fset.v Addr.vo Adist.vo Addec.vo Map.vo -Allmaps.vo: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo -Allmaps.vi: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo -Adist.vo: Adist.v Addr.vo -Adist.vi: Adist.v Addr.vo -Addr.vo: Addr.v -Addr.vi: Addr.v -Addec.vo: Addec.v Addr.vo -Addec.vi: Addec.v Addr.vo -Adalloc.vo: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo -Adalloc.vi: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo -Mapsubset.html: Mapsubset.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html -Maplists.html: Maplists.v Addr.html Addec.html Map.html Fset.html Mapaxioms.html Mapsubset.html Mapcard.html Mapcanon.html Mapc.html Mapiter.html Mapfold.html -Mapiter.html: Mapiter.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html -Mapfold.html: Mapfold.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Lsort.html Mapsubset.html -Mapcard.html: Mapcard.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Mapsubset.html Lsort.html -Mapcanon.html: Mapcanon.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Lsort.html Mapsubset.html Mapcard.html -Mapc.html: Mapc.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html Mapiter.html Mapsubset.html Lsort.html Mapcard.html Mapcanon.html -Mapaxioms.html: Mapaxioms.v Addr.html Adist.html Addec.html Map.html Fset.html -Map.html: Map.v Addr.html Adist.html Addec.html -Lsort.html: Lsort.v Addr.html Adist.html Addec.html Map.html Mapiter.html -Fset.html: Fset.v Addr.html Adist.html Addec.html Map.html -Allmaps.html: Allmaps.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Mapsubset.html Lsort.html Mapfold.html Mapcard.html Mapcanon.html Mapc.html Maplists.html Adalloc.html -Adist.html: Adist.v Addr.html -Addr.html: Addr.v -Addec.html: Addec.v Addr.html -Adalloc.html: Adalloc.v Addr.html Adist.html Addec.html Map.html Fset.html diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v deleted file mode 100644 index ca8e7eeb..00000000 --- a/theories/IntMap/Adalloc.v +++ /dev/null @@ -1,94 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Adalloc.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Nnat. -Require Import Map. -Require Import Fset. - -Section AdAlloc. - - Variable A : Set. - - (** Allocator: returns an address not in the domain of [m]. - This allocator is optimal in that it returns the lowest possible address, - in the usual ordering on integers. It is not the most efficient, however. *) - Fixpoint ad_alloc_opt (m:Map A) : ad := - match m with - | M0 => N0 - | M1 a _ => if Neqb a N0 then Npos 1 else N0 - | M2 m1 m2 => - Nmin (Ndouble (ad_alloc_opt m1)) - (Ndouble_plus_one (ad_alloc_opt m2)) - end. - - Lemma ad_alloc_opt_allocates_1 : - forall m:Map A, MapGet A m (ad_alloc_opt m) = None. - Proof. - induction m as [| a| m0 H m1 H0]. reflexivity. - simpl in |- *. elim (sumbool_of_bool (Neqb a N0)). intro H. rewrite H. - rewrite (Neqb_complete _ _ H). reflexivity. - intro H. rewrite H. rewrite H. reflexivity. - intros. change - (ad_alloc_opt (M2 A m0 m1)) with (Nmin (Ndouble (ad_alloc_opt m0)) - (Ndouble_plus_one (ad_alloc_opt m1))) - in |- *. - elim - (Nmin_choice (Ndouble (ad_alloc_opt m0)) - (Ndouble_plus_one (ad_alloc_opt m1))). - intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption. - apply Ndouble_bit0. - intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption. - apply Ndouble_plus_one_bit0. - Qed. - - Lemma ad_alloc_opt_allocates : - forall m:Map A, in_dom A (ad_alloc_opt m) m = false. - Proof. - unfold in_dom in |- *. intro. rewrite (ad_alloc_opt_allocates_1 m). reflexivity. - Qed. - - (** Moreover, this is optimal: all addresses below [(ad_alloc_opt m)] - are in [dom m]: *) - - Lemma ad_alloc_opt_optimal_1 : - forall (m:Map A) (a:ad), - Nle (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = Some y}. - Proof. - induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold Nle in |- *. simpl in |- *. intros. discriminate H. - simpl in |- *. intros b H. elim (sumbool_of_bool (Neqb a N0)). intro H0. rewrite H0 in H. - unfold Nle in H. cut (N0 = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity. - rewrite <- (N_of_nat_of_N b). - rewrite <- (le_n_O_eq _ (le_S_n _ _ (leb_complete_conv _ _ H))). reflexivity. - intro H0. rewrite H0 in H. discriminate H. - intros. simpl in H1. elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3. - rewrite H3 in H1. elim (H _ (Nlt_double_mono_conv _ _ (Nmin_lt_3 _ _ _ H1))). intros y H4. - split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption. - apply Ndouble_bit0. - intro H2. elim H2. intros a0 H3. rewrite H3 in H1. - elim (H0 _ (Nlt_double_plus_one_mono_conv _ _ (Nmin_lt_4 _ _ _ H1))). intros y H4. - split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. - assumption. - apply Ndouble_plus_one_bit0. - Qed. - - Lemma ad_alloc_opt_optimal : - forall (m:Map A) (a:ad), - Nle (ad_alloc_opt m) a = false -> in_dom A a m = true. - Proof. - intros. unfold in_dom in |- *. elim (ad_alloc_opt_optimal_1 m a H). intros y H0. rewrite H0. - reflexivity. - Qed. - -End AdAlloc. diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v deleted file mode 100644 index 5b46c969..00000000 --- a/theories/IntMap/Fset.v +++ /dev/null @@ -1,371 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Fset.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -(*s Sets operations on maps *) - -Require Import Bool. -Require Import Sumbool. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. - -Section Dom. - - Variables A B : Set. - - Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A := - match m with - | M0 => fun _:Map B => M0 A - | M1 a y => - fun m':Map B => match MapGet B m' a with - | None => M0 A - | _ => m - end - | M2 m1 m2 => - fun m':Map B => - match m' with - | M0 => M0 A - | M1 a' y' => - match MapGet A m a' with - | None => M0 A - | Some y => M1 A a' y - end - | M2 m'1 m'2 => - makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2) - end - end. - - Lemma MapDomRestrTo_semantics : - forall (m:Map A) (m':Map B), - eqm A (MapGet A (MapDomRestrTo m m')) - (fun a0:ad => - match MapGet B m' a0 with - | None => None - | _ => MapGet A m a0 - end). - Proof. - unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial. - intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H. - rewrite <- (Neqb_complete _ _ H). case (MapGet B m' a); try reflexivity. - intro. apply M1_semantics_1. - intro H. rewrite H. case (MapGet B m' a). - case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H). - case (MapGet B m' a1); reflexivity. - simple induction m'. trivial. - unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). - intro H1. - rewrite (Neqb_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0). - case (MapGet A (M2 A m0 m1) a1); try reflexivity. - intro. apply M1_semantics_1. - intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a); try reflexivity. - intro. exact (M1_semantics_2 A a a1 a2 H1). - intros. change - (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a = - match MapGet B (M2 B m2 m3) a with - | None => None - | Some _ => MapGet A (M2 A m0 m1) a - end) in |- *. - rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a). - rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)). - rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a). - case (Nbit0 a); reflexivity. - Qed. - - Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A := - match m with - | M0 => fun _:Map B => M0 A - | M1 a y => - fun m':Map B => match MapGet B m' a with - | None => m - | _ => M0 A - end - | M2 m1 m2 => - fun m':Map B => - match m' with - | M0 => m - | M1 a' y' => MapRemove A m a' - | M2 m'1 m'2 => - makeM2 A (MapDomRestrBy m1 m'1) (MapDomRestrBy m2 m'2) - end - end. - - Lemma MapDomRestrBy_semantics : - forall (m:Map A) (m':Map B), - eqm A (MapGet A (MapDomRestrBy m m')) - (fun a0:ad => - match MapGet B m' a0 with - | None => MapGet A m a0 - | _ => None - end). - Proof. - unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial. - intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H. - rewrite (Neqb_complete _ _ H). case (MapGet B m' a1). trivial. - apply M1_semantics_1. - intro H. rewrite H. case (MapGet B m' a). - case (MapGet B m' a1); trivial. - rewrite (M1_semantics_2 A a a1 a0 H). - case (MapGet B m' a1); trivial. - simple induction m'. trivial. - unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1). - elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1). - rewrite (M1_semantics_1 B a1 a0). reflexivity. - intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity. - intros. change - (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a = - match MapGet B (M2 B m2 m3) a with - | None => MapGet A (M2 A m0 m1) a - | Some _ => None - end) in |- *. - rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a). - rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)). - rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a). - case (Nbit0 a); reflexivity. - Qed. - - Definition in_dom (a:ad) (m:Map A) := - match MapGet A m a with - | None => false - | _ => true - end. - - Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false. - Proof. - trivial. - Qed. - - Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = Neqb a a0. - Proof. - unfold in_dom in |- *. intros. simpl in |- *. case (Neqb a a0); reflexivity. - Qed. - - Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true. - Proof. - intros. rewrite in_dom_M1. apply Neqb_correct. - Qed. - - Lemma in_dom_M1_2 : - forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0. - Proof. - intros. apply (Neqb_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption. - Qed. - - Lemma in_dom_some : - forall (m:Map A) (a:ad), - in_dom a m = true -> {y : A | MapGet A m a = Some y}. - Proof. - unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial. - intro H0. rewrite H0 in H. discriminate H. - Qed. - - Lemma in_dom_none : - forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = None. - Proof. - unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0. - intros y H1. rewrite H1 in H. discriminate H. - trivial. - Qed. - - Lemma in_dom_put : - forall (m:Map A) (a0:ad) (y0:A) (a:ad), - in_dom a (MapPut A m a0 y0) = orb (Neqb a a0) (in_dom a m). - Proof. - unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a). - elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H. - rewrite H. rewrite orb_true_b. reflexivity. - intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. rewrite orb_false_b. - reflexivity. - Qed. - - Lemma in_dom_put_behind : - forall (m:Map A) (a0:ad) (y0:A) (a:ad), - in_dom a (MapPut_behind A m a0 y0) = orb (Neqb a a0) (in_dom a m). - Proof. - unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a). - elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H. - rewrite H. case (MapGet A m a); reflexivity. - intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. case (MapGet A m a); trivial. - Qed. - - Lemma in_dom_remove : - forall (m:Map A) (a0 a:ad), - in_dom a (MapRemove A m a0) = andb (negb (Neqb a a0)) (in_dom a m). - Proof. - unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a). - elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H. - rewrite H. reflexivity. - intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. - case (MapGet A m a); reflexivity. - Qed. - - Lemma in_dom_merge : - forall (m m':Map A) (a:ad), - in_dom a (MapMerge A m m') = orb (in_dom a m) (in_dom a m'). - Proof. - unfold in_dom in |- *. intros. rewrite (MapMerge_semantics A m m' a). - elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0. - case (MapGet A m a); reflexivity. - intro H. rewrite H. rewrite orb_b_false. reflexivity. - Qed. - - Lemma in_dom_delta : - forall (m m':Map A) (a:ad), - in_dom a (MapDelta A m m') = xorb (in_dom a m) (in_dom a m'). - Proof. - unfold in_dom in |- *. intros. rewrite (MapDelta_semantics A m m' a). - elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0. - case (MapGet A m a); reflexivity. - intro H. rewrite H. case (MapGet A m a); reflexivity. - Qed. - -End Dom. - -Section InDom. - - Variables A B : Set. - - Lemma in_dom_restrto : - forall (m:Map A) (m':Map B) (a:ad), - in_dom A a (MapDomRestrTo A B m m') = - andb (in_dom A a m) (in_dom B a m'). - Proof. - unfold in_dom in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a). - elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0. - rewrite andb_b_true. reflexivity. - intro H. rewrite H. rewrite andb_b_false. reflexivity. - Qed. - - Lemma in_dom_restrby : - forall (m:Map A) (m':Map B) (a:ad), - in_dom A a (MapDomRestrBy A B m m') = - andb (in_dom A a m) (negb (in_dom B a m')). - Proof. - unfold in_dom in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a). - elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0. - unfold negb in |- *. rewrite andb_b_false. reflexivity. - intro H. rewrite H. unfold negb in |- *. rewrite andb_b_true. reflexivity. - Qed. - -End InDom. - -Definition FSet := Map unit. - -Section FSetDefs. - - Variable A : Set. - - Definition in_FSet : ad -> FSet -> bool := in_dom unit. - - Fixpoint MapDom (m:Map A) : FSet := - match m with - | M0 => M0 unit - | M1 a _ => M1 unit a tt - | M2 m m' => M2 unit (MapDom m) (MapDom m') - end. - - Lemma MapDom_semantics_1 : - forall (m:Map A) (a:ad) (y:A), - MapGet A m a = Some y -> in_FSet a (MapDom m) = true. - Proof. - simple induction m. intros. discriminate H. - unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0. - case (Neqb a a0). trivial. - intro. discriminate H. - intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *. - unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a). - case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption. - unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption. - Qed. - - Lemma MapDom_semantics_2 : - forall (m:Map A) (a:ad), - in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = Some y}. - Proof. - simple induction m. intros. discriminate H. - unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (Neqb a a0). - intro. split with y. reflexivity. - intro. discriminate H. - intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *. - unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a). - case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption. - unfold in_FSet, in_dom in H. intro. apply H. assumption. - Qed. - - Lemma MapDom_semantics_3 : - forall (m:Map A) (a:ad), - MapGet A m a = None -> in_FSet a (MapDom m) = false. - Proof. - intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0. - elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1. - trivial. - Qed. - - Lemma MapDom_semantics_4 : - forall (m:Map A) (a:ad), - in_FSet a (MapDom m) = false -> MapGet A m a = None. - Proof. - intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1. - rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H. - trivial. - Qed. - - Lemma MapDom_Dom : - forall (m:Map A) (a:ad), in_dom A a m = in_FSet a (MapDom m). - Proof. - intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H. - elim (MapDom_semantics_2 m a H). intros y H0. rewrite H. unfold in_dom in |- *. rewrite H0. - reflexivity. - intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity. - Qed. - - Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'. - - Lemma in_FSet_union : - forall (s s':FSet) (a:ad), - in_FSet a (FSetUnion s s') = orb (in_FSet a s) (in_FSet a s'). - Proof. - exact (in_dom_merge unit). - Qed. - - Definition FSetInter (s s':FSet) : FSet := MapDomRestrTo unit unit s s'. - - Lemma in_FSet_inter : - forall (s s':FSet) (a:ad), - in_FSet a (FSetInter s s') = andb (in_FSet a s) (in_FSet a s'). - Proof. - exact (in_dom_restrto unit unit). - Qed. - - Definition FSetDiff (s s':FSet) : FSet := MapDomRestrBy unit unit s s'. - - Lemma in_FSet_diff : - forall (s s':FSet) (a:ad), - in_FSet a (FSetDiff s s') = andb (in_FSet a s) (negb (in_FSet a s')). - Proof. - exact (in_dom_restrby unit unit). - Qed. - - Definition FSetDelta (s s':FSet) : FSet := MapDelta unit s s'. - - Lemma in_FSet_delta : - forall (s s':FSet) (a:ad), - in_FSet a (FSetDelta s s') = xorb (in_FSet a s) (in_FSet a s'). - Proof. - exact (in_dom_delta unit). - Qed. - -End FSetDefs. - -Lemma FSet_Dom : forall s:FSet, MapDom unit s = s. -Proof. - simple induction s. trivial. - simpl in |- *. intros a t. elim t. reflexivity. - intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. -Qed.
\ No newline at end of file diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v deleted file mode 100644 index c8d793a1..00000000 --- a/theories/IntMap/Lsort.v +++ /dev/null @@ -1,413 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Lsort.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import List. -Require Import Mapiter. - -Section LSort. - - Variable A : Set. - - Fixpoint alist_sorted (l:alist A) : bool := - match l with - | nil => true - | (a, _) :: l' => - match l' with - | nil => true - | (a', y') :: l'' => andb (Nless a a') (alist_sorted l') - end - end. - - Fixpoint alist_nth_ad (n:nat) (l:alist A) {struct l} : ad := - match l with - | nil => N0 (* dummy *) - | (a, y) :: l' => match n with - | O => a - | S n' => alist_nth_ad n' l' - end - end. - - Definition alist_sorted_1 (l:alist A) := - forall n:nat, - S (S n) <= length l -> - Nless (alist_nth_ad n l) (alist_nth_ad (S n) l) = true. - - Lemma alist_sorted_imp_1 : - forall l:alist A, alist_sorted l = true -> alist_sorted_1 l. - Proof. - unfold alist_sorted_1 in |- *. simple induction l. intros. elim (le_Sn_O (S n) H0). - intro r. elim r. intros a y. simple induction l0. intros. simpl in H1. - elim (le_Sn_O n (le_S_n (S n) 0 H1)). - intro r0. elim r0. intros a0 y0. simple induction n. intros. simpl in |- *. simpl in H1. - exact (proj1 (andb_prop _ _ H1)). - intros. change - (Nless (alist_nth_ad n0 ((a0, y0) :: l1)) - (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) - in |- *. - apply H0. exact (proj2 (andb_prop _ _ H1)). - apply le_S_n. exact H3. - Qed. - - Definition alist_sorted_2 (l:alist A) := - forall m n:nat, - m < n -> - S n <= length l -> Nless (alist_nth_ad m l) (alist_nth_ad n l) = true. - - Lemma alist_sorted_1_imp_2 : - forall l:alist A, alist_sorted_1 l -> alist_sorted_2 l. - Proof. - unfold alist_sorted_1, alist_sorted_2, lt in |- *. intros l H m n H0. elim H0. exact (H m). - intros. apply Nless_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le. - assumption. - apply H. assumption. - Qed. - - Lemma alist_sorted_2_imp : - forall l:alist A, alist_sorted_2 l -> alist_sorted l = true. - Proof. - unfold alist_sorted_2, lt in |- *. simple induction l. trivial. - intro r. elim r. intros a y. simple induction l0. trivial. - intro r0. elim r0. intros a0 y0. intros. - change (andb (Nless a a0) (alist_sorted ((a0, y0) :: l1)) = true) - in |- *. - apply andb_true_intro. split. apply (H1 0 1). apply le_n. - simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n. - apply H0. intros. apply (H1 (S m) (S n)). apply le_n_S. assumption. - exact (le_n_S _ _ H3). - Qed. - - Lemma app_length : - forall (C:Set) (l l':list C), length (l ++ l') = length l + length l'. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (H l'). reflexivity. - Qed. - - Lemma aapp_length : - forall l l':alist A, length (aapp A l l') = length l + length l'. - Proof. - exact (app_length (ad * A)). - Qed. - - Lemma alist_nth_ad_aapp_1 : - forall (l l':alist A) (n:nat), - S n <= length l -> alist_nth_ad n (aapp A l l') = alist_nth_ad n l. - Proof. - simple induction l. intros. elim (le_Sn_O n H). - intro r. elim r. intros a y l' H l''. simple induction n. trivial. - intros. simpl in |- *. apply H. apply le_S_n. exact H1. - Qed. - - Lemma alist_nth_ad_aapp_2 : - forall (l l':alist A) (n:nat), - S n <= length l' -> - alist_nth_ad (length l + n) (aapp A l l') = alist_nth_ad n l'. - Proof. - simple induction l. trivial. - intro r. elim r. intros a y l' H l'' n H0. simpl in |- *. apply H. exact H0. - Qed. - - Lemma interval_split : - forall p q n:nat, - S n <= p + q -> {n' : nat | S n' <= q /\ n = p + n'} + {S n <= p}. - Proof. - simple induction p. simpl in |- *. intros. left. split with n. split; [ assumption | reflexivity ]. - intros p' H q. simple induction n. intros. right. apply le_n_S. apply le_O_n. - intros. elim (H _ _ (le_S_n _ _ H1)). intro H2. left. elim H2. intros n' H3. - elim H3. intros H4 H5. split with n'. split; [ assumption | rewrite H5; reflexivity ]. - intro H2. right. apply le_n_S. assumption. - Qed. - - Lemma alist_conc_sorted : - forall l l':alist A, - alist_sorted_2 l -> - alist_sorted_2 l' -> - (forall n n':nat, - S n <= length l -> - S n' <= length l' -> - Nless (alist_nth_ad n l) (alist_nth_ad n' l') = true) -> - alist_sorted_2 (aapp A l l'). - Proof. - unfold alist_sorted_2, lt in |- *. intros. rewrite (aapp_length l l') in H3. - elim - (interval_split (length l) (length l') m - (le_trans _ _ _ (le_n_S _ _ (lt_le_weak m n H2)) H3)). - intro H4. elim H4. intros m' H5. elim H5. intros. rewrite H7. - rewrite (alist_nth_ad_aapp_2 l l' m' H6). elim (interval_split (length l) (length l') n H3). - intro H8. elim H8. intros n' H9. elim H9. intros. rewrite H11. - rewrite (alist_nth_ad_aapp_2 l l' n' H10). apply H0. rewrite H7 in H2. rewrite H11 in H2. - change (S (length l) + m' <= length l + n') in H2. - rewrite (plus_Snm_nSm (length l) m') in H2. exact ((fun p n m:nat => plus_le_reg_l n m p) (length l) (S m') n' H2). - exact H10. - intro H8. rewrite H7 in H2. cut (S (length l) <= length l). intros. elim (le_Sn_n _ H9). - apply le_trans with (m := S n). apply le_n_S. apply le_trans with (m := S (length l + m')). - apply le_trans with (m := length l + m'). apply le_plus_l. - apply le_n_Sn. - exact H2. - exact H8. - intro H4. rewrite (alist_nth_ad_aapp_1 l l' m H4). - elim (interval_split (length l) (length l') n H3). intro H5. elim H5. intros n' H6. elim H6. - intros. rewrite H8. rewrite (alist_nth_ad_aapp_2 l l' n' H7). exact (H1 m n' H4 H7). - intro H5. rewrite (alist_nth_ad_aapp_1 l l' n H5). exact (H m n H2 H5). - Qed. - - Lemma alist_nth_ad_semantics : - forall (l:alist A) (n:nat), - S n <= length l -> - {y : A | alist_semantics A l (alist_nth_ad n l) = Some y}. - Proof. - simple induction l. intros. elim (le_Sn_O _ H). - intro r. elim r. intros a y l0 H. simple induction n. simpl in |- *. intro. split with y. - rewrite (Neqb_correct a). reflexivity. - intros. elim (H _ (le_S_n _ _ H1)). intros y0 H2. - elim (sumbool_of_bool (Neqb a (alist_nth_ad n0 l0))). intro H3. split with y. - rewrite (Neqb_complete _ _ H3). simpl in |- *. rewrite (Neqb_correct (alist_nth_ad n0 l0)). - reflexivity. - intro H3. split with y0. simpl in |- *. rewrite H3. assumption. - Qed. - - Lemma alist_of_Map_nth_ad : - forall (m:Map A) (pf:ad -> ad) (l:alist A), - l = - MapFold1 A (alist A) (anil A) (aapp A) - (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) pf m -> - forall n:nat, S n <= length l -> {a' : ad | alist_nth_ad n l = pf a'}. - Proof. - intros. elim (alist_nth_ad_semantics l n H0). intros y H1. - apply (alist_of_Map_semantics_1_1 A m pf (alist_nth_ad n l) y). - rewrite <- H. assumption. - Qed. - - Definition ad_monotonic (pf:ad -> ad) := - forall a a':ad, Nless a a' = true -> Nless (pf a) (pf a') = true. - - Lemma Ndouble_monotonic : ad_monotonic Ndouble. - Proof. - unfold ad_monotonic in |- *. intros. rewrite Nless_def_1. assumption. - Qed. - - Lemma Ndouble_plus_one_monotonic : ad_monotonic Ndouble_plus_one. - Proof. - unfold ad_monotonic in |- *. intros. rewrite Nless_def_2. assumption. - Qed. - - Lemma ad_comp_monotonic : - forall pf pf':ad -> ad, - ad_monotonic pf -> - ad_monotonic pf' -> ad_monotonic (fun a0:ad => pf (pf' a0)). - Proof. - unfold ad_monotonic in |- *. intros. apply H. apply H0. exact H1. - Qed. - - Lemma ad_comp_double_monotonic : - forall pf:ad -> ad, - ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble a0)). - Proof. - intros. apply ad_comp_monotonic. assumption. - exact Ndouble_monotonic. - Qed. - - Lemma ad_comp_double_plus_un_monotonic : - forall pf:ad -> ad, - ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble_plus_one a0)). - Proof. - intros. apply ad_comp_monotonic. assumption. - exact Ndouble_plus_one_monotonic. - Qed. - - Lemma alist_of_Map_sorts_1 : - forall (m:Map A) (pf:ad -> ad), - ad_monotonic pf -> - alist_sorted_2 - (MapFold1 A (alist A) (anil A) (aapp A) - (fun (a:ad) (y:A) => acons A (a, y) (anil A)) pf m). - Proof. - simple induction m. simpl in |- *. intros. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity. - intros. simpl in |- *. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity. - intros. simpl in |- *. apply alist_conc_sorted. - exact - (H (fun a0:ad => pf (Ndouble a0)) (ad_comp_double_monotonic pf H1)). - exact - (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) - (ad_comp_double_plus_un_monotonic pf H1)). - intros. elim - (alist_of_Map_nth_ad m0 (fun a0:ad => pf (Ndouble a0)) - (MapFold1 A (alist A) (anil A) (aapp A) - (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) - (fun a0:ad => pf (Ndouble a0)) m0) (refl_equal _) n H2). - intros a H4. rewrite H4. elim - (alist_of_Map_nth_ad m1 (fun a0:ad => pf (Ndouble_plus_one a0)) - (MapFold1 A (alist A) (anil A) (aapp A) - (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) - (fun a0:ad => pf (Ndouble_plus_one a0)) m1) ( - refl_equal _) n' H3). - intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply Nless_def_3. - Qed. - - Lemma alist_of_Map_sorts : - forall m:Map A, alist_sorted (alist_of_Map A m) = true. - Proof. - intro. apply alist_sorted_2_imp. - exact - (alist_of_Map_sorts_1 m (fun a0:ad => a0) - (fun (a a':ad) (p:Nless a a' = true) => p)). - Qed. - - Lemma alist_of_Map_sorts1 : - forall m:Map A, alist_sorted_1 (alist_of_Map A m). - Proof. - intro. apply alist_sorted_imp_1. apply alist_of_Map_sorts. - Qed. - - Lemma alist_of_Map_sorts2 : - forall m:Map A, alist_sorted_2 (alist_of_Map A m). - Proof. - intro. apply alist_sorted_1_imp_2. apply alist_of_Map_sorts1. - Qed. - - Lemma alist_too_low : - forall (l:alist A) (a a':ad) (y:A), - Nless a a' = true -> - alist_sorted_2 ((a', y) :: l) -> - alist_semantics A ((a', y) :: l) a = None. - Proof. - simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (Neqb a' a)). intro H1. - rewrite (Neqb_complete _ _ H1) in H. rewrite (Nless_not_refl a) in H. discriminate H. - intro H1. rewrite H1. reflexivity. - intro r. elim r. intros a y l0 H a0 a1 y0 H0 H1. - change - (match Neqb a1 a0 with - | true => Some y0 - | false => alist_semantics A ((a, y) :: l0) a0 - end = None) in |- *. - elim (sumbool_of_bool (Neqb a1 a0)). intro H2. rewrite (Neqb_complete _ _ H2) in H0. - rewrite (Nless_not_refl a0) in H0. discriminate H0. - intro H2. rewrite H2. apply H. apply Nless_trans with (a' := a1). assumption. - unfold alist_sorted_2 in H1. apply (H1 0 1). apply lt_n_Sn. - simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n. - apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. - cut (alist_sorted ((a1, y0) :: (a, y) :: l0) = true). intro H3. - exact (proj2 (andb_prop _ _ H3)). - apply alist_sorted_2_imp. assumption. - Qed. - - Lemma alist_semantics_nth_ad : - forall (l:alist A) (a:ad) (y:A), - alist_semantics A l a = Some y -> - {n : nat | S n <= length l /\ alist_nth_ad n l = a}. - Proof. - simple induction l. intros. discriminate H. - intro r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (Neqb a a0)). - intro H1. rewrite H1 in H0. split with 0. split. simpl in |- *. apply le_n_S. apply le_O_n. - simpl in |- *. exact (Neqb_complete _ _ H1). - intro H1. rewrite H1 in H0. elim (H a0 y0 H0). intros n' H2. split with (S n'). split. - simpl in |- *. apply le_n_S. exact (proj1 H2). - exact (proj2 H2). - Qed. - - Lemma alist_semantics_tail : - forall (l:alist A) (a:ad) (y:A), - alist_sorted_2 ((a, y) :: l) -> - eqm A (alist_semantics A l) - (fun a0:ad => - if Neqb a a0 then None else alist_semantics A ((a, y) :: l) a0). - Proof. - unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. - rewrite <- (Neqb_complete _ _ H0). unfold alist_sorted_2 in H. - elim (option_sum A (alist_semantics A l a)). intro H1. elim H1. intros y0 H2. - elim (alist_semantics_nth_ad l a y0 H2). intros n H3. elim H3. intros. - cut - (Nless (alist_nth_ad 0 ((a, y) :: l)) - (alist_nth_ad (S n) ((a, y) :: l)) = true). - intro. simpl in H6. rewrite H5 in H6. rewrite (Nless_not_refl a) in H6. discriminate H6. - apply H. apply lt_O_Sn. - simpl in |- *. apply le_n_S. assumption. - trivial. - intro H0. simpl in |- *. rewrite H0. reflexivity. - Qed. - - Lemma alist_semantics_same_tail : - forall (l l':alist A) (a:ad) (y:A), - alist_sorted_2 ((a, y) :: l) -> - alist_sorted_2 ((a, y) :: l') -> - eqm A (alist_semantics A ((a, y) :: l)) - (alist_semantics A ((a, y) :: l')) -> - eqm A (alist_semantics A l) (alist_semantics A l'). - Proof. - unfold eqm in |- *. intros. rewrite (alist_semantics_tail _ _ _ H a0). - rewrite (alist_semantics_tail _ _ _ H0 a0). case (Neqb a a0). reflexivity. - exact (H1 a0). - Qed. - - Lemma alist_sorted_tail : - forall (l:alist A) (a:ad) (y:A), - alist_sorted_2 ((a, y) :: l) -> alist_sorted_2 l. - Proof. - unfold alist_sorted_2 in |- *. intros. apply (H (S m) (S n)). apply lt_n_S. assumption. - simpl in |- *. apply le_n_S. assumption. - Qed. - - Lemma alist_canonical : - forall l l':alist A, - eqm A (alist_semantics A l) (alist_semantics A l') -> - alist_sorted_2 l -> alist_sorted_2 l' -> l = l'. - Proof. - unfold eqm in |- *. simple induction l. simple induction l'. trivial. - intro r. elim r. intros a y l0 H H0 H1 H2. simpl in H0. - cut - (None = - match Neqb a a with - | true => Some y - | false => alist_semantics A l0 a - end). - rewrite (Neqb_correct a). intro. discriminate H3. - exact (H0 a). - intro r. elim r. intros a y l0 H. simple induction l'. intros. simpl in H0. - cut - (match Neqb a a with - | true => Some y - | false => alist_semantics A l0 a - end = None). - rewrite (Neqb_correct a). intro. discriminate H3. - exact (H0 a). - intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (Nless_total a a'). intro H4. - elim H4. intro H5. - cut - (alist_semantics A ((a, y) :: l0) a = - alist_semantics A ((a', y') :: l'0) a). - intro. rewrite (alist_too_low l'0 a a' y' H5 H3) in H6. simpl in H6. - rewrite (Neqb_correct a) in H6. discriminate H6. - exact (H1 a). - intro H5. cut - (alist_semantics A ((a, y) :: l0) a' = - alist_semantics A ((a', y') :: l'0) a'). - intro. rewrite (alist_too_low l0 a' a y H5 H2) in H6. simpl in H6. - rewrite (Neqb_correct a') in H6. discriminate H6. - exact (H1 a'). - intro H4. rewrite H4. - cut - (alist_semantics A ((a, y) :: l0) a = - alist_semantics A ((a', y') :: l'0) a). - intro. simpl in H5. rewrite H4 in H5. rewrite (Neqb_correct a') in H5. inversion H5. - rewrite H4 in H1. rewrite H7 in H1. cut (l0 = l'0). intro. rewrite H6. reflexivity. - apply H. rewrite H4 in H2. rewrite H7 in H2. - exact (alist_semantics_same_tail l0 l'0 a' y' H2 H3 H1). - exact (alist_sorted_tail _ _ _ H2). - exact (alist_sorted_tail _ _ _ H3). - exact (H1 a). - Qed. - -End LSort.
\ No newline at end of file diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v deleted file mode 100644 index 2be6de04..00000000 --- a/theories/IntMap/Map.v +++ /dev/null @@ -1,869 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Map.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -(** Definition of finite sets as trees indexed by adresses *) - -Require Import Bool. -Require Import Sumbool. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. - -(* The type [ad] of addresses is now [N] in [BinNat]. *) - -Definition ad := N. - -(* a Notation or complete replacement would be nice, - but that would changes hyps names *) - -Section MapDefs. - -(** We now define maps from ad to A. *) - Variable A : Set. - - Inductive Map : Set := - | M0 : Map - | M1 : ad -> A -> Map - | M2 : Map -> Map -> Map. - - Lemma option_sum : forall o:option A, {y : A | o = Some y} + {o = None}. - Proof. - simple induction o. - left. split with a. reflexivity. - right. reflexivity. - Qed. - - (** The semantics of maps is given by the function [MapGet]. - The semantics of a map [m] is a partial, finite function from - [ad] to [A]: *) - - Fixpoint MapGet (m:Map) : ad -> option A := - match m with - | M0 => fun a:ad => None - | M1 x y => fun a:ad => if Neqb x a then Some y else None - | M2 m1 m2 => - fun a:ad => - match a with - | N0 => MapGet m1 N0 - | Npos xH => MapGet m2 N0 - | Npos (xO p) => MapGet m1 (Npos p) - | Npos (xI p) => MapGet m2 (Npos p) - end - end. - - Definition newMap := M0. - - Definition MapSingleton := M1. - - Definition eqm (g g':ad -> option A) := forall a:ad, g a = g' a. - - Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => None). - Proof. - simpl in |- *. unfold eqm in |- *. trivial. - Qed. - - Lemma MapSingleton_semantics : - forall (a:ad) (y:A), - eqm (MapGet (MapSingleton a y)) - (fun a':ad => if Neqb a a' then Some y else None). - Proof. - simpl in |- *. unfold eqm in |- *. trivial. - Qed. - - Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = Some y. - Proof. - unfold MapGet in |- *. intros. rewrite (Neqb_correct a). reflexivity. - Qed. - - Lemma M1_semantics_2 : - forall (a a':ad) (y:A), Neqb a a' = false -> MapGet (M1 a y) a' = None. - Proof. - intros. simpl in |- *. rewrite H. reflexivity. - Qed. - - Lemma Map2_semantics_1 : - forall m m':Map, - eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (Ndouble a)). - Proof. - unfold eqm in |- *. simple induction a; trivial. - Qed. - - Lemma Map2_semantics_1_eq : - forall (m m':Map) (f:ad -> option A), - eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (Ndouble a)). - Proof. - unfold eqm in |- *. - intros. - rewrite <- (H (Ndouble a)). - exact (Map2_semantics_1 m m' a). - Qed. - - Lemma Map2_semantics_2 : - forall m m':Map, - eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (Ndouble_plus_one a)). - Proof. - unfold eqm in |- *. simple induction a; trivial. - Qed. - - Lemma Map2_semantics_2_eq : - forall (m m':Map) (f:ad -> option A), - eqm (MapGet (M2 m m')) f -> - eqm (MapGet m') (fun a:ad => f (Ndouble_plus_one a)). - Proof. - unfold eqm in |- *. - intros. - rewrite <- (H (Ndouble_plus_one a)). - exact (Map2_semantics_2 m m' a). - Qed. - - Lemma MapGet_M2_bit_0_0 : - forall a:ad, - Nbit0 a = false -> - forall m m':Map, MapGet (M2 m m') a = MapGet m (Ndiv2 a). - Proof. - simple induction a; trivial. simple induction p. intros. discriminate H0. - trivial. - intros. discriminate H. - Qed. - - Lemma MapGet_M2_bit_0_1 : - forall a:ad, - Nbit0 a = true -> - forall m m':Map, MapGet (M2 m m') a = MapGet m' (Ndiv2 a). - Proof. - simple induction a. intros. discriminate H. - simple induction p. trivial. - intros. discriminate H0. - trivial. - Qed. - - Lemma MapGet_M2_bit_0_if : - forall (m m':Map) (a:ad), - MapGet (M2 m m') a = - (if Nbit0 a then MapGet m' (Ndiv2 a) else MapGet m (Ndiv2 a)). - Proof. - intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H. - apply MapGet_M2_bit_0_1; assumption. - intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption. - Qed. - - Lemma MapGet_M2_bit_0 : - forall (m m' m'':Map) (a:ad), - (if Nbit0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) = - MapGet m (Ndiv2 a). - Proof. - intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H. - apply MapGet_M2_bit_0_1; assumption. - intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption. - Qed. - - Lemma Map2_semantics_3 : - forall m m':Map, - eqm (MapGet (M2 m m')) - (fun a:ad => - match Nbit0 a with - | false => MapGet m (Ndiv2 a) - | true => MapGet m' (Ndiv2 a) - end). - Proof. - unfold eqm in |- *. - simple induction a; trivial. - simple induction p; trivial. - Qed. - - Lemma Map2_semantics_3_eq : - forall (m m':Map) (f f':ad -> option A), - eqm (MapGet m) f -> - eqm (MapGet m') f' -> - eqm (MapGet (M2 m m')) - (fun a:ad => - match Nbit0 a with - | false => f (Ndiv2 a) - | true => f' (Ndiv2 a) - end). - Proof. - unfold eqm in |- *. - intros. - rewrite <- (H (Ndiv2 a)). - rewrite <- (H0 (Ndiv2 a)). - exact (Map2_semantics_3 m m' a). - Qed. - - Fixpoint MapPut1 (a:ad) (y:A) (a':ad) (y':A) (p:positive) {struct p} : - Map := - match p with - | xO p' => - let m := MapPut1 (Ndiv2 a) y (Ndiv2 a') y' p' in - match Nbit0 a with - | false => M2 m M0 - | true => M2 M0 m - end - | _ => - match Nbit0 a with - | false => M2 (M1 (Ndiv2 a) y) (M1 (Ndiv2 a') y') - | true => M2 (M1 (Ndiv2 a') y') (M1 (Ndiv2 a) y) - end - end. - - Lemma MapGet_if_commute : - forall (b:bool) (m m':Map) (a:ad), - MapGet (if b then m else m') a = (if b then MapGet m a else MapGet m' a). - Proof. - intros. case b; trivial. - Qed. - - (*i - Lemma MapGet_M2_bit_0_1' : (m,m',m'',m''':Map) - (a:ad) (MapGet (if (Nbit0 a) then (M2 m m') else (M2 m'' m''')) a)= - (MapGet (if (Nbit0 a) then m' else m'') (Ndiv2 a)). - Proof. - Intros. Rewrite (MapGet_if_commute (Nbit0 a)). Rewrite (MapGet_if_commute (Nbit0 a)). - Cut (Nbit0 a)=false\/(Nbit0 a)=true. Intros. Elim H. Intros. Rewrite H0. - Apply MapGet_M2_bit_0_0. Assumption. - Intros. Rewrite H0. Apply MapGet_M2_bit_0_1. Assumption. - Case (Nbit0 a); Auto. - Qed. - i*) - - Lemma MapGet_if_same : - forall (m:Map) (b:bool) (a:ad), MapGet (if b then m else m) a = MapGet m a. - Proof. - simple induction b; trivial. - Qed. - - Lemma MapGet_M2_bit_0_2 : - forall (m m' m'':Map) (a:ad), - MapGet (if Nbit0 a then M2 m m' else M2 m' m'') a = - MapGet m' (Ndiv2 a). - Proof. - intros. rewrite MapGet_if_commute. apply MapGet_M2_bit_0. - Qed. - - Lemma MapPut1_semantics_1 : - forall (p:positive) (a a':ad) (y y':A), - Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a = Some y. - Proof. - simple induction p. intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. - intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- Nxor_div2. rewrite H0. - reflexivity. - intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. - Qed. - - Lemma MapPut1_semantics_2 : - forall (p:positive) (a a':ad) (y y':A), - Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a' = Some y'. - Proof. - simple induction p. intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_2 a a' p0 H0). - rewrite if_negb. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. - intros. simpl in |- *. rewrite (Nsame_bit0 a a' p0 H0). rewrite MapGet_M2_bit_0_2. - apply H. rewrite <- Nxor_div2. rewrite H0. reflexivity. - intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_1 a a' H). rewrite if_negb. - rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. - Qed. - - Lemma MapGet_M2_both_None : - forall (m m':Map) (a:ad), - MapGet m (Ndiv2 a) = None -> - MapGet m' (Ndiv2 a) = None -> MapGet (M2 m m') a = None. - Proof. - intros. rewrite (Map2_semantics_3 m m' a). - case (Nbit0 a); assumption. - Qed. - - Lemma MapPut1_semantics_3 : - forall (p:positive) (a a' a0:ad) (y y':A), - Nxor a a' = Npos p -> - Neqb a a0 = false -> - Neqb a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = None. - Proof. - simple induction p. intros. unfold MapPut1 in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb. - rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption. - rewrite (Nneg_bit0_2 a a' p0 H0) in H3. rewrite (negb_intro (Nbit0 a')). - rewrite (negb_intro (Nbit0 a0)). rewrite H3. reflexivity. - intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nneg_bit0_2 a a' p0 H0). rewrite H4. - rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2. - apply M1_semantics_2; assumption. - intro; case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2; - assumption. - intros. simpl in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb. - rewrite MapGet_M2_bit_0_2. reflexivity. - intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nsame_bit0 a a' p0 H0). rewrite H4. - rewrite if_negb. rewrite MapGet_M2_bit_0_2. reflexivity. - intro. cut (Nxor (Ndiv2 a) (Ndiv2 a') = Npos p0). intro. - case (Nbit0 a); apply MapGet_M2_both_None; trivial; apply H; - assumption. - rewrite <- Nxor_div2. rewrite H0. reflexivity. - intros. simpl in |- *. elim (Nneq_elim a a0 H0). intro. rewrite H2. rewrite if_negb. - rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption. - rewrite (Nneg_bit0_1 a a' H) in H2. rewrite (negb_intro (Nbit0 a')). - rewrite (negb_intro (Nbit0 a0)). rewrite H2. reflexivity. - intro. elim (Nneq_elim a' a0 H1). intro. rewrite (Nneg_bit0_1 a a' H). rewrite H3. - rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2. - apply M1_semantics_2; assumption. - intro. case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2; - assumption. - Qed. - - Lemma MapPut1_semantics : - forall (p:positive) (a a':ad) (y y':A), - Nxor a a' = Npos p -> - eqm (MapGet (MapPut1 a y a' y' p)) - (fun a0:ad => - if Neqb a a0 - then Some y - else if Neqb a' a0 then Some y' else None). - Proof. - unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. - rewrite <- (Neqb_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H). - intro H0. rewrite H0. elim (sumbool_of_bool (Neqb a' a0)). intro H1. - rewrite <- (Neqb_complete _ _ H1). rewrite (Neqb_correct a'). - exact (MapPut1_semantics_2 p a a' y y' H). - intro H1. rewrite H1. exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1). - Qed. - - Lemma MapPut1_semantics' : - forall (p:positive) (a a':ad) (y y':A), - Nxor a a' = Npos p -> - eqm (MapGet (MapPut1 a y a' y' p)) - (fun a0:ad => - if Neqb a' a0 - then Some y' - else if Neqb a a0 then Some y else None). - Proof. - unfold eqm in |- *. intros. rewrite (MapPut1_semantics p a a' y y' H a0). - elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. - rewrite <- (Neqb_complete a a0 H0). rewrite (Neqb_comm a' a). - rewrite (Nxor_eq_false a a' p H). reflexivity. - intro H0. rewrite H0. reflexivity. - Qed. - - Fixpoint MapPut (m:Map) : ad -> A -> Map := - match m with - | M0 => M1 - | M1 a y => - fun (a':ad) (y':A) => - match Nxor a a' with - | N0 => M1 a' y' - | Npos p => MapPut1 a y a' y' p - end - | M2 m1 m2 => - fun (a:ad) (y:A) => - match a with - | N0 => M2 (MapPut m1 N0 y) m2 - | Npos xH => M2 m1 (MapPut m2 N0 y) - | Npos (xO p) => M2 (MapPut m1 (Npos p) y) m2 - | Npos (xI p) => M2 m1 (MapPut m2 (Npos p) y) - end - end. - - Lemma MapPut_semantics_1 : - forall (a:ad) (y:A) (a0:ad), - MapGet (MapPut M0 a y) a0 = MapGet (M1 a y) a0. - Proof. - trivial. - Qed. - - Lemma MapPut_semantics_2_1 : - forall (a:ad) (y y':A) (a0:ad), - MapGet (MapPut (M1 a y) a y') a0 = - (if Neqb a a0 then Some y' else None). - Proof. - simpl in |- *. intros. rewrite (Nxor_nilpotent a). trivial. - Qed. - - Lemma MapPut_semantics_2_2 : - forall (a a':ad) (y y':A) (a0 a'':ad), - Nxor a a' = a'' -> - MapGet (MapPut (M1 a y) a' y') a0 = - (if Neqb a' a0 then Some y' else if Neqb a a0 then Some y else None). - Proof. - simple induction a''. intro. rewrite (Nxor_eq _ _ H). rewrite MapPut_semantics_2_1. - case (Neqb a' a0); trivial. - intros. simpl in |- *. rewrite H. rewrite (MapPut1_semantics p a a' y y' H a0). - elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. rewrite <- (Neqb_complete _ _ H0). - rewrite (Neqb_comm a' a). rewrite (Nxor_eq_false _ _ _ H). reflexivity. - intro H0. rewrite H0. reflexivity. - Qed. - - Lemma MapPut_semantics_2 : - forall (a a':ad) (y y':A) (a0:ad), - MapGet (MapPut (M1 a y) a' y') a0 = - (if Neqb a' a0 then Some y' else if Neqb a a0 then Some y else None). - Proof. - intros. apply MapPut_semantics_2_2 with (a'' := Nxor a a'); trivial. - Qed. - - Lemma MapPut_semantics_3_1 : - forall (m m':Map) (a:ad) (y:A), - MapPut (M2 m m') a y = - (if Nbit0 a - then M2 m (MapPut m' (Ndiv2 a) y) - else M2 (MapPut m (Ndiv2 a) y) m'). - Proof. - simple induction a. trivial. - simple induction p; trivial. - Qed. - - Lemma MapPut_semantics : - forall (m:Map) (a:ad) (y:A), - eqm (MapGet (MapPut m a y)) - (fun a':ad => if Neqb a a' then Some y else MapGet m a'). - Proof. - unfold eqm in |- *. simple induction m. exact MapPut_semantics_1. - intros. unfold MapGet at 2 in |- *. apply MapPut_semantics_2; assumption. - intros. rewrite MapPut_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a0). - elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. - elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite H2. - rewrite (H0 (Ndiv2 a) y (Ndiv2 a0)). elim (sumbool_of_bool (Neqb a a0)). - intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity. - intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity. - intro H2. rewrite H2. rewrite (Neqb_comm a a0). rewrite (Nbit0_neq a0 a H2 H1). - reflexivity. - intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)). - intro H2. rewrite H2. rewrite (Nbit0_neq a a0 H1 H2). reflexivity. - intro H2. rewrite H2. rewrite (H (Ndiv2 a) y (Ndiv2 a0)). - elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3. - rewrite (Ndiv2_eq a a0 H3). reflexivity. - intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq a a0 H3 H1). reflexivity. - Qed. - - Fixpoint MapPut_behind (m:Map) : ad -> A -> Map := - match m with - | M0 => M1 - | M1 a y => - fun (a':ad) (y':A) => - match Nxor a a' with - | N0 => m - | Npos p => MapPut1 a y a' y' p - end - | M2 m1 m2 => - fun (a:ad) (y:A) => - match a with - | N0 => M2 (MapPut_behind m1 N0 y) m2 - | Npos xH => M2 m1 (MapPut_behind m2 N0 y) - | Npos (xO p) => M2 (MapPut_behind m1 (Npos p) y) m2 - | Npos (xI p) => M2 m1 (MapPut_behind m2 (Npos p) y) - end - end. - - Lemma MapPut_behind_semantics_3_1 : - forall (m m':Map) (a:ad) (y:A), - MapPut_behind (M2 m m') a y = - (if Nbit0 a - then M2 m (MapPut_behind m' (Ndiv2 a) y) - else M2 (MapPut_behind m (Ndiv2 a) y) m'). - Proof. - simple induction a. trivial. - simple induction p; trivial. - Qed. - - Lemma MapPut_behind_as_before_1 : - forall a a' a0:ad, - Neqb a' a0 = false -> - forall y y':A, - MapGet (MapPut (M1 a y) a' y') a0 = - MapGet (MapPut_behind (M1 a y) a' y') a0. - Proof. - intros a a' a0. simpl in |- *. intros H y y'. elim (Ndiscr (Nxor a a')). intro H0. elim H0. - intros p H1. rewrite H1. reflexivity. - intro H0. rewrite H0. rewrite (Nxor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H). - exact (M1_semantics_2 a' a0 y' H). - Qed. - - Lemma MapPut_behind_as_before : - forall (m:Map) (a:ad) (y:A) (a0:ad), - Neqb a a0 = false -> - MapGet (MapPut m a y) a0 = MapGet (MapPut_behind m a y) a0. - Proof. - simple induction m. trivial. - intros a y a' y' a0 H. exact (MapPut_behind_as_before_1 a a' a0 H y y'). - intros. rewrite MapPut_semantics_3_1. rewrite MapPut_behind_semantics_3_1. - elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. - rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)). intro H3. - rewrite H3. apply H0. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2). - intro H3. rewrite H3. reflexivity. - intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if. - elim (sumbool_of_bool (Nbit0 a0)). intro H3. rewrite H3. reflexivity. - intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2). - Qed. - - Lemma MapPut_behind_new : - forall (m:Map) (a:ad) (y:A), - MapGet (MapPut_behind m a y) a = - match MapGet m a with - | Some y' => Some y' - | _ => Some y - end. - Proof. - simple induction m. simpl in |- *. intros. rewrite (Neqb_correct a). reflexivity. - intros. elim (Ndiscr (Nxor a a1)). intro H. elim H. intros p H0. simpl in |- *. - rewrite H0. rewrite (Nxor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0). - assumption. - intro H. simpl in |- *. rewrite H. rewrite <- (Nxor_eq _ _ H). rewrite (Neqb_correct a). - exact (M1_semantics_1 a a0). - intros. rewrite MapPut_behind_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a). - elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1). - exact (H0 (Ndiv2 a) y). - intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (Ndiv2 a) y). - Qed. - - Lemma MapPut_behind_semantics : - forall (m:Map) (a:ad) (y:A), - eqm (MapGet (MapPut_behind m a y)) - (fun a':ad => - match MapGet m a' with - | Some y' => Some y' - | _ => if Neqb a a' then Some y else None - end). - Proof. - unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. - rewrite (Neqb_complete _ _ H). apply MapPut_behind_new. - intro H. rewrite H. rewrite <- (MapPut_behind_as_before m a y a0 H). - rewrite (MapPut_semantics m a y a0). rewrite H. case (MapGet m a0); trivial. - Qed. - - Definition makeM2 (m m':Map) := - match m, m' with - | M0, M0 => M0 - | M0, M1 a y => M1 (Ndouble_plus_one a) y - | M1 a y, M0 => M1 (Ndouble a) y - | _, _ => M2 m m' - end. - - Lemma makeM2_M2 : - forall m m':Map, eqm (MapGet (makeM2 m m')) (MapGet (M2 m m')). - Proof. - unfold eqm in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H. - rewrite (MapGet_M2_bit_0_1 a H m m'). case m'. case m. reflexivity. - intros a0 y. simpl in |- *. rewrite (Nodd_not_double a H a0). reflexivity. - intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. - assumption. - case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))). - intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double_plus_one a H). - rewrite (Neqb_correct a). reflexivity. - intro H0. rewrite H0. rewrite (Neqb_comm a0 (Ndiv2 a)) in H0. - rewrite (Nnot_div2_not_double_plus_one a a0 H0). reflexivity. - intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. - assumption. - intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. - assumption. - intros m1 m2. unfold makeM2 in |- *. - cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (Ndiv2 a)). - case m; trivial. - exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)). - intro H. rewrite (MapGet_M2_bit_0_0 a H m m'). case m. case m'. reflexivity. - intros a0 y. simpl in |- *. rewrite (Neven_not_double_plus_one a H a0). reflexivity. - intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. - assumption. - case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))). intro H0. - rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double a H). - rewrite (Neqb_correct a). reflexivity. - intro H0. rewrite H0. rewrite (Neqb_comm (Ndouble a0) a). - rewrite (Neqb_comm a0 (Ndiv2 a)) in H0. rewrite (Nnot_div2_not_double a a0 H0). - reflexivity. - intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. - assumption. - intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. - assumption. - intros m1 m2. unfold makeM2 in |- *. exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m'). - Qed. - - Fixpoint MapRemove (m:Map) : ad -> Map := - match m with - | M0 => fun _:ad => M0 - | M1 a y => - fun a':ad => match Neqb a a' with - | true => M0 - | false => m - end - | M2 m1 m2 => - fun a:ad => - if Nbit0 a - then makeM2 m1 (MapRemove m2 (Ndiv2 a)) - else makeM2 (MapRemove m1 (Ndiv2 a)) m2 - end. - - Lemma MapRemove_semantics : - forall (m:Map) (a:ad), - eqm (MapGet (MapRemove m a)) - (fun a':ad => if Neqb a a' then None else MapGet m a'). - Proof. - unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (Neqb a a0); trivial. - intros. simpl in |- *. elim (sumbool_of_bool (Neqb a1 a2)). intro H. rewrite H. - elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. reflexivity. - intro H0. rewrite H0. rewrite (Neqb_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0). - intro H. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. rewrite H. - rewrite <- (Neqb_complete _ _ H0) in H. rewrite H. reflexivity. - intro H0. rewrite H0. rewrite H. reflexivity. - intros. change - (MapGet - (if Nbit0 a - then makeM2 m0 (MapRemove m1 (Ndiv2 a)) - else makeM2 (MapRemove m0 (Ndiv2 a)) m1) a0 = - (if Neqb a a0 then None else MapGet (M2 m0 m1) a0)) - in |- *. - elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. - rewrite (makeM2_M2 m0 (MapRemove m1 (Ndiv2 a)) a0). elim (sumbool_of_bool (Nbit0 a0)). - intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (Ndiv2 a) (Ndiv2 a0)). - elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3). - reflexivity. - intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). - rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). reflexivity. - assumption. - intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (Ndiv2 a))). - rewrite (Neqb_comm a a0). rewrite (Nbit0_neq _ _ H2 H1). - rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). reflexivity. - intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (Ndiv2 a)) m1 a0). - elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite MapGet_M2_bit_0_1. - rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (Nbit0_neq a a0 H1 H2). reflexivity. - assumption. - intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (Ndiv2 a) (Ndiv2 a0)). - rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (Neqb a a0)). intro H3. - rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity. - intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity. - assumption. - Qed. - - Fixpoint MapCard (m:Map) : nat := - match m with - | M0 => 0 - | M1 _ _ => 1 - | M2 m m' => MapCard m + MapCard m' - end. - - Fixpoint MapMerge (m:Map) : Map -> Map := - match m with - | M0 => fun m':Map => m' - | M1 a y => fun m':Map => MapPut_behind m' a y - | M2 m1 m2 => - fun m':Map => - match m' with - | M0 => m - | M1 a' y' => MapPut m a' y' - | M2 m'1 m'2 => M2 (MapMerge m1 m'1) (MapMerge m2 m'2) - end - end. - - Lemma MapMerge_semantics : - forall m m':Map, - eqm (MapGet (MapMerge m m')) - (fun a0:ad => - match MapGet m' a0 with - | Some y' => Some y' - | None => MapGet m a0 - end). - Proof. - unfold eqm in |- *. simple induction m. intros. simpl in |- *. case (MapGet m' a); trivial. - intros. simpl in |- *. rewrite (MapPut_behind_semantics m' a a0 a1). reflexivity. - simple induction m'. trivial. - intros. unfold MapMerge in |- *. rewrite (MapPut_semantics (M2 m0 m1) a a0 a1). - elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1). - rewrite (M1_semantics_1 a1 a0). reflexivity. - intro H1. rewrite H1. rewrite (M1_semantics_2 a a1 a0 H1). reflexivity. - intros. cut (MapMerge (M2 m0 m1) (M2 m2 m3) = M2 (MapMerge m0 m2) (MapMerge m1 m3)). - intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). - rewrite (H m2 (Ndiv2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a). - rewrite (MapGet_M2_bit_0_if m0 m1 a). case (Nbit0 a); trivial. - reflexivity. - Qed. - - (** [MapInter], [MapRngRestrTo], [MapRngRestrBy], [MapInverse] - not implemented: need a decidable equality on [A]. *) - - Fixpoint MapDelta (m:Map) : Map -> Map := - match m with - | M0 => fun m':Map => m' - | M1 a y => - fun m':Map => - match MapGet m' a with - | None => MapPut m' a y - | _ => MapRemove m' a - end - | M2 m1 m2 => - fun m':Map => - match m' with - | M0 => m - | M1 a' y' => - match MapGet m a' with - | None => MapPut m a' y' - | _ => MapRemove m a' - end - | M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2) - end - end. - - Lemma MapDelta_semantics_comm : - forall m m':Map, eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m)). - Proof. - unfold eqm in |- *. simple induction m. simple induction m'; reflexivity. - simple induction m'. reflexivity. - unfold MapDelta in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H. - rewrite <- (Neqb_complete _ _ H). rewrite (M1_semantics_1 a a2). - rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (Neqb_correct a). reflexivity. - intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (Neqb_comm a a1) in H. - rewrite (M1_semantics_2 a1 a a2 H). rewrite (MapPut_semantics (M1 a a0) a1 a2 a3). - rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (Neqb a a3)). - intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0) in H. rewrite H. - rewrite (Neqb_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity. - intro H0. rewrite H0. rewrite (M1_semantics_2 a a3 a0 H0). - elim (sumbool_of_bool (Neqb a1 a3)). intro H1. rewrite H1. - rewrite (Neqb_complete _ _ H1). exact (M1_semantics_1 a3 a2). - intro H1. rewrite H1. exact (M1_semantics_2 a1 a3 a2 H1). - intros. reflexivity. - simple induction m'. reflexivity. - reflexivity. - intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). - rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a). - rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a). - rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a). - rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)). reflexivity. - Qed. - - Lemma MapDelta_semantics_1_1 : - forall (a:ad) (y:A) (m':Map) (a0:ad), - MapGet (M1 a y) a0 = None -> - MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = None. - Proof. - intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1. - rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H. - intro H1. case (MapGet m' a). - rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial. - rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption. - Qed. - - Lemma MapDelta_semantics_1 : - forall (m m':Map) (a:ad), - MapGet m a = None -> - MapGet m' a = None -> MapGet (MapDelta m m') a = None. - Proof. - simple induction m. trivial. - exact MapDelta_semantics_1_1. - simple induction m'. trivial. - intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). - apply MapDelta_semantics_1_1; trivial. - intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). - rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5. - apply H0. rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. exact H3. - rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. exact H4. - intro H5. rewrite H5. apply H. rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. exact H3. - rewrite (MapGet_M2_bit_0_0 a H5 m2 m3) in H4. exact H4. - Qed. - - Lemma MapDelta_semantics_2_1 : - forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A), - MapGet (M1 a y) a0 = None -> - MapGet m' a0 = Some y0 -> MapGet (MapDelta (M1 a y) m') a0 = Some y0. - Proof. - intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1. - rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H. - intro H1. case (MapGet m' a). - rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial. - rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption. - Qed. - - Lemma MapDelta_semantics_2_2 : - forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A), - MapGet (M1 a y) a0 = Some y0 -> - MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = Some y0. - Proof. - intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1. - rewrite (Neqb_complete _ _ H1) in H. rewrite (Neqb_complete _ _ H1). - rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (Neqb_correct a0). - rewrite (M1_semantics_1 a0 y) in H. simple inversion H. assumption. - intro H1. rewrite (M1_semantics_2 a a0 y H1) in H. discriminate H. - Qed. - - Lemma MapDelta_semantics_2 : - forall (m m':Map) (a:ad) (y:A), - MapGet m a = None -> - MapGet m' a = Some y -> MapGet (MapDelta m m') a = Some y. - Proof. - simple induction m. trivial. - exact MapDelta_semantics_2_1. - simple induction m'. intros. discriminate H2. - intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). - apply MapDelta_semantics_2_2; assumption. - intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). - rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5. - apply H0. rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption. - rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption. - intro H5. rewrite H5. apply H. rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption. - rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption. - Qed. - - Lemma MapDelta_semantics_3_1 : - forall (a0:ad) (y0:A) (m':Map) (a:ad) (y y':A), - MapGet (M1 a0 y0) a = Some y -> - MapGet m' a = Some y' -> MapGet (MapDelta (M1 a0 y0) m') a = None. - Proof. - intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a0 a)). intro H1. - rewrite (Neqb_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a). - rewrite (Neqb_correct a). reflexivity. - intro H1. rewrite (M1_semantics_2 a0 a y0 H1) in H. discriminate H. - Qed. - - Lemma MapDelta_semantics_3 : - forall (m m':Map) (a:ad) (y y':A), - MapGet m a = Some y -> - MapGet m' a = Some y' -> MapGet (MapDelta m m') a = None. - Proof. - simple induction m. intros. discriminate H. - exact MapDelta_semantics_3_1. - simple induction m'. intros. discriminate H2. - intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). - exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1). - intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). - rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5. - apply (H0 m3 (Ndiv2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption. - rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption. - intro H5. rewrite H5. apply (H m2 (Ndiv2 a) y y'). - rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption. - rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption. - Qed. - - Lemma MapDelta_semantics : - forall m m':Map, - eqm (MapGet (MapDelta m m')) - (fun a0:ad => - match MapGet m a0, MapGet m' a0 with - | None, Some y' => Some y' - | Some y, None => Some y - | _, _ => None - end). - Proof. - unfold eqm in |- *. intros. elim (option_sum (MapGet m' a)). intro H. elim H. intros a0 H0. - rewrite H0. elim (option_sum (MapGet m a)). intro H1. elim H1. intros a1 H2. rewrite H2. - exact (MapDelta_semantics_3 m m' a a1 a0 H2 H0). - intro H1. rewrite H1. exact (MapDelta_semantics_2 m m' a a0 H1 H0). - intro H. rewrite H. elim (option_sum (MapGet m a)). intro H0. elim H0. intros a0 H1. - rewrite H1. rewrite (MapDelta_semantics_comm m m' a). - exact (MapDelta_semantics_2 m' m a a0 H H1). - intro H0. rewrite H0. exact (MapDelta_semantics_1 m m' a H0 H). - Qed. - - Definition MapEmptyp (m:Map) := match m with - | M0 => true - | _ => false - end. - - Lemma MapEmptyp_correct : MapEmptyp M0 = true. - Proof. - reflexivity. - Qed. - - Lemma MapEmptyp_complete : forall m:Map, MapEmptyp m = true -> m = M0. - Proof. - simple induction m; trivial. intros. discriminate H. - intros. discriminate H1. - Qed. - - (** [MapSplit] not implemented: not the preferred way of recursing over Maps - (use [MapSweep], [MapCollect], or [MapFold] in Mapiter.v. *) - -End MapDefs.
\ No newline at end of file diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v deleted file mode 100644 index 0722bcfa..00000000 --- a/theories/IntMap/Mapaxioms.v +++ /dev/null @@ -1,761 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapaxioms.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Fset. - -Section MapAxioms. - - Variables A B C : Set. - - Lemma eqm_sym : forall f f':ad -> option A, eqm A f f' -> eqm A f' f. - Proof. - unfold eqm in |- *. intros. rewrite H. reflexivity. - Qed. - - Lemma eqm_refl : forall f:ad -> option A, eqm A f f. - Proof. - unfold eqm in |- *. trivial. - Qed. - - Lemma eqm_trans : - forall f f' f'':ad -> option A, eqm A f f' -> eqm A f' f'' -> eqm A f f''. - Proof. - unfold eqm in |- *. intros. rewrite H. exact (H0 a). - Qed. - - Definition eqmap (m m':Map A) := eqm A (MapGet A m) (MapGet A m'). - - Lemma eqmap_sym : forall m m':Map A, eqmap m m' -> eqmap m' m. - Proof. - intros. unfold eqmap in |- *. apply eqm_sym. assumption. - Qed. - - Lemma eqmap_refl : forall m:Map A, eqmap m m. - Proof. - intros. unfold eqmap in |- *. apply eqm_refl. - Qed. - - Lemma eqmap_trans : - forall m m' m'':Map A, eqmap m m' -> eqmap m' m'' -> eqmap m m''. - Proof. - intros. exact (eqm_trans (MapGet A m) (MapGet A m') (MapGet A m'') H H0). - Qed. - - Lemma MapPut_as_Merge : - forall (m:Map A) (a:ad) (y:A), - eqmap (MapPut A m a y) (MapMerge A m (M1 A a y)). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m a y a0). - rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2. - elim (sumbool_of_bool (Neqb a a0)); intro H; rewrite H; reflexivity. - Qed. - - Lemma MapPut_ext : - forall m m':Map A, - eqmap m m' -> - forall (a:ad) (y:A), eqmap (MapPut A m a y) (MapPut A m' a y). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m' a y a0). - rewrite (MapPut_semantics A m a y a0). - case (Neqb a a0); [ reflexivity | apply H ]. - Qed. - - Lemma MapPut_behind_as_Merge : - forall (m:Map A) (a:ad) (y:A), - eqmap (MapPut_behind A m a y) (MapMerge A (M1 A a y) m). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m a y a0). - rewrite (MapMerge_semantics A (M1 A a y) m a0). reflexivity. - Qed. - - Lemma MapPut_behind_ext : - forall m m':Map A, - eqmap m m' -> - forall (a:ad) (y:A), - eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m' a y a0). - rewrite (MapPut_behind_semantics A m a y a0). rewrite (H a0). reflexivity. - Qed. - - Lemma MapMerge_empty_m_1 : forall m:Map A, MapMerge A (M0 A) m = m. - Proof. - trivial. - Qed. - - Lemma MapMerge_empty_m : forall m:Map A, eqmap (MapMerge A (M0 A) m) m. - Proof. - unfold eqmap, eqm in |- *. trivial. - Qed. - - Lemma MapMerge_m_empty_1 : forall m:Map A, MapMerge A m (M0 A) = m. - Proof. - simple induction m; trivial. - Qed. - - Lemma MapMerge_m_empty : forall m:Map A, eqmap (MapMerge A m (M0 A)) m. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite MapMerge_m_empty_1. reflexivity. - Qed. - - Lemma MapMerge_empty_l : - forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a). - rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial. - intros. discriminate H0. - exact (H a). - Qed. - - Lemma MapMerge_empty_r : - forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m' (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a). - rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial. - exact (H a). - Qed. - - Lemma MapMerge_assoc : - forall m m' m'':Map A, - eqmap (MapMerge A (MapMerge A m m') m'') - (MapMerge A m (MapMerge A m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapMerge A m m') m'' a). - rewrite (MapMerge_semantics A m (MapMerge A m' m'') a). rewrite (MapMerge_semantics A m m' a). - rewrite (MapMerge_semantics A m' m'' a). - case (MapGet A m'' a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapMerge_idempotent : forall m:Map A, eqmap (MapMerge A m m) m. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m m a). - case (MapGet A m a); trivial. - Qed. - - Lemma MapMerge_ext : - forall m1 m2 m'1 m'2:Map A, - eqmap m1 m'1 -> - eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m'2). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m1 m2 a). - rewrite (MapMerge_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. - Qed. - - Lemma MapMerge_ext_l : - forall m1 m'1 m2:Map A, - eqmap m1 m'1 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m2). - Proof. - intros. apply MapMerge_ext. assumption. - apply eqmap_refl. - Qed. - - Lemma MapMerge_ext_r : - forall m1 m2 m'2:Map A, - eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m1 m'2). - Proof. - intros. apply MapMerge_ext. apply eqmap_refl. - assumption. - Qed. - - Lemma MapMerge_RestrTo_l : - forall m m' m'':Map A, - eqmap (MapMerge A (MapDomRestrTo A A m m') m'') - (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapDomRestrTo A A m m') m'' a). - rewrite (MapDomRestrTo_semantics A A m m' a). - rewrite - (MapDomRestrTo_semantics A A (MapMerge A m m'') (MapMerge A m' m'') a) - . - rewrite (MapMerge_semantics A m' m'' a). rewrite (MapMerge_semantics A m m'' a). - case (MapGet A m'' a); case (MapGet A m' a); reflexivity. - Qed. - - Lemma MapRemove_as_RestrBy : - forall (m:Map A) (a:ad) (y:B), - eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y)). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m a a0). - rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (Neqb a a0)). - intro H. rewrite H. rewrite (Neqb_complete a a0 H). rewrite (M1_semantics_1 B a0 y). - reflexivity. - intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity. - Qed. - - Lemma MapRemove_ext : - forall m m':Map A, - eqmap m m' -> forall a:ad, eqmap (MapRemove A m a) (MapRemove A m' a). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m' a a0). - rewrite (MapRemove_semantics A m a a0). - case (Neqb a a0); [ reflexivity | apply H ]. - Qed. - - Lemma MapDomRestrTo_empty_m_1 : - forall m:Map B, MapDomRestrTo A B (M0 A) m = M0 A. - Proof. - trivial. - Qed. - - Lemma MapDomRestrTo_empty_m : - forall m:Map B, eqmap (MapDomRestrTo A B (M0 A) m) (M0 A). - Proof. - unfold eqmap, eqm in |- *. trivial. - Qed. - - Lemma MapDomRestrTo_m_empty_1 : - forall m:Map A, MapDomRestrTo A B m (M0 B) = M0 A. - Proof. - simple induction m; trivial. - Qed. - - Lemma MapDomRestrTo_m_empty : - forall m:Map A, eqmap (MapDomRestrTo A B m (M0 B)) (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_m_empty_1 m). reflexivity. - Qed. - - Lemma MapDomRestrTo_assoc : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'') - (MapDomRestrTo A B m (MapDomRestrTo B C m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B m (MapDomRestrTo B C m' m'') a). - rewrite (MapDomRestrTo_semantics B C m' m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrTo_idempotent : - forall m:Map A, eqmap (MapDomRestrTo A A m m) m. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A A m m a). - case (MapGet A m a); trivial. - Qed. - - Lemma MapDomRestrTo_Dom : - forall (m:Map A) (m':Map B), - eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m')). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A unit m (MapDom B m') a). - elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H. - elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. unfold in_FSet, in_dom in H. - generalize H. case (MapGet unit (MapDom B m') a); trivial. intro H1. discriminate H1. - intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H. - generalize H. case (MapGet unit (MapDom B m') a); trivial. - intros H0 H1. discriminate H1. - Qed. - - Lemma MapDomRestrBy_empty_m_1 : - forall m:Map B, MapDomRestrBy A B (M0 A) m = M0 A. - Proof. - trivial. - Qed. - - Lemma MapDomRestrBy_empty_m : - forall m:Map B, eqmap (MapDomRestrBy A B (M0 A) m) (M0 A). - Proof. - unfold eqmap, eqm in |- *. trivial. - Qed. - - Lemma MapDomRestrBy_m_empty_1 : - forall m:Map A, MapDomRestrBy A B m (M0 B) = m. - Proof. - simple induction m; trivial. - Qed. - - Lemma MapDomRestrBy_m_empty : - forall m:Map A, eqmap (MapDomRestrBy A B m (M0 B)) m. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_m_empty_1 m). reflexivity. - Qed. - - Lemma MapDomRestrBy_Dom : - forall (m:Map A) (m':Map B), - eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m')). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrBy_semantics A unit m (MapDom B m') a). - elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H. - elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. - unfold in_FSet, in_dom in H. generalize H. case (MapGet unit (MapDom B m') a); trivial. - intro H1. discriminate H1. - intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H. - generalize H. case (MapGet unit (MapDom B m') a); trivial. - intros H0 H1. discriminate H1. - Qed. - - Lemma MapDomRestrBy_m_m_1 : - forall m:Map A, eqmap (MapDomRestrBy A A m m) (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A A m m a). - case (MapGet A m a); trivial. - Qed. - - Lemma MapDomRestrBy_By : - forall (m:Map A) (m' m'':Map B), - eqmap (MapDomRestrBy A B (MapDomRestrBy A B m m') m'') - (MapDomRestrBy A B m (MapMerge B m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A B m m') m'' a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrBy_semantics A B m (MapMerge B m' m'') a). - rewrite (MapMerge_semantics B m' m'' a). - case (MapGet B m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrBy_By_comm : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrBy A C (MapDomRestrBy A B m m') m'') - (MapDomRestrBy A B (MapDomRestrBy A C m m'') m'). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrBy_semantics A C (MapDomRestrBy A B m m') m'' a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A C m m'') m' a). - rewrite (MapDomRestrBy_semantics A C m m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrBy_To : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'') - (MapDomRestrTo A B m (MapDomRestrBy B C m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B m (MapDomRestrBy B C m' m'') a). - rewrite (MapDomRestrBy_semantics B C m' m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrBy_To_comm : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'') - (MapDomRestrTo A B (MapDomRestrBy A C m m'') m'). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B (MapDomRestrBy A C m m'') m' a). - rewrite (MapDomRestrBy_semantics A C m m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrTo_By : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'') - (MapDomRestrTo A C m (MapDomRestrBy C B m'' m')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A C m (MapDomRestrBy C B m'' m') a). - rewrite (MapDomRestrBy_semantics C B m'' m' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrTo_By_comm : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'') - (MapDomRestrBy A B (MapDomRestrTo A C m m'') m'). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrBy_semantics A B (MapDomRestrTo A C m m'') m' a). - rewrite (MapDomRestrTo_semantics A C m m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapDomRestrTo_To_comm : - forall (m:Map A) (m':Map B) (m'':Map C), - eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'') - (MapDomRestrTo A B (MapDomRestrTo A C m m'') m'). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B (MapDomRestrTo A C m m'') m' a). - rewrite (MapDomRestrTo_semantics A C m m'' a). - case (MapGet C m'' a); case (MapGet B m' a); trivial. - Qed. - - Lemma MapMerge_DomRestrTo : - forall (m m':Map A) (m'':Map B), - eqmap (MapDomRestrTo A B (MapMerge A m m') m'') - (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A B (MapMerge A m m') m'' a). - rewrite (MapMerge_semantics A m m' a). - rewrite - (MapMerge_semantics A (MapDomRestrTo A B m m'') - (MapDomRestrTo A B m' m'') a). - rewrite (MapDomRestrTo_semantics A B m' m'' a). - rewrite (MapDomRestrTo_semantics A B m m'' a). - case (MapGet B m'' a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapMerge_DomRestrBy : - forall (m m':Map A) (m'':Map B), - eqmap (MapDomRestrBy A B (MapMerge A m m') m'') - (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrBy_semantics A B (MapMerge A m m') m'' a). - rewrite (MapMerge_semantics A m m' a). - rewrite - (MapMerge_semantics A (MapDomRestrBy A B m m'') - (MapDomRestrBy A B m' m'') a). - rewrite (MapDomRestrBy_semantics A B m' m'' a). - rewrite (MapDomRestrBy_semantics A B m m'' a). - case (MapGet B m'' a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapDelta_empty_m_1 : forall m:Map A, MapDelta A (M0 A) m = m. - Proof. - trivial. - Qed. - - Lemma MapDelta_empty_m : forall m:Map A, eqmap (MapDelta A (M0 A) m) m. - Proof. - unfold eqmap, eqm in |- *. trivial. - Qed. - - Lemma MapDelta_m_empty_1 : forall m:Map A, MapDelta A m (M0 A) = m. - Proof. - simple induction m; trivial. - Qed. - - Lemma MapDelta_m_empty : forall m:Map A, eqmap (MapDelta A m (M0 A)) m. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite MapDelta_m_empty_1. reflexivity. - Qed. - - Lemma MapDelta_nilpotent : forall m:Map A, eqmap (MapDelta A m m) (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m a). - case (MapGet A m a); trivial. - Qed. - - Lemma MapDelta_as_Merge : - forall m m':Map A, - eqmap (MapDelta A m m') - (MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m)). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite (MapDelta_semantics A m m' a). - rewrite - (MapMerge_semantics A (MapDomRestrBy A A m m') ( - MapDomRestrBy A A m' m) a). - rewrite (MapDomRestrBy_semantics A A m' m a). - rewrite (MapDomRestrBy_semantics A A m m' a). - case (MapGet A m a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapDelta_as_DomRestrBy : - forall m m':Map A, - eqmap (MapDelta A m m') - (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). - rewrite - (MapDomRestrBy_semantics A A (MapMerge A m m') ( - MapDomRestrTo A A m m') a). - rewrite (MapDomRestrTo_semantics A A m m' a). rewrite (MapMerge_semantics A m m' a). - case (MapGet A m a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapDelta_as_DomRestrBy_2 : - forall m m':Map A, - eqmap (MapDelta A m m') - (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m)). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). - rewrite - (MapDomRestrBy_semantics A A (MapMerge A m m') ( - MapDomRestrTo A A m' m) a). - rewrite (MapDomRestrTo_semantics A A m' m a). rewrite (MapMerge_semantics A m m' a). - case (MapGet A m a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapDelta_sym : - forall m m':Map A, eqmap (MapDelta A m m') (MapDelta A m' m). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). - rewrite (MapDelta_semantics A m' m a). - case (MapGet A m a); case (MapGet A m' a); trivial. - Qed. - - Lemma MapDelta_ext : - forall m1 m2 m'1 m'2:Map A, - eqmap m1 m'1 -> - eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m'2). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m1 m2 a). - rewrite (MapDelta_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. - Qed. - - Lemma MapDelta_ext_l : - forall m1 m'1 m2:Map A, - eqmap m1 m'1 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m2). - Proof. - intros. apply MapDelta_ext. assumption. - apply eqmap_refl. - Qed. - - Lemma MapDelta_ext_r : - forall m1 m2 m'2:Map A, - eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m1 m'2). - Proof. - intros. apply MapDelta_ext. apply eqmap_refl. - assumption. - Qed. - - Lemma MapDom_Split_1 : - forall (m:Map A) (m':Map B), - eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite - (MapMerge_semantics A (MapDomRestrTo A B m m') ( - MapDomRestrBy A B m m') a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - case (MapGet B m' a); case (MapGet A m a); trivial. - Qed. - - Lemma MapDom_Split_2 : - forall (m:Map A) (m':Map B), - eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite - (MapMerge_semantics A (MapDomRestrBy A B m m') ( - MapDomRestrTo A B m m') a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - case (MapGet B m' a); case (MapGet A m a); trivial. - Qed. - - Lemma MapDom_Split_3 : - forall (m:Map A) (m':Map B), - eqmap - (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')) - (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. - rewrite - (MapDomRestrTo_semantics A A (MapDomRestrTo A B m m') - (MapDomRestrBy A B m m') a). - rewrite (MapDomRestrBy_semantics A B m m' a). - rewrite (MapDomRestrTo_semantics A B m m' a). - case (MapGet B m' a); case (MapGet A m a); trivial. - Qed. - -End MapAxioms. - -Lemma MapDomRestrTo_ext : - forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) - (m'2:Map B), - eqmap A m1 m'1 -> - eqmap B m2 m'2 -> - eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m'2). -Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m1 m2 a). - rewrite (MapDomRestrTo_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. -Qed. - -Lemma MapDomRestrTo_ext_l : - forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A), - eqmap A m1 m'1 -> - eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m2). -Proof. - intros. apply MapDomRestrTo_ext; [ assumption | apply eqmap_refl ]. -Qed. - -Lemma MapDomRestrTo_ext_r : - forall (A B:Set) (m1:Map A) (m2 m'2:Map B), - eqmap B m2 m'2 -> - eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m1 m'2). -Proof. - intros. apply MapDomRestrTo_ext; [ apply eqmap_refl | assumption ]. -Qed. - -Lemma MapDomRestrBy_ext : - forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) - (m'2:Map B), - eqmap A m1 m'1 -> - eqmap B m2 m'2 -> - eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m'2). -Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m1 m2 a). - rewrite (MapDomRestrBy_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. -Qed. - -Lemma MapDomRestrBy_ext_l : - forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A), - eqmap A m1 m'1 -> - eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m2). -Proof. - intros. apply MapDomRestrBy_ext; [ assumption | apply eqmap_refl ]. -Qed. - -Lemma MapDomRestrBy_ext_r : - forall (A B:Set) (m1:Map A) (m2 m'2:Map B), - eqmap B m2 m'2 -> - eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m1 m'2). -Proof. - intros. apply MapDomRestrBy_ext; [ apply eqmap_refl | assumption ]. -Qed. - -Lemma MapDomRestrBy_m_m : - forall (A:Set) (m:Map A), - eqmap A (MapDomRestrBy A unit m (MapDom A m)) (M0 A). -Proof. - intros. apply eqmap_trans with (m' := MapDomRestrBy A A m m). apply eqmap_sym. - apply MapDomRestrBy_Dom. - apply MapDomRestrBy_m_m_1. -Qed. - -Lemma FSetDelta_assoc : - forall s s' s'':FSet, - eqmap unit (MapDelta _ (MapDelta _ s s') s'') - (MapDelta _ s (MapDelta _ s' s'')). -Proof. - unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics unit (MapDelta unit s s') s'' a). - rewrite (MapDelta_semantics unit s s' a). - rewrite (MapDelta_semantics unit s (MapDelta unit s' s'') a). - rewrite (MapDelta_semantics unit s' s'' a). - case (MapGet _ s a); case (MapGet _ s' a); case (MapGet _ s'' a); trivial. - intros. elim u. elim u1. reflexivity. -Qed. - -Lemma FSet_ext : - forall s s':FSet, - (forall a:ad, in_FSet a s = in_FSet a s') -> eqmap unit s s'. -Proof. - unfold in_FSet, eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_dom _ a s)). intro H0. - elim (in_dom_some _ s a H0). intros y H1. rewrite (H a) in H0. elim (in_dom_some _ s' a H0). - intros y' H2. rewrite H1. rewrite H2. elim y. elim y'. reflexivity. - intro H0. rewrite (in_dom_none _ s a H0). rewrite (H a) in H0. rewrite (in_dom_none _ s' a H0). - reflexivity. -Qed. - -Lemma FSetUnion_comm : - forall s s':FSet, eqmap unit (FSetUnion s s') (FSetUnion s' s). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_union. apply orb_comm. -Qed. - -Lemma FSetUnion_assoc : - forall s s' s'':FSet, - eqmap unit (FSetUnion (FSetUnion s s') s'') - (FSetUnion s (FSetUnion s' s'')). -Proof. - exact (MapMerge_assoc unit). -Qed. - -Lemma FSetUnion_M0_s : forall s:FSet, eqmap unit (FSetUnion (M0 unit) s) s. -Proof. - exact (MapMerge_empty_m unit). -Qed. - -Lemma FSetUnion_s_M0 : forall s:FSet, eqmap unit (FSetUnion s (M0 unit)) s. -Proof. - exact (MapMerge_m_empty unit). -Qed. - -Lemma FSetUnion_idempotent : forall s:FSet, eqmap unit (FSetUnion s s) s. -Proof. - exact (MapMerge_idempotent unit). -Qed. - -Lemma FSetInter_comm : - forall s s':FSet, eqmap unit (FSetInter s s') (FSetInter s' s). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_inter. apply andb_comm. -Qed. - -Lemma FSetInter_assoc : - forall s s' s'':FSet, - eqmap unit (FSetInter (FSetInter s s') s'') - (FSetInter s (FSetInter s' s'')). -Proof. - exact (MapDomRestrTo_assoc unit unit unit). -Qed. - -Lemma FSetInter_M0_s : - forall s:FSet, eqmap unit (FSetInter (M0 unit) s) (M0 unit). -Proof. - exact (MapDomRestrTo_empty_m unit unit). -Qed. - -Lemma FSetInter_s_M0 : - forall s:FSet, eqmap unit (FSetInter s (M0 unit)) (M0 unit). -Proof. - exact (MapDomRestrTo_m_empty unit unit). -Qed. - -Lemma FSetInter_idempotent : forall s:FSet, eqmap unit (FSetInter s s) s. -Proof. - exact (MapDomRestrTo_idempotent unit). -Qed. - -Lemma FSetUnion_Inter_l : - forall s s' s'':FSet, - eqmap unit (FSetUnion (FSetInter s s') s'') - (FSetInter (FSetUnion s s'') (FSetUnion s' s'')). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter. - rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union. - case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. -Qed. - -Lemma FSetUnion_Inter_r : - forall s s' s'':FSet, - eqmap unit (FSetUnion s (FSetInter s' s'')) - (FSetInter (FSetUnion s s') (FSetUnion s s'')). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter. - rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union. - case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. -Qed. - -Lemma FSetInter_Union_l : - forall s s' s'':FSet, - eqmap unit (FSetInter (FSetUnion s s') s'') - (FSetUnion (FSetInter s s'') (FSetInter s' s'')). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union. - rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter. - case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. -Qed. - -Lemma FSetInter_Union_r : - forall s s' s'':FSet, - eqmap unit (FSetInter s (FSetUnion s' s'')) - (FSetUnion (FSetInter s s') (FSetInter s s'')). -Proof. - intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union. - rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter. - case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. -Qed.
\ No newline at end of file diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v deleted file mode 100644 index 163373bf..00000000 --- a/theories/IntMap/Mapc.v +++ /dev/null @@ -1,539 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapc.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Map. -Require Import Mapaxioms. -Require Import Fset. -Require Import Mapiter. -Require Import Mapsubset. -Require Import List. -Require Import Lsort. -Require Import Mapcard. -Require Import Mapcanon. - -Section MapC. - - Variables A B C : Set. - - Lemma MapPut_as_Merge_c : - forall m:Map A, - mapcanon A m -> - forall (a:ad) (y:A), MapPut A m a y = MapMerge A m (M1 A a y). - Proof. - intros. apply mapcanon_unique. exact (MapPut_canon A m H a y). - apply MapMerge_canon. assumption. - apply M1_canon. - apply MapPut_as_Merge. - Qed. - - Lemma MapPut_behind_as_Merge_c : - forall m:Map A, - mapcanon A m -> - forall (a:ad) (y:A), MapPut_behind A m a y = MapMerge A (M1 A a y) m. - Proof. - intros. apply mapcanon_unique. exact (MapPut_behind_canon A m H a y). - apply MapMerge_canon. apply M1_canon. - assumption. - apply MapPut_behind_as_Merge. - Qed. - - Lemma MapMerge_empty_m_c : forall m:Map A, MapMerge A (M0 A) m = m. - Proof. - trivial. - Qed. - - Lemma MapMerge_assoc_c : - forall m m' m'':Map A, - mapcanon A m -> - mapcanon A m' -> - mapcanon A m'' -> - MapMerge A (MapMerge A m m') m'' = MapMerge A m (MapMerge A m' m''). - Proof. - intros. apply mapcanon_unique. - apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption. - apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption. - apply MapMerge_assoc. - Qed. - - Lemma MapMerge_idempotent_c : - forall m:Map A, mapcanon A m -> MapMerge A m m = m. - Proof. - intros. apply mapcanon_unique. apply MapMerge_canon; assumption. - assumption. - apply MapMerge_idempotent. - Qed. - - Lemma MapMerge_RestrTo_l_c : - forall m m' m'':Map A, - mapcanon A m -> - mapcanon A m'' -> - MapMerge A (MapDomRestrTo A A m m') m'' = - MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m''). - Proof. - intros. apply mapcanon_unique. apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. - assumption. - apply MapDomRestrTo_canon; apply MapMerge_canon; assumption. - apply MapMerge_RestrTo_l. - Qed. - - Lemma MapRemove_as_RestrBy_c : - forall m:Map A, - mapcanon A m -> - forall (a:ad) (y:B), MapRemove A m a = MapDomRestrBy A B m (M1 B a y). - Proof. - intros. apply mapcanon_unique. apply MapRemove_canon; assumption. - apply MapDomRestrBy_canon; assumption. - apply MapRemove_as_RestrBy. - Qed. - - Lemma MapDomRestrTo_assoc_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrTo A C (MapDomRestrTo A B m m') m'' = - MapDomRestrTo A B m (MapDomRestrTo B C m' m''). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon; try assumption. - apply MapDomRestrTo_canon; try assumption. - apply MapDomRestrTo_canon; try assumption. - apply MapDomRestrTo_assoc. - Qed. - - Lemma MapDomRestrTo_idempotent_c : - forall m:Map A, mapcanon A m -> MapDomRestrTo A A m m = m. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption. - assumption. - apply MapDomRestrTo_idempotent. - Qed. - - Lemma MapDomRestrTo_Dom_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - MapDomRestrTo A B m m' = MapDomRestrTo A unit m (MapDom B m'). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_Dom. - Qed. - - Lemma MapDomRestrBy_Dom_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - MapDomRestrBy A B m m' = MapDomRestrBy A unit m (MapDom B m'). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_Dom. - Qed. - - Lemma MapDomRestrBy_By_c : - forall (m:Map A) (m' m'':Map B), - mapcanon A m -> - MapDomRestrBy A B (MapDomRestrBy A B m m') m'' = - MapDomRestrBy A B m (MapMerge B m' m''). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon; try assumption. - apply MapDomRestrBy_canon; try assumption. - apply MapDomRestrBy_canon; try assumption. - apply MapDomRestrBy_By. - Qed. - - Lemma MapDomRestrBy_By_comm_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrBy A C (MapDomRestrBy A B m m') m'' = - MapDomRestrBy A B (MapDomRestrBy A C m m'') m'. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon. - apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_canon. apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_By_comm. - Qed. - - Lemma MapDomRestrBy_To_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrBy A C (MapDomRestrTo A B m m') m'' = - MapDomRestrTo A B m (MapDomRestrBy B C m' m''). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrBy_To. - Qed. - - Lemma MapDomRestrBy_To_comm_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrBy A C (MapDomRestrTo A B m m') m'' = - MapDomRestrTo A B (MapDomRestrBy A C m m'') m'. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_canon. apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_To_comm. - Qed. - - Lemma MapDomRestrTo_By_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrTo A C (MapDomRestrBy A B m m') m'' = - MapDomRestrTo A C m (MapDomRestrBy C B m'' m'). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon. - apply MapDomRestrBy_canon; assumption. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_By. - Qed. - - Lemma MapDomRestrTo_By_comm_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrTo A C (MapDomRestrBy A B m m') m'' = - MapDomRestrBy A B (MapDomRestrTo A C m m'') m'. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon. - apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_canon. apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_By_comm. - Qed. - - Lemma MapDomRestrTo_To_comm_c : - forall (m:Map A) (m':Map B) (m'':Map C), - mapcanon A m -> - MapDomRestrTo A C (MapDomRestrTo A B m m') m'' = - MapDomRestrTo A B (MapDomRestrTo A C m m'') m'. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon. - apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_canon. apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_To_comm. - Qed. - - Lemma MapMerge_DomRestrTo_c : - forall (m m':Map A) (m'':Map B), - mapcanon A m -> - mapcanon A m' -> - MapDomRestrTo A B (MapMerge A m m') m'' = - MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m''). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon. - apply MapMerge_canon; assumption. - apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. - apply MapDomRestrTo_canon; assumption. - apply MapMerge_DomRestrTo. - Qed. - - Lemma MapMerge_DomRestrBy_c : - forall (m m':Map A) (m'':Map B), - mapcanon A m -> - mapcanon A m' -> - MapDomRestrBy A B (MapMerge A m m') m'' = - MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m''). - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. - apply MapMerge_canon. apply MapDomRestrBy_canon; assumption. - apply MapDomRestrBy_canon; assumption. - apply MapMerge_DomRestrBy. - Qed. - - Lemma MapDelta_nilpotent_c : - forall m:Map A, mapcanon A m -> MapDelta A m m = M0 A. - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply M0_canon. - apply MapDelta_nilpotent. - Qed. - - Lemma MapDelta_as_Merge_c : - forall m m':Map A, - mapcanon A m -> - mapcanon A m' -> - MapDelta A m m' = - MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m). - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply MapMerge_canon; apply MapDomRestrBy_canon; assumption. - apply MapDelta_as_Merge. - Qed. - - Lemma MapDelta_as_DomRestrBy_c : - forall m m':Map A, - mapcanon A m -> - mapcanon A m' -> - MapDelta A m m' = - MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m'). - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. - apply MapDelta_as_DomRestrBy. - Qed. - - Lemma MapDelta_as_DomRestrBy_2_c : - forall m m':Map A, - mapcanon A m -> - mapcanon A m' -> - MapDelta A m m' = - MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m). - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. - apply MapDelta_as_DomRestrBy_2. - Qed. - - Lemma MapDelta_sym_c : - forall m m':Map A, - mapcanon A m -> mapcanon A m' -> MapDelta A m m' = MapDelta A m' m. - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply MapDelta_canon; assumption. apply MapDelta_sym. - Qed. - - Lemma MapDom_Split_1_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - m = MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'). - Proof. - intros. apply mapcanon_unique. assumption. - apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. - apply MapDomRestrBy_canon; assumption. - apply MapDom_Split_1. - Qed. - - Lemma MapDom_Split_2_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - m = MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m'). - Proof. - intros. apply mapcanon_unique. assumption. - apply MapMerge_canon. apply MapDomRestrBy_canon; assumption. - apply MapDomRestrTo_canon; assumption. - apply MapDom_Split_2. - Qed. - - Lemma MapDom_Split_3_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') = - M0 A. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrTo_canon. - apply MapDomRestrTo_canon; assumption. - apply M0_canon. - apply MapDom_Split_3. - Qed. - - Lemma Map_of_alist_of_Map_c : - forall m:Map A, mapcanon A m -> Map_of_alist A (alist_of_Map A m) = m. - Proof. - intros. apply mapcanon_unique; try assumption. apply Map_of_alist_canon. - apply Map_of_alist_of_Map. - Qed. - - Lemma alist_of_Map_of_alist_c : - forall l:alist A, - alist_sorted_2 A l -> alist_of_Map A (Map_of_alist A l) = l. - Proof. - intros. apply alist_canonical. apply alist_of_Map_of_alist. - apply alist_of_Map_sorts2. - assumption. - Qed. - - Lemma MapSubset_antisym_c : - forall (m:Map A) (m':Map B), - mapcanon A m -> - mapcanon B m' -> - MapSubset A B m m' -> MapSubset B A m' m -> MapDom A m = MapDom B m'. - Proof. - intros. apply (mapcanon_unique unit). apply MapDom_canon; assumption. - apply MapDom_canon; assumption. - apply MapSubset_antisym; assumption. - Qed. - - Lemma FSubset_antisym_c : - forall s s':FSet, - mapcanon unit s -> - mapcanon unit s' -> MapSubset _ _ s s' -> MapSubset _ _ s' s -> s = s'. - Proof. - intros. apply (mapcanon_unique unit); try assumption. apply FSubset_antisym; assumption. - Qed. - - Lemma MapDisjoint_empty_c : - forall m:Map A, mapcanon A m -> MapDisjoint A A m m -> m = M0 A. - Proof. - intros. apply mapcanon_unique; try assumption; try apply M0_canon. - apply MapDisjoint_empty; assumption. - Qed. - - Lemma MapDelta_disjoint_c : - forall m m':Map A, - mapcanon A m -> - mapcanon A m' -> - MapDisjoint A A m m' -> MapDelta A m m' = MapMerge A m m'. - Proof. - intros. apply mapcanon_unique. apply MapDelta_canon; assumption. - apply MapMerge_canon; assumption. apply MapDelta_disjoint; assumption. - Qed. - -End MapC. - -Lemma FSetDelta_assoc_c : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s' -> - mapcanon unit s'' -> - MapDelta _ (MapDelta _ s s') s'' = MapDelta _ s (MapDelta _ s' s''). -Proof. - intros. apply (mapcanon_unique unit). apply MapDelta_canon. apply MapDelta_canon; assumption. - assumption. - apply MapDelta_canon. assumption. - apply MapDelta_canon; assumption. - apply FSetDelta_assoc; assumption. -Qed. - -Lemma FSet_ext_c : - forall s s':FSet, - mapcanon unit s -> - mapcanon unit s' -> (forall a:ad, in_FSet a s = in_FSet a s') -> s = s'. -Proof. - intros. apply (mapcanon_unique unit); try assumption. apply FSet_ext. assumption. -Qed. - -Lemma FSetUnion_comm_c : - forall s s':FSet, - mapcanon unit s -> mapcanon unit s' -> FSetUnion s s' = FSetUnion s' s. -Proof. - intros. - apply (mapcanon_unique unit); - try (unfold FSetUnion in |- *; apply MapMerge_canon; assumption). - apply FSetUnion_comm. -Qed. - -Lemma FSetUnion_assoc_c : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s' -> - mapcanon unit s'' -> - FSetUnion (FSetUnion s s') s'' = FSetUnion s (FSetUnion s' s''). -Proof. - exact (MapMerge_assoc_c unit). -Qed. - -Lemma FSetUnion_M0_s_c : forall s:FSet, FSetUnion (M0 unit) s = s. -Proof. - exact (MapMerge_empty_m_c unit). -Qed. - -Lemma FSetUnion_s_M0_c : forall s:FSet, FSetUnion s (M0 unit) = s. -Proof. - exact (MapMerge_m_empty_1 unit). -Qed. - -Lemma FSetUnion_idempotent : - forall s:FSet, mapcanon unit s -> FSetUnion s s = s. -Proof. - exact (MapMerge_idempotent_c unit). -Qed. - -Lemma FSetInter_comm_c : - forall s s':FSet, - mapcanon unit s -> mapcanon unit s' -> FSetInter s s' = FSetInter s' s. -Proof. - intros. - apply (mapcanon_unique unit); - try (unfold FSetInter in |- *; apply MapDomRestrTo_canon; assumption). - apply FSetInter_comm. -Qed. - -Lemma FSetInter_assoc_c : - forall s s' s'':FSet, - mapcanon unit s -> - FSetInter (FSetInter s s') s'' = FSetInter s (FSetInter s' s''). -Proof. - exact (MapDomRestrTo_assoc_c unit unit unit). -Qed. - -Lemma FSetInter_M0_s_c : forall s:FSet, FSetInter (M0 unit) s = M0 unit. -Proof. - trivial. -Qed. - -Lemma FSetInter_s_M0_c : forall s:FSet, FSetInter s (M0 unit) = M0 unit. -Proof. - exact (MapDomRestrTo_m_empty_1 unit unit). -Qed. - -Lemma FSetInter_idempotent : - forall s:FSet, mapcanon unit s -> FSetInter s s = s. -Proof. - exact (MapDomRestrTo_idempotent_c unit). -Qed. - -Lemma FSetUnion_Inter_l_c : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s'' -> - FSetUnion (FSetInter s s') s'' = - FSetInter (FSetUnion s s'') (FSetUnion s' s''). -Proof. - intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption. - unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption. - unfold FSetInter in |- *; unfold FSetUnion in |- *; - apply MapDomRestrTo_canon; apply MapMerge_canon; - assumption. - apply FSetUnion_Inter_l. -Qed. - -Lemma FSetUnion_Inter_r : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s' -> - FSetUnion s (FSetInter s' s'') = - FSetInter (FSetUnion s s') (FSetUnion s s''). -Proof. - intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption. - unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption. - unfold FSetInter in |- *; unfold FSetUnion in |- *; - apply MapDomRestrTo_canon; apply MapMerge_canon; - assumption. - apply FSetUnion_Inter_r. -Qed. - -Lemma FSetInter_Union_l_c : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s' -> - FSetInter (FSetUnion s s') s'' = - FSetUnion (FSetInter s s'') (FSetInter s' s''). -Proof. - intros. apply (mapcanon_unique unit). unfold FSetInter in |- *. - apply MapDomRestrTo_canon; try assumption. unfold FSetUnion in |- *. - apply MapMerge_canon; assumption. - unfold FSetUnion in |- *; unfold FSetInter in |- *; apply MapMerge_canon; - apply MapDomRestrTo_canon; assumption. - apply FSetInter_Union_l. -Qed. - -Lemma FSetInter_Union_r : - forall s s' s'':FSet, - mapcanon unit s -> - mapcanon unit s' -> - FSetInter s (FSetUnion s' s'') = - FSetUnion (FSetInter s s') (FSetInter s s''). -Proof. - intros. apply (mapcanon_unique unit). unfold FSetInter in |- *. - apply MapDomRestrTo_canon; try assumption. - unfold FSetUnion in |- *. apply MapMerge_canon; unfold FSetInter in |- *; apply MapDomRestrTo_canon; - assumption. - apply FSetInter_Union_r. -Qed.
\ No newline at end of file diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v deleted file mode 100644 index 33741b98..00000000 --- a/theories/IntMap/Mapcanon.v +++ /dev/null @@ -1,401 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapcanon.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Mapaxioms. -Require Import Mapiter. -Require Import Fset. -Require Import List. -Require Import Lsort. -Require Import Mapsubset. -Require Import Mapcard. - -Section MapCanon. - - Variable A : Set. - - Inductive mapcanon : Map A -> Prop := - | M0_canon : mapcanon (M0 A) - | M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y) - | M2_canon : - forall m1 m2:Map A, - mapcanon m1 -> - mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2). - - Lemma mapcanon_M2 : - forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2). - Proof. - intros. inversion H. assumption. - Qed. - - Lemma mapcanon_M2_1 : - forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1. - Proof. - intros. inversion H. assumption. - Qed. - - Lemma mapcanon_M2_2 : - forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2. - Proof. - intros. inversion H. assumption. - Qed. - - Lemma M2_eqmap_1 : - forall m0 m1 m2 m3:Map A, - eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_div2 a). - rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1). - rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m2 m3). - exact (H (Ndouble a)). - Qed. - - Lemma M2_eqmap_2 : - forall m0 m1 m2 m3:Map A, - eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3. - Proof. - unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_plus_one_div2 a). - rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1). - rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m2 m3). - exact (H (Ndouble_plus_one a)). - Qed. - - Lemma mapcanon_unique : - forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'. - Proof. - simple induction m. simple induction m'. trivial. - intros a y H H0 H1. cut (None = MapGet A (M1 A a y) a). simpl in |- *. rewrite (Neqb_correct a). - intro. discriminate H2. - exact (H1 a). - intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4). - rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2). - intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = None). simpl in |- *. - rewrite (Neqb_correct a). intro. discriminate H2. - exact (H1 a). - intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *. - rewrite (Neqb_correct a). intro. elim (sumbool_of_bool (Neqb a0 a)). intro H3. - rewrite H3 in H2. inversion H2. rewrite (Neqb_complete _ _ H3). reflexivity. - intro H3. rewrite H3 in H2. discriminate H2. - exact (H1 a). - intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)). - rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2). - simple induction m'. intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4). - rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1). - intros a y H1 H2 H3. cut (2 <= MapCard A (M1 A a y)). intro. - elim (le_Sn_O _ (le_S_n _ _ H4)). - rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1). - intros. rewrite (H m2). rewrite (H0 m3). reflexivity. - exact (mapcanon_M2_2 _ _ H3). - exact (mapcanon_M2_2 _ _ H4). - exact (M2_eqmap_2 _ _ _ _ H5). - exact (mapcanon_M2_1 _ _ H3). - exact (mapcanon_M2_1 _ _ H4). - exact (M2_eqmap_1 _ _ _ _ H5). - Qed. - - Lemma MapPut1_canon : - forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p). - Proof. - simple induction p. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon. - apply M1_canon. - apply le_n. - apply M2_canon. apply M1_canon. - apply M1_canon. - apply le_n. - simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M0_canon. - apply H. - simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n. - apply M2_canon. apply H. - apply M0_canon. - simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n. - simpl in |- *. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon. - apply M1_canon. - simpl in |- *. apply le_n. - apply M2_canon. apply M1_canon. - apply M1_canon. - simpl in |- *. apply le_n. - Qed. - - Lemma MapPut_canon : - forall m:Map A, - mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y). - Proof. - simple induction m. intros. simpl in |- *. apply M1_canon. - intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon. - intro. apply MapPut1_canon. - intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). - exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1). - apply plus_le_compat. exact (MapCard_Put_lb A m0 N0 y). - apply le_n. - intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1). - apply H0. exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (Npos p0) y). - intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). - exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (Npos p0) y). - apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1). - apply H0. apply (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_l. exact (MapCard_Put_lb A m1 N0 y). - Qed. - - Lemma MapPut_behind_canon : - forall m:Map A, - mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y). - Proof. - simple induction m. intros. simpl in |- *. apply M1_canon. - intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon. - intro. apply MapPut1_canon. - intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). - exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1). - apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 N0 y). - apply le_n. - intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1). - apply H0. exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (Npos p0) y). - intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). - exact (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (Npos p0) y). - apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1). - apply H0. apply (mapcanon_M2_2 m0 m1 H1). - simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). - exact (mapcanon_M2 m0 m1 H1). - apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 N0 y). - Qed. - - Lemma makeM2_canon : - forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m'). - Proof. - intro. case m. intro. case m'. intros. exact M0_canon. - intros a y H H0. exact (M1_canon (Ndouble_plus_one a) y). - intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0). - intros a y m'. case m'. intros. exact (M1_canon (Ndouble a) y). - intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n. - intros. simpl in |- *. apply M2_canon; try assumption. - apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0). - exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))). - simpl in |- *. intros. apply M2_canon; try assumption. - apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H). - exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')). - Qed. - - Fixpoint MapCanonicalize (m:Map A) : Map A := - match m with - | M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1) - | _ => m - end. - - Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m). - Proof. - simple induction m. apply eqmap_refl. - intros. apply eqmap_refl. - intros. simpl in |- *. unfold eqmap, eqm in |- *. intro. - rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a). - rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if. - rewrite <- (H (Ndiv2 a)). rewrite <- (H0 (Ndiv2 a)). reflexivity. - Qed. - - Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m). - Proof. - simple induction m. apply M0_canon. - intros. simpl in |- *. apply M1_canon. - intros. simpl in |- *. apply makeM2_canon; assumption. - Qed. - - Lemma mapcanon_exists : - forall m:Map A, {m' : Map A | eqmap A m m' /\ mapcanon m'}. - Proof. - intro. split with (MapCanonicalize m). split. apply mapcanon_exists_1. - apply mapcanon_exists_2. - Qed. - - Lemma MapRemove_canon : - forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a). - Proof. - simple induction m. intros. exact M0_canon. - intros a y H a0. simpl in |- *. case (Neqb a a0). exact M0_canon. - assumption. - intros. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1). - apply H0. exact (mapcanon_M2_2 _ _ H1). - apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1). - exact (mapcanon_M2_2 _ _ H1). - Qed. - - Lemma MapMerge_canon : - forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m'). - Proof. - simple induction m. intros. exact H0. - simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y). - simple induction m'. intros. exact H1. - intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y). - intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 _ _ H3). - exact (mapcanon_M2_1 _ _ H4). - apply H0. exact (mapcanon_M2_2 _ _ H3). - exact (mapcanon_M2_2 _ _ H4). - change (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *. - apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H3). - exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)). - Qed. - - Lemma MapDelta_canon : - forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m'). - Proof. - simple induction m. intros. exact H0. - simpl in |- *. intros a y m' H H0. case (MapGet A m' a). - intro. exact (MapRemove_canon m' H0 a). - exact (MapPut_canon m' H0 a y). - simple induction m'. intros. exact H1. - unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a). - intro. exact (MapRemove_canon _ H1 a). - exact (MapPut_canon _ H1 a y). - intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3). - exact (mapcanon_M2_1 _ _ H4). - apply H0. exact (mapcanon_M2_2 _ _ H3). - exact (mapcanon_M2_2 _ _ H4). - Qed. - - Variable B : Set. - - Lemma MapDomRestrTo_canon : - forall m:Map A, - mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m'). - Proof. - simple induction m. intros. exact M0_canon. - simpl in |- *. intros a y H m'. case (MapGet B m' a). - intro. apply M1_canon. - exact M0_canon. - simple induction m'. exact M0_canon. - unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). - intro. apply M1_canon. - exact M0_canon. - intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). - apply H0. exact (mapcanon_M2_2 m0 m1 H1). - Qed. - - Lemma MapDomRestrBy_canon : - forall m:Map A, - mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m'). - Proof. - simple induction m. intros. exact M0_canon. - simpl in |- *. intros a y H m'. case (MapGet B m' a); try assumption. - intro. exact M0_canon. - simple induction m'. exact H1. - intros a y. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1). - apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1). - apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1). - exact (mapcanon_M2_2 _ _ H1). - intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1). - apply H0. exact (mapcanon_M2_2 _ _ H1). - Qed. - - Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l). - Proof. - simple induction l. exact M0_canon. - intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption. - Qed. - - Lemma MapSubset_c_1 : - forall (m:Map A) (m':Map B), - mapcanon m -> MapSubset A B m m' -> MapDomRestrBy A B m m' = M0 A. - Proof. - intros. apply mapcanon_unique. apply MapDomRestrBy_canon. assumption. - apply M0_canon. - exact (MapSubset_imp_2 _ _ m m' H0). - Qed. - - Lemma MapSubset_c_2 : - forall (m:Map A) (m':Map B), - MapDomRestrBy A B m m' = M0 A -> MapSubset A B m m'. - Proof. - intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. rewrite H. apply eqmap_refl. - Qed. - -End MapCanon. - -Section FSetCanon. - - Variable A : Set. - - Lemma MapDom_canon : - forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m). - Proof. - simple induction m. intro. exact (M0_canon unit). - intros a y H. exact (M1_canon unit a _). - intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1). - apply H0. exact (mapcanon_M2_2 A _ _ H1). - change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom. - exact (mapcanon_M2 A _ _ H1). - Qed. - -End FSetCanon. - -Section MapFoldCanon. - - Variables A B : Set. - - Lemma MapFold_canon_1 : - forall m0:Map B, - mapcanon B m0 -> - forall op:Map B -> Map B -> Map B, - (forall m1:Map B, - mapcanon B m1 -> - forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) -> - forall f:ad -> A -> Map B, - (forall (a:ad) (y:A), mapcanon B (f a y)) -> - forall (m:Map A) (pf:ad -> ad), - mapcanon B (MapFold1 A (Map B) m0 op f pf m). - Proof. - simple induction m. intro. exact H. - intros a y pf. simpl in |- *. apply H1. - intros. simpl in |- *. apply H0. apply H2. - apply H3. - Qed. - - Lemma MapFold_canon : - forall m0:Map B, - mapcanon B m0 -> - forall op:Map B -> Map B -> Map B, - (forall m1:Map B, - mapcanon B m1 -> - forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) -> - forall f:ad -> A -> Map B, - (forall (a:ad) (y:A), mapcanon B (f a y)) -> - forall m:Map A, mapcanon B (MapFold A (Map B) m0 op f m). - Proof. - intros. exact (MapFold_canon_1 m0 H op H0 f H1 m (fun a:ad => a)). - Qed. - - Lemma MapCollect_canon : - forall f:ad -> A -> Map B, - (forall (a:ad) (y:A), mapcanon B (f a y)) -> - forall m:Map A, mapcanon B (MapCollect A B f m). - Proof. - intros. rewrite MapCollect_as_Fold. apply MapFold_canon. apply M0_canon. - intros. exact (MapMerge_canon B m1 m2 H0 H1). - assumption. - Qed. - -End MapFoldCanon.
\ No newline at end of file diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v deleted file mode 100644 index 36be9bf9..00000000 --- a/theories/IntMap/Mapcard.v +++ /dev/null @@ -1,764 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapcard.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Mapaxioms. -Require Import Mapiter. -Require Import Fset. -Require Import Mapsubset. -Require Import List. -Require Import Lsort. -Require Import Peano_dec. - -Section MapCard. - - Variables A B : Set. - - Lemma MapCard_M0 : MapCard A (M0 A) = 0. - Proof. - trivial. - Qed. - - Lemma MapCard_M1 : forall (a:ad) (y:A), MapCard A (M1 A a y) = 1. - Proof. - trivial. - Qed. - - Lemma MapCard_is_O : - forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = None. - Proof. - simple induction m. trivial. - intros a y H. discriminate H. - intros. simpl in H1. elim (plus_is_O _ _ H1). intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a). - case (Nbit0 a). apply H0. assumption. - apply H. assumption. - Qed. - - Lemma MapCard_is_not_O : - forall (m:Map A) (a:ad) (y:A), - MapGet A m a = Some y -> {n : nat | MapCard A m = S n}. - Proof. - simple induction m. intros. discriminate H. - intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (Neqb a a0)). intro H0. split with 0. - reflexivity. - intro H0. rewrite H0 in H. discriminate H. - intros. elim (sumbool_of_bool (Nbit0 a)). intro H2. - rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (Ndiv2 a) y H1). intros n H3. - simpl in |- *. rewrite H3. split with (MapCard A m0 + n). - rewrite <- (plus_Snm_nSm (MapCard A m0) n). reflexivity. - intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (Ndiv2 a) y H1). - intros n H3. simpl in |- *. rewrite H3. split with (n + MapCard A m1). reflexivity. - Qed. - - Lemma MapCard_is_one : - forall m:Map A, - MapCard A m = 1 -> {a : ad & {y : A | MapGet A m a = Some y}}. - Proof. - simple induction m. intro. discriminate H. - intros a y H. split with a. split with y. apply M1_semantics_1. - intros. simpl in H1. elim (plus_is_one (MapCard A m0) (MapCard A m1) H1). - intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (Ndouble_plus_one a). - rewrite (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1). - rewrite Ndouble_plus_one_div2. exact H5. - intro H2. elim H2. intros. elim (H H3). intros a H5. split with (Ndouble a). - rewrite (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1). - rewrite Ndouble_div2. exact H5. - Qed. - - Lemma MapCard_is_one_unique : - forall m:Map A, - MapCard A m = 1 -> - forall (a a':ad) (y y':A), - MapGet A m a = Some y -> - MapGet A m a' = Some y' -> a = a' /\ y = y'. - Proof. - simple induction m. intro. discriminate H. - intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. rewrite (Neqb_complete _ _ H2) in H0. - rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (Neqb a a')). - intro H5. rewrite (Neqb_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1. - inversion H1. rewrite <- (Neqb_complete _ _ H2). rewrite <- (Neqb_complete _ _ H5). - rewrite <- H4. rewrite <- H6. split; reflexivity. - intro H5. rewrite (M1_semantics_2 A a a' a0 H5) in H1. discriminate H1. - intro H2. rewrite (M1_semantics_2 A a a1 a0 H2) in H0. discriminate H0. - intros. simpl in H1. elim (plus_is_one _ _ H1). intro H4. elim H4. intros. - rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (Nbit0 a)). - intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3. - elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3). - intros. split. rewrite <- (Ndiv2_double_plus_one a H7). - rewrite <- (Ndiv2_double_plus_one a' H8). rewrite H9. reflexivity. - assumption. - intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (Ndiv2 a')) in H3. - discriminate H3. - intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (Ndiv2 a)) in H2. - discriminate H2. - intro H4. elim H4. intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. - elim (sumbool_of_bool (Nbit0 a)). intro H7. rewrite H7 in H2. - rewrite (MapCard_is_O m1 H6 (Ndiv2 a)) in H2. discriminate H2. - intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3. - elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3. - rewrite (MapCard_is_O m1 H6 (Ndiv2 a')) in H3. discriminate H3. - intro H8. rewrite H8 in H3. elim (H H5 _ _ _ _ H2 H3). intros. split. - rewrite <- (Ndiv2_double a H7). rewrite <- (Ndiv2_double a' H8). - rewrite H9. reflexivity. - assumption. - Qed. - - Lemma length_as_fold : - forall (C:Set) (l:list C), - length l = fold_right (fun (_:C) (n:nat) => S n) 0 l. - Proof. - simple induction l. reflexivity. - intros. simpl in |- *. rewrite H. reflexivity. - Qed. - - Lemma length_as_fold_2 : - forall l:alist A, - length l = - fold_right (fun (r:ad * A) (n:nat) => let (a, y) := r in 1 + n) 0 l. - Proof. - simple induction l. reflexivity. - intros. simpl in |- *. rewrite H. elim a; reflexivity. - Qed. - - Lemma MapCard_as_Fold_1 : - forall (m:Map A) (pf:ad -> ad), - MapCard A m = MapFold1 A nat 0 plus (fun (_:ad) (_:A) => 1) pf m. - Proof. - simple induction m. trivial. - trivial. - intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (Ndouble a0))). - rewrite <- (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity. - Qed. - - Lemma MapCard_as_Fold : - forall m:Map A, - MapCard A m = MapFold A nat 0 plus (fun (_:ad) (_:A) => 1) m. - Proof. - intro. exact (MapCard_as_Fold_1 m (fun a0:ad => a0)). - Qed. - - Lemma MapCard_as_length : - forall m:Map A, MapCard A m = length (alist_of_Map A m). - Proof. - intro. rewrite MapCard_as_Fold. rewrite length_as_fold_2. - apply MapFold_as_fold with - (op := plus) (neutral := 0) (f := fun (_:ad) (_:A) => 1). exact plus_assoc_reverse. - trivial. - intro. rewrite <- plus_n_O. reflexivity. - Qed. - - Lemma MapCard_Put1_equals_2 : - forall (p:positive) (a a':ad) (y y':A), - MapCard A (MapPut1 A a y a' y' p) = 2. - Proof. - simple induction p. intros. simpl in |- *. case (Nbit0 a); reflexivity. - intros. simpl in |- *. case (Nbit0 a). exact (H (Ndiv2 a) (Ndiv2 a') y y'). - simpl in |- *. rewrite <- plus_n_O. exact (H (Ndiv2 a) (Ndiv2 a') y y'). - intros. simpl in |- *. case (Nbit0 a); reflexivity. - Qed. - - Lemma MapCard_Put_sum : - forall (m m':Map A) (a:ad) (y:A) (n n':nat), - m' = MapPut A m a y -> - n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}. - Proof. - simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. right. - rewrite H0. rewrite H1. reflexivity. - intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (Ndiscr (Nxor a a0)). intro H2. - elim H2. intros p H3. rewrite H3 in H. rewrite H in H1. - rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. simpl in H0. right. - rewrite H0. rewrite H1. reflexivity. - intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. simpl in H0. left. - rewrite H0. rewrite H1. reflexivity. - intros. simpl in H2. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. - elim (sumbool_of_bool (Nbit0 a)). intro H4. rewrite H4 in H1. - elim - (H0 (MapPut A m1 (Ndiv2 a) y) (Ndiv2 a) y ( - MapCard A m1) (MapCard A (MapPut A m1 (Ndiv2 a) y)) ( - refl_equal _) (refl_equal _) (refl_equal _)). - intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. left. - assumption. - intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. - rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)) in H3. - simpl in H3. rewrite <- H2 in H3. right. assumption. - intro H4. rewrite H4 in H1. - elim - (H (MapPut A m0 (Ndiv2 a) y) (Ndiv2 a) y ( - MapCard A m0) (MapCard A (MapPut A m0 (Ndiv2 a) y)) ( - refl_equal _) (refl_equal _) (refl_equal _)). - intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. - left. assumption. - intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. simpl in H3. rewrite <- H2 in H3. - right. assumption. - Qed. - - Lemma MapCard_Put_lb : - forall (m:Map A) (a:ad) (y:A), MapCard A (MapPut A m a y) >= MapCard A m. - Proof. - unfold ge in |- *. intros. - elim - (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) - (MapCard A (MapPut A m a y)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H. rewrite H. apply le_n. - intro H. rewrite H. apply le_n_Sn. - Qed. - - Lemma MapCard_Put_ub : - forall (m:Map A) (a:ad) (y:A), - MapCard A (MapPut A m a y) <= S (MapCard A m). - Proof. - intros. - elim - (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) - (MapCard A (MapPut A m a y)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H. rewrite H. apply le_n_Sn. - intro H. rewrite H. apply le_n. - Qed. - - Lemma MapCard_Put_1 : - forall (m:Map A) (a:ad) (y:A), - MapCard A (MapPut A m a y) = MapCard A m -> - {y : A | MapGet A m a = Some y}. - Proof. - simple induction m. intros. discriminate H. - intros a y a0 y0 H. simpl in H. elim (Ndiscr (Nxor a a0)). intro H0. elim H0. - intros p H1. rewrite H1 in H. rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H. - discriminate H. - intro H0. rewrite H0 in H. rewrite (Nxor_eq _ _ H0). split with y. apply M1_semantics_1. - intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. elim (sumbool_of_bool (Nbit0 a)). - intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (Ndiv2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). - intros y0 H3. split with y0. rewrite <- H3. exact (MapGet_M2_bit_0_1 A a H2 m0 m1). - intro H2. rewrite H2 in H1. simpl in H1. - rewrite - (plus_comm (MapCard A (MapPut A m0 (Ndiv2 a) y)) (MapCard A m1)) - in H1. - rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. - elim (H (Ndiv2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). intros y0 H3. split with y0. - rewrite <- H3. exact (MapGet_M2_bit_0_0 A a H2 m0 m1). - Qed. - - Lemma MapCard_Put_2 : - forall (m:Map A) (a:ad) (y:A), - MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = None. - Proof. - simple induction m. trivial. - intros. simpl in H. elim (sumbool_of_bool (Neqb a a1)). intro H0. - rewrite (Neqb_complete _ _ H0) in H. rewrite (Nxor_nilpotent a1) in H. discriminate H. - intro H0. exact (M1_semantics_2 A a a1 a0 H0). - intros. elim (sumbool_of_bool (Nbit0 a)). intro H2. - rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (Ndiv2 a) y). - apply (fun n m p:nat => plus_reg_l m p n) with (n := MapCard A m0). - rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). simpl in H1. simpl in |- *. rewrite <- H1. - clear H1. - induction a. discriminate H2. - induction p. reflexivity. - discriminate H2. - reflexivity. - intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (Ndiv2 a) y). - cut - (MapCard A (MapPut A m0 (Ndiv2 a) y) + MapCard A m1 = - S (MapCard A m0) + MapCard A m1). - intro. rewrite (plus_comm (MapCard A (MapPut A m0 (Ndiv2 a) y)) (MapCard A m1)) - in H3. - rewrite (plus_comm (S (MapCard A m0)) (MapCard A m1)) in H3. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H3). - simpl in |- *. simpl in H1. rewrite <- H1. induction a. trivial. - induction p. discriminate H2. - reflexivity. - discriminate H2. - Qed. - - Lemma MapCard_Put_1_conv : - forall (m:Map A) (a:ad) (y y':A), - MapGet A m a = Some y -> MapCard A (MapPut A m a y') = MapCard A m. - Proof. - intros. - elim - (MapCard_Put_sum m (MapPut A m a y') a y' (MapCard A m) - (MapCard A (MapPut A m a y')) (refl_equal _) ( - refl_equal _) (refl_equal _)). - trivial. - intro H0. rewrite (MapCard_Put_2 m a y' H0) in H. discriminate H. - Qed. - - Lemma MapCard_Put_2_conv : - forall (m:Map A) (a:ad) (y:A), - MapGet A m a = None -> MapCard A (MapPut A m a y) = S (MapCard A m). - Proof. - intros. - elim - (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) - (MapCard A (MapPut A m a y)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H0. elim (MapCard_Put_1 m a y H0). intros y' H1. rewrite H1 in H. discriminate H. - trivial. - Qed. - - Lemma MapCard_ext : - forall m m':Map A, - eqm A (MapGet A m) (MapGet A m') -> MapCard A m = MapCard A m'. - Proof. - unfold eqm in |- *. intros. rewrite (MapCard_as_length m). rewrite (MapCard_as_length m'). - rewrite (alist_canonical A (alist_of_Map A m) (alist_of_Map A m')). reflexivity. - unfold eqm in |- *. intro. rewrite (Map_of_alist_semantics A (alist_of_Map A m) a). - rewrite (Map_of_alist_semantics A (alist_of_Map A m') a). rewrite (Map_of_alist_of_Map A m' a). - rewrite (Map_of_alist_of_Map A m a). exact (H a). - apply alist_of_Map_sorts2. - apply alist_of_Map_sorts2. - Qed. - - Lemma MapCard_Dom : forall m:Map A, MapCard A m = MapCard unit (MapDom A m). - Proof. - simple induction m; trivial. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. - Qed. - - Lemma MapCard_Dom_Put_behind : - forall (m:Map A) (a:ad) (y:A), - MapDom A (MapPut_behind A m a y) = MapDom A (MapPut A m a y). - Proof. - simple induction m. trivial. - intros a y a0 y0. simpl in |- *. elim (Ndiscr (Nxor a a0)). intro H. elim H. - intros p H0. rewrite H0. reflexivity. - intro H. rewrite H. rewrite (Nxor_eq _ _ H). reflexivity. - intros. simpl in |- *. elim (Ndiscr a). intro H1. elim H1. intros p H2. rewrite H2. case p. - intro p0. simpl in |- *. rewrite H0. reflexivity. - intro p0. simpl in |- *. rewrite H. reflexivity. - simpl in |- *. rewrite H0. reflexivity. - intro H1. rewrite H1. simpl in |- *. rewrite H. reflexivity. - Qed. - - Lemma MapCard_Put_behind_Put : - forall (m:Map A) (a:ad) (y:A), - MapCard A (MapPut_behind A m a y) = MapCard A (MapPut A m a y). - Proof. - intros. rewrite MapCard_Dom. rewrite MapCard_Dom. rewrite MapCard_Dom_Put_behind. - reflexivity. - Qed. - - Lemma MapCard_Put_behind_sum : - forall (m m':Map A) (a:ad) (y:A) (n n':nat), - m' = MapPut_behind A m a y -> - n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}. - Proof. - intros. apply (MapCard_Put_sum m (MapPut A m a y) a y n n'); trivial. - rewrite <- MapCard_Put_behind_Put. rewrite <- H. assumption. - Qed. - - Lemma MapCard_makeM2 : - forall m m':Map A, MapCard A (makeM2 A m m') = MapCard A m + MapCard A m'. - Proof. - intros. rewrite (MapCard_ext _ _ (makeM2_M2 A m m')). reflexivity. - Qed. - - Lemma MapCard_Remove_sum : - forall (m m':Map A) (a:ad) (n n':nat), - m' = MapRemove A m a -> - n = MapCard A m -> n' = MapCard A m' -> {n = n'} + {n = S n'}. - Proof. - simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. left. rewrite H1. assumption. - simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. rewrite H2 in H. - rewrite H in H1. simpl in H1. right. rewrite H1. assumption. - intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. left. rewrite H1. assumption. - intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (Nbit0 a)). intro H4. - rewrite H4 in H1. rewrite H1 in H3. - rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H3. - elim - (H0 (MapRemove A m1 (Ndiv2 a)) (Ndiv2 a) ( - MapCard A m1) (MapCard A (MapRemove A m1 (Ndiv2 a))) - (refl_equal _) (refl_equal _) (refl_equal _)). - intro H5. rewrite H5 in H2. left. rewrite H3. exact H2. - intro H5. rewrite H5 in H2. - rewrite <- - (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 a)))) - in H2. - right. rewrite H3. exact H2. - intro H4. rewrite H4 in H1. rewrite H1 in H3. - rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H3. - elim - (H (MapRemove A m0 (Ndiv2 a)) (Ndiv2 a) ( - MapCard A m0) (MapCard A (MapRemove A m0 (Ndiv2 a))) - (refl_equal _) (refl_equal _) (refl_equal _)). - intro H5. rewrite H5 in H2. left. rewrite H3. exact H2. - intro H5. rewrite H5 in H2. right. rewrite H3. exact H2. - Qed. - - Lemma MapCard_Remove_ub : - forall (m:Map A) (a:ad), MapCard A (MapRemove A m a) <= MapCard A m. - Proof. - intros. - elim - (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) - (MapCard A (MapRemove A m a)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H. rewrite H. apply le_n. - intro H. rewrite H. apply le_n_Sn. - Qed. - - Lemma MapCard_Remove_lb : - forall (m:Map A) (a:ad), S (MapCard A (MapRemove A m a)) >= MapCard A m. - Proof. - unfold ge in |- *. intros. - elim - (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) - (MapCard A (MapRemove A m a)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H. rewrite H. apply le_n_Sn. - intro H. rewrite H. apply le_n. - Qed. - - Lemma MapCard_Remove_1 : - forall (m:Map A) (a:ad), - MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = None. - Proof. - simple induction m. trivial. - simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (Neqb a a0)). intro H0. - rewrite H0 in H. discriminate H. - intro H0. rewrite H0. reflexivity. - intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1. - rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H1. - rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). - intro H2. rewrite H2 in H1. - rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H1. - rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H. - rewrite - (plus_comm (MapCard A (MapRemove A m0 (Ndiv2 a))) (MapCard A m1)) - in H1. - rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). - Qed. - - Lemma MapCard_Remove_2 : - forall (m:Map A) (a:ad), - S (MapCard A (MapRemove A m a)) = MapCard A m -> - {y : A | MapGet A m a = Some y}. - Proof. - simple induction m. intros. discriminate H. - intros a y a0 H. simpl in H. elim (sumbool_of_bool (Neqb a a0)). intro H0. - rewrite (Neqb_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y). - intro H0. rewrite H0 in H. discriminate H. - intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1. - rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H1. - rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. - change - (S (MapCard A m0) + MapCard A (MapRemove A m1 (Ndiv2 a)) = - MapCard A m0 + MapCard A m1) in H1. - rewrite - (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 a)))) - in H1. - exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). - intro H2. rewrite H2 in H1. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H. - rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H1. - change - (S (MapCard A (MapRemove A m0 (Ndiv2 a))) + MapCard A m1 = - MapCard A m0 + MapCard A m1) in H1. - rewrite - (plus_comm (S (MapCard A (MapRemove A m0 (Ndiv2 a)))) (MapCard A m1)) - in H1. - rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). - Qed. - - Lemma MapCard_Remove_1_conv : - forall (m:Map A) (a:ad), - MapGet A m a = None -> MapCard A (MapRemove A m a) = MapCard A m. - Proof. - intros. - elim - (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) - (MapCard A (MapRemove A m a)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H0. rewrite H0. reflexivity. - intro H0. elim (MapCard_Remove_2 m a (sym_eq H0)). intros y H1. rewrite H1 in H. - discriminate H. - Qed. - - Lemma MapCard_Remove_2_conv : - forall (m:Map A) (a:ad) (y:A), - MapGet A m a = Some y -> S (MapCard A (MapRemove A m a)) = MapCard A m. - Proof. - intros. - elim - (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) - (MapCard A (MapRemove A m a)) (refl_equal _) ( - refl_equal _) (refl_equal _)). - intro H0. rewrite (MapCard_Remove_1 m a (sym_eq H0)) in H. discriminate H. - intro H0. rewrite H0. reflexivity. - Qed. - - Lemma MapMerge_Restr_Card : - forall m m':Map A, - MapCard A m + MapCard A m' = - MapCard A (MapMerge A m m') + MapCard A (MapDomRestrTo A A m m'). - Proof. - simple induction m. simpl in |- *. intro. apply plus_n_O. - simpl in |- *. intros a y m'. elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y0 H0. - rewrite H0. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_1_conv m' a y0 y H0). - simpl in |- *. rewrite <- plus_Snm_nSm. apply plus_n_O. - intro H. rewrite H. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_2_conv m' a y H). - apply plus_n_O. - intros. - change - (MapCard A m0 + MapCard A m1 + MapCard A m' = - MapCard A (MapMerge A (M2 A m0 m1) m') + - MapCard A (MapDomRestrTo A A (M2 A m0 m1) m')) - in |- *. - elim m'. reflexivity. - intros a y. unfold MapMerge in |- *. unfold MapDomRestrTo in |- *. - elim (option_sum A (MapGet A (M2 A m0 m1) a)). intro H1. elim H1. intros y0 H2. rewrite H2. - rewrite (MapCard_Put_1_conv (M2 A m0 m1) a y0 y H2). reflexivity. - intro H1. rewrite H1. rewrite (MapCard_Put_2_conv (M2 A m0 m1) a y H1). simpl in |- *. - rewrite <- (plus_Snm_nSm (MapCard A m0 + MapCard A m1) 0). reflexivity. - intros. simpl in |- *. - rewrite - (plus_permute_2_in_4 (MapCard A m0) (MapCard A m1) ( - MapCard A m2) (MapCard A m3)). - rewrite (H m2). rewrite (H0 m3). - rewrite - (MapCard_makeM2 (MapDomRestrTo A A m0 m2) (MapDomRestrTo A A m1 m3)) - . - apply plus_permute_2_in_4. - Qed. - - Lemma MapMerge_disjoint_Card : - forall m m':Map A, - MapDisjoint A A m m' -> - MapCard A (MapMerge A m m') = MapCard A m + MapCard A m'. - Proof. - intros. rewrite (MapMerge_Restr_Card m m'). - rewrite (MapCard_ext _ _ (MapDisjoint_imp_2 _ _ _ _ H)). apply plus_n_O. - Qed. - - Lemma MapSplit_Card : - forall (m:Map A) (m':Map B), - MapCard A m = - MapCard A (MapDomRestrTo A B m m') + MapCard A (MapDomRestrBy A B m m'). - Proof. - intros. rewrite (MapCard_ext _ _ (MapDom_Split_1 A B m m')). apply MapMerge_disjoint_Card. - apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. apply MapDom_Split_3. - Qed. - - Lemma MapMerge_Card_ub : - forall m m':Map A, - MapCard A (MapMerge A m m') <= MapCard A m + MapCard A m'. - Proof. - intros. rewrite MapMerge_Restr_Card. apply le_plus_l. - Qed. - - Lemma MapDomRestrTo_Card_ub_l : - forall (m:Map A) (m':Map B), - MapCard A (MapDomRestrTo A B m m') <= MapCard A m. - Proof. - intros. rewrite (MapSplit_Card m m'). apply le_plus_l. - Qed. - - Lemma MapDomRestrBy_Card_ub_l : - forall (m:Map A) (m':Map B), - MapCard A (MapDomRestrBy A B m m') <= MapCard A m. - Proof. - intros. rewrite (MapSplit_Card m m'). apply le_plus_r. - Qed. - - Lemma MapMerge_Card_disjoint : - forall m m':Map A, - MapCard A (MapMerge A m m') = MapCard A m + MapCard A m' -> - MapDisjoint A A m m'. - Proof. - simple induction m. intros. apply Map_M0_disjoint. - simpl in |- *. intros. rewrite (MapCard_Put_behind_Put m' a a0) in H. unfold MapDisjoint, in_dom in |- *. - simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. - rewrite (Neqb_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1. - discriminate H1. - intro H2. rewrite H2 in H0. discriminate H0. - simple induction m'. intros. apply Map_disjoint_M0. - intros a y H1. rewrite <- (MapCard_ext _ _ (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1. - unfold MapCard at 3 in H1. rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) 0) in H1. - rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. unfold MapDisjoint, in_dom in |- *. - unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H4. - rewrite <- (Neqb_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2. - discriminate H2. - intro H4. rewrite H4 in H3. discriminate H3. - intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H6. - unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := Ndiv2 a). apply le_antisym. - apply MapMerge_Card_ub. - apply (fun p n m:nat => plus_le_reg_l n m p) with - (p := MapCard A m0 + MapCard A m2). - rewrite - (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) ( - MapCard A m1) (MapCard A m3)). - change - (MapCard A (M2 A (MapMerge A m0 m2) (MapMerge A m1 m3)) = - MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) - in H3. - rewrite <- H3. simpl in |- *. apply plus_le_compat_r. apply MapMerge_Card_ub. - elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m0 m1) in H7. - unfold in_dom in |- *. rewrite H7. reflexivity. - elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m2 m3) in H7. - unfold in_dom in |- *. rewrite H7. reflexivity. - intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := Ndiv2 a). apply le_antisym. - apply MapMerge_Card_ub. - apply (fun p n m:nat => plus_le_reg_l n m p) with - (p := MapCard A m1 + MapCard A m3). - rewrite - (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A m0 + MapCard A m2)) - . - rewrite - (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) ( - MapCard A m1) (MapCard A m3)). - rewrite - (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A (MapMerge A m0 m2))) - . - change - (MapCard A (MapMerge A m0 m2) + MapCard A (MapMerge A m1 m3) = - MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) - in H3. - rewrite <- H3. apply plus_le_compat_l. apply MapMerge_Card_ub. - elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m0 m1) in H7. - unfold in_dom in |- *. rewrite H7. reflexivity. - elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m2 m3) in H7. - unfold in_dom in |- *. rewrite H7. reflexivity. - Qed. - - Lemma MapCard_is_Sn : - forall (m:Map A) (n:nat), - MapCard _ m = S n -> {a : ad | in_dom _ a m = true}. - Proof. - simple induction m. intros. discriminate H. - intros a y n H. split with a. unfold in_dom in |- *. rewrite (M1_semantics_1 _ a y). reflexivity. - intros. simpl in H1. elim (O_or_S (MapCard _ m0)). intro H2. elim H2. intros m2 H3. - elim (H _ (sym_eq H3)). intros a H4. split with (Ndouble a). unfold in_dom in |- *. - rewrite (MapGet_M2_bit_0_0 A (Ndouble a) (Ndouble_bit0 a) m0 m1). - rewrite (Ndouble_div2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity. - intro H2. rewrite <- H2 in H1. simpl in H1. elim (H0 _ H1). intros a H3. - split with (Ndouble_plus_one a). unfold in_dom in |- *. - rewrite - (MapGet_M2_bit_0_1 A (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a) - m0 m1). - rewrite (Ndouble_plus_one_div2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4. - reflexivity. - Qed. - -End MapCard. - -Section MapCard2. - - Variables A B : Set. - - Lemma MapSubset_card_eq_1 : - forall (n:nat) (m:Map A) (m':Map B), - MapSubset _ _ m m' -> - MapCard _ m = n -> MapCard _ m' = n -> MapSubset _ _ m' m. - Proof. - simple induction n. intros. unfold MapSubset, in_dom in |- *. intro. rewrite (MapCard_is_O _ m H0 a). - rewrite (MapCard_is_O _ m' H1 a). intro H2. discriminate H2. - intros. elim (MapCard_is_Sn A m n0 H1). intros a H3. elim (in_dom_some _ _ _ H3). - intros y H4. elim (in_dom_some _ _ _ (H0 _ H3)). intros y' H6. - cut (eqmap _ (MapPut _ (MapRemove _ m a) a y) m). intro. - cut (eqmap _ (MapPut _ (MapRemove _ m' a) a y') m'). intro. - apply MapSubset_ext with - (m0 := MapPut _ (MapRemove _ m' a) a y') - (m2 := MapPut _ (MapRemove _ m a) a y). - assumption. - assumption. - apply MapSubset_Put_mono. apply H. apply MapSubset_Remove_mono. assumption. - rewrite <- (MapCard_Remove_2_conv _ m a y H4) in H1. inversion_clear H1. reflexivity. - rewrite <- (MapCard_Remove_2_conv _ m' a y' H6) in H2. inversion_clear H2. reflexivity. - unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove B m' a) a y' a0). - elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7). - apply sym_eq. assumption. - intro H7. rewrite H7. rewrite (MapRemove_semantics _ m' a a0). rewrite H7. reflexivity. - unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove A m a) a y a0). - elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7). - apply sym_eq. assumption. - intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity. - Qed. - - Lemma MapDomRestrTo_Card_ub_r : - forall (m:Map A) (m':Map B), - MapCard A (MapDomRestrTo A B m m') <= MapCard B m'. - Proof. - simple induction m. intro. simpl in |- *. apply le_O_n. - intros a y m'. simpl in |- *. elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y0 H0. - rewrite H0. elim (MapCard_is_not_O B m' a y0 H0). intros n H1. rewrite H1. simpl in |- *. - apply le_n_S. apply le_O_n. - intro H. rewrite H. simpl in |- *. apply le_O_n. - simple induction m'. simpl in |- *. apply le_O_n. - - intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. - intro. simpl in |- *. apply le_n. - apply le_O_n. - intros. simpl in |- *. rewrite - (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3)) - . - apply plus_le_compat. apply H. - apply H0. - Qed. - -End MapCard2. - -Section MapCard3. - - Variables A B : Set. - - Lemma MapMerge_Card_lb_l : - forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m. - Proof. - unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m')). - rewrite (plus_comm (MapCard A m') (MapCard A m)). - rewrite (plus_comm (MapCard A m') (MapCard A (MapMerge A m m'))). - rewrite (MapMerge_Restr_Card A m m'). apply plus_le_compat_l. apply MapDomRestrTo_Card_ub_r. - Qed. - - Lemma MapMerge_Card_lb_r : - forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m'. - Proof. - unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m)). rewrite (MapMerge_Restr_Card A m m'). - rewrite - (plus_comm (MapCard A (MapMerge A m m')) - (MapCard A (MapDomRestrTo A A m m'))). - apply plus_le_compat_r. apply MapDomRestrTo_Card_ub_l. - Qed. - - Lemma MapDomRestrBy_Card_lb : - forall (m:Map A) (m':Map B), - MapCard B m' + MapCard A (MapDomRestrBy A B m m') >= MapCard A m. - Proof. - unfold ge in |- *. intros. rewrite (MapSplit_Card A B m m'). apply plus_le_compat_r. - apply MapDomRestrTo_Card_ub_r. - Qed. - - Lemma MapSubset_Card_le : - forall (m:Map A) (m':Map B), - MapSubset A B m m' -> MapCard A m <= MapCard B m'. - Proof. - intros. apply le_trans with (m := MapCard B m' + MapCard A (MapDomRestrBy A B m m')). - exact (MapDomRestrBy_Card_lb m m'). - rewrite (MapCard_ext _ _ _ (MapSubset_imp_2 _ _ _ _ H)). simpl in |- *. rewrite <- plus_n_O. - apply le_n. - Qed. - - Lemma MapSubset_card_eq : - forall (m:Map A) (m':Map B), - MapSubset _ _ m m' -> - MapCard _ m' <= MapCard _ m -> eqmap _ (MapDom _ m) (MapDom _ m'). - Proof. - intros. apply MapSubset_antisym. assumption. - cut (MapCard B m' = MapCard A m). intro. apply (MapSubset_card_eq_1 A B (MapCard A m)). - assumption. - reflexivity. - assumption. - apply le_antisym. assumption. - apply MapSubset_Card_le. assumption. - Qed. - -End MapCard3.
\ No newline at end of file diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v deleted file mode 100644 index eb58cb64..00000000 --- a/theories/IntMap/Mapfold.v +++ /dev/null @@ -1,425 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapfold.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Fset. -Require Import Mapaxioms. -Require Import Mapiter. -Require Import Lsort. -Require Import Mapsubset. -Require Import List. - -Section MapFoldResults. - - Variable A : Set. - - Variable M : Set. - Variable neutral : M. - Variable op : M -> M -> M. - - Variable nleft : forall a:M, op neutral a = a. - Variable nright : forall a:M, op a neutral = a. - Variable assoc : forall a b c:M, op (op a b) c = op a (op b c). - - Lemma MapFold_ext : - forall (f:ad -> A -> M) (m m':Map A), - eqmap A m m' -> MapFold _ _ neutral op f m = MapFold _ _ neutral op f m'. - Proof. - intros. rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m). - rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m'). - cut (alist_of_Map A m = alist_of_Map A m'). intro. rewrite H0. reflexivity. - apply alist_canonical. unfold eqmap in H. apply eqm_trans with (f' := MapGet A m). - apply eqm_sym. apply alist_of_Map_semantics. - apply eqm_trans with (f' := MapGet A m'). assumption. - apply alist_of_Map_semantics. - apply alist_of_Map_sorts2. - apply alist_of_Map_sorts2. - Qed. - - Lemma MapFold_ext_f_1 : - forall (m:Map A) (f g:ad -> A -> M) (pf:ad -> ad), - (forall (a:ad) (y:A), MapGet _ m a = Some y -> f (pf a) y = g (pf a) y) -> - MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op g pf m. - Proof. - simple induction m. trivial. - simpl in |- *. intros. apply H. rewrite (Neqb_correct a). reflexivity. - intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (Ndouble a0))). - rewrite (H0 f g (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity. - intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption. - apply Ndouble_plus_one_bit0. - intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption. - apply Ndouble_bit0. - Qed. - - Lemma MapFold_ext_f : - forall (f g:ad -> A -> M) (m:Map A), - (forall (a:ad) (y:A), MapGet _ m a = Some y -> f a y = g a y) -> - MapFold _ _ neutral op f m = MapFold _ _ neutral op g m. - Proof. - intros. exact (MapFold_ext_f_1 m f g (fun a0:ad => a0) H). - Qed. - - Lemma MapFold1_as_Fold_1 : - forall (m:Map A) (f f':ad -> A -> M) (pf pf':ad -> ad), - (forall (a:ad) (y:A), f (pf a) y = f' (pf' a) y) -> - MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f' pf' m. - Proof. - simple induction m. trivial. - intros. simpl in |- *. apply H. - intros. simpl in |- *. - rewrite - (H f f' (fun a0:ad => pf (Ndouble a0)) - (fun a0:ad => pf' (Ndouble a0))). - rewrite - (H0 f f' (fun a0:ad => pf (Ndouble_plus_one a0)) - (fun a0:ad => pf' (Ndouble_plus_one a0))). - reflexivity. - intros. apply H1. - intros. apply H1. - Qed. - - Lemma MapFold1_as_Fold : - forall (f:ad -> A -> M) (pf:ad -> ad) (m:Map A), - MapFold1 _ _ neutral op f pf m = - MapFold _ _ neutral op (fun (a:ad) (y:A) => f (pf a) y) m. - Proof. - intros. unfold MapFold in |- *. apply MapFold1_as_Fold_1. trivial. - Qed. - - Lemma MapFold1_ext : - forall (f:ad -> A -> M) (m m':Map A), - eqmap A m m' -> - forall pf:ad -> ad, - MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f pf m'. - Proof. - intros. rewrite MapFold1_as_Fold. rewrite MapFold1_as_Fold. apply MapFold_ext. assumption. - Qed. - - Variable comm : forall a b:M, op a b = op b a. - - Lemma MapFold_Put_disjoint_1 : - forall (p:positive) (f:ad -> A -> M) (pf:ad -> ad) - (a1 a2:ad) (y1 y2:A), - Nxor a1 a2 = Npos p -> - MapFold1 A M neutral op f pf (MapPut1 A a1 y1 a2 y2 p) = - op (f (pf a1) y1) (f (pf a2) y2). - Proof. - simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H1. rewrite H1. - simpl in |- *. rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double. apply comm. - change (Nbit0 a2 = negb true) in |- *. rewrite <- H1. rewrite (Nneg_bit0_2 _ _ _ H0). - rewrite negb_elim. reflexivity. - assumption. - intro H1. rewrite H1. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one. - reflexivity. - change (Nbit0 a2 = negb false) in |- *. rewrite <- H1. rewrite (Nneg_bit0_2 _ _ _ H0). - rewrite negb_elim. reflexivity. - assumption. - simpl in |- *. intros. elim (sumbool_of_bool (Nbit0 a1)). intro H1. rewrite H1. simpl in |- *. - rewrite nleft. - rewrite - (H f (fun a0:ad => pf (Ndouble_plus_one a0)) ( - Ndiv2 a1) (Ndiv2 a2) y1 y2). - rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double_plus_one. reflexivity. - unfold Nodd. - rewrite <- (Nsame_bit0 _ _ _ H0). assumption. - assumption. - rewrite <- Nxor_div2. rewrite H0. reflexivity. - intro H1. rewrite H1. simpl in |- *. rewrite nright. - rewrite - (H f (fun a0:ad => pf (Ndouble a0)) (Ndiv2 a1) (Ndiv2 a2) y1 y2) - . - rewrite Ndiv2_double. rewrite Ndiv2_double. reflexivity. - unfold Neven. - rewrite <- (Nsame_bit0 _ _ _ H0). assumption. - assumption. - rewrite <- Nxor_div2. rewrite H0. reflexivity. - intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H0. rewrite H0. simpl in |- *. - rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one. apply comm. - assumption. - change (Nbit0 a2 = negb true) in |- *. rewrite <- H0. rewrite (Nneg_bit0_1 _ _ H). - rewrite negb_elim. reflexivity. - intro H0. rewrite H0. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one. - reflexivity. - change (Nbit0 a2 = negb false) in |- *. rewrite <- H0. rewrite (Nneg_bit0_1 _ _ H). - rewrite negb_elim. reflexivity. - assumption. - Qed. - - Lemma MapFold_Put_disjoint_2 : - forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad), - MapGet A m a = None -> - MapFold1 A M neutral op f pf (MapPut A m a y) = - op (f (pf a) y) (MapFold1 A M neutral op f pf m). - Proof. - simple induction m. intros. simpl in |- *. rewrite (nright (f (pf a) y)). reflexivity. - intros a1 y1 a2 y2 pf H. simpl in |- *. elim (Ndiscr (Nxor a1 a2)). intro H0. elim H0. - intros p H1. rewrite H1. rewrite comm. exact (MapFold_Put_disjoint_1 p f pf a1 a2 y1 y2 H1). - intro H0. rewrite (Neqb_complete _ _ (Nxor_eq_true _ _ H0)) in H. - rewrite (M1_semantics_1 A a2 y1) in H. discriminate H. - intros. elim (sumbool_of_bool (Nbit0 a)). intro H2. - cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (Ndiv2 a) y)). intro. - rewrite H3. simpl in |- *. rewrite (H0 (Ndiv2 a) y (fun a0:ad => pf (Ndouble_plus_one a0))). - rewrite Ndiv2_double_plus_one. rewrite <- assoc. - rewrite - (comm (MapFold1 A M neutral op f (fun a0:ad => pf (Ndouble a0)) m0) - (f (pf a) y)). - rewrite assoc. reflexivity. - assumption. - rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. assumption. - simpl in |- *. elim (Ndiscr a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5. - reflexivity. - intros p0 H4 H5. rewrite H5 in H2. discriminate H2. - intro H4. rewrite H4. reflexivity. - intro H3. rewrite H3 in H2. discriminate H2. - intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (Ndiv2 a) y) m1). - intro. rewrite H3. simpl in |- *. rewrite (H (Ndiv2 a) y (fun a0:ad => pf (Ndouble a0))). - rewrite Ndiv2_double. rewrite <- assoc. reflexivity. - assumption. - rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. assumption. - simpl in |- *. elim (Ndiscr a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5 in H2. - discriminate H2. - intros p0 H4 H5. rewrite H5. reflexivity. - intro H4. rewrite H4 in H2. discriminate H2. - intro H3. rewrite H3. reflexivity. - Qed. - - Lemma MapFold_Put_disjoint : - forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A), - MapGet A m a = None -> - MapFold A M neutral op f (MapPut A m a y) = - op (f a y) (MapFold A M neutral op f m). - Proof. - intros. exact (MapFold_Put_disjoint_2 f m a y (fun a0:ad => a0) H). - Qed. - - Lemma MapFold_Put_behind_disjoint_2 : - forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad), - MapGet A m a = None -> - MapFold1 A M neutral op f pf (MapPut_behind A m a y) = - op (f (pf a) y) (MapFold1 A M neutral op f pf m). - Proof. - intros. cut (eqmap A (MapPut_behind A m a y) (MapPut A m a y)). intro. - rewrite (MapFold1_ext f _ _ H0 pf). apply MapFold_Put_disjoint_2. assumption. - apply eqmap_trans with (m' := MapMerge A (M1 A a y) m). apply MapPut_behind_as_Merge. - apply eqmap_trans with (m' := MapMerge A m (M1 A a y)). - apply eqmap_trans with (m' := MapDelta A (M1 A a y) m). apply eqmap_sym. apply MapDelta_disjoint. - unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). - intro H2. rewrite (Neqb_complete _ _ H2) in H. rewrite H in H1. discriminate H1. - intro H2. rewrite H2 in H0. discriminate H0. - apply eqmap_trans with (m' := MapDelta A m (M1 A a y)). apply MapDelta_sym. - apply MapDelta_disjoint. unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. - elim (sumbool_of_bool (Neqb a a0)). intro H2. rewrite (Neqb_complete _ _ H2) in H. - rewrite H in H0. discriminate H0. - intro H2. rewrite H2 in H1. discriminate H1. - apply eqmap_sym. apply MapPut_as_Merge. - Qed. - - Lemma MapFold_Put_behind_disjoint : - forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A), - MapGet A m a = None -> - MapFold A M neutral op f (MapPut_behind A m a y) = - op (f a y) (MapFold A M neutral op f m). - Proof. - intros. exact (MapFold_Put_behind_disjoint_2 f m a y (fun a0:ad => a0) H). - Qed. - - Lemma MapFold_Merge_disjoint_1 : - forall (f:ad -> A -> M) (m1 m2:Map A) (pf:ad -> ad), - MapDisjoint A A m1 m2 -> - MapFold1 A M neutral op f pf (MapMerge A m1 m2) = - op (MapFold1 A M neutral op f pf m1) (MapFold1 A M neutral op f pf m2). - Proof. - simple induction m1. simpl in |- *. intros. rewrite nleft. reflexivity. - intros. unfold MapMerge in |- *. apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf). - apply in_dom_none. exact (MapDisjoint_M1_l _ _ m2 a a0 H). - simple induction m2. intros. simpl in |- *. rewrite nright. reflexivity. - intros. unfold MapMerge in |- *. rewrite (MapFold_Put_disjoint_2 f (M2 A m m0) a a0 pf). apply comm. - apply in_dom_none. exact (MapDisjoint_M1_r _ _ (M2 A m m0) a a0 H1). - intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (Ndouble a0))). - rewrite (H0 m4 (fun a0:ad => pf (Ndouble_plus_one a0))). - cut (forall a b c d:M, op (op a b) (op c d) = op (op a c) (op b d)). intro. apply H4. - intros. rewrite assoc. rewrite <- (assoc b c d). rewrite (comm b c). rewrite (assoc c b d). - rewrite assoc. reflexivity. - exact (MapDisjoint_M2_r _ _ _ _ _ _ H3). - exact (MapDisjoint_M2_l _ _ _ _ _ _ H3). - Qed. - - Lemma MapFold_Merge_disjoint : - forall (f:ad -> A -> M) (m1 m2:Map A), - MapDisjoint A A m1 m2 -> - MapFold A M neutral op f (MapMerge A m1 m2) = - op (MapFold A M neutral op f m1) (MapFold A M neutral op f m2). - Proof. - intros. exact (MapFold_Merge_disjoint_1 f m1 m2 (fun a0:ad => a0) H). - Qed. - -End MapFoldResults. - -Section MapFoldDistr. - - Variable A : Set. - - Variable M : Set. - Variable neutral : M. - Variable op : M -> M -> M. - - Variable M' : Set. - Variable neutral' : M'. - Variable op' : M' -> M' -> M'. - - Variable N : Set. - - Variable times : M -> N -> M'. - - Variable absorb : forall c:N, times neutral c = neutral'. - Variable - distr : - forall (a b:M) (c:N), times (op a b) c = op' (times a c) (times b c). - - Lemma MapFold_distr_r_1 : - forall (f:ad -> A -> M) (m:Map A) (c:N) (pf:ad -> ad), - times (MapFold1 A M neutral op f pf m) c = - MapFold1 A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) pf m. - Proof. - simple induction m. intros. exact (absorb c). - trivial. - intros. simpl in |- *. rewrite distr. rewrite H. rewrite H0. reflexivity. - Qed. - - Lemma MapFold_distr_r : - forall (f:ad -> A -> M) (m:Map A) (c:N), - times (MapFold A M neutral op f m) c = - MapFold A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) m. - Proof. - intros. exact (MapFold_distr_r_1 f m c (fun a:ad => a)). - Qed. - -End MapFoldDistr. - -Section MapFoldDistrL. - - Variable A : Set. - - Variable M : Set. - Variable neutral : M. - Variable op : M -> M -> M. - - Variable M' : Set. - Variable neutral' : M'. - Variable op' : M' -> M' -> M'. - - Variable N : Set. - - Variable times : N -> M -> M'. - - Variable absorb : forall c:N, times c neutral = neutral'. - Variable - distr : - forall (a b:M) (c:N), times c (op a b) = op' (times c a) (times c b). - - Lemma MapFold_distr_l : - forall (f:ad -> A -> M) (m:Map A) (c:N), - times c (MapFold A M neutral op f m) = - MapFold A M' neutral' op' (fun (a:ad) (y:A) => times c (f a y)) m. - Proof. - intros. apply MapFold_distr_r with (times := fun (a:M) (b:N) => times b a); - assumption. - Qed. - -End MapFoldDistrL. - -Section MapFoldExists. - - Variable A : Set. - - Lemma MapFold_orb_1 : - forall (f:ad -> A -> bool) (m:Map A) (pf:ad -> ad), - MapFold1 A bool false orb f pf m = - match MapSweep1 A f pf m with - | Some _ => true - | _ => false - end. - Proof. - simple induction m. trivial. - intros a y pf. simpl in |- *. unfold MapSweep2 in |- *. case (f (pf a) y); reflexivity. - intros. simpl in |- *. rewrite (H (fun a0:ad => pf (Ndouble a0))). - rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). - case (MapSweep1 A f (fun a0:ad => pf (Ndouble a0)) m0); reflexivity. - Qed. - - Lemma MapFold_orb : - forall (f:ad -> A -> bool) (m:Map A), - MapFold A bool false orb f m = - match MapSweep A f m with - | Some _ => true - | _ => false - end. - Proof. - intros. exact (MapFold_orb_1 f m (fun a:ad => a)). - Qed. - -End MapFoldExists. - -Section DMergeDef. - - Variable A : Set. - - Definition DMerge := - MapFold (Map A) (Map A) (M0 A) (MapMerge A) (fun (_:ad) (m:Map A) => m). - - Lemma in_dom_DMerge_1 : - forall (m:Map (Map A)) (a:ad), - in_dom A a (DMerge m) = - match MapSweep _ (fun (_:ad) (m0:Map A) => in_dom A a m0) m with - | Some _ => true - | _ => false - end. - Proof. - unfold DMerge in |- *. intros. - rewrite - (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false orb ad - (in_dom A) (fun c:ad => refl_equal _) (in_dom_merge A)) - . - apply MapFold_orb. - Qed. - - Lemma in_dom_DMerge_2 : - forall (m:Map (Map A)) (a:ad), - in_dom A a (DMerge m) = true -> - {b : ad & - {m0 : Map A | MapGet _ m b = Some m0 /\ in_dom A a m0 = true}}. - Proof. - intros m a. rewrite in_dom_DMerge_1. - elim - (option_sum _ - (MapSweep (Map A) (fun (_:ad) (m0:Map A) => in_dom A a m0) m)). - intro H. elim H. intro r. elim r. intros b m0 H0. intro. split with b. split with m0. - split. exact (MapSweep_semantics_2 _ _ _ _ _ H0). - exact (MapSweep_semantics_1 _ _ _ _ _ H0). - intro H. rewrite H. intro. discriminate H0. - Qed. - - Lemma in_dom_DMerge_3 : - forall (m:Map (Map A)) (a b:ad) (m0:Map A), - MapGet _ m a = Some m0 -> - in_dom A b m0 = true -> in_dom A b (DMerge m) = true. - Proof. - intros m a b m0 H H0. rewrite in_dom_DMerge_1. - elim - (MapSweep_semantics_4 _ (fun (_:ad) (m'0:Map A) => in_dom A b m'0) _ _ _ - H H0). - intros a' H1. elim H1. intros m'0 H2. rewrite H2. reflexivity. - Qed. - -End DMergeDef.
\ No newline at end of file diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v deleted file mode 100644 index a8ba7e39..00000000 --- a/theories/IntMap/Mapiter.v +++ /dev/null @@ -1,618 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapiter.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Mapaxioms. -Require Import Fset. -Require Import List. - -Section MapIter. - - Variable A : Set. - - Section MapSweepDef. - - Variable f : ad -> A -> bool. - - Definition MapSweep2 (a0:ad) (y:A) := - if f a0 y then Some (a0, y) else None. - - Fixpoint MapSweep1 (pf:ad -> ad) (m:Map A) {struct m} : - option (ad * A) := - match m with - | M0 => None - | M1 a y => MapSweep2 (pf a) y - | M2 m m' => - match MapSweep1 (fun a:ad => pf (Ndouble a)) m with - | Some r => Some r - | None => MapSweep1 (fun a:ad => pf (Ndouble_plus_one a)) m' - end - end. - - Definition MapSweep (m:Map A) := MapSweep1 (fun a:ad => a) m. - - Lemma MapSweep_semantics_1_1 : - forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), - MapSweep1 pf m = Some (a, y) -> f a y = true. - Proof. - simple induction m. intros. discriminate H. - simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (f (pf a) y)). intro H. unfold MapSweep2 in |- *. - rewrite H. intro H0. inversion H0. rewrite <- H3. assumption. - intro H. unfold MapSweep2 in |- *. rewrite H. intro H0. discriminate H0. - simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). - intro H2. elim H2. intros r H3. rewrite H3 in H1. inversion H1. rewrite H5 in H3. - exact (H (fun a0:ad => pf (Ndouble a0)) a y H3). - intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H1). - Qed. - - Lemma MapSweep_semantics_1 : - forall (m:Map A) (a:ad) (y:A), MapSweep m = Some (a, y) -> f a y = true. - Proof. - intros. exact (MapSweep_semantics_1_1 m (fun a:ad => a) a y H). - Qed. - - Lemma MapSweep_semantics_2_1 : - forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), - MapSweep1 pf m = Some (a, y) -> {a' : ad | a = pf a'}. - Proof. - simple induction m. intros. discriminate H. - simpl in |- *. unfold MapSweep2 in |- *. intros a y pf a0 y0. case (f (pf a) y). intros. split with a. - inversion H. reflexivity. - intro. discriminate H. - intros m0 H m1 H0 pf a y. simpl in |- *. - elim - (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H1. elim H1. - intros r H2. rewrite H2. intro H3. inversion H3. rewrite H5 in H2. - elim (H (fun a0:ad => pf (Ndouble a0)) a y H2). intros a0 H6. split with (Ndouble a0). - assumption. - intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H2). - intros a0 H3. split with (Ndouble_plus_one a0). assumption. - Qed. - - Lemma MapSweep_semantics_2_2 : - forall (m:Map A) (pf fp:ad -> ad), - (forall a0:ad, fp (pf a0) = a0) -> - forall (a:ad) (y:A), - MapSweep1 pf m = Some (a, y) -> MapGet A m (fp a) = Some y. - Proof. - simple induction m. intros. discriminate H0. - simpl in |- *. intros a y pf fp H a0 y0. unfold MapSweep2 in |- *. elim (sumbool_of_bool (f (pf a) y)). - intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (Neqb_correct a). - reflexivity. - intro H0. rewrite H0. intro H1. discriminate H1. - intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (Nbit0 (fp a))). - intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). - intro H4. simpl in H2. apply - (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) - (fun a0:ad => Ndiv2 (fp a0))). - intro. rewrite H1. apply Ndouble_plus_one_div2. - elim - (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H5. elim H5. - intros r H6. rewrite H6 in H2. inversion H2. rewrite H8 in H6. - elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (Ndouble a0)) a y H6). intros a0 H9. - rewrite H9 in H3. rewrite (H1 (Ndouble a0)) in H3. rewrite (Ndouble_bit0 a0) in H3. - discriminate H3. - intro H5. rewrite H5 in H2. assumption. - intro H4. simpl in H2. rewrite H4 in H2. - apply - (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) - (fun a0:ad => Ndiv2 (fp a0))). intro. - rewrite H1. apply Ndouble_plus_one_div2. - assumption. - intro H3. rewrite H3. simpl in H2. - elim - (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H4. elim H4. - intros r H5. rewrite H5 in H2. inversion H2. rewrite H7 in H5. - apply - (H (fun a0:ad => pf (Ndouble a0)) (fun a0:ad => Ndiv2 (fp a0))). intro. rewrite H1. - apply Ndouble_div2. - assumption. - intro H4. rewrite H4 in H2. - elim - (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (Ndouble_plus_one a0)) a y - H2). - intros a0 H5. rewrite H5 in H3. rewrite (H1 (Ndouble_plus_one a0)) in H3. - rewrite (Ndouble_plus_one_bit0 a0) in H3. discriminate H3. - Qed. - - Lemma MapSweep_semantics_2 : - forall (m:Map A) (a:ad) (y:A), - MapSweep m = Some (a, y) -> MapGet A m a = Some y. - Proof. - intros. - exact - (MapSweep_semantics_2_2 m (fun a0:ad => a0) (fun a0:ad => a0) - (fun a0:ad => refl_equal a0) a y H). - Qed. - - Lemma MapSweep_semantics_3_1 : - forall (m:Map A) (pf:ad -> ad), - MapSweep1 pf m = None -> - forall (a:ad) (y:A), MapGet A m a = Some y -> f (pf a) y = false. - Proof. - simple induction m. intros. discriminate H0. - simpl in |- *. unfold MapSweep2 in |- *. intros a y pf. elim (sumbool_of_bool (f (pf a) y)). intro H. - rewrite H. intro. discriminate H0. - intro H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (Neqb a a0)). intro H1. rewrite H1. - intro H2. inversion H2. rewrite <- H4. rewrite <- (Neqb_complete _ _ H1). assumption. - intro H1. rewrite H1. intro. discriminate H2. - intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (Ndouble a)) m0)). - intro H3. elim H3. intros r H4. rewrite H4 in H1. discriminate H1. - intro H3. rewrite H3 in H1. elim (sumbool_of_bool (Nbit0 a)). intro H4. - rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double_plus_one a H4). - exact (H0 (fun a:ad => pf (Ndouble_plus_one a)) H1 (Ndiv2 a) y H2). - intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double a H4). - exact (H (fun a:ad => pf (Ndouble a)) H3 (Ndiv2 a) y H2). - Qed. - - Lemma MapSweep_semantics_3 : - forall m:Map A, - MapSweep m = None -> - forall (a:ad) (y:A), MapGet A m a = Some y -> f a y = false. - Proof. - intros. - exact (MapSweep_semantics_3_1 m (fun a0:ad => a0) H a y H0). - Qed. - - Lemma MapSweep_semantics_4_1 : - forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), - MapGet A m a = Some y -> - f (pf a) y = true -> - {a' : ad & {y' : A | MapSweep1 pf m = Some (a', y')}}. - Proof. - simple induction m. intros. discriminate H. - intros. elim (sumbool_of_bool (Neqb a a1)). intro H1. split with (pf a1). split with y. - rewrite (Neqb_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *. - rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 _ a1 a0) in H. - inversion H. rewrite H0. reflexivity. - - intro H1. rewrite (M1_semantics_2 _ a a1 a0 H1) in H. discriminate H. - - intros. elim (sumbool_of_bool (Nbit0 a)). intro H3. - rewrite (MapGet_M2_bit_0_1 _ _ H3 m0 m1) in H1. - rewrite <- (Ndiv2_double_plus_one a H3) in H2. - elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) y H1 H2). intros a'' H4. elim H4. - intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (Ndouble a)) m0)). - intro H6. elim H6. intro r. elim r. intros a''' y''' H7. rewrite H7. split with a'''. - split with y'''. reflexivity. - intro H6. rewrite H6. split with a''. split with y''. assumption. - intro H3. rewrite (MapGet_M2_bit_0_0 _ _ H3 m0 m1) in H1. - rewrite <- (Ndiv2_double a H3) in H2. - elim (H (fun a0:ad => pf (Ndouble a0)) (Ndiv2 a) y H1 H2). intros a'' H4. elim H4. - intros y'' H5. split with a''. split with y''. simpl in |- *. rewrite H5. reflexivity. - Qed. - - Lemma MapSweep_semantics_4 : - forall (m:Map A) (a:ad) (y:A), - MapGet A m a = Some y -> - f a y = true -> {a' : ad & {y' : A | MapSweep m = Some (a', y')}}. - Proof. - intros. exact (MapSweep_semantics_4_1 m (fun a0:ad => a0) a y H H0). - Qed. - - End MapSweepDef. - - Variable B : Set. - - Fixpoint MapCollect1 (f:ad -> A -> Map B) (pf:ad -> ad) - (m:Map A) {struct m} : Map B := - match m with - | M0 => M0 B - | M1 a y => f (pf a) y - | M2 m1 m2 => - MapMerge B (MapCollect1 f (fun a0:ad => pf (Ndouble a0)) m1) - (MapCollect1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2) - end. - - Definition MapCollect (f:ad -> A -> Map B) (m:Map A) := - MapCollect1 f (fun a:ad => a) m. - - Section MapFoldDef. - - Variable M : Set. - Variable neutral : M. - Variable op : M -> M -> M. - - Fixpoint MapFold1 (f:ad -> A -> M) (pf:ad -> ad) - (m:Map A) {struct m} : M := - match m with - | M0 => neutral - | M1 a y => f (pf a) y - | M2 m1 m2 => - op (MapFold1 f (fun a0:ad => pf (Ndouble a0)) m1) - (MapFold1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2) - end. - - Definition MapFold (f:ad -> A -> M) (m:Map A) := - MapFold1 f (fun a:ad => a) m. - - Lemma MapFold_empty : forall f:ad -> A -> M, MapFold f (M0 A) = neutral. - Proof. - trivial. - Qed. - - Lemma MapFold_M1 : - forall (f:ad -> A -> M) (a:ad) (y:A), MapFold f (M1 A a y) = f a y. - Proof. - trivial. - Qed. - - Variable State : Set. - Variable f : State -> ad -> A -> State * M. - - Fixpoint MapFold1_state (state:State) (pf:ad -> ad) - (m:Map A) {struct m} : State * M := - match m with - | M0 => (state, neutral) - | M1 a y => f state (pf a) y - | M2 m1 m2 => - match MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m1 with - | (state1, x1) => - match - MapFold1_state state1 - (fun a0:ad => pf (Ndouble_plus_one a0)) m2 - with - | (state2, x2) => (state2, op x1 x2) - end - end - end. - - Definition MapFold_state (state:State) := - MapFold1_state state (fun a:ad => a). - - Lemma pair_sp : forall (B C:Set) (x:B * C), x = (fst x, snd x). - Proof. - simple induction x. trivial. - Qed. - - Lemma MapFold_state_stateless_1 : - forall (m:Map A) (g:ad -> A -> M) (pf:ad -> ad), - (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) -> - forall state:State, snd (MapFold1_state state pf m) = MapFold1 g pf m. - Proof. - simple induction m. trivial. - intros. simpl in |- *. apply H. - intros. simpl in |- *. rewrite - (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0)) - . - rewrite (H g (fun a0:ad => pf (Ndouble a0)) H1 state). - rewrite - (pair_sp _ _ - (MapFold1_state - (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0)) - (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) - . - simpl in |- *. - rewrite - (H0 g (fun a0:ad => pf (Ndouble_plus_one a0)) H1 - (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0))) - . - reflexivity. - Qed. - - Lemma MapFold_state_stateless : - forall g:ad -> A -> M, - (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) -> - forall (state:State) (m:Map A), - snd (MapFold_state state m) = MapFold g m. - Proof. - intros. exact (MapFold_state_stateless_1 m g (fun a0:ad => a0) H state). - Qed. - - End MapFoldDef. - - Lemma MapCollect_as_Fold : - forall (f:ad -> A -> Map B) (m:Map A), - MapCollect f m = MapFold (Map B) (M0 B) (MapMerge B) f m. - Proof. - simple induction m; trivial. - Qed. - - Definition alist := list (ad * A). - Definition anil := nil (A:=(ad * A)). - Definition acons := cons (A:=(ad * A)). - Definition aapp := app (A:=(ad * A)). - - Definition alist_of_Map := - MapFold alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil). - - Fixpoint alist_semantics (l:alist) : ad -> option A := - match l with - | nil => fun _:ad => None - | (a, y) :: l' => - fun a0:ad => if Neqb a a0 then Some y else alist_semantics l' a0 - end. - - Lemma alist_semantics_app : - forall (l l':alist) (a:ad), - alist_semantics (aapp l l') a = - match alist_semantics l a with - | None => alist_semantics l' a - | Some y => Some y - end. - Proof. - unfold aapp in |- *. simple induction l. trivial. - intros. elim a. intros a1 y1. simpl in |- *. case (Neqb a1 a0). reflexivity. - apply H. - Qed. - - Lemma alist_of_Map_semantics_1_1 : - forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), - alist_semantics - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) pf - m) a = Some y -> {a' : ad | a = pf a'}. - Proof. - simple induction m. simpl in |- *. intros. discriminate H. - simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (Neqb (pf a) a0)). intro H. rewrite H. - intro H0. split with a. rewrite (Neqb_complete _ _ H). reflexivity. - intro H. rewrite H. intro H0. discriminate H0. - intros. change - (alist_semantics - (aapp - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) - (fun a0:ad => pf (Ndouble a0)) m0) - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) - (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) a = - Some y) in H1. - rewrite - (alist_semantics_app - (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil) - (fun a0:ad => pf (Ndouble a0)) m0) - (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil) - (fun a0:ad => pf (Ndouble_plus_one a0)) m1) a) - in H1. - elim - (option_sum A - (alist_semantics - (MapFold1 alist anil aapp - (fun (a0:ad) (y0:A) => acons (a0, y0) anil) - (fun a0:ad => pf (Ndouble a0)) m0) a)). - intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (Ndouble a0)) a y0 H3). intros a0 H4. - split with (Ndouble a0). assumption. - intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H1). - intros a0 H3. split with (Ndouble_plus_one a0). assumption. - Qed. - - Definition ad_inj (pf:ad -> ad) := - forall a0 a1:ad, pf a0 = pf a1 -> a0 = a1. - - Lemma ad_comp_double_inj : - forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble a0)). - Proof. - unfold ad_inj in |- *. intros. apply Ndouble_inj. exact (H _ _ H0). - Qed. - - Lemma ad_comp_double_plus_un_inj : - forall pf:ad -> ad, - ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble_plus_one a0)). - Proof. - unfold ad_inj in |- *. intros. apply Ndouble_plus_one_inj. exact (H _ _ H0). - Qed. - - Lemma alist_of_Map_semantics_1 : - forall (m:Map A) (pf:ad -> ad), - ad_inj pf -> - forall a:ad, - MapGet A m a = - alist_semantics - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) - pf m) (pf a). - Proof. - simple induction m. trivial. - simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. - rewrite (Neqb_complete _ _ H0). rewrite (Neqb_correct (pf a1)). reflexivity. - intro H0. rewrite H0. elim (sumbool_of_bool (Neqb (pf a) (pf a1))). intro H1. - rewrite (H a a1 (Neqb_complete _ _ H1)) in H0. rewrite (Neqb_correct a1) in H0. - discriminate H0. - intro H1. rewrite H1. reflexivity. - intros. change - (MapGet A (M2 A m0 m1) a = - alist_semantics - (aapp - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) - (fun a0:ad => pf (Ndouble a0)) m0) - (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) - (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) ( - pf a)) in |- *. - rewrite alist_semantics_app. rewrite (MapGet_M2_bit_0_if A m0 m1 a). - elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3. - rewrite (Ndouble_bit0 a0). - rewrite <- - (H (fun a1:ad => pf (Ndouble a1)) (ad_comp_double_inj pf H1) a0) - . - rewrite Ndouble_div2. case (MapGet A m0 a0); trivial. - elim - (option_sum A - (alist_semantics - (MapFold1 alist anil aapp - (fun (a1:ad) (y:A) => acons (a1, y) anil) - (fun a1:ad => pf (Ndouble_plus_one a1)) m1) - (pf (Ndouble a0)))). - intro H4. elim H4. intros y H5. - elim - (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (Ndouble_plus_one a1)) - (pf (Ndouble a0)) y H5). - intros a1 H6. cut (Nbit0 (Ndouble a0) = Nbit0 (Ndouble_plus_one a1)). - intro. rewrite (Ndouble_bit0 a0) in H7. rewrite (Ndouble_plus_one_bit0 a1) in H7. - discriminate H7. - rewrite (H1 (Ndouble a0) (Ndouble_plus_one a1) H6). reflexivity. - intro H4. rewrite H4. reflexivity. - intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (Ndouble_plus_one_bit0 a0). - rewrite <- - (H0 (fun a1:ad => pf (Ndouble_plus_one a1)) - (ad_comp_double_plus_un_inj pf H1) a0). - rewrite Ndouble_plus_one_div2. - elim - (option_sum A - (alist_semantics - (MapFold1 alist anil aapp - (fun (a1:ad) (y:A) => acons (a1, y) anil) - (fun a1:ad => pf (Ndouble a1)) m0) - (pf (Ndouble_plus_one a0)))). - intro H4. elim H4. intros y H5. - elim - (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (Ndouble a1)) - (pf (Ndouble_plus_one a0)) y H5). - intros a1 H6. cut (Nbit0 (Ndouble_plus_one a0) = Nbit0 (Ndouble a1)). - intro H7. rewrite (Ndouble_plus_one_bit0 a0) in H7. rewrite (Ndouble_bit0 a1) in H7. - discriminate H7. - rewrite (H1 (Ndouble_plus_one a0) (Ndouble a1) H6). reflexivity. - intro H4. rewrite H4. reflexivity. - Qed. - - Lemma alist_of_Map_semantics : - forall m:Map A, eqm A (MapGet A m) (alist_semantics (alist_of_Map m)). - Proof. - unfold eqm in |- *. intros. exact - (alist_of_Map_semantics_1 m (fun a0:ad => a0) - (fun (a0 a1:ad) (p:a0 = a1) => p) a). - Qed. - - Fixpoint Map_of_alist (l:alist) : Map A := - match l with - | nil => M0 A - | (a, y) :: l' => MapPut A (Map_of_alist l') a y - end. - - Lemma Map_of_alist_semantics : - forall l:alist, eqm A (alist_semantics l) (MapGet A (Map_of_alist l)). - Proof. - unfold eqm in |- *. simple induction l. trivial. - intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (Neqb a0 a)). - intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0). - rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (Neqb_correct a). - reflexivity. - intro H0. rewrite H0. rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a). - rewrite H0. apply H. - Qed. - - Lemma Map_of_alist_of_Map : - forall m:Map A, eqmap A (Map_of_alist (alist_of_Map m)) m. - Proof. - unfold eqmap in |- *. intro. apply eqm_trans with (f' := alist_semantics (alist_of_Map m)). - apply eqm_sym. apply Map_of_alist_semantics. - apply eqm_sym. apply alist_of_Map_semantics. - Qed. - - Lemma alist_of_Map_of_alist : - forall l:alist, - eqm A (alist_semantics (alist_of_Map (Map_of_alist l))) - (alist_semantics l). - Proof. - intro. apply eqm_trans with (f' := MapGet A (Map_of_alist l)). - apply eqm_sym. apply alist_of_Map_semantics. - apply eqm_sym. apply Map_of_alist_semantics. - Qed. - - Lemma fold_right_aapp : - forall (M:Set) (neutral:M) (op:M -> M -> M), - (forall a b c:M, op (op a b) c = op a (op b c)) -> - (forall a:M, op neutral a = a) -> - forall (f:ad -> A -> M) (l l':alist), - fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) - neutral (aapp l l') = - op - (fold_right - (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral - l) - (fold_right - (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral - l'). - Proof. - simple induction l. simpl in |- *. intro. rewrite H0. reflexivity. - intros r l0 H1 l'. elim r. intros a y. simpl in |- *. rewrite H. rewrite (H1 l'). reflexivity. - Qed. - - Lemma MapFold_as_fold_1 : - forall (M:Set) (neutral:M) (op:M -> M -> M), - (forall a b c:M, op (op a b) c = op a (op b c)) -> - (forall a:M, op neutral a = a) -> - (forall a:M, op a neutral = a) -> - forall (f:ad -> A -> M) (m:Map A) (pf:ad -> ad), - MapFold1 M neutral op f pf m = - fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) - neutral - (MapFold1 alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil) pf - m). - Proof. - simple induction m. trivial. - intros. simpl in |- *. rewrite H1. reflexivity. - intros. simpl in |- *. rewrite (fold_right_aapp M neutral op H H0 f). - rewrite (H2 (fun a0:ad => pf (Ndouble a0))). rewrite (H3 (fun a0:ad => pf (Ndouble_plus_one a0))). - reflexivity. - Qed. - - Lemma MapFold_as_fold : - forall (M:Set) (neutral:M) (op:M -> M -> M), - (forall a b c:M, op (op a b) c = op a (op b c)) -> - (forall a:M, op neutral a = a) -> - (forall a:M, op a neutral = a) -> - forall (f:ad -> A -> M) (m:Map A), - MapFold M neutral op f m = - fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) - neutral (alist_of_Map m). - Proof. - intros. exact (MapFold_as_fold_1 M neutral op H H0 H1 f m (fun a0:ad => a0)). - Qed. - - Lemma alist_MapMerge_semantics : - forall m m':Map A, - eqm A (alist_semantics (aapp (alist_of_Map m') (alist_of_Map m))) - (alist_semantics (alist_of_Map (MapMerge A m m'))). - Proof. - unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a). - rewrite <- (alist_of_Map_semantics m' a). - rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). - rewrite (MapMerge_semantics A m m' a). reflexivity. - Qed. - - Lemma alist_MapMerge_semantics_disjoint : - forall m m':Map A, - eqmap A (MapDomRestrTo A A m m') (M0 A) -> - eqm A (alist_semantics (aapp (alist_of_Map m) (alist_of_Map m'))) - (alist_semantics (alist_of_Map (MapMerge A m m'))). - Proof. - unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a). - rewrite <- (alist_of_Map_semantics m' a). - rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). rewrite (MapMerge_semantics A m m' a). - elim (option_sum _ (MapGet A m a)). intro H0. elim H0. intros y H1. rewrite H1. - elim (option_sum _ (MapGet A m' a)). intro H2. elim H2. intros y' H3. - cut (MapGet A (MapDomRestrTo A A m m') a = None). - rewrite (MapDomRestrTo_semantics A A m m' a). rewrite H3. rewrite H1. intro. discriminate H4. - exact (H a). - intro H2. rewrite H2. reflexivity. - intro H0. rewrite H0. case (MapGet A m' a); trivial. - Qed. - - Lemma alist_semantics_disjoint_comm : - forall l l':alist, - eqmap A (MapDomRestrTo A A (Map_of_alist l) (Map_of_alist l')) (M0 A) -> - eqm A (alist_semantics (aapp l l')) (alist_semantics (aapp l' l)). - Proof. - unfold eqm in |- *. intros. rewrite (alist_semantics_app l l' a). rewrite (alist_semantics_app l' l a). - rewrite <- (alist_of_Map_of_alist l a). rewrite <- (alist_of_Map_of_alist l' a). - rewrite <- - (alist_semantics_app (alist_of_Map (Map_of_alist l)) - (alist_of_Map (Map_of_alist l')) a). - rewrite <- - (alist_semantics_app (alist_of_Map (Map_of_alist l')) - (alist_of_Map (Map_of_alist l)) a). - rewrite (alist_MapMerge_semantics (Map_of_alist l) (Map_of_alist l') a). - rewrite - (alist_MapMerge_semantics_disjoint (Map_of_alist l) ( - Map_of_alist l') H a). - reflexivity. - Qed. - -End MapIter. diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v deleted file mode 100644 index 56a3c160..00000000 --- a/theories/IntMap/Maplists.v +++ /dev/null @@ -1,438 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Maplists.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import BinNat. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Fset. -Require Import Mapaxioms. -Require Import Mapsubset. -Require Import Mapcard. -Require Import Mapcanon. -Require Import Mapc. -Require Import Bool. -Require Import Sumbool. -Require Import List. -Require Import Arith. -Require Import Mapiter. -Require Import Mapfold. - -Section MapLists. - - Fixpoint ad_in_list (a:ad) (l:list ad) {struct l} : bool := - match l with - | nil => false - | a' :: l' => orb (Neqb a a') (ad_in_list a l') - end. - - Fixpoint ad_list_stutters (l:list ad) : bool := - match l with - | nil => false - | a :: l' => orb (ad_in_list a l') (ad_list_stutters l') - end. - - Lemma ad_in_list_forms_circuit : - forall (x:ad) (l:list ad), - ad_in_list x l = true -> - {l1 : list ad & {l2 : list ad | l = l1 ++ x :: l2}}. - Proof. - simple induction l. intro. discriminate H. - intros. elim (sumbool_of_bool (Neqb x a)). intro H1. simpl in H0. split with (nil (A:=ad)). - split with l0. rewrite (Neqb_complete _ _ H1). reflexivity. - intro H2. simpl in H0. rewrite H2 in H0. simpl in H0. elim (H H0). intros l'1 H3. - split with (a :: l'1). elim H3. intros l2 H4. split with l2. rewrite H4. reflexivity. - Qed. - - Lemma ad_list_stutters_has_circuit : - forall l:list ad, - ad_list_stutters l = true -> - {x : ad & - {l0 : list ad & - {l1 : list ad & {l2 : list ad | l = l0 ++ x :: l1 ++ x :: l2}}}}. - Proof. - simple induction l. intro. discriminate H. - intros. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. split with a. - split with (nil (A:=ad)). simpl in |- *. elim (ad_in_list_forms_circuit a l0 H1). intros l1 H2. - split with l1. elim H2. intros l2 H3. split with l2. rewrite H3. reflexivity. - intro H1. elim (H H1). intros x H2. split with x. elim H2. intros l1 H3. - split with (a :: l1). elim H3. intros l2 H4. split with l2. elim H4. intros l3 H5. - split with l3. rewrite H5. reflexivity. - Qed. - - Fixpoint Elems (l:list ad) : FSet := - match l with - | nil => M0 unit - | a :: l' => MapPut _ (Elems l') a tt - end. - - Lemma Elems_canon : forall l:list ad, mapcanon _ (Elems l). - Proof. - simple induction l. exact (M0_canon unit). - intros. simpl in |- *. apply MapPut_canon. assumption. - Qed. - - Lemma Elems_app : - forall l l':list ad, Elems (l ++ l') = FSetUnion (Elems l) (Elems l'). - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)). - rewrite (MapPut_as_Merge_c unit (Elems (l0 ++ l'))). - change - (FSetUnion (Elems (l0 ++ l')) (M1 unit a tt) = - FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')) - in |- *. - rewrite FSetUnion_comm_c. rewrite (FSetUnion_comm_c (Elems l0) (M1 unit a tt)). - rewrite FSetUnion_assoc_c. rewrite (H l'). reflexivity. - apply M1_canon. - apply Elems_canon. - apply Elems_canon. - apply Elems_canon. - apply M1_canon. - apply Elems_canon. - apply M1_canon. - apply Elems_canon. - apply Elems_canon. - Qed. - - Lemma Elems_rev : forall l:list ad, Elems (rev l) = Elems l. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite Elems_app. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)). - rewrite H. reflexivity. - apply Elems_canon. - Qed. - - Lemma ad_in_elems_in_list : - forall (l:list ad) (a:ad), in_FSet a (Elems l) = ad_in_list a l. - Proof. - simple induction l. trivial. - simpl in |- *. unfold in_FSet in |- *. intros. rewrite (in_dom_put _ (Elems l0) a tt a0). - rewrite (H a0). reflexivity. - Qed. - - Lemma ad_list_not_stutters_card : - forall l:list ad, - ad_list_stutters l = false -> length l = MapCard _ (Elems l). - Proof. - simple induction l. trivial. - simpl in |- *. intros. rewrite MapCard_Put_2_conv. rewrite H. reflexivity. - elim (orb_false_elim _ _ H0). trivial. - elim (sumbool_of_bool (in_FSet a (Elems l0))). rewrite ad_in_elems_in_list. - intro H1. rewrite H1 in H0. discriminate H0. - exact (in_dom_none unit (Elems l0) a). - Qed. - - Lemma ad_list_card : forall l:list ad, MapCard _ (Elems l) <= length l. - Proof. - simple induction l. trivial. - intros. simpl in |- *. apply le_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub. - apply le_n_S. assumption. - Qed. - - Lemma ad_list_stutters_card : - forall l:list ad, - ad_list_stutters l = true -> MapCard _ (Elems l) < length l. - Proof. - simple induction l. intro. discriminate H. - intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. - rewrite <- (ad_in_elems_in_list l0 a) in H1. elim (in_dom_some _ _ _ H1). intros y H2. - rewrite (MapCard_Put_1_conv _ _ _ _ tt H2). apply le_lt_trans with (m := length l0). - apply ad_list_card. - apply lt_n_Sn. - intro H1. apply le_lt_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub. - apply lt_n_S. apply H. assumption. - Qed. - - Lemma ad_list_not_stutters_card_conv : - forall l:list ad, - length l = MapCard _ (Elems l) -> ad_list_stutters l = false. - Proof. - intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0. - cut (MapCard _ (Elems l) < length l). intro. rewrite H in H1. elim (lt_irrefl _ H1). - exact (ad_list_stutters_card _ H0). - trivial. - Qed. - - Lemma ad_list_stutters_card_conv : - forall l:list ad, - MapCard _ (Elems l) < length l -> ad_list_stutters l = true. - Proof. - intros. elim (sumbool_of_bool (ad_list_stutters l)). trivial. - intro H0. rewrite (ad_list_not_stutters_card _ H0) in H. elim (lt_irrefl _ H). - Qed. - - Lemma ad_in_list_l : - forall (l l':list ad) (a:ad), - ad_in_list a l = true -> ad_in_list a (l ++ l') = true. - Proof. - simple induction l. intros. discriminate H. - intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. - intro H1. rewrite (H l' a0 H1). apply orb_b_true. - Qed. - - Lemma ad_list_stutters_app_l : - forall l l':list ad, - ad_list_stutters l = true -> ad_list_stutters (l ++ l') = true. - Proof. - simple induction l. intros. discriminate H. - intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. - rewrite (ad_in_list_l l0 l' a H1). reflexivity. - intro H1. rewrite (H l' H1). apply orb_b_true. - Qed. - - Lemma ad_in_list_r : - forall (l l':list ad) (a:ad), - ad_in_list a l' = true -> ad_in_list a (l ++ l') = true. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (H l' a0 H0). apply orb_b_true. - Qed. - - Lemma ad_list_stutters_app_r : - forall l l':list ad, - ad_list_stutters l' = true -> ad_list_stutters (l ++ l') = true. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (H l' H0). apply orb_b_true. - Qed. - - Lemma ad_list_stutters_app_conv_l : - forall l l':list ad, - ad_list_stutters (l ++ l') = false -> ad_list_stutters l = false. - Proof. - intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0. - rewrite (ad_list_stutters_app_l l l' H0) in H. discriminate H. - trivial. - Qed. - - Lemma ad_list_stutters_app_conv_r : - forall l l':list ad, - ad_list_stutters (l ++ l') = false -> ad_list_stutters l' = false. - Proof. - intros. elim (sumbool_of_bool (ad_list_stutters l')). intro H0. - rewrite (ad_list_stutters_app_r l l' H0) in H. discriminate H. - trivial. - Qed. - - Lemma ad_in_list_app_1 : - forall (l l':list ad) (x:ad), ad_in_list x (l ++ x :: l') = true. - Proof. - simple induction l. simpl in |- *. intros. rewrite (Neqb_correct x). reflexivity. - intros. simpl in |- *. rewrite (H l' x). apply orb_b_true. - Qed. - - Lemma ad_in_list_app : - forall (l l':list ad) (x:ad), - ad_in_list x (l ++ l') = orb (ad_in_list x l) (ad_in_list x l'). - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite <- orb_assoc. rewrite (H l' x). reflexivity. - Qed. - - Lemma ad_in_list_rev : - forall (l:list ad) (x:ad), ad_in_list x (rev l) = ad_in_list x l. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite ad_in_list_app. rewrite (H x). simpl in |- *. rewrite orb_b_false. - apply orb_comm. - Qed. - - Lemma ad_list_has_circuit_stutters : - forall (l0 l1 l2:list ad) (x:ad), - ad_list_stutters (l0 ++ x :: l1 ++ x :: l2) = true. - Proof. - simple induction l0. simpl in |- *. intros. rewrite (ad_in_list_app_1 l1 l2 x). reflexivity. - intros. simpl in |- *. rewrite (H l1 l2 x). apply orb_b_true. - Qed. - - Lemma ad_list_stutters_prev_l : - forall (l l':list ad) (x:ad), - ad_in_list x l = true -> ad_list_stutters (l ++ x :: l') = true. - Proof. - intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1. - rewrite H1. rewrite app_ass. simpl in |- *. apply ad_list_has_circuit_stutters. - Qed. - - Lemma ad_list_stutters_prev_conv_l : - forall (l l':list ad) (x:ad), - ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l = false. - Proof. - intros. elim (sumbool_of_bool (ad_in_list x l)). intro H0. - rewrite (ad_list_stutters_prev_l l l' x H0) in H. discriminate H. - trivial. - Qed. - - Lemma ad_list_stutters_prev_r : - forall (l l':list ad) (x:ad), - ad_in_list x l' = true -> ad_list_stutters (l ++ x :: l') = true. - Proof. - intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1. - rewrite H1. apply ad_list_has_circuit_stutters. - Qed. - - Lemma ad_list_stutters_prev_conv_r : - forall (l l':list ad) (x:ad), - ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l' = false. - Proof. - intros. elim (sumbool_of_bool (ad_in_list x l')). intro H0. - rewrite (ad_list_stutters_prev_r l l' x H0) in H. discriminate H. - trivial. - Qed. - - Lemma ad_list_Elems : - forall l l':list ad, - MapCard _ (Elems l) = MapCard _ (Elems l') -> - length l = length l' -> ad_list_stutters l = ad_list_stutters l'. - Proof. - intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H1. rewrite H1. apply sym_eq. - apply ad_list_stutters_card_conv. rewrite <- H. rewrite <- H0. apply ad_list_stutters_card. - assumption. - intro H1. rewrite H1. apply sym_eq. apply ad_list_not_stutters_card_conv. rewrite <- H. - rewrite <- H0. apply ad_list_not_stutters_card. assumption. - Qed. - - Lemma ad_list_app_length : - forall l l':list ad, length (l ++ l') = length l + length l'. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (H l'). reflexivity. - Qed. - - Lemma ad_list_stutters_permute : - forall l l':list ad, - ad_list_stutters (l ++ l') = ad_list_stutters (l' ++ l). - Proof. - intros. apply ad_list_Elems. rewrite Elems_app. rewrite Elems_app. - rewrite (FSetUnion_comm_c _ _ (Elems_canon l) (Elems_canon l')). reflexivity. - rewrite ad_list_app_length. rewrite ad_list_app_length. apply plus_comm. - Qed. - - Lemma ad_list_rev_length : forall l:list ad, length (rev l) = length l. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite ad_list_app_length. simpl in |- *. rewrite H. rewrite <- plus_Snm_nSm. - rewrite <- plus_n_O. reflexivity. - Qed. - - Lemma ad_list_stutters_rev : - forall l:list ad, ad_list_stutters (rev l) = ad_list_stutters l. - Proof. - intros. apply ad_list_Elems. rewrite Elems_rev. reflexivity. - apply ad_list_rev_length. - Qed. - - Lemma ad_list_app_rev : - forall (l l':list ad) (x:ad), rev l ++ x :: l' = rev (x :: l) ++ l'. - Proof. - simple induction l. trivial. - intros. simpl in |- *. rewrite (app_ass (rev l0) (a :: nil) (x :: l')). simpl in |- *. - rewrite (H (x :: l') a). simpl in |- *. - rewrite (app_ass (rev l0) (a :: nil) (x :: nil)). simpl in |- *. - rewrite app_ass. simpl in |- *. rewrite app_ass. reflexivity. - Qed. - - Section ListOfDomDef. - - Variable A : Set. - - Definition ad_list_of_dom := - MapFold A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil). - - Lemma ad_in_list_of_dom_in_dom : - forall (m:Map A) (a:ad), ad_in_list a (ad_list_of_dom m) = in_dom A a m. - Proof. - unfold ad_list_of_dom in |- *. intros. - rewrite - (MapFold_distr_l A (list ad) nil (app (A:=ad)) bool false orb ad - (fun (a:ad) (l:list ad) => ad_in_list a l) ( - fun c:ad => refl_equal _) ad_in_list_app - (fun (a0:ad) (_:A) => a0 :: nil) m a). - simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (Neqb a a0) false) m). - elim - (option_sum _ - (MapSweep A (fun (a0:ad) (_:A) => orb (Neqb a a0) false) m)). intro H. elim H. - intro r. elim r. intros a0 y H0. rewrite H0. unfold in_dom in |- *. - elim (orb_prop _ _ (MapSweep_semantics_1 _ _ _ _ _ H0)). intro H1. - rewrite (Neqb_complete _ _ H1). rewrite (MapSweep_semantics_2 A _ _ _ _ H0). reflexivity. - intro H1. discriminate H1. - intro H. rewrite H. elim (sumbool_of_bool (in_dom A a m)). intro H0. - elim (in_dom_some A m a H0). intros y H1. - elim (orb_false_elim _ _ (MapSweep_semantics_3 _ _ _ H _ _ H1)). intro H2. - rewrite (Neqb_correct a) in H2. discriminate H2. - exact (sym_eq (y:=_)). - Qed. - - Lemma Elems_of_list_of_dom : - forall m:Map A, eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m). - Proof. - unfold eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_FSet a (Elems (ad_list_of_dom m)))). - intro H. elim (in_dom_some _ _ _ H). intro t. elim t. intro H0. - rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H. - rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H. - elim (in_dom_some _ _ _ H). intro t'. elim t'. intro H1. rewrite H1. assumption. - intro H. rewrite (in_dom_none _ _ _ H). - rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H. - rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H. - rewrite (in_dom_none _ _ _ H). reflexivity. - Qed. - - Lemma Elems_of_list_of_dom_c : - forall m:Map A, mapcanon A m -> Elems (ad_list_of_dom m) = MapDom A m. - Proof. - intros. apply (mapcanon_unique unit). apply Elems_canon. - apply MapDom_canon. assumption. - apply Elems_of_list_of_dom. - Qed. - - Lemma ad_list_of_dom_card_1 : - forall (m:Map A) (pf:ad -> ad), - length - (MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) - pf m) = MapCard A m. - Proof. - simple induction m; try trivial. simpl in |- *. intros. rewrite ad_list_app_length. - rewrite (H (fun a0:ad => pf (Ndouble a0))). rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). - reflexivity. - Qed. - - Lemma ad_list_of_dom_card : - forall m:Map A, length (ad_list_of_dom m) = MapCard A m. - Proof. - exact (fun m:Map A => ad_list_of_dom_card_1 m (fun a:ad => a)). - Qed. - - Lemma ad_list_of_dom_not_stutters : - forall m:Map A, ad_list_stutters (ad_list_of_dom m) = false. - Proof. - intro. apply ad_list_not_stutters_card_conv. rewrite ad_list_of_dom_card. apply sym_eq. - rewrite (MapCard_Dom A m). apply MapCard_ext. exact (Elems_of_list_of_dom m). - Qed. - - End ListOfDomDef. - - Lemma ad_list_of_dom_Dom_1 : - forall (A:Set) (m:Map A) (pf:ad -> ad), - MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) pf - m = - MapFold1 unit (list ad) nil (app (A:=ad)) - (fun (a:ad) (_:unit) => a :: nil) pf (MapDom A m). - Proof. - simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (Ndouble a0))). - rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity. - Qed. - - Lemma ad_list_of_dom_Dom : - forall (A:Set) (m:Map A), - ad_list_of_dom A m = ad_list_of_dom unit (MapDom A m). - Proof. - intros. exact (ad_list_of_dom_Dom_1 A m (fun a0:ad => a0)). - Qed. - -End MapLists.
\ No newline at end of file diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v deleted file mode 100644 index 6771c03e..00000000 --- a/theories/IntMap/Mapsubset.v +++ /dev/null @@ -1,605 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) -(*i $Id: Mapsubset.v 8733 2006-04-25 22:52:18Z letouzey $ i*) - -Require Import Bool. -Require Import Sumbool. -Require Import Arith. -Require Import NArith. -Require Import Ndigits. -Require Import Ndec. -Require Import Map. -Require Import Fset. -Require Import Mapaxioms. -Require Import Mapiter. - -Section MapSubsetDef. - - Variables A B : Set. - - Definition MapSubset (m:Map A) (m':Map B) := - forall a:ad, in_dom A a m = true -> in_dom B a m' = true. - - Definition MapSubset_1 (m:Map A) (m':Map B) := - match MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m with - | None => true - | _ => false - end. - - Definition MapSubset_2 (m:Map A) (m':Map B) := - eqmap A (MapDomRestrBy A B m m') (M0 A). - - Lemma MapSubset_imp_1 : - forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_1 m m' = true. - Proof. - unfold MapSubset, MapSubset_1 in |- *. intros. - elim - (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)). - intro H0. elim H0. intro r. elim r. intros a y H1. cut (negb (in_dom B a m') = true). - intro. cut (in_dom A a m = false). intro. unfold in_dom in H3. - rewrite (MapSweep_semantics_2 _ _ m a y H1) in H3. discriminate H3. - elim (sumbool_of_bool (in_dom A a m)). intro H3. rewrite (H a H3) in H2. discriminate H2. - trivial. - exact (MapSweep_semantics_1 _ _ m a y H1). - intro H0. rewrite H0. reflexivity. - Qed. - - Lemma MapSubset_1_imp : - forall (m:Map A) (m':Map B), MapSubset_1 m m' = true -> MapSubset m m'. - Proof. - unfold MapSubset, MapSubset_1 in |- *. unfold in_dom at 2 in |- *. intros. elim (option_sum _ (MapGet A m a)). - intro H1. elim H1. intros y H2. - elim - (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)). intro H3. - elim H3. intro r. elim r. intros a' y' H4. rewrite H4 in H. discriminate H. - intro H3. cut (negb (in_dom B a m') = false). intro. rewrite (negb_intro (in_dom B a m')). - rewrite H4. reflexivity. - exact (MapSweep_semantics_3 _ _ m H3 a y H2). - intro H1. rewrite H1 in H0. discriminate H0. - Qed. - - Lemma map_dom_empty_1 : - forall m:Map A, eqmap A m (M0 A) -> forall a:ad, in_dom _ a m = false. - Proof. - unfold eqmap, eqm, in_dom in |- *. intros. rewrite (H a). reflexivity. - Qed. - - Lemma map_dom_empty_2 : - forall m:Map A, (forall a:ad, in_dom _ a m = false) -> eqmap A m (M0 A). - Proof. - unfold eqmap, eqm, in_dom in |- *. intros. - cut - (match MapGet A m a with - | None => false - | Some _ => true - end = false). - case (MapGet A m a); trivial. - intros. discriminate H0. - exact (H a). - Qed. - - Lemma MapSubset_imp_2 : - forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_2 m m'. - Proof. - unfold MapSubset, MapSubset_2 in |- *. intros. apply map_dom_empty_2. intro. rewrite in_dom_restrby. - elim (sumbool_of_bool (in_dom A a m)). intro H0. rewrite H0. rewrite (H a H0). reflexivity. - intro H0. rewrite H0. reflexivity. - Qed. - - Lemma MapSubset_2_imp : - forall (m:Map A) (m':Map B), MapSubset_2 m m' -> MapSubset m m'. - Proof. - unfold MapSubset, MapSubset_2 in |- *. intros. cut (in_dom _ a (MapDomRestrBy A B m m') = false). - rewrite in_dom_restrby. intro. elim (andb_false_elim _ _ H1). rewrite H0. - intro H2. discriminate H2. - intro H2. rewrite (negb_intro (in_dom B a m')). rewrite H2. reflexivity. - exact (map_dom_empty_1 _ H a). - Qed. - -End MapSubsetDef. - -Section MapSubsetOrder. - - Variables A B C : Set. - - Lemma MapSubset_refl : forall m:Map A, MapSubset A A m m. - Proof. - unfold MapSubset in |- *. trivial. - Qed. - - Lemma MapSubset_antisym : - forall (m:Map A) (m':Map B), - MapSubset A B m m' -> - MapSubset B A m' m -> eqmap unit (MapDom A m) (MapDom B m'). - Proof. - unfold MapSubset, eqmap, eqm in |- *. intros. elim (option_sum _ (MapGet _ (MapDom A m) a)). - intro H1. elim H1. intro t. elim t. intro H2. elim (option_sum _ (MapGet _ (MapDom B m') a)). - intro H3. elim H3. intro t'. elim t'. intro H4. rewrite H4. exact H2. - intro H3. cut (in_dom B a m' = true). intro. rewrite (MapDom_Dom B m' a) in H4. - unfold in_FSet, in_dom in H4. rewrite H3 in H4. discriminate H4. - apply H. rewrite (MapDom_Dom A m a). unfold in_FSet, in_dom in |- *. rewrite H2. reflexivity. - intro H1. elim (option_sum _ (MapGet _ (MapDom B m') a)). intro H2. elim H2. intros t H3. - cut (in_dom A a m = true). intro. rewrite (MapDom_Dom A m a) in H4. unfold in_FSet, in_dom in H4. - rewrite H1 in H4. discriminate H4. - apply H0. rewrite (MapDom_Dom B m' a). unfold in_FSet, in_dom in |- *. rewrite H3. reflexivity. - intro H2. rewrite H2. exact H1. - Qed. - - Lemma MapSubset_trans : - forall (m:Map A) (m':Map B) (m'':Map C), - MapSubset A B m m' -> MapSubset B C m' m'' -> MapSubset A C m m''. - Proof. - unfold MapSubset in |- *. intros. apply H0. apply H. assumption. - Qed. - -End MapSubsetOrder. - -Section FSubsetOrder. - - Lemma FSubset_refl : forall s:FSet, MapSubset _ _ s s. - Proof. - exact (MapSubset_refl unit). - Qed. - - Lemma FSubset_antisym : - forall s s':FSet, - MapSubset _ _ s s' -> MapSubset _ _ s' s -> eqmap unit s s'. - Proof. - intros. rewrite <- (FSet_Dom s). rewrite <- (FSet_Dom s'). - exact (MapSubset_antisym _ _ s s' H H0). - Qed. - - Lemma FSubset_trans : - forall s s' s'':FSet, - MapSubset _ _ s s' -> MapSubset _ _ s' s'' -> MapSubset _ _ s s''. - Proof. - exact (MapSubset_trans unit unit unit). - Qed. - -End FSubsetOrder. - -Section MapSubsetExtra. - - Variables A B : Set. - - Lemma MapSubset_Dom_1 : - forall (m:Map A) (m':Map B), - MapSubset A B m m' -> MapSubset unit unit (MapDom A m) (MapDom B m'). - Proof. - unfold MapSubset in |- *. intros. elim (MapDom_semantics_2 _ m a H0). intros y H1. - cut (in_dom A a m = true -> in_dom B a m' = true). intro. unfold in_dom in H2. - rewrite H1 in H2. elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. - intros y' H4. exact (MapDom_semantics_1 _ m' a y' H4). - intro H3. rewrite H3 in H2. cut (false = true). intro. discriminate H4. - apply H2. reflexivity. - exact (H a). - Qed. - - Lemma MapSubset_Dom_2 : - forall (m:Map A) (m':Map B), - MapSubset unit unit (MapDom A m) (MapDom B m') -> MapSubset A B m m'. - Proof. - unfold MapSubset in |- *. intros. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)). - intro H1. elim H1. intros y H2. - elim (MapDom_semantics_2 _ _ _ (H a (MapDom_semantics_1 _ _ _ _ H2))). intros y' H3. - unfold in_dom in |- *. rewrite H3. reflexivity. - intro H1. rewrite H1 in H0. discriminate H0. - Qed. - - Lemma MapSubset_1_Dom : - forall (m:Map A) (m':Map B), - MapSubset_1 A B m m' = MapSubset_1 unit unit (MapDom A m) (MapDom B m'). - Proof. - intros. elim (sumbool_of_bool (MapSubset_1 A B m m')). intro H. rewrite H. - apply sym_eq. apply MapSubset_imp_1. apply MapSubset_Dom_1. exact (MapSubset_1_imp _ _ _ _ H). - intro H. rewrite H. elim (sumbool_of_bool (MapSubset_1 unit unit (MapDom A m) (MapDom B m'))). - intro H0. - rewrite - (MapSubset_imp_1 _ _ _ _ - (MapSubset_Dom_2 _ _ (MapSubset_1_imp _ _ _ _ H0))) - in H. - discriminate H. - intro. apply sym_eq. assumption. - Qed. - - Lemma MapSubset_Put : - forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut A m a y). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite H. apply orb_b_true. - Qed. - - Lemma MapSubset_Put_mono : - forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B), - MapSubset A B m m' -> MapSubset A B (MapPut A m a y) (MapPut B m' a y'). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite (in_dom_put A m a y a0) in H0. - elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. - intro H1. rewrite (H _ H1). apply orb_b_true. - Qed. - - Lemma MapSubset_Put_behind : - forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut_behind A m a y). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. rewrite H. apply orb_b_true. - Qed. - - Lemma MapSubset_Put_behind_mono : - forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B), - MapSubset A B m m' -> - MapSubset A B (MapPut_behind A m a y) (MapPut_behind B m' a y'). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. - rewrite (in_dom_put_behind A m a y a0) in H0. - elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. - intro H1. rewrite (H _ H1). apply orb_b_true. - Qed. - - Lemma MapSubset_Remove : - forall (m:Map A) (a:ad), MapSubset A A (MapRemove A m a) m. - Proof. - unfold MapSubset in |- *. intros. unfold MapSubset in |- *. intros. rewrite (in_dom_remove _ m a a0) in H. - elim (andb_prop _ _ H). trivial. - Qed. - - Lemma MapSubset_Remove_mono : - forall (m:Map A) (m':Map B) (a:ad), - MapSubset A B m m' -> MapSubset A B (MapRemove A m a) (MapRemove B m' a). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_remove. rewrite (in_dom_remove A m a a0) in H0. - elim (andb_prop _ _ H0). intros. rewrite H1. rewrite (H _ H2). reflexivity. - Qed. - - Lemma MapSubset_Merge_l : - forall m m':Map A, MapSubset A A m (MapMerge A m m'). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. reflexivity. - Qed. - - Lemma MapSubset_Merge_r : - forall m m':Map A, MapSubset A A m' (MapMerge A m m'). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. apply orb_b_true. - Qed. - - Lemma MapSubset_Merge_mono : - forall (m m':Map A) (m'' m''':Map B), - MapSubset A B m m'' -> - MapSubset A B m' m''' -> - MapSubset A B (MapMerge A m m') (MapMerge B m'' m'''). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite (in_dom_merge A m m' a) in H1. - elim (orb_true_elim _ _ H1). intro H2. rewrite (H _ H2). reflexivity. - intro H2. rewrite (H0 _ H2). apply orb_b_true. - Qed. - - Lemma MapSubset_DomRestrTo_l : - forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrTo A B m m') m. - Proof. - unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H). - trivial. - Qed. - - Lemma MapSubset_DomRestrTo_r : - forall (m:Map A) (m':Map B), MapSubset A B (MapDomRestrTo A B m m') m'. - Proof. - unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H). - trivial. - Qed. - - Lemma MapSubset_ext : - forall (m0 m1:Map A) (m2 m3:Map B), - eqmap A m0 m1 -> - eqmap B m2 m3 -> MapSubset A B m0 m2 -> MapSubset A B m1 m3. - Proof. - intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. - apply eqmap_trans with (m' := MapDomRestrBy A B m0 m2). apply MapDomRestrBy_ext. apply eqmap_sym. - assumption. - apply eqmap_sym. assumption. - exact (MapSubset_imp_2 _ _ _ _ H1). - Qed. - - Variables C D : Set. - - Lemma MapSubset_DomRestrTo_mono : - forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), - MapSubset _ _ m m'' -> - MapSubset _ _ m' m''' -> - MapSubset _ _ (MapDomRestrTo _ _ m m') (MapDomRestrTo _ _ m'' m'''). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_restrto. rewrite (in_dom_restrto A B m m' a) in H1. - elim (andb_prop _ _ H1). intros. rewrite (H _ H2). rewrite (H0 _ H3). reflexivity. - Qed. - - Lemma MapSubset_DomRestrBy_l : - forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrBy A B m m') m. - Proof. - unfold MapSubset in |- *. intros. rewrite (in_dom_restrby _ _ m m' a) in H. elim (andb_prop _ _ H). - trivial. - Qed. - - Lemma MapSubset_DomRestrBy_mono : - forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), - MapSubset _ _ m m'' -> - MapSubset _ _ m''' m' -> - MapSubset _ _ (MapDomRestrBy _ _ m m') (MapDomRestrBy _ _ m'' m'''). - Proof. - unfold MapSubset in |- *. intros. rewrite in_dom_restrby. rewrite (in_dom_restrby A B m m' a) in H1. - elim (andb_prop _ _ H1). intros. rewrite (H _ H2). elim (sumbool_of_bool (in_dom D a m''')). - intro H4. rewrite (H0 _ H4) in H3. discriminate H3. - intro H4. rewrite H4. reflexivity. - Qed. - -End MapSubsetExtra. - -Section MapDisjointDef. - - Variables A B : Set. - - Definition MapDisjoint (m:Map A) (m':Map B) := - forall a:ad, in_dom A a m = true -> in_dom B a m' = true -> False. - - Definition MapDisjoint_1 (m:Map A) (m':Map B) := - match MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m with - | None => true - | _ => false - end. - - Definition MapDisjoint_2 (m:Map A) (m':Map B) := - eqmap A (MapDomRestrTo A B m m') (M0 A). - - Lemma MapDisjoint_imp_1 : - forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_1 m m' = true. - Proof. - unfold MapDisjoint, MapDisjoint_1 in |- *. intros. - elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H0. elim H0. - intro r. elim r. intros a y H1. cut (in_dom A a m = true -> in_dom B a m' = true -> False). - intro. unfold in_dom at 1 in H2. rewrite (MapSweep_semantics_2 _ _ _ _ _ H1) in H2. - rewrite (MapSweep_semantics_1 _ _ _ _ _ H1) in H2. elim (H2 (refl_equal _) (refl_equal _)). - exact (H a). - intro H0. rewrite H0. reflexivity. - Qed. - - Lemma MapDisjoint_1_imp : - forall (m:Map A) (m':Map B), MapDisjoint_1 m m' = true -> MapDisjoint m m'. - Proof. - unfold MapDisjoint, MapDisjoint_1 in |- *. intros. - elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H2. elim H2. - intro r. elim r. intros a' y' H3. rewrite H3 in H. discriminate H. - intro H2. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)). intro H3. elim H3. - intros y H4. rewrite (MapSweep_semantics_3 _ _ _ H2 a y H4) in H1. discriminate H1. - intro H3. rewrite H3 in H0. discriminate H0. - Qed. - - Lemma MapDisjoint_imp_2 : - forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_2 m m'. - Proof. - unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. - rewrite (MapDomRestrTo_semantics A B m m' a). - cut (in_dom A a m = true -> in_dom B a m' = true -> False). intro. - elim (option_sum _ (MapGet A m a)). intro H1. elim H1. intros y H2. unfold in_dom at 1 in H0. - elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. intros y' H4. unfold in_dom at 1 in H0. - rewrite H4 in H0. rewrite H2 in H0. elim (H0 (refl_equal _) (refl_equal _)). - intro H3. rewrite H3. reflexivity. - intro H1. rewrite H1. case (MapGet B m' a); reflexivity. - exact (H a). - Qed. - - Lemma MapDisjoint_2_imp : - forall (m:Map A) (m':Map B), MapDisjoint_2 m m' -> MapDisjoint m m'. - Proof. - unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. elim (in_dom_some _ _ _ H0). - intros y H2. elim (in_dom_some _ _ _ H1). intros y' H3. - cut (MapGet A (MapDomRestrTo A B m m') a = None). intro. - rewrite (MapDomRestrTo_semantics _ _ m m' a) in H4. rewrite H3 in H4. rewrite H2 in H4. - discriminate H4. - exact (H a). - Qed. - - Lemma Map_M0_disjoint : forall m:Map B, MapDisjoint (M0 A) m. - Proof. - unfold MapDisjoint, in_dom in |- *. intros. discriminate H. - Qed. - - Lemma Map_disjoint_M0 : forall m:Map A, MapDisjoint m (M0 B). - Proof. - unfold MapDisjoint, in_dom in |- *. intros. discriminate H0. - Qed. - -End MapDisjointDef. - -Section MapDisjointExtra. - - Variables A B : Set. - - Lemma MapDisjoint_ext : - forall (m0 m1:Map A) (m2 m3:Map B), - eqmap A m0 m1 -> - eqmap B m2 m3 -> MapDisjoint A B m0 m2 -> MapDisjoint A B m1 m3. - Proof. - intros. apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. - apply eqmap_trans with (m' := MapDomRestrTo A B m0 m2). apply eqmap_sym. apply MapDomRestrTo_ext. - assumption. - assumption. - exact (MapDisjoint_imp_2 _ _ _ _ H1). - Qed. - - Lemma MapMerge_disjoint : - forall m m':Map A, - MapDisjoint A A m m' -> - forall a:ad, - in_dom A a (MapMerge A m m') = - orb (andb (in_dom A a m) (negb (in_dom A a m'))) - (andb (in_dom A a m') (negb (in_dom A a m))). - Proof. - unfold MapDisjoint in |- *. intros. rewrite in_dom_merge. elim (sumbool_of_bool (in_dom A a m)). - intro H0. rewrite H0. elim (sumbool_of_bool (in_dom A a m')). intro H1. elim (H a H0 H1). - intro H1. rewrite H1. reflexivity. - intro H0. rewrite H0. simpl in |- *. rewrite andb_b_true. reflexivity. - Qed. - - Lemma MapDisjoint_M2_l : - forall (m0 m1:Map A) (m2 m3:Map B), - MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m0 m2. - Proof. - unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m0 a)). intro H2. - elim H2. intros y H3. elim (option_sum _ (MapGet B m2 a)). intro H4. elim H4. - intros y' H5. apply (H (Ndouble a)). - rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m0 m1). - rewrite (Ndouble_div2 a). rewrite H3. reflexivity. - rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m2 m3). - rewrite (Ndouble_div2 a). rewrite H5. reflexivity. - intro H4. rewrite H4 in H1. discriminate H1. - intro H2. rewrite H2 in H0. discriminate H0. - Qed. - - Lemma MapDisjoint_M2_r : - forall (m0 m1:Map A) (m2 m3:Map B), - MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m1 m3. - Proof. - unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m1 a)). intro H2. - elim H2. intros y H3. elim (option_sum _ (MapGet B m3 a)). intro H4. elim H4. - intros y' H5. apply (H (Ndouble_plus_one a)). - rewrite - (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a) - m0 m1). - rewrite (Ndouble_plus_one_div2 a). rewrite H3. reflexivity. - rewrite - (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a) - m2 m3). - rewrite (Ndouble_plus_one_div2 a). rewrite H5. reflexivity. - intro H4. rewrite H4 in H1. discriminate H1. - intro H2. rewrite H2 in H0. discriminate H0. - Qed. - - Lemma MapDisjoint_M2 : - forall (m0 m1:Map A) (m2 m3:Map B), - MapDisjoint A B m0 m2 -> - MapDisjoint A B m1 m3 -> MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3). - Proof. - unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H3. - rewrite (MapGet_M2_bit_0_1 A a H3 m0 m1) in H1. - rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (Ndiv2 a) H1 H2). - intro H3. rewrite (MapGet_M2_bit_0_0 A a H3 m0 m1) in H1. - rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (Ndiv2 a) H1 H2). - Qed. - - Lemma MapDisjoint_M1_l : - forall (m:Map A) (a:ad) (y:B), - MapDisjoint B A (M1 B a y) m -> in_dom A a m = false. - Proof. - unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0. - elim (H a (in_dom_M1_1 B a y) H0). - trivial. - Qed. - - Lemma MapDisjoint_M1_r : - forall (m:Map A) (a:ad) (y:B), - MapDisjoint A B m (M1 B a y) -> in_dom A a m = false. - Proof. - unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0. - elim (H a H0 (in_dom_M1_1 B a y)). - trivial. - Qed. - - Lemma MapDisjoint_M1_conv_l : - forall (m:Map A) (a:ad) (y:B), - in_dom A a m = false -> MapDisjoint B A (M1 B a y) m. - Proof. - unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H0) in H. rewrite H1 in H. - discriminate H. - Qed. - - Lemma MapDisjoint_M1_conv_r : - forall (m:Map A) (a:ad) (y:B), - in_dom A a m = false -> MapDisjoint A B m (M1 B a y). - Proof. - unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H1) in H. rewrite H0 in H. - discriminate H. - Qed. - - Lemma MapDisjoint_sym : - forall (m:Map A) (m':Map B), MapDisjoint A B m m' -> MapDisjoint B A m' m. - Proof. - unfold MapDisjoint in |- *. intros. exact (H _ H1 H0). - Qed. - - Lemma MapDisjoint_empty : - forall m:Map A, MapDisjoint A A m m -> eqmap A m (M0 A). - Proof. - unfold eqmap, eqm in |- *. intros. rewrite <- (MapDomRestrTo_idempotent A m a). - exact (MapDisjoint_imp_2 A A m m H a). - Qed. - - Lemma MapDelta_disjoint : - forall m m':Map A, - MapDisjoint A A m m' -> eqmap A (MapDelta A m m') (MapMerge A m m'). - Proof. - intros. - apply eqmap_trans with - (m' := MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')). - apply MapDelta_as_DomRestrBy. - apply eqmap_trans with (m' := MapDomRestrBy A A (MapMerge A m m') (M0 A)). - apply MapDomRestrBy_ext. apply eqmap_refl. - exact (MapDisjoint_imp_2 A A m m' H). - apply MapDomRestrBy_m_empty. - Qed. - - Variable C : Set. - - Lemma MapDomRestr_disjoint : - forall (m:Map A) (m':Map B) (m'':Map C), - MapDisjoint A B (MapDomRestrTo A C m m'') (MapDomRestrBy B C m' m''). - Proof. - unfold MapDisjoint in |- *. intros m m' m'' a. rewrite in_dom_restrto. rewrite in_dom_restrby. - intros. elim (andb_prop _ _ H). elim (andb_prop _ _ H0). intros. rewrite H4 in H2. - discriminate H2. - Qed. - - Lemma MapDelta_RestrTo_disjoint : - forall m m':Map A, - MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m'). - Proof. - unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto. - intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H. - Qed. - - Lemma MapDelta_RestrTo_disjoint_2 : - forall m m':Map A, - MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m). - Proof. - unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto. - intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H. - Qed. - - Variable D : Set. - - Lemma MapSubset_Disjoint : - forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), - MapSubset _ _ m m' -> - MapSubset _ _ m'' m''' -> - MapDisjoint _ _ m' m''' -> MapDisjoint _ _ m m''. - Proof. - unfold MapSubset, MapDisjoint in |- *. intros. exact (H1 _ (H _ H2) (H0 _ H3)). - Qed. - - Lemma MapSubset_Disjoint_l : - forall (m:Map A) (m':Map B) (m'':Map C), - MapSubset _ _ m m' -> MapDisjoint _ _ m' m'' -> MapDisjoint _ _ m m''. - Proof. - unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ (H _ H1) H2). - Qed. - - Lemma MapSubset_Disjoint_r : - forall (m:Map A) (m'':Map C) (m''':Map D), - MapSubset _ _ m'' m''' -> - MapDisjoint _ _ m m''' -> MapDisjoint _ _ m m''. - Proof. - unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ H1 (H _ H2)). - Qed. - -End MapDisjointExtra.
\ No newline at end of file diff --git a/theories/IntMap/intro.tex b/theories/IntMap/intro.tex deleted file mode 100644 index 9ad93050..00000000 --- a/theories/IntMap/intro.tex +++ /dev/null @@ -1,6 +0,0 @@ -\section{Maps indexed by binary integers : IntMap}\label{IntMap} - -This library contains a data structure for finite sets implemented by -an efficient structure of map (trees indexed by binary integers). -It was initially developed by Jean Goubault. - diff --git a/theories/Lists/List.v b/theories/Lists/List.v index c80d0b15..a72283d9 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1,15 +1,14 @@ - (************************************************************************) - (* 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 *) - (************************************************************************) +(************************************************************************) +(* 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 *) +(************************************************************************) - (*i $Id: List.v 9290 2006-10-26 19:20:42Z herbelin $ i*) +(*i $Id: List.v 10999 2008-05-27 15:55:22Z letouzey $ i*) Require Import Le Gt Minus Min Bool. -Require Import Setoid. Set Implicit Arguments. @@ -82,8 +81,6 @@ End Lists. Implicit Arguments nil [A]. Infix "::" := cons (at level 60, right associativity) : list_scope. Infix "++" := app (right associativity, at level 60) : list_scope. - -Ltac now_show c := change c in |- *. Open Scope list_scope. @@ -314,7 +311,27 @@ Section Facts. now_show (H = a \/ In a (y ++ m)). elim H2; auto. Qed. - + + Lemma app_inv_head: + forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. + Proof. + induction l; simpl; auto; injection 1; auto. + Qed. + + Lemma app_inv_tail: + forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. + Proof. + intros l l1 l2; revert l1 l2 l. + induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + simpl; auto; intros l H. + absurd (length (x2 :: l2 ++ l) <= length l). + simpl; rewrite app_length; auto with arith. + rewrite <- H; auto with arith. + absurd (length (x1 :: l1 ++ l) <= length l). + simpl; rewrite app_length; auto with arith. + rewrite H; auto with arith. + injection H; clear H; intros; f_equal; eauto. + Qed. End Facts. @@ -512,6 +529,20 @@ Section Elts. exists (a::l'); exists a'; auto. Qed. + Lemma removelast_app : + forall l l', l' <> nil -> removelast (l++l') = l ++ removelast l'. + Proof. + induction l. + simpl; auto. + simpl; intros. + assert (l++l' <> nil). + destruct l. + simpl; auto. + simpl; discriminate. + specialize (IHl l' H). + destruct (l++l'); [elim H0; auto|f_equal; auto]. + Qed. + (****************************************) (** ** Counting occurences of a element *) @@ -534,8 +565,7 @@ Section Elts. simpl; intros; split; [destruct 1 | apply gt_irrefl]. simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq]. rewrite Heq; intuition. - rewrite <- (IHl x). - tauto. + pose (IHl x). intuition. Qed. Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil. @@ -668,8 +698,8 @@ Section ListOps. rewrite app_nth1; auto. rewrite (minus_plus_simpl_l_reverse (length l) n 1). replace (1 + length l) with (S (length l)); auto with arith. - rewrite <- minus_Sn_m; auto with arith; simpl. - apply IHl; auto. + rewrite <- minus_Sn_m; auto with arith. + apply IHl ; auto with arith. rewrite rev_length; auto. Qed. @@ -899,7 +929,7 @@ Section ListOps. apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app. apply perm_skip. apply (IH a l1' l2 l3' l4); auto. - (* swap *) + (* contradict *) intros x y l l' Hp IH; intros. break_list l1 b l1' H; break_list l3 c l3' H0. auto. @@ -1345,7 +1375,7 @@ End Fold_Right_Recursor. destruct n; destruct d; simpl; auto. destruct a; destruct (split l); simpl; auto. destruct a; destruct (split l); simpl in *; auto. - rewrite IHl; simpl; auto. + apply IHl. Qed. Lemma split_length_l : forall (l:list (A*B)), @@ -1618,7 +1648,7 @@ Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons (**************************************) -(* ** Cutting a list at some position *) +(** * Cutting a list at some position *) (**************************************) Section Cutting. @@ -1651,6 +1681,45 @@ Section Cutting. f_equal; auto. Qed. + Lemma firstn_length : forall n l, length (firstn n l) = min n (length l). + Proof. + induction n; destruct l; simpl; auto. + Qed. + + Lemma removelast_firstn : forall n l, n < length l -> + removelast (firstn (S n) l) = firstn n l. + Proof. + induction n; destruct l. + simpl; auto. + simpl; auto. + simpl; auto. + intros. + simpl in H. + change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l). + change (firstn (S n) (a::l)) with (a::firstn n l). + rewrite removelast_app. + rewrite IHn; auto with arith. + + clear IHn; destruct l; simpl in *; try discriminate. + inversion_clear H. + inversion_clear H0. + Qed. + + Lemma firstn_removelast : forall n l, n < length l -> + firstn n (removelast l) = firstn n l. + Proof. + induction n; destruct l. + simpl; auto. + simpl; auto. + simpl; auto. + intros. + simpl in H. + change (removelast (a :: l)) with (removelast ((a::nil)++l)). + rewrite removelast_app. + simpl; f_equal; auto with arith. + intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1. + Qed. + End Cutting. @@ -1672,8 +1741,8 @@ Section ReDun. inversion_clear 1; auto. inversion_clear 1. constructor. - swap H0. - apply in_or_app; destruct (in_app_or _ _ _ H); simpl; tauto. + contradict H0. + apply in_or_app; destruct (in_app_or _ _ _ H0); simpl; tauto. apply IHl with a0; auto. Qed. @@ -1682,8 +1751,8 @@ Section ReDun. induction l; simpl. inversion_clear 1; auto. inversion_clear 1. - swap H0. - destruct H. + contradict H0. + destruct H0. subst a0. apply in_or_app; right; red; auto. destruct (IHl _ _ H1); auto. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 4e009ed5..021a64c1 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListSet.v 6844 2005-03-16 13:09:55Z herbelin $ i*) +(*i $Id: ListSet.v 10616 2008-03-04 17:33:35Z letouzey $ i*) (** A Library for finite sets, implemented as lists *) @@ -20,7 +20,7 @@ Set Implicit Arguments. Section first_definitions. - Variable A : Set. + Variable A : Type. Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}. Definition set := list A. @@ -100,7 +100,7 @@ Section first_definitions. Qed. Lemma set_mem_ind : - forall (B:Set) (P:B -> Prop) (y z:B) (a:A) (x:set), + forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z). Proof. @@ -110,7 +110,7 @@ Section first_definitions. Qed. Lemma set_mem_ind2 : - forall (B:Set) (P:B -> Prop) (y z:B) (a:A) (x:set), + forall (B:Type) (P:B -> Prop) (y z:B) (a:A) (x:set), (set_In a x -> P y) -> (~ set_In a x -> P z) -> P (if set_mem a x then y else z). @@ -373,7 +373,7 @@ End first_definitions. Section other_definitions. - Variables A B : Set. + Variables A B : Type. Definition set_prod : set A -> set B -> set (A * B) := list_prod (A:=A) (B:=B). diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index e46f1279..515ed138 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListTactics.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: ListTactics.v 9427 2006-12-11 18:46:35Z bgregoir $ i*) Require Import BinPos. Require Import List. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index eb40594b..4edc1581 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: SetoidList.v 8853 2006-05-23 18:17:38Z herbelin $ *) +(* $Id: SetoidList.v 10616 2008-03-04 17:33:35Z letouzey $ *) Require Export List. Require Export Sorting. @@ -21,7 +21,7 @@ Unset Strict Implicit. found in [Sorting]. *) Section Type_with_equality. -Variable A : Set. +Variable A : Type. Variable eqA : A -> A -> Prop. (** Being in a list modulo an equality relation over type [A]. *) @@ -32,6 +32,18 @@ Inductive InA (x : A) : list A -> Prop := Hint Constructors InA. +Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. +Proof. + intuition. + inversion H; auto. +Qed. + +Lemma InA_nil : forall x, InA x nil <-> False. +Proof. + intuition. + inversion H. +Qed. + (** An alternative definition of [InA]. *) Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. @@ -53,7 +65,28 @@ Hint Constructors NoDupA. (** lists with same elements modulo [eqA] *) -Definition eqlistA l l' := forall x, InA x l <-> InA x l'. +Definition equivlistA l l' := forall x, InA x l <-> InA x l'. + +(** lists with same elements modulo [eqA] at the same place *) + +Inductive eqlistA : list A -> list A -> Prop := + | eqlistA_nil : eqlistA nil nil + | eqlistA_cons : forall x x' l l', + eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). + +Hint Constructors eqlistA. + +(** Compatibility of a boolean function with respect to an equality. *) + +Definition compat_bool (f : A->bool) := forall x y, eqA x y -> f x = f y. + +(** Compatibility of a function upon natural numbers. *) + +Definition compat_nat (f : A->nat) := forall x y, eqA x y -> f x = f y. + +(** Compatibility of a predicate with respect to an equality. *) + +Definition compat_P (P : A->Prop) := forall x y, eqA x y -> P x -> P y. (** Results concerning lists modulo [eqA] *) @@ -91,6 +124,35 @@ exists (a::l1); exists y; exists l2; auto. split; simpl; f_equal; auto. Qed. +Lemma InA_app : forall l1 l2 x, + InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. +Proof. + induction l1; simpl in *; intuition. + inversion_clear H; auto. + elim (IHl1 l2 x H0); auto. +Qed. + +Lemma InA_app_iff : forall l1 l2 x, + InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2. +Proof. + split. + apply InA_app. + destruct 1; generalize H; do 2 rewrite InA_alt. + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. +Qed. + +Lemma InA_rev : forall p m, + InA p (rev m) <-> InA p m. +Proof. + intros; do 2 rewrite InA_alt. + split; intros (y,H); exists y; intuition. + rewrite In_rev; auto. + rewrite <- In_rev; auto. +Qed. + (** Results concerning lists modulo [eqA] and [ltA] *) Variable ltA : A -> A -> Prop. @@ -106,10 +168,12 @@ Hint Immediate ltA_eqA eqA_ltA. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). +Hint Constructors lelistA sort. + Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. Proof. - intro s; case s; constructor; inversion_clear H0. + destruct l; constructor; inversion_clear H0; eapply ltA_trans; eauto. Qed. @@ -153,6 +217,26 @@ intros; eapply SortA_InfA_InA; eauto. apply InA_InfA. Qed. +Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). +Proof. + induction l1; simpl; auto. + inversion_clear 1; auto. +Qed. + +Lemma SortA_app : + forall l1 l2, SortA l1 -> SortA l2 -> + (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> + SortA (l1 ++ l2). +Proof. + induction l1; simpl in *; intuition. + inversion_clear H. + constructor; auto. + apply InfA_app; auto. + destruct l2; auto. +Qed. + +Section NoDupA. + Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. Proof. simple induction l; auto. @@ -185,7 +269,6 @@ intros. apply (H1 x); auto. Qed. - Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). Proof. induction l. @@ -206,33 +289,240 @@ rewrite In_rev; auto. inversion H4. Qed. +Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). +Proof. + induction l; simpl in *; inversion_clear 1; auto. + constructor; eauto. + contradict H0. + rewrite InA_app_iff in *; rewrite InA_cons; intuition. +Qed. -Lemma InA_app : forall l1 l2 x, - InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. +Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). Proof. - induction l1; simpl in *; intuition. - inversion_clear H; auto. - elim (IHl1 l2 x H0); auto. + induction l; simpl in *; inversion_clear 1; auto. + constructor; eauto. + assert (H2:=IHl _ _ H1). + inversion_clear H2. + rewrite InA_cons. + red; destruct 1. + apply H0. + rewrite InA_app_iff in *; rewrite InA_cons; auto. + apply H; auto. + constructor. + contradict H0. + rewrite InA_app_iff in *; rewrite InA_cons; intuition. + eapply NoDupA_split; eauto. Qed. - Hint Constructors lelistA sort. +End NoDupA. -Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). +(** Some results about [eqlistA] *) + +Section EqlistA. + +Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. Proof. - induction l1; simpl; auto. - inversion_clear 1; auto. +induction 1; auto; simpl; congruence. Qed. -Lemma SortA_app : - forall l1 l2, SortA l1 -> SortA l2 -> - (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> - SortA (l1 ++ l2). +Lemma eqlistA_app : forall l1 l1' l2 l2', + eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). Proof. - induction l1; simpl in *; intuition. - inversion_clear H. - constructor; auto. - apply InfA_app; auto. - destruct l2; auto. +intros l1 l1' l2 l2' H; revert l2 l2'; induction H; simpl; auto. +Qed. + +Lemma eqlistA_rev_app : forall l1 l1', + eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> + eqlistA ((rev l1)++l2) ((rev l1')++l2'). +Proof. +induction 1; auto. +simpl; intros. +do 2 rewrite app_ass; simpl; auto. +Qed. + +Lemma eqlistA_rev : forall l1 l1', + eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). +Proof. +intros. +rewrite (app_nil_end (rev l1)). +rewrite (app_nil_end (rev l1')). +apply eqlistA_rev_app; auto. +Qed. + +Lemma SortA_equivlistA_eqlistA : forall l l', + SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. +Proof. +induction l; destruct l'; simpl; intros; auto. +destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. +destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. +inversion_clear H; inversion_clear H0. +assert (forall y, InA y l -> ltA a y). +intros; eapply SortA_InfA_InA with (l:=l); eauto. +assert (forall y, InA y l' -> ltA a0 y). +intros; eapply SortA_InfA_InA with (l:=l'); eauto. +clear H3 H4. +assert (eqA a a0). + destruct (H1 a). + destruct (H1 a0). + assert (InA a (a0::l')) by auto. + inversion_clear H8; auto. + assert (InA a0 (a::l)) by auto. + inversion_clear H8; auto. + elim (@ltA_not_eqA a a); auto. + apply ltA_trans with a0; auto. +constructor; auto. +apply IHl; auto. +split; intros. +destruct (H1 x). +assert (H8 : InA x (a0::l')) by auto; inversion_clear H8; auto. +elim (@ltA_not_eqA a x); eauto. +destruct (H1 x). +assert (H8 : InA x (a::l)) by auto; inversion_clear H8; auto. +elim (@ltA_not_eqA a0 x); eauto. +Qed. + +End EqlistA. + +(** A few things about [filter] *) + +Section Filter. + +Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). +Proof. +induction l; simpl; auto. +inversion_clear 1; auto. +destruct (f a); auto. +constructor; auto. +apply In_InfA; auto. +intros. +rewrite filter_In in H; destruct H. +eapply SortA_InfA_InA; eauto. +Qed. + +Lemma filter_InA : forall f, (compat_bool f) -> + forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. +Proof. +intros; do 2 rewrite InA_alt; intuition. +destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. +destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. + rewrite (H _ _ H0); auto. +destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. + rewrite <- (H _ _ H0); auto. +Qed. + +Lemma filter_split : + forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> + forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. +Proof. +induction l; simpl; intros; auto. +inversion_clear H0. +pattern l at 1; rewrite IHl; auto. +case_eq (f a); simpl; intros; auto. +assert (forall e, In e l -> f e = false). + intros. + assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). + case_eq (f e); simpl; intros; auto. + elim (@ltA_not_eqA e e); auto. + apply ltA_trans with a; eauto. +replace (List.filter f l) with (@nil A); auto. +generalize H3; clear; induction l; simpl; auto. +case_eq (f a); auto; intros. +rewrite H3 in H; auto; try discriminate. +Qed. + +End Filter. + +Section Fold. + +Variable B:Type. +Variable eqB:B->B->Prop. + +(** Compatibility of a two-argument function with respect to two equalities. *) +Definition compat_op (f : A -> B -> B) := + forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y'). + +(** Two-argument functions that allow to reorder their arguments. *) +Definition transpose (f : A -> B -> B) := + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + +Variable st:Setoid_Theory _ eqB. +Variable f:A->B->B. +Variable i:B. +Variable Comp:compat_op f. + +Lemma fold_right_eqlistA : + forall s s', eqlistA s s' -> + eqB (fold_right f i s) (fold_right f i s'). +Proof. +induction 1; simpl; auto. +refl_st. +Qed. + +Variable Ass:transpose f. + +Lemma fold_right_commutes : forall s1 s2 x, + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +refl_st. +trans_st (f a (f x (fold_right f i (s1++s2)))). +Qed. + +Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> + NoDupA (x::l) -> NoDupA (l1++y::l2) -> + equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). +Proof. + intros; intro a. + generalize (H2 a). + repeat rewrite InA_app_iff. + do 2 rewrite InA_cons. + inversion_clear H0. + assert (SW:=NoDupA_swap H1). + inversion_clear SW. + rewrite InA_app_iff in H0. + split; intros. + assert (~eqA a x). + contradict H3; apply InA_eqA with a; auto. + assert (~eqA a y). + contradict H8; eauto. + intuition. + assert (eqA a x \/ InA a l) by intuition. + destruct H8; auto. + elim H0. + destruct H7; [left|right]; eapply InA_eqA; eauto. +Qed. + +Lemma fold_right_equivlistA : + forall s s', NoDupA s -> NoDupA s' -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). +Proof. + simple induction s. + destruct s'; simpl. + intros; refl_st; auto. + unfold equivlistA; intros. + destruct (H1 a). + assert (X : InA a nil); auto; inversion X. + intros x l Hrec s' N N' E; simpl in *. + assert (InA x s'). + rewrite <- (E x); auto. + destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). + subst s'. + trans_st (f x (fold_right f i (s1++s2))). + apply Comp; auto. + apply Hrec; auto. + inversion_clear N; auto. + eapply NoDupA_split; eauto. + eapply equivlistA_NoDupA_split; eauto. + trans_st (f y (fold_right f i (s1++s2))). + apply Comp; auto; refl_st. + sym_st; apply fold_right_commutes. +Qed. + +Lemma fold_right_add : + forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). +Proof. + intros; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. Section Remove. @@ -279,7 +569,7 @@ destruct H0; apply eqA_trans with a; auto. split. inversion_clear 1. split; auto. -swap n. +contradict n. apply eqA_trans with y; auto. rewrite (IHl x y) in H0; destruct H0; auto. destruct 1; inversion_clear H; auto. @@ -298,14 +588,14 @@ rewrite removeA_InA. intuition. Qed. -Lemma removeA_eqlistA : forall l l' x, - ~InA x l -> eqlistA (x :: l) l' -> eqlistA l (removeA x l'). +Lemma removeA_equivlistA : forall l l' x, + ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). Proof. -unfold eqlistA; intros. +unfold equivlistA; intros. rewrite removeA_InA. split; intros. rewrite <- H0; split; auto. -swap H. +contradict H. apply InA_eqA with x0; auto. rewrite <- (H0 x0) in H1. destruct H1. @@ -313,160 +603,17 @@ inversion_clear H1; auto. elim H2; auto. Qed. -Let addlistA x l l' := forall y, InA y l' <-> eqA x y \/ InA y l. - -Lemma removeA_add : - forall s s' x x', NoDupA s -> NoDupA (x' :: s') -> - ~ eqA x x' -> ~ InA x s -> - addlistA x s (x' :: s') -> addlistA x (removeA x' s) s'. -Proof. -unfold addlistA; intros. -inversion_clear H0. -rewrite removeA_InA; auto. -split; intros. -destruct (eqA_dec x y); auto; intros. -right; split; auto. -destruct (H3 y); clear H3. -destruct H6; intuition. -swap H4; apply InA_eqA with y; auto. -destruct H0. -assert (InA y (x' :: s')) by (rewrite H3; auto). -inversion_clear H6; auto. -elim H1; apply eqA_trans with y; auto. -destruct H0. -assert (InA y (x' :: s')) by (rewrite H3; auto). -inversion_clear H7; auto. -elim H6; auto. -Qed. - -Section Fold. - -Variable B:Set. -Variable eqB:B->B->Prop. - -(** Two-argument functions that allow to reorder its arguments. *) -Definition transpose (f : A -> B -> B) := - forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). - -(** Compatibility of a two-argument function with respect to two equalities. *) -Definition compat_op (f : A -> B -> B) := - forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y'). - -(** Compatibility of a function upon natural numbers. *) -Definition compat_nat (f : A -> nat) := - forall x x' : A, eqA x x' -> f x = f x'. - -Variable st:Setoid_Theory _ eqB. -Variable f:A->B->B. -Variable Comp:compat_op f. -Variable Ass:transpose f. -Variable i:B. - -Lemma removeA_fold_right_0 : - forall s x, ~InA x s -> - eqB (fold_right f i s) (fold_right f i (removeA x s)). -Proof. - simple induction s; simpl; intros. - refl_st. - destruct (eqA_dec x a); simpl; intros. - absurd_hyp e; auto. - apply Comp; auto. -Qed. - -Lemma removeA_fold_right : - forall s x, NoDupA s -> InA x s -> - eqB (fold_right f i s) (f x (fold_right f i (removeA x s))). -Proof. - simple induction s; simpl. - inversion_clear 2. - intros. - inversion_clear H0. - destruct (eqA_dec x a); simpl; intros. - apply Comp; auto. - apply removeA_fold_right_0; auto. - swap H2; apply InA_eqA with x; auto. - inversion_clear H1. - destruct n; auto. - trans_st (f a (f x (fold_right f i (removeA x l)))). -Qed. - -Lemma fold_right_equal : - forall s s', NoDupA s -> NoDupA s' -> - eqlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). -Proof. - simple induction s. - destruct s'; simpl. - intros; refl_st; auto. - unfold eqlistA; intros. - destruct (H1 a). - assert (X : InA a nil); auto; inversion X. - intros x l Hrec s' N N' E; simpl in *. - trans_st (f x (fold_right f i (removeA x s'))). - apply Comp; auto. - apply Hrec; auto. - inversion N; auto. - apply removeA_NoDupA; auto; apply eqA_trans. - apply removeA_eqlistA; auto. - inversion_clear N; auto. - sym_st. - apply removeA_fold_right; auto. - unfold eqlistA in E. - rewrite <- E; auto. -Qed. - -Lemma fold_right_add : - forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> - addlistA x s s' -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. - simple induction s'. - unfold addlistA; intros. - destruct (H2 x); clear H2. - assert (X : InA x nil); auto; inversion X. - intros x' l' Hrec s x N N' IN EQ; simpl. - (* if x=x' *) - destruct (eqA_dec x x'). - apply Comp; auto. - apply fold_right_equal; auto. - inversion_clear N'; trivial. - unfold eqlistA; unfold addlistA in EQ; intros. - destruct (EQ x0); clear EQ. - split; intros. - destruct H; auto. - inversion_clear N'. - destruct H2; apply InA_eqA with x0; auto. - apply eqA_trans with x; auto. - assert (X:InA x0 (x' :: l')); auto; inversion_clear X; auto. - destruct IN; apply InA_eqA with x0; auto. - apply eqA_trans with x'; auto. - (* else x<>x' *) - trans_st (f x' (f x (fold_right f i (removeA x' s)))). - apply Comp; auto. - apply Hrec; auto. - apply removeA_NoDupA; auto; apply eqA_trans. - inversion_clear N'; auto. - rewrite removeA_InA; intuition. - apply removeA_add; auto. - trans_st (f x (f x' (fold_right f i (removeA x' s)))). - apply Comp; auto. - sym_st. - apply removeA_fold_right; auto. - destruct (EQ x'). - destruct H; auto; destruct n; auto. -Qed. +End Remove. End Fold. -End Remove. - End Type_with_equality. -Hint Constructors InA. -Hint Constructors NoDupA. -Hint Constructors sort. -Hint Constructors lelistA. +Hint Unfold compat_bool compat_nat compat_P. +Hint Constructors InA NoDupA sort lelistA eqlistA. Section Find. -Variable A B : Set. +Variable A B : Type. Variable eqA : A -> A -> Prop. Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x. Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v new file mode 100644 index 00000000..bdbe0ecc --- /dev/null +++ b/theories/Lists/StreamMemo.v @@ -0,0 +1,205 @@ +(************************************************************************) +(* 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 Import Eqdep_dec. +Require Import Streams. + +(** * Memoization *) + +(** Successive outputs of a given function [f] are stored in + a stream in order to avoid duplicated computations. *) + +Section MemoFunction. + +Variable A: Type. +Variable f: nat -> A. + +CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). + +Definition memo_list := memo_make 0. + +Fixpoint memo_get (n:nat) (l:Stream A) : A := + match n with + | O => hd l + | S n1 => memo_get n1 (tl l) + end. + +Theorem memo_get_correct: forall n, memo_get n memo_list = f n. +Proof. +assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)). + induction n as [| n Hrec]; try (intros m; refine (refl_equal _)). + intros m; simpl; rewrite Hrec. + rewrite plus_n_Sm; auto. +intros n; apply trans_equal with (f (n + 0)); try exact (F1 n 0). +rewrite <- plus_n_O; auto. +Qed. + +(** Building with possible sharing using a iterator [g] : + We now suppose in addition that [f n] is in fact the [n]-th + iterate of a function [g]. +*) + +Variable g: A -> A. + +Hypothesis Hg_correct: forall n, f (S n) = g (f n). + +CoFixpoint imemo_make (fn:A) : Stream A := + let fn1 := g fn in + Cons fn1 (imemo_make fn1). + +Definition imemo_list := let f0 := f 0 in + Cons f0 (imemo_make f0). + +Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n. +Proof. +assert (F1: forall n m, + memo_get n (imemo_make (f m)) = f (S (n + m))). + induction n as [| n Hrec]; try (intros m; exact (sym_equal (Hg_correct m))). + simpl; intros m; rewrite <- Hg_correct; rewrite Hrec; rewrite <- plus_n_Sm; auto. +destruct n as [| n]; try apply refl_equal. +unfold imemo_list; simpl; rewrite F1. +rewrite <- plus_n_O; auto. +Qed. + +End MemoFunction. + +(** For a dependent function, the previous solution is + reused thanks to a temporarly hiding of the dependency + in a "container" [memo_val]. *) + +Section DependentMemoFunction. + +Variable A: nat -> Type. +Variable f: forall n, A n. + +Inductive memo_val: Type := + memo_mval: forall n, A n -> memo_val. + +Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} := + match n, m return {n = m} + {True} with + | 0, 0 =>left True (refl_equal 0) + | 0, S m1 => right (0 = S m1) I + | S n1, 0 => right (S n1 = 0) I + | S n1, S m1 => + match is_eq n1 m1 with + | left H => left True (f_equal S H) + | right _ => right (S n1 = S m1) I + end + end. + +Definition memo_get_val n (v: memo_val): A n := +match v with +| memo_mval m x => + match is_eq n m with + | left H => + match H in (@eq _ _ y) return (A y -> A n) with + | refl_equal => fun v1 : A n => v1 + end + | right _ => fun _ : A m => f n + end x +end. + +Let mf n := memo_mval n (f n). + +Definition dmemo_list := memo_list _ mf. + +Definition dmemo_get n l := memo_get_val n (memo_get _ n l). + +Theorem dmemo_get_correct: forall n, dmemo_get n dmemo_list = f n. +Proof. +intros n; unfold dmemo_get, dmemo_list. +rewrite (memo_get_correct memo_val mf n); simpl. +case (is_eq n n); simpl; auto; intros e. +assert (e = refl_equal n). + apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + left; auto. + right; intros HH; discriminate HH. + right; intros HH; discriminate HH. + case (Hx y). + intros HH; left; case HH; auto. + intros HH; right; intros HH1; case HH. + injection HH1; auto. +rewrite H; auto. +Qed. + +(** Finally, a version with both dependency and iterator *) + +Variable g: forall n, A n -> A (S n). + +Hypothesis Hg_correct: forall n, f (S n) = g n (f n). + +Let mg v := match v with + memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. + +Definition dimemo_list := imemo_list _ mf mg. + +Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. +Proof. +intros n; unfold dmemo_get, dimemo_list. +rewrite (imemo_get_correct memo_val mf mg); simpl. +case (is_eq n n); simpl; auto; intros e. +assert (e = refl_equal n). + apply eq_proofs_unicity. + induction x as [| x Hx]; destruct y as [| y]. + left; auto. + right; intros HH; discriminate HH. + right; intros HH; discriminate HH. + case (Hx y). + intros HH; left; case HH; auto. + intros HH; right; intros HH1; case HH. + injection HH1; auto. +rewrite H; auto. +intros n1; unfold mf; rewrite Hg_correct; auto. +Qed. + +End DependentMemoFunction. + +(** An example with the memo function on factorial *) + +(* +Require Import ZArith. +Open Scope Z_scope. + +Fixpoint tfact (n: nat) := + match n with + | O => 1 + | S n1 => Z_of_nat n * tfact n1 + end. + +Definition lfact_list := + dimemo_list _ tfact (fun n z => (Z_of_nat (S n) * z)). + +Definition lfact n := dmemo_get _ tfact n lfact_list. + +Theorem lfact_correct n: lfact n = tfact n. +Proof. +intros n; unfold lfact, lfact_list. +rewrite dimemo_get_correct; auto. +Qed. + +Fixpoint nop p := + match p with + | xH => 0 + | xI p1 => nop p1 + | xO p1 => nop p1 + end. + +Fixpoint test z := + match z with + | Z0 => 0 + | Zpos p1 => nop p1 + | Zneg p1 => nop p1 + end. + +Time Eval vm_compute in test (lfact 2000). +Time Eval vm_compute in test (lfact 2000). +Time Eval vm_compute in test (lfact 1500). +Time Eval vm_compute in (lfact 1500). +*) + diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 7bc6a09d..49990502 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Streams.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id: Streams.v 9967 2007-07-11 15:25:03Z roconnor $ i*) Set Implicit Arguments. @@ -14,9 +14,9 @@ Set Implicit Arguments. Section Streams. -Variable A : Set. +Variable A : Type. -CoInductive Stream : Set := +CoInductive Stream : Type := Cons : A -> Stream -> Stream. @@ -146,6 +146,15 @@ Inductive Exists ( x: Stream ) : Prop := CoInductive ForAll (x: Stream) : Prop := HereAndFurther : P x -> ForAll (tl x) -> ForAll x. +Lemma ForAll_Str_nth_tl : forall m x, ForAll x -> ForAll (Str_nth_tl m x). +Proof. +induction m. + tauto. +intros x [_ H]. +simpl. +apply IHm. +assumption. +Qed. Section Co_Induction_ForAll. Variable Inv : Stream -> Prop. @@ -162,15 +171,78 @@ End Stream_Properties. End Streams. Section Map. -Variables A B : Set. +Variables A B : Type. Variable f : A -> B. CoFixpoint map (s:Stream A) : Stream B := Cons (f (hd s)) (map (tl s)). + +Lemma Str_nth_tl_map : forall n s, Str_nth_tl n (map s)= map (Str_nth_tl n s). +Proof. +induction n. +reflexivity. +simpl. +intros s. +apply IHn. +Qed. + +Lemma Str_nth_map : forall n s, Str_nth n (map s)= f (Str_nth n s). +Proof. +intros n s. +unfold Str_nth. +rewrite Str_nth_tl_map. +reflexivity. +Qed. + +Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P +(map s)) S <-> ForAll P (map S). +Proof. +intros P S. +split; generalize S; clear S; cofix; intros S; constructor; +destruct H as [H0 H]; firstorder. +Qed. + +Lemma Exists_map : forall (P:Stream B -> Prop) (S:Stream A), Exists (fun s => P +(map s)) S -> Exists P (map S). +Proof. +intros P S H. +(induction H;[left|right]); firstorder. +Defined. + End Map. Section Constant_Stream. -Variable A : Set. +Variable A : Type. Variable a : A. CoFixpoint const : Stream A := Cons a const. End Constant_Stream. -Unset Implicit Arguments.
\ No newline at end of file +Section Zip. + +Variable A B C : Type. +Variable f: A -> B -> C. + +CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := +Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). + +Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), + Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). +Proof. +induction n. +reflexivity. +intros [x xs] [y ys]. +unfold Str_nth in *. +simpl in *. +apply IHn. +Qed. + +Lemma Str_nth_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth n (zipWith a + b)= f (Str_nth n a) (Str_nth n b). +Proof. +intros. +unfold Str_nth. +rewrite Str_nth_tl_zipWith. +reflexivity. +Qed. + +End Zip. + +Unset Implicit Arguments. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3b066cfc..3d434b37 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -1,4 +1,3 @@ -(* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -7,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ChoiceFacts.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: ChoiceFacts.v 10756 2008-04-04 17:10:45Z herbelin $ i*) (** Some facts and definitions concerning choice and description in intuitionistic logic. @@ -30,7 +29,7 @@ description principles - OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice - OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice - (called AC* in Bell [Bell]) + (called AC* in Bell [[Bell]]) - OAC! - ID_iota = intuitionistic definite description @@ -44,13 +43,15 @@ description principles (an unconstrained generalisation of the constructive principle of independence of premises) - Drinker = drinker's paradox (small form) - (called Ex in Bell [Bell]) + (called Ex in Bell [[Bell]]) We let also -IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal predicate logic -IPL_2 = 2nd-order impredicative minimal predicate logic +IPL_2 = 2nd-order impredicative minimal predicate logic (with ex. quant.) IPL^2 = 2nd-order functional minimal predicate logic (with ex. quant.) +IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.) + +with no prerequisite on the non-emptyness of domains Table of contents @@ -58,24 +59,26 @@ Table of contents 2. IPL_2^2 |- AC_rel + AC! = AC_fun -3. 1. AC_rel + PI -> GAC_rel and PL_2 |- AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel +3.1. typed IPL_2 + Sigma-types + PI |- AC_rel = GAC_rel and IPL_2 |- AC_rel + IGP -> GAC_rel and IPL_2 |- GAC_rel = OAC_rel + +3.2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker -4. 2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker +3.3. D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker -5. Derivability of choice for decidable relations with well-ordered codomain +4. Derivability of choice for decidable relations with well-ordered codomain -6. Equivalence of choices on dependent or non dependent functional types +5. Equivalence of choices on dependent or non dependent functional types -7. Non contradiction of constructive descriptions wrt functional choices +6. Non contradiction of constructive descriptions wrt functional choices -8. Definite description transports classical logic to the computational world +7. Definite description transports classical logic to the computational world References: -[Bell] John L. Bell, Choice principles in intuitionistic set theory, +[[Bell]] John L. Bell, Choice principles in intuitionistic set theory, unpublished. -[Bell93] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic +[[Bell93]] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. [Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in @@ -84,8 +87,6 @@ intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. Set Implicit Arguments. -Notation Local "'inhabited' A" := A (at level 10, only parsing). - (**********************************************************************) (** * Definitions *) @@ -95,9 +96,9 @@ Section ChoiceSchemes. Variables A B :Type. -Variables P:A->Prop. +Variable P:A->Prop. -Variables R:A->B->Prop. +Variable R:A->B->Prop. (** ** Constructive choice and description *) @@ -183,15 +184,15 @@ Definition OmniscientFunctionalChoice_on := (** D_epsilon *) -Definition ClassicalIndefiniteDescription := +Definition EpsilonStatement_on := forall P:A->Prop, - A -> { x:A | (exists x, P x) -> P x }. + inhabited A -> { x:A | (exists x, P x) -> P x }. (** D_iota *) -Definition ClassicalDefiniteDescription := +Definition IotaStatement_on := forall P:A->Prop, - A -> { x:A | (exists! x, P x) -> P x }. + inhabited A -> { x:A | (exists! x, P x) -> P x }. End ChoiceSchemes. @@ -223,6 +224,11 @@ Notation ConstructiveDefiniteDescription := Notation ConstructiveIndefiniteDescription := (forall A, ConstructiveIndefiniteDescription_on A). +Notation IotaStatement := + (forall A, IotaStatement_on A). +Notation EpsilonStatement := + (forall A, EpsilonStatement_on A). + (** Subclassical schemes *) Definition ProofIrrelevance := @@ -238,16 +244,17 @@ Definition SmallDrinker'sParadox := exists x, (exists x, P x) -> P x. (**********************************************************************) -(** * AC_rel + PDP = AC_fun +(** * AC_rel + AC! = AC_fun We show that the functional formulation of the axiom of Choice (usual formulation in type theory) is equivalent to its relational - formulation (only formulation of set theory) + the axiom of - (parametric) definite description (aka axiom of unique choice) *) + formulation (only formulation of set theory) + functional relation + reification (aka axiom of unique choice, or, principle of (parametric) + definite descriptions) *) (** This shows that the axiom of choice can be assumed (under its relational formulation) without known inconsistency with classical logic, - though definite description conflicts with classical logic *) + though functional relation reification conflicts with classical logic *) Lemma description_rel_choice_imp_funct_choice : forall A B : Type, @@ -289,7 +296,7 @@ Proof. exists f; exact H0. Qed. -Theorem FunChoice_Equiv_RelChoice_and_ParamDefinDescr : +Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : forall A B, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. @@ -301,11 +308,13 @@ Proof. Qed. (**********************************************************************) -(** * Connection between the guarded, non guarded and descriptive choices and *) +(** * Connection between the guarded, non guarded and omniscient choices *) -(** We show that the guarded relational formulation of the axiom of Choice - comes from the non guarded formulation in presence either of the - independance of premises or proof-irrelevance *) +(** We show that the guarded formulations of the axiom of choice + are equivalent to their "omniscient" variant and comes from the non guarded + formulation in presence either of the independance of general premises + or subset types (themselves derivable from subtypes thanks to proof- + irrelevance) *) (**********************************************************************) (** ** AC_rel + PI -> GAC_rel and AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel *) @@ -352,9 +361,17 @@ Proof. exists R'; firstorder. Qed. +Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice : + ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice). +Proof. + auto decomp using + guarded_rel_choice_imp_rel_choice, + rel_choice_and_proof_irrel_imp_guarded_rel_choice. +Qed. + (** OAC_rel = GAC_rel *) -Lemma guarded_iff_omniscient_rel_choice : +Corollary guarded_iff_omniscient_rel_choice : GuardedRelationalChoice <-> OmniscientRelationalChoice. Proof. split. @@ -378,6 +395,7 @@ Proof. exists (f tt); auto. Qed. + Lemma guarded_fun_choice_imp_fun_choice : GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet. Proof. @@ -396,9 +414,19 @@ Proof. intro x; apply IndPrem; eauto. Qed. +Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice : + FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises + <-> GuardedFunctionalChoice. +Proof. + auto decomp using + guarded_fun_choice_imp_indep_of_general_premises, + guarded_fun_choice_imp_fun_choice, + fun_choice_and_indep_general_prem_imp_guarded_fun_choice. +Qed. + (** AC_fun + Drinker = OAC_fun *) -(** This was already observed by Bell [Bell] *) +(** This was already observed by Bell [[Bell]] *) Lemma omniscient_fun_choice_imp_small_drinker : OmniscientFunctionalChoice -> SmallDrinker'sParadox. @@ -427,12 +455,22 @@ Proof. exists f; assumption. Qed. +Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice : + FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox + <-> OmniscientFunctionalChoice. +Proof. + auto decomp using + omniscient_fun_choice_imp_small_drinker, + omniscient_fun_choice_imp_fun_choice, + fun_choice_and_small_drinker_imp_omniscient_fun_choice. +Qed. + (** OAC_fun = GAC_fun *) (** This is derivable from the intuitionistic equivalence between IGP and Drinker but we give a direct proof *) -Lemma guarded_iff_omniscient_fun_choice : +Theorem guarded_iff_omniscient_fun_choice : GuardedFunctionalChoice <-> OmniscientFunctionalChoice. Proof. split. @@ -444,6 +482,57 @@ Proof. Qed. (**********************************************************************) +(** ** D_iota -> ID_iota and D_epsilon <-> ID_epsilon + Drinker *) + +(** D_iota -> ID_iota *) + +Lemma iota_imp_constructive_definite_description : + IotaStatement -> ConstructiveDefiniteDescription. +Proof. + intros D_iota A P H. + destruct D_iota with (P:=P) as (x,H1). + destruct H; red in H; auto. + exists x; apply H1; assumption. +Qed. + +(** ID_epsilon + Drinker <-> D_epsilon *) + +Lemma epsilon_imp_constructive_indefinite_description: + EpsilonStatement -> ConstructiveIndefiniteDescription. +Proof. + intros D_epsilon A P H. + destruct D_epsilon with (P:=P) as (x,H1). + destruct H; auto. + exists x; apply H1; assumption. +Qed. + +Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon : + SmallDrinker'sParadox -> ConstructiveIndefiniteDescription -> + EpsilonStatement. +Proof. + intros Drinkers D_epsilon A P Inh; + apply D_epsilon; apply Drinkers; assumption. +Qed. + +Lemma epsilon_imp_small_drinker : + EpsilonStatement -> SmallDrinker'sParadox. +Proof. + intros D_epsilon A P Inh; edestruct D_epsilon; eauto. +Qed. + +Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon : + (SmallDrinker'sParadox * ConstructiveIndefiniteDescription -> + EpsilonStatement) * + (EpsilonStatement -> + SmallDrinker'sParadox * ConstructiveIndefiniteDescription). +Proof. + auto decomp using + epsilon_imp_constructive_indefinite_description, + constructive_indefinite_description_and_small_drinker_imp_epsilon, + epsilon_imp_small_drinker. +Qed. + +(**********************************************************************) (** * Derivability of choice for decidable relations with well-ordered codomain *) (** Countable codomains, such as [nat], can be equipped with a @@ -457,45 +546,7 @@ Qed. *) Require Import Wf_nat. -Require Import Compare_dec. Require Import Decidable. -Require Import Arith. - -Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) := - exists! x, P x /\ forall x', P x' -> R x x'. - -Lemma dec_inh_nat_subset_has_unique_least_element : - forall P:nat->Prop, (forall n, P n \/ ~ P n) -> - (exists n, P n) -> has_unique_least_element le P. -Proof. - intros P Pdec (n0,HPn0). - assert - (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'') - \/(forall n', P n' -> n<=n')). - induction n. - right. - intros n' Hn'. - apply le_O_n. - destruct IHn. - left; destruct H as (n', (Hlt', HPn')). - exists n'; split. - apply lt_S; assumption. - assumption. - destruct (Pdec n). - left; exists n; split. - apply lt_n_Sn. - split; assumption. - right. - intros n' Hltn'. - destruct (le_lt_eq_dec n n') as [Hltn|Heqn]. - apply H; assumption. - assumption. - destruct H0. - rewrite Heqn; assumption. - destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0]; - repeat split; - assumption || intros n' (HPn',Hminn'); apply le_antisym; auto. -Qed. Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) := (forall x:A, exists y : B, R x y) -> @@ -614,16 +665,24 @@ Proof. destruct Heq using eq_indd; trivial. Qed. +Corollary dep_iff_non_dep_functional_rel_reification : + FunctionalRelReification <-> DependentFunctionalRelReification. +Proof. + auto decomp using + non_dep_dep_functional_rel_reification, + dep_non_dep_functional_rel_reification. +Qed. + (**********************************************************************) (** * Non contradiction of constructive descriptions wrt functional axioms of choice *) (** ** Non contradiction of indefinite description *) -Lemma relative_non_contradiction_of_indefinite_desc : - (ConstructiveIndefiniteDescription -> False) - -> (FunctionalChoice -> False). +Lemma relative_non_contradiction_of_indefinite_descr : + forall C:Prop, (ConstructiveIndefiniteDescription -> C) + -> (FunctionalChoice -> C). Proof. - intros H AC_fun. + intros C H AC_fun. assert (AC_depfun := non_dep_dep_functional_choice AC_fun). pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}). pose (B0 := fun x:A0 => projT1 x). @@ -632,11 +691,8 @@ Proof. destruct (AC_depfun A0 B0 R0 H0) as (f, Hf). apply H. intros A P H'. - exists (f (existT (fun _ => sigT _) A - (existT (fun P => exists x, P x) P H'))). - pose (Hf' := - Hf (existT (fun _ => sigT _) A - (existT (fun P => exists x, P x) P H'))). + exists (f (existT _ A (existT _ P H'))). + pose (Hf' := Hf (existT _ A (existT _ P H'))). assumption. Qed. @@ -652,10 +708,10 @@ Qed. (** ** Non contradiction of definite description *) Lemma relative_non_contradiction_of_definite_descr : - (ConstructiveDefiniteDescription -> False) - -> (FunctionalRelReification -> False). + forall C:Prop, (ConstructiveDefiniteDescription -> C) + -> (FunctionalRelReification -> C). Proof. - intros H FunReify. + intros C H FunReify. assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify). pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}). pose (B0 := fun x:A0 => projT1 x). @@ -664,11 +720,8 @@ Proof. destruct (DepFunReify A0 B0 R0 H0) as (f, Hf). apply H. intros A P H'. - exists (f (existT (fun _ => sigT _) A - (existT (fun P => exists! x, P x) P H'))). - pose (Hf' := - Hf (existT (fun _ => sigT _) A - (existT (fun P => exists! x, P x) P H'))). + exists (f (existT _ A (existT _ P H'))). + pose (Hf' := Hf (existT _ A (existT _ P H'))). assumption. Qed. @@ -681,20 +734,37 @@ Proof. apply (proj2_sig (DefDescr B (R x) (H x))). Qed. +(** Remark, the following corollaries morally hold: + +Definition In_propositional_context (A:Type) := forall C:Prop, (A -> C) -> C. + +Corollary constructive_definite_descr_in_prop_context_iff_fun_reification : + In_propositional_context ConstructiveIndefiniteDescription + <-> FunctionalChoice. + +Corollary constructive_definite_descr_in_prop_context_iff_fun_reification : + In_propositional_context ConstructiveDefiniteDescription + <-> FunctionalRelReification. + +but expecting [FunctionalChoice] (resp. [FunctionalRelReification]) to +be applied on the same Type universes on both sides of the first +(resp. second) equivalence breaks the stratification of universes. +*) + (**********************************************************************) (** * Excluded-middle + definite description => computational excluded-middle *) -(** The idea for the following proof comes from [ChicliPottierSimpson02] *) +(** The idea for the following proof comes from [[ChicliPottierSimpson02]] *) (** Classical logic and axiom of unique choice (i.e. functional - relation reification), as shown in [ChicliPottierSimpson02], + relation reification), as shown in [[ChicliPottierSimpson02]], implies the double-negation of excluded-middle in [Set] (which is incompatible with the impredicativity of [Set]). We adapt the proof to show that constructive definite description transports excluded-middle from [Prop] to [Set]. - [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos + [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical Quotients and Quotient Types in Coq, Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646, Springer Verlag. *) @@ -717,3 +787,13 @@ Proof. left; trivial. right; trivial. Qed. + +Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : + FunctionalRelReification -> + (forall P:Prop, P \/ ~ P) -> + forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. +Proof. + intros FunReify EM C; auto decomp using + constructive_definite_descr_excluded_middle, + (relative_non_contradiction_of_definite_descr (C:=C)). +Qed. diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index bb8186ae..f9b59a6a 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -6,11 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*) +(*i $Id: ClassicalChoice.v 10170 2007-10-03 14:41:25Z herbelin $ i*) -(** This file provides classical logic, and functional choice *) +(** 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 + as the indefinite descriptions provided by the axiom of choice can + be used only in a propositional context (especially, they cannot + be used to build choice functions outside the scope of a theorem + proof) *) -(** This file extends ClassicalUniqueChoice.v with the axiom of choice. +(** This file extends ClassicalUniqueChoice.v with full choice. As ClassicalUniqueChoice.v, it implies the double-negation of excluded-middle in [Set] and leads to a classical world populated with non computable functions. Especially it conflicts with the diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index 1f1c34bf..3737abf6 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -6,14 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalDescription.v 9514 2007-01-22 14:58:50Z herbelin $ i*) +(*i $Id: ClassicalDescription.v 10170 2007-10-03 14:41:25Z herbelin $ i*) -(** This file provides classical logic and definite description *) +(** This file provides classical logic and definite description, which is + equivalent to providing classical logic and Church's iota operator *) -(** Classical definite description operator (i.e. iota) implies - excluded-middle in [Set] and leads to a classical world populated - with non computable functions. It conflicts with the - impredicativity of [Set] *) +(** Classical logic and definite descriptions implies excluded-middle + in [Set] and leads to a classical world populated with non + computable functions. It conflicts with the impredicativity of + [Set] *) Set Implicit Arguments. diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 6d0a9c77..2a4de511 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalEpsilon.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: ClassicalEpsilon.v 10170 2007-10-03 14:41:25Z herbelin $ i*) -(** This file provides classical logic and indefinite description - (Hilbert's epsilon operator) *) +(** This file provides classical logic and indefinite description under + the form of Hilbert's epsilon operator *) -(** Classical epsilon's operator (i.e. indefinite description) implies +(** Hilbert's epsilon operator and classical logic implies excluded-middle in [Set] and leads to a classical world populated with non computable functions. It conflicts with the impredicativity of [Set] *) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index dd911db6..734de52d 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: ClassicalFacts.v 10156 2007-09-30 19:02:14Z herbelin $ i*) (** Some facts and definitions about classical logic @@ -31,8 +31,8 @@ Table of contents: 3.1. Weak excluded middle -3.2. Gödel-Dummet axiom and right distributivity of implication over - disjunction +3.2. Gödel-Dummett axiom and right distributivity of implication over + disjunction 3 3. Independence of general premises and drinker's paradox @@ -91,6 +91,17 @@ Proof. right; apply (Ext A False); split; [ exact H | apply False_ind ]. Qed. +(** A weakest form of propositional extensionality: extensionality for + provable propositions only *) + +Definition provable_prop_extensionality := forall A:Prop, A -> A = True. + +Lemma provable_prop_ext : + prop_extensionality -> provable_prop_extensionality. +Proof. + intros Ext A Ha; apply Ext; split; trivial. +Qed. + (************************************************************************) (** * Classical logic and proof-irrelevance *) @@ -105,6 +116,7 @@ Qed. (just take the identity), which implies the existence of a fixpoint operator in [A] (e.g. take the Y combinator of lambda-calculus) + *) Definition inhabited (A:Prop) := A. @@ -143,6 +155,10 @@ Proof. reflexivity. Qed. +(** Remark: [prop_extensionality] can be replaced in lemma [ext_prop_fixpoint] + by the weakest property [provable_prop_extensionality]. +*) + (************************************************************************) (** ** CC |- prop_ext /\ dep elim on bool -> proof-irrelevance *) @@ -230,6 +246,11 @@ Section Proof_irrelevance_Prop_Ext_CC. End Proof_irrelevance_Prop_Ext_CC. +(** Remark: [prop_extensionality] can be replaced in lemma + [ext_prop_dep_proof_irrel_gen] by the weakest property + [provable_prop_extensionality]. +*) + (************************************************************************) (** ** CIC |- prop. ext. -> proof-irrelevance *) @@ -396,7 +417,7 @@ End Proof_irrelevance_CCI. (** We show the following increasing in the strength of axioms: - weak excluded-middle - - right distributivity of implication over disjunction and Gödel-Dummet axiom + - right distributivity of implication over disjunction and Gödel-Dummett axiom - independence of general premises and drinker's paradox - excluded-middle *) @@ -533,7 +554,11 @@ Proof. Qed. (** Independence of general premises is weaker than (generalized) - excluded middle *) + excluded middle + +Remark: generalized excluded middle is preferred here to avoid relying on +the "ex falso quodlibet" property (i.e. [False -> forall A, A]) +*) Definition generalized_excluded_middle := forall A B:Prop, A \/ (A -> B). diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 28d32fcc..bb846aa6 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -6,9 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalUniqueChoice.v 9026 2006-07-06 15:16:20Z herbelin $ i*) +(*i $Id: ClassicalUniqueChoice.v 10170 2007-10-03 14:41:25Z herbelin $ i*) -(** This file provides classical logic and unique choice *) +(** 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 + be used only in a propositional context (especially, they cannot + be used to build functions outside the scope of a theorem proof) *) (** Classical logic and unique choice, as shown in [ChicliPottierSimpson02], implies the double-negation of diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 61e377ea..f1503d24 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id:$ i*) +(*i $Id: ConstructiveEpsilon.v 10739 2008-04-01 14:45:20Z herbelin $ i*) (** This module proves the constructive description schema, which infers the sigma-existence (i.e., [Set]-existence) of a witness to a @@ -20,17 +20,19 @@ 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. 14.2.3 and 15.4. In particular, this trick is used in the proof of -[Acc_iter] in the module Coq.Init.Wf. There, recursion is done on an +[Fix_F] in the module Coq.Init.Wf. There, recursion is done on an inductive predicate [Acc] and the resulting type is in [Type]. The predicate [Acc] delineates elements that are accessible via a given relation [R]. An element is accessible if there are no infinite [R]-descending chains starting from it. -To use [Acc_iter], we define a relation R and prove that if [exists n, +To use [Fix_F], we define a relation R and prove that if [exists n, P n] then 0 is accessible with respect to R. Then, by induction on the definition of [Acc R 0], we show [{n : nat | P n}]. *) +(** Based on ideas from Benjamin Werner and Jean-François Monin *) + (** Contributed by Yevgeniy Makarov *) Require Import Arith. @@ -49,7 +51,8 @@ numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after infinite [R]-descending chain from 0 is equivalent to the termination of our searching algorithm. *) -Let R (x y : nat) := (x = S y /\ ~ P y). +Let R (x y : nat) : Prop := x = S y /\ ~ P y. + Notation Local "'acc' x" := (Acc R x) (at level 10). Lemma P_implies_acc : forall x : nat, P x -> acc x. @@ -78,7 +81,7 @@ Defined. Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}. Proof. -intros Acc_0. pattern 0. apply Acc_iter with (R := R); [| assumption]. +intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption]. clear Acc_0; intros x IH. destruct (P_decidable x) as [Px | not_Px]. exists x; simpl; assumption. @@ -102,7 +105,7 @@ Section ConstructiveEpsilon. there are functions [f : A -> nat] and [g : nat -> A] such that [g] is a left inverse of [f]. *) -Variable A : Type. +Variable A : Set. Variable f : A -> nat. Variable g : nat -> A. @@ -132,24 +135,11 @@ Proof. intros; apply constructive_indefinite_description; firstorder. Defined. -Definition epsilon (E : exists x : A, P x) : A +Definition constructive_epsilon (E : exists x : A, P x) : A := proj1_sig (constructive_indefinite_description E). -Definition epsilon_spec (E : (exists x, P x)) : P (epsilon E) +Definition constructive_epsilon_spec (E : (exists x, P x)) : P (constructive_epsilon E) := proj2_sig (constructive_indefinite_description E). End ConstructiveEpsilon. -Theorem choice : - forall (A B : Type) (f : B -> nat) (g : nat -> B), - (forall x : B, g (f x) = x) -> - forall (R : A -> B -> Prop), - (forall (x : A) (y : B), {R x y} + {~ R x y}) -> - (forall x : A, exists y : B, R x y) -> - (exists f : A -> B, forall x : A, R x (f x)). -Proof. -intros A B f g gof_eq_id R R_dec H. -exists (fun x : A => epsilon B f g gof_eq_id (R x) (R_dec x) (H x)). -intro x. -apply (epsilon_spec B f g gof_eq_id (R x) (R_dec x) (H x)). -Qed. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 8317f6bb..a7c098e8 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -5,56 +5,191 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Decidable.v 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: Decidable.v 10500 2008-02-02 15:51:00Z letouzey $ i*) (** Properties of decidable propositions *) Definition decidable (P:Prop) := P \/ ~ P. Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P. -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. Qed. Theorem dec_True : decidable True. -unfold decidable in |- *; auto. +Proof. +unfold decidable; auto. Qed. Theorem dec_False : decidable False. -unfold decidable, not in |- *; auto. +Proof. +unfold decidable, not; auto. Qed. Theorem dec_or : forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B). -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. Qed. Theorem dec_and : forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B). -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. Qed. Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A). -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. Qed. Theorem dec_imp : forall A B:Prop, decidable A -> decidable B -> decidable (A -> B). -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. +Qed. + +Theorem dec_iff : + forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). +Proof. +unfold decidable; tauto. Qed. Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P. -unfold decidable in |- *; tauto. Qed. +Proof. +unfold decidable; tauto. +Qed. Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B. -tauto. Qed. +Proof. +tauto. +Qed. Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B. -unfold decidable in |- *; tauto. Qed. +Proof. +unfold decidable; tauto. +Qed. Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B. -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. Qed. Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B. -unfold decidable in |- *; tauto. +Proof. +unfold decidable; tauto. +Qed. + +(** Results formulated with iff, used in FSetDecide. + Negation are expanded since it is unclear whether setoid rewrite + will always perform conversion. *) + +(** We begin with lemmas that, when read from left to right, + can be understood as ways to eliminate uses of [not]. *) + +Theorem not_true_iff : (True -> False) <-> False. +Proof. +tauto. +Qed. + +Theorem not_false_iff : (False -> False) <-> True. +Proof. +tauto. +Qed. + +Theorem not_not_iff : forall A:Prop, decidable A -> + (((A -> False) -> False) <-> A). +Proof. +unfold decidable; tauto. +Qed. + +Theorem contrapositive : forall A B:Prop, decidable A -> + (((A -> False) -> (B -> False)) <-> (B -> A)). +Proof. +unfold decidable; tauto. +Qed. + +Lemma or_not_l_iff_1 : forall A B: Prop, decidable A -> + ((A -> False) \/ B <-> (A -> B)). +Proof. +unfold decidable. tauto. +Qed. + +Lemma or_not_l_iff_2 : forall A B: Prop, decidable B -> + ((A -> False) \/ B <-> (A -> B)). +Proof. +unfold decidable. tauto. +Qed. + +Lemma or_not_r_iff_1 : forall A B: Prop, decidable A -> + (A \/ (B -> False) <-> (B -> A)). +Proof. +unfold decidable. tauto. Qed. + +Lemma or_not_r_iff_2 : forall A B: Prop, decidable B -> + (A \/ (B -> False) <-> (B -> A)). +Proof. +unfold decidable. tauto. +Qed. + +Lemma imp_not_l : forall A B: Prop, decidable A -> + (((A -> False) -> B) <-> (A \/ B)). +Proof. +unfold decidable. tauto. +Qed. + + +(** Moving Negations Around: + We have four lemmas that, when read from left to right, + describe how to push negations toward the leaves of a + proposition and, when read from right to left, describe + how to pull negations toward the top of a proposition. *) + +Theorem not_or_iff : forall A B:Prop, + (A \/ B -> False) <-> (A -> False) /\ (B -> False). +Proof. +tauto. +Qed. + +Lemma not_and_iff : forall A B:Prop, + (A /\ B -> False) <-> (A -> B -> False). +Proof. +tauto. +Qed. + +Lemma not_imp_iff : forall A B:Prop, decidable A -> + (((A -> B) -> False) <-> A /\ (B -> False)). +Proof. +unfold decidable. tauto. +Qed. + +Lemma not_imp_rev_iff : forall A B : Prop, decidable A -> + (((A -> B) -> False) <-> (B -> False) /\ A). +Proof. +unfold decidable. tauto. +Qed. + + + +(** With the following hint database, we can leverage [auto] to check + decidability of propositions. *) + +Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff + : decidable_prop. + +(** [solve_decidable using lib] will solve goals about the + decidability of a proposition, assisted by an auxiliary + database of lemmas. The database is intended to contain + lemmas stating the decidability of base propositions, + (e.g., the decidability of equality on a particular + inductive type). *) + +Tactic Notation "solve_decidable" "using" ident(db) := + match goal with + | |- decidable _ => + solve [ auto 100 with decidable_prop db ] + end. + +Tactic Notation "solve_decidable" := + solve_decidable using core. diff --git a/theories/Logic/DecidableType.v b/theories/Logic/DecidableType.v index a38b111f..a65e2c52 100644 --- a/theories/Logic/DecidableType.v +++ b/theories/Logic/DecidableType.v @@ -6,19 +6,36 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableType.v 8933 2006-06-09 14:08:38Z herbelin $ *) +(* $Id: DecidableType.v 10616 2008-03-04 17:33:35Z letouzey $ *) Require Export SetoidList. Set Implicit Arguments. Unset Strict Implicit. +(** * Types with Equalities, and nothing more (for subtyping purpose) *) + +Module Type EqualityType. + + Parameter Inline t : Type. + + Parameter Inline eq : t -> t -> Prop. + + Axiom eq_refl : forall x : t, eq x x. + Axiom eq_sym : forall x y : t, eq x y -> eq y x. + Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans. + +End EqualityType. + (** * Types with decidable Equalities (but no ordering) *) Module Type DecidableType. - Parameter t : Set. + Parameter Inline t : Type. - Parameter eq : t -> t -> Prop. + Parameter Inline eq : t -> t -> Prop. Axiom eq_refl : forall x : t, eq x x. Axiom eq_sym : forall x y : t, eq x y -> eq y x. @@ -37,7 +54,7 @@ Module KeyDecidableType(D:DecidableType). Import D. Section Elt. - Variable elt : Set. + Variable elt : Type. Notation key:=t. Definition eqk (p p':key*elt) := eq (fst p) (fst p'). diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v index a4f99de2..9c928598 100644 --- a/theories/Logic/DecidableTypeEx.v +++ b/theories/Logic/DecidableTypeEx.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableTypeEx.v 8933 2006-06-09 14:08:38Z herbelin $ *) +(* $Id: DecidableTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) Require Import DecidableType OrderedType OrderedTypeEx. Set Implicit Arguments. @@ -18,7 +18,7 @@ Unset Strict Implicit. the equality is the usual one of Coq. *) Module Type UsualDecidableType. - Parameter t : Set. + Parameter Inline t : Type. Definition eq := @eq t. Definition eq_refl := @refl_equal t. Definition eq_sym := @sym_eq t. @@ -30,6 +30,22 @@ End UsualDecidableType. Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U. +(** an shortcut for easily building a UsualDecidableType *) + +Module Type MiniDecidableType. + Parameter Inline t : Type. + Parameter eq_dec : forall x y:t, { x=y }+{ x<>y }. +End MiniDecidableType. + +Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. + Definition t:=M.t. + Definition eq := @eq t. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + Definition eq_dec := M.eq_dec. +End Make_UDT. + (** An OrderedType can be seen as a DecidableType *) Module OT_as_DT (O:OrderedType) <: DecidableType. @@ -48,3 +64,54 @@ Module Nat_as_DT <: UsualDecidableType := OT_as_DT (Nat_as_OT). Module Positive_as_DT <: UsualDecidableType := OT_as_DT (Positive_as_OT). Module N_as_DT <: UsualDecidableType := OT_as_DT (N_as_OT). Module Z_as_DT <: UsualDecidableType := OT_as_DT (Z_as_OT). + +(** From two decidable types, we can build a new DecidableType + over their cartesian product. *) + +Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. + + Definition t := prod D1.t D2.t. + + Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y). + + Lemma eq_refl : forall x : t, eq x x. + Proof. + intros (x1,x2); red; simpl; auto. + Qed. + + Lemma eq_sym : forall x y : t, eq x y -> eq y x. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. + Qed. + + Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + Proof. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + Qed. + + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl. + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition. + Defined. + +End PairDecidableType. + +(** Similarly for pairs of UsualDecidableType *) + +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: DecidableType. + Definition t := prod D1.t D2.t. + Definition eq := @eq t. + Definition eq_refl := @refl_equal t. + Definition eq_sym := @sym_eq t. + Definition eq_trans := @trans_eq t. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || + (right; intro H; injection H; auto). + Defined. + +End PairUsualDecidableType. diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v new file mode 100644 index 00000000..962f2a2a --- /dev/null +++ b/theories/Logic/Description.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Description.v 10170 2007-10-03 14:41:25Z 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 *) + +Require Import ChoiceFacts. + +Set Implicit Arguments. + +Axiom constructive_definite_description : + forall (A : Type) (P : A->Prop), + (exists! x, P x) -> { x : A | P x }. diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v new file mode 100644 index 00000000..65d4d853 --- /dev/null +++ b/theories/Logic/Epsilon.v @@ -0,0 +1,72 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Epsilon.v 10170 2007-10-03 14:41:25Z herbelin $ i*) + +(** This file provides indefinite description under the form of + Hilbert's epsilon operator; it does not assume classical logic. *) + +Require Import ChoiceFacts. + +Set Implicit Arguments. + +(** Hilbert's epsilon: operator and specification in one statement *) + +Axiom epsilon_statement : + forall (A : Type) (P : A->Prop), inhabited A -> + { x : A | (exists x, P x) -> P x }. + +Lemma constructive_indefinite_description : + forall (A : Type) (P : A->Prop), + (exists x, P x) -> { x : A | P x }. +Proof. + apply epsilon_imp_constructive_indefinite_description. + exact epsilon_statement. +Qed. + +Lemma small_drinkers'_paradox : + forall (A:Type) (P:A -> Prop), inhabited A -> + exists x, (exists x, P x) -> P x. +Proof. + apply epsilon_imp_small_drinker. + exact epsilon_statement. +Qed. + +Theorem iota_statement : + forall (A : Type) (P : A->Prop), inhabited A -> + { x : A | (exists! x : A, P x) -> P x }. +Proof. + intros; destruct epsilon_statement with (P:=P); firstorder. +Qed. + +Lemma constructive_definite_description : + forall (A : Type) (P : A->Prop), + (exists! x, P x) -> { x : A | P x }. +Proof. + apply iota_imp_constructive_definite_description. + exact iota_statement. +Qed. + +(** Hilbert's epsilon operator and its specification *) + +Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A + := proj1_sig (epsilon_statement P i). + +Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : + (exists x, P x) -> P (epsilon i P) + := proj2_sig (epsilon_statement P i). + +(** Church's iota operator and its specification *) + +Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A + := proj1_sig (iota_statement P i). + +Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : + (exists! x:A, P x) -> P (iota i P) + := proj2_sig (iota_statement P i). + diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 94a577ca..844bff88 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqdepFacts.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: EqdepFacts.v 11095 2008-06-10 19:36:10Z herbelin $ i*) (** This file defines dependent equality and shows its equivalence with equality on dependent pairs (inhabiting sigma-types). It derives @@ -104,7 +104,7 @@ Implicit Arguments eq_dep1 [U P]. (** Dependent equality is equivalent to equality on dependent pairs *) -Lemma eq_sigS_eq_dep : +Lemma eq_sigT_eq_dep : 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. Proof. @@ -113,26 +113,19 @@ Proof. apply eq_dep_intro. Qed. +Notation eq_sigS_eq_dep := eq_sigT_eq_dep (only parsing). (* Compatibility *) + Lemma equiv_eqex_eqdep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), - existS P p x = existS P q y <-> eq_dep p x q y. + existT P p x = existT P q y <-> eq_dep p x q y. Proof. split. (* -> *) - apply eq_sigS_eq_dep. + apply eq_sigT_eq_dep. (* <- *) destruct 1; reflexivity. Qed. -Lemma eq_sigT_eq_dep : - 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. -Proof. - intros. - dependent rewrite H. - apply eq_dep_intro. -Qed. - Lemma eq_dep_eq_sigT : 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. @@ -258,7 +251,7 @@ Section Corollaries. Proof. intro eq_dep_eq; red; intros. apply eq_dep_eq. - apply eq_sigS_eq_dep. + apply eq_sigT_eq_dep. assumption. Qed. @@ -270,7 +263,7 @@ Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2. (************************************************************************) -(** *** C. Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) +(** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) Module Type EqdepElimination. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 103efd22..0281916e 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep_dec.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Eqdep_dec.v 10144 2007-09-26 15:12:17Z vsiles $ i*) (** 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. @@ -158,6 +158,13 @@ Proof. apply (Streicher_K__eq_rect_eq A (K_dec_type eq_dec)). Qed. +(** We deduce the injectivity of dependent equality for decidable types *) +Theorem eq_dep_eq_dec : + forall A:Type, + (forall x y:A, {x = y} + {x <> y}) -> + forall (P:A->Type) (p:A) (x y:P p), eq_dep A P p x p y -> x = y. +Proof (fun A eq_dec => eq_rect_eq__eq_dep_eq A (eq_rect_eq_dec eq_dec)). + Unset Implicit Arguments. (************************************************************************) @@ -229,7 +236,7 @@ Module DecidableEqDep (M:DecidableType). End DecidableEqDep. (************************************************************************) -(** ** B Definition of the functor that builds properties of dependent equalities on decidable sets in Set *) +(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Set *) (** The signature of decidable sets in [Set] *) @@ -296,3 +303,15 @@ Module DecidableEqDepSet (M:DecidableSet). Notation inj_pairT2 := inj_pair2. End DecidableEqDepSet. + + (** From decidability to inj_pair2 **) +Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) -> + ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ). +Proof. + intros A eq_dec. + apply eq_dep_eq__inj_pair2. + apply eq_rect_eq__eq_dep_eq. + unfold Eq_rect_eq. + apply eq_rect_eq_dec. + apply eq_dec. +Qed. diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v new file mode 100644 index 00000000..740b889a --- /dev/null +++ b/theories/Logic/IndefiniteDescription.v @@ -0,0 +1,39 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: IndefiniteDescription.v 10170 2007-10-03 14:41:25Z 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 + stronger than the axiom of choice (which cannot be used outside + the context of a theorem proof). *) + +Require Import ChoiceFacts. + +Set Implicit Arguments. + +Axiom constructive_indefinite_description : + forall (A : Type) (P : A->Prop), + (exists x, P x) -> { x : A | P x }. + +Lemma constructive_definite_description : + forall (A : Type) (P : A->Prop), + (exists! x, P x) -> { x : A | P x }. +Proof. + intros; apply constructive_indefinite_description; firstorder. +Qed. + +Lemma functional_choice : + forall (A B : Type) (R:A->B->Prop), + (forall x : A, exists y : B, R x y) -> + (exists f : A->B, forall x : A, R x (f x)). +Proof. + apply constructive_indefinite_descr_fun_choice. + exact constructive_indefinite_description. +Qed. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 6a723e43..c3573ac3 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: JMeq.v 9077 2006-08-24 08:44:32Z herbelin $ i*) +(*i $Id: JMeq.v 9849 2007-05-22 20:40:04Z herbelin $ i*) (** John Major's Equality as proposed by Conor McBride @@ -19,9 +19,12 @@ Set Implicit Arguments. +Unset Elimination Schemes. + Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop := JMeq_refl : JMeq x x. -Reset JMeq_rect. + +Set Elimination Schemes. Hint Resolve JMeq_refl. @@ -65,20 +68,42 @@ Lemma JMeq_rect_r : intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial. Qed. -(** [JMeq] is equivalent to [(eq_dep Type [X]X)] *) +(** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *) Require Import Eqdep. -Lemma JMeq_eq_dep : +Lemma JMeq_eq_dep_id : forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y. Proof. destruct 1. apply eq_dep_intro. Qed. -Lemma eq_dep_JMeq : +Lemma eq_dep_id_JMeq : forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y. Proof. destruct 1. -apply JMeq_refl. +apply JMeq_refl. +Qed. + +(** [eq_dep U P p x q y] is strictly finer than [JMeq (P p) x (P q) y] *) + +Lemma eq_dep_JMeq : + forall U P p x q y, eq_dep U P p x q y -> JMeq x y. +Proof. +destruct 1. +apply JMeq_refl. +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. +Proof. +exists bool. exists (fun _ => True). exists true. exists false. +exists I. exists I. +split. +trivial. +intro H. +assert (true=false) by (destruct H; reflexivity). +discriminate. Qed. diff --git a/theories/Logic/SetIsType.v b/theories/Logic/SetIsType.v new file mode 100644 index 00000000..3286beb4 --- /dev/null +++ b/theories/Logic/SetIsType.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** * The Set universe seen as a synonym for Type *) + +(** After loading this file, Set becomes just another name for Type. + This allows to easily perform a Set-to-Type migration, or at least + test whether a development relies or not on specific features of + 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 diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 78353145..20dabed2 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinNat.v 8771 2006-04-29 11:55:57Z letouzey $ i*) +(*i $Id: BinNat.v 10806 2008-04-16 23:51:06Z letouzey $ i*) Require Import BinPos. Unset Boxed Definitions. @@ -59,6 +59,16 @@ Definition Nsucc n := | Npos p => Npos (Psucc p) end. +(** Predecessor *) + +Definition Npred (n : N) := match n with +| N0 => N0 +| Npos p => match p with + | xH => N0 + | _ => Npos (Ppred p) + end +end. + (** Addition *) Definition Nplus n m := @@ -70,6 +80,21 @@ Definition Nplus n m := Infix "+" := Nplus : N_scope. +(** Subtraction *) + +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. + +Infix "-" := Nminus : N_scope. + (** Multiplication *) Definition Nmult n m := @@ -93,6 +118,28 @@ Definition Ncompare n m := Infix "?=" := Ncompare (at level 70, no associativity) : N_scope. +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. + +Infix "<=" := Nle : N_scope. +Infix "<" := Nlt : N_scope. +Infix ">=" := Nge : N_scope. +Infix ">" := Ngt : N_scope. + +(** Min and max *) + +Definition Nmin (n n' : N) := match Ncompare n n' with + | Lt | Eq => n + | Gt => n' + end. + +Definition Nmax (n n' : N) := match Ncompare n n' with + | Lt | Eq => n' + | Gt => n + end. + (** convenient induction principles *) Lemma N_ind_double : @@ -123,15 +170,48 @@ Qed. (** Peano induction on binary natural numbers *) -Theorem Nind : - forall P:N -> Prop, - P N0 -> (forall n:N, P n -> P (Nsucc n)) -> forall n:N, P n. +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. + +Theorem Nrect_base : forall P a f, Nrect P a f N0 = a. +Proof. +intros P a f; simpl; reflexivity. +Qed. + +Theorem Nrect_step : forall P a f n, Nrect P a f (Nsucc n) = f n (Nrect P a f n). +Proof. +intros P a f; destruct n as [| p]; simpl; +[rewrite Prect_base | rewrite Prect_succ]; reflexivity. +Qed. + +Definition Nind (P : N -> Prop) := Nrect P. + +Definition Nrec (P : N -> Set) := Nrect P. + +Theorem Nrec_base : forall P a f, Nrec P a f N0 = a. Proof. -destruct n. - assumption. - apply Pind with (P := fun p => P (Npos p)). -exact (H0 N0 H). -intro p'; exact (H0 (Npos p')). +intros P a f; unfold Nrec; apply Nrect_base. +Qed. + +Theorem Nrec_step : forall P a f n, Nrec P a f (Nsucc n) = f n (Nrec P a f n). +Proof. +intros P a f; unfold Nrec; apply Nrect_step. +Qed. + +(** Properties of successor and predecessor *) + +Theorem Npred_succ : forall n : N, Npred (Nsucc n) = n. +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. Qed. (** Properties of addition *) @@ -171,6 +251,11 @@ destruct n; destruct m. simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity. Qed. +Theorem Nsucc_0 : forall n : N, Nsucc n <> N0. +Proof. +intro n; elim n; simpl Nsucc; intros; discriminate. +Qed. + Theorem Nsucc_inj : forall n m:N, Nsucc n = Nsucc m -> n = m. Proof. destruct n; destruct m; simpl in |- *; intro H; reflexivity || injection H; @@ -188,13 +273,51 @@ intro n; pattern n in |- *; apply Nind; clear n; simpl in |- *. apply IHn; apply Nsucc_inj; assumption. Qed. +(** Properties of subtraction. *) + +Lemma Nminus_N0_Nle : forall n n' : N, n - n' = N0 <-> n <= n'. +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. +Qed. + +Theorem Nminus_0_r : forall n : N, n - N0 = n. +Proof. +now destruct n. +Qed. + +Theorem Nminus_succ_r : forall n m : N, n - (Nsucc m) = Npred (n - m). +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 |]. +Qed. + (** Properties of multiplication *) +Theorem Nmult_0_l : forall n:N, N0 * n = N0. +Proof. +reflexivity. +Qed. + Theorem Nmult_1_l : forall n:N, Npos 1 * n = n. Proof. destruct n; reflexivity. Qed. +Theorem Nmult_Sn_m : forall n m : N, (Nsucc n) * m = m + n * m. +Proof. +destruct n as [| n]; destruct m as [| m]; simpl; auto. +rewrite Pmult_Sn_m; reflexivity. +Qed. + Theorem Nmult_1_r : forall n:N, n * Npos 1%positive = n. Proof. destruct n; simpl in |- *; try reflexivity. @@ -233,13 +356,14 @@ destruct n; destruct m; reflexivity || (try discriminate H). injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity. Qed. -Theorem Nmult_0_l : forall n:N, N0 * n = N0. +(** Properties of comparison *) + +Lemma Ncompare_refl : forall n, (n ?= n) = Eq. Proof. -reflexivity. +destruct n; simpl; auto. +apply Pcompare_refl. Qed. -(** Properties of comparison *) - Theorem Ncompare_Eq_eq : forall n m:N, (n ?= m) = Eq -> n = m. Proof. destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H; @@ -247,10 +371,10 @@ destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H; rewrite (Pcompare_Eq_eq n m H); reflexivity. Qed. -Lemma Ncompare_refl : forall n, (n ?= n) = Eq. +Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m. Proof. -destruct n; simpl; auto. -apply Pcompare_refl. +split; intros; + [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ]. Qed. Lemma Ncompare_antisym : forall n m, CompOpp (n ?= m) = (m ?= n). @@ -259,6 +383,30 @@ destruct n; destruct m; simpl; auto. exact (Pcompare_antisym p p0 Eq). Qed. +Theorem Nlt_irrefl : forall n : N, ~ n < n. +Proof. +intro n; unfold Nlt; now rewrite Ncompare_refl. +Qed. + +Theorem Ncompare_n_Sm : + forall n m : N, Ncompare n (Nsucc m) = Lt <-> Ncompare n m = Lt \/ n = m. +Proof. +intros n m; split; destruct n as [| p]; destruct m as [| q]; simpl; auto. +destruct p; simpl; intros; discriminate. +pose proof (proj1 (Pcompare_p_Sq p q)); +assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. +intros H; destruct H; discriminate. +pose proof (proj2 (Pcompare_p_Sq p q)); +assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. +Qed. + +(** 0 is the least natural number *) + +Theorem Ncompare_0 : forall n : N, Ncompare n N0 <> Lt. +Proof. +destruct n; discriminate. +Qed. + (** Dividing by 2 *) Definition Ndiv2 (n:N) := diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v index 513a67c2..e3293e70 100644 --- a/theories/NArith/BinPos.v +++ b/theories/NArith/BinPos.v @@ -6,19 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinPos.v 6699 2005-02-07 14:30:08Z coq $ i*) +(*i $Id: BinPos.v 11033 2008-06-01 22:56:50Z letouzey $ i*) Unset Boxed Definitions. (**********************************************************************) (** Binary positive numbers *) -(** Original development by Pierre Crégut, CNET, Lannion, France *) +(** Original development by Pierre Crégut, CNET, Lannion, France *) Inductive positive : Set := - | xI : positive -> positive - | xO : positive -> positive - | xH : positive. +| xI : positive -> positive +| xO : positive -> positive +| xH : positive. (** Declare binding key for scope positive_scope *) @@ -30,164 +30,181 @@ 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 - | xI x' => xO (Psucc x') - | xO x' => xI x' - | xH => xO xH + | p~1 => (Psucc p)~0 + | p~0 => p~1 + | 1 => 1~0 end. (** Addition *) Set Boxed Definitions. -Fixpoint Pplus (x y:positive) {struct x} : positive := +Fixpoint Pplus (x y:positive) : positive := match x, y with - | xI x', xI y' => xO (Pplus_carry x' y') - | xI x', xO y' => xI (Pplus x' y') - | xI x', xH => xO (Psucc x') - | xO x', xI y' => xI (Pplus x' y') - | xO x', xO y' => xO (Pplus x' y') - | xO x', xH => xI x' - | xH, xI y' => xO (Psucc y') - | xH, xO y' => xI y' - | xH, xH => xO xH + | 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) {struct x} : positive := + +with Pplus_carry (x y:positive) : positive := match x, y with - | xI x', xI y' => xI (Pplus_carry x' y') - | xI x', xO y' => xO (Pplus_carry x' y') - | xI x', xH => xI (Psucc x') - | xO x', xI y' => xO (Pplus_carry x' y') - | xO x', xO y' => xI (Pplus x' y') - | xO x', xH => xO (Psucc x') - | xH, xI y' => xI (Psucc y') - | xH, xO y' => xO (Psucc y') - | xH, xH => xI xH + | 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. -Open Local Scope positive_scope. - (** From binary positive numbers to Peano natural numbers *) -Fixpoint Pmult_nat (x:positive) (pow2:nat) {struct x} : nat := +Fixpoint Pmult_nat (x:positive) (pow2:nat) : nat := match x with - | xI x' => (pow2 + Pmult_nat x' (pow2 + pow2))%nat - | xO x' => Pmult_nat x' (pow2 + pow2)%nat - | xH => pow2 + | 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 1. +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 => xH - | S x' => Psucc (P_of_succ_nat x') + | 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 - | xI x' => xI (xO x') - | xO x' => xI (Pdouble_minus_one x') - | xH => xH + | p~1 => p~0~1 + | p~0 => (Pdouble_minus_one p)~1 + | 1 => 1 end. (** Predecessor *) Definition Ppred (x:positive) := match x with - | xI x' => xO x' - | xO x' => Pdouble_minus_one x' - | xH => xH + | 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. +| 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 xH - | IsNeg => IsNeg - | IsPos p => IsPos (xI p) + | 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 (xO p) + | IsNul => IsNul + | IsNeg => IsNeg + | IsPos p => IsPos p~0 end. (** Operation x -> 2*x-2 *) Definition Pdouble_minus_two (x:positive) := match x with - | xI x' => IsPos (xO (xO x')) - | xO x' => IsPos (xO (Pdouble_minus_one x')) - | xH => IsNul + | 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 - | xI x', xI y' => Pdouble_mask (Pminus_mask x' y') - | xI x', xO y' => Pdouble_plus_one_mask (Pminus_mask x' y') - | xI x', xH => IsPos (xO x') - | xO x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y') - | xO x', xO y' => Pdouble_mask (Pminus_mask x' y') - | xO x', xH => IsPos (Pdouble_minus_one x') - | xH, xH => IsNul - | xH, _ => IsNeg + | 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 := + +with Pminus_mask_carry (x y:positive) {struct y} : positive_mask := match x, y with - | xI x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y') - | xI x', xO y' => Pdouble_mask (Pminus_mask x' y') - | xI x', xH => IsPos (Pdouble_minus_one x') - | xO x', xI y' => Pdouble_mask (Pminus_mask_carry x' y') - | xO x', xO y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y') - | xO x', xH => Pdouble_minus_two x' - | xH, _ => IsNeg + | 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 - | _ => xH + | IsPos z => z + | _ => 1 end. Infix "-" := Pminus : positive_scope. (** Multiplication on binary positive numbers *) -Fixpoint Pmult (x y:positive) {struct x} : positive := +Fixpoint Pmult (x y:positive) : positive := match x with - | xI x' => y + xO (Pmult x' y) - | xO x' => xO (Pmult x' y) - | xH => y + | p~1 => y + (Pmult p y)~0 + | p~0 => (Pmult p y)~0 + | 1 => y end. Infix "*" := Pmult : positive_scope. @@ -196,9 +213,9 @@ Infix "*" := Pmult : positive_scope. Definition Pdiv2 (z:positive) := match z with - | xH => xH - | xO p => p - | xI p => p + | 1 => 1 + | p~0 => p + | p~1 => p end. Infix "/" := Pdiv2 : positive_scope. @@ -207,25 +224,51 @@ Infix "/" := Pdiv2 : positive_scope. Fixpoint Pcompare (x y:positive) (r:comparison) {struct y} : comparison := match x, y with - | xI x', xI y' => Pcompare x' y' r - | xI x', xO y' => Pcompare x' y' Gt - | xI x', xH => Gt - | xO x', xI y' => Pcompare x' y' Lt - | xO x', xO y' => Pcompare x' y' r - | xO x', xH => Gt - | xH, xI y' => Lt - | xH, xO y' => Lt - | xH, xH => r + | 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. + (**********************************************************************) (** Miscellaneous properties of binary positive numbers *) -Lemma ZL11 : forall p:positive, p = xH \/ p <> xH. +Lemma ZL11 : forall p:positive, p = 1 \/ p <> 1. Proof. -intros x; case x; intros; (left; reflexivity) || (right; discriminate). + intros x; case x; intros; (left; reflexivity) || (right; discriminate). Qed. (**********************************************************************) @@ -233,78 +276,70 @@ Qed. (** Specification of [xI] in term of [Psucc] and [xO] *) -Lemma xI_succ_xO : forall p:positive, xI p = Psucc (xO p). +Lemma xI_succ_xO : forall p:positive, p~1 = Psucc p~0. Proof. -reflexivity. + reflexivity. Qed. Lemma Psucc_discr : forall p:positive, p <> Psucc p. Proof. -intro x; destruct x as [p| p| ]; discriminate. + destruct p; discriminate. Qed. (** Successor and double *) Lemma Psucc_o_double_minus_one_eq_xO : - forall p:positive, Psucc (Pdouble_minus_one p) = xO p. + forall p:positive, Psucc (Pdouble_minus_one p) = p~0. Proof. -intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx; - reflexivity. + induction p; simpl; f_equal; auto. Qed. Lemma Pdouble_minus_one_o_succ_eq_xI : - forall p:positive, Pdouble_minus_one (Psucc p) = xI p. + forall p:positive, Pdouble_minus_one (Psucc p) = p~1. Proof. -intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx; - reflexivity. + induction p; simpl; f_equal; auto. Qed. Lemma xO_succ_permute : - forall p:positive, xO (Psucc p) = Psucc (Psucc (xO p)). + forall p:positive, (Psucc p)~0 = Psucc (Psucc p~0). Proof. -intro y; induction y as [y Hrecy| y Hrecy| ]; simpl in |- *; auto. + induction p; simpl; auto. Qed. Lemma double_moins_un_xO_discr : - forall p:positive, Pdouble_minus_one p <> xO p. + forall p:positive, Pdouble_minus_one p <> p~0. Proof. -intro x; destruct x as [p| p| ]; discriminate. + destruct p; discriminate. Qed. (** Successor and predecessor *) -Lemma Psucc_not_one : forall p:positive, Psucc p <> xH. +Lemma Psucc_not_one : forall p:positive, Psucc p <> 1. Proof. -intro x; destruct x as [x| x| ]; discriminate. + destruct p; discriminate. Qed. Lemma Ppred_succ : forall p:positive, Ppred (Psucc p) = p. Proof. -intro x; destruct x as [p| p| ]; [ idtac | idtac | simpl in |- *; auto ]; - (induction p as [p IHp| | ]; [ idtac | reflexivity | reflexivity ]); - simpl in |- *; simpl in IHp; try rewrite <- IHp; reflexivity. + 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 = xH \/ Psucc (Ppred p) = p. +Lemma Psucc_pred : forall p:positive, p = 1 \/ Psucc (Ppred p) = p. Proof. -intro x; induction x as [x Hrecx| x Hrecx| ]; - [ simpl in |- *; auto - | simpl in |- *; intros; right; apply Psucc_o_double_minus_one_eq_xO - | auto ]. + 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. -intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H; - discriminate H || (try (injection H; clear H; intro H)). -rewrite (IHx y H); reflexivity. -absurd (Psucc x = xH); [ apply Psucc_not_one | assumption ]. -apply f_equal with (1 := H); assumption. -absurd (Psucc y = xH); - [ apply Psucc_not_one | symmetry in |- *; assumption ]. -reflexivity. + 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. (**********************************************************************) @@ -312,656 +347,758 @@ Qed. (** Specification of [Psucc] in term of [Pplus] *) -Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + xH. +Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + 1. Proof. -intro q; destruct q as [p| p| ]; reflexivity. + destruct p; reflexivity. Qed. -Lemma Pplus_one_succ_l : forall p:positive, Psucc p = xH + p. +Lemma Pplus_one_succ_l : forall p:positive, Psucc p = 1 + p. Proof. -intro q; destruct q as [p| p| ]; reflexivity. + destruct p; reflexivity. Qed. (** Specification of [Pplus_carry] *) Theorem Pplus_carry_spec : - forall p q:positive, Pplus_carry p q = Psucc (p + q). + forall p q:positive, Pplus_carry p q = Psucc (p + q). 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; rewrite IHp; - auto. + induction p; destruct q; simpl; f_equal; auto. Qed. (** Commutativity *) Theorem Pplus_comm : forall p q:positive, p + q = q + p. 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; - try do 2 rewrite Pplus_carry_spec; rewrite IHp; auto. + 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). + forall p q:positive, p + Psucc q = Psucc (p + q). 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; - [ rewrite Pplus_carry_spec; rewrite IHp; auto - | rewrite Pplus_carry_spec; auto - | destruct p; simpl in |- *; auto - | rewrite IHp; auto - | destruct p; simpl in |- *; auto ]. + 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). + forall p q:positive, Psucc p + q = Psucc (p + q). Proof. -intros x y; rewrite Pplus_comm; rewrite Pplus_comm with (p := x); - apply Pplus_succ_permute_r. + 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 <> xH -> Pplus_carry p (Ppred q) = p + q. + forall p q:positive, q <> 1 -> Pplus_carry p (Ppred q) = p + q. Proof. -intros q z H; elim (Psucc_pred z); - [ intro; absurd (z = xH); auto - | intros E; pattern z at 2 in |- *; rewrite <- E; - rewrite Pplus_succ_permute_r; rewrite Pplus_carry_spec; - trivial ]. -Qed. + 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. -intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H; - discriminate H || injection H; clear H; intro H; apply (IHx y H). + 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. + forall p q:positive, Pplus_carry q p <> Psucc p. Proof. -intros x y H; absurd (y + x = x); - [ apply Pplus_no_neutral - | apply Psucc_inj; rewrite <- Pplus_carry_spec; assumption ]. + 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. + forall p q r s:positive, Pplus_carry p r = Pplus_carry q s -> p + r = q + s. Proof. -intros x y z t H; apply Psucc_inj; do 2 rewrite <- Pplus_carry_spec; - assumption. + 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 x y z; generalize x y; clear x y. -induction z as [z| z| ]. - destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *; - intro H; discriminate H || (try (injection H; clear H; intro H)). - rewrite IHz with (1 := Pplus_carry_plus _ _ _ _ H); reflexivity. - absurd (Pplus_carry x z = Psucc z); - [ apply Pplus_carry_no_neutral | assumption ]. - rewrite IHz with (1 := H); reflexivity. - symmetry in H; absurd (Pplus_carry y z = Psucc z); - [ apply Pplus_carry_no_neutral | assumption ]. - reflexivity. - destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *; - intro H; discriminate H || (try (injection H; clear H; intro H)). - rewrite IHz with (1 := H); reflexivity. - absurd (x + z = z); [ apply Pplus_no_neutral | assumption ]. - rewrite IHz with (1 := H); reflexivity. - symmetry in H; absurd (y + z = z); - [ apply Pplus_no_neutral | assumption ]. - reflexivity. - intros H x y; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption. + 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 x y z H; apply Pplus_reg_r with (r := x); - rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y); - assumption. + 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. + forall p q r:positive, Pplus_carry p r = Pplus_carry q r -> p = q. Proof. -intros x y z H; apply Pplus_reg_r with (r := z); apply Pplus_carry_plus; - assumption. + 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. + forall p q r:positive, Pplus_carry p q = Pplus_carry p r -> q = r. Proof. -intros x y z H; apply Pplus_reg_r with (r := x); - rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y); - apply Pplus_carry_plus; assumption. + 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. -intros x y; generalize x; clear x. -induction y as [y| y| ]; intro x. - destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *; - repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r; - repeat rewrite Pplus_succ_permute_l; - reflexivity || (repeat apply f_equal with (A := positive)); - apply IHy. - destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *; - repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r; - repeat rewrite Pplus_succ_permute_l; - reflexivity || (repeat apply f_equal with (A := positive)); - apply IHy. - intro z; rewrite Pplus_comm with (p := xH); - do 2 rewrite <- Pplus_one_succ_r; rewrite Pplus_succ_permute_l; - rewrite Pplus_succ_permute_r; reflexivity. + 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, xO (p + q) = xI p + Pdouble_minus_one q. + forall p q:positive, (p + q)~0 = p~1 + Pdouble_minus_one q. Proof. -intros; change (xI p) with (xO p + xH) in |- *. -rewrite <- Pplus_assoc; rewrite <- Pplus_one_succ_l; - rewrite Psucc_o_double_minus_one_eq_xO. -reflexivity. + 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) = xO p + Pdouble_minus_one q. + 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 as [q| q| ]; simpl in |- *; - try rewrite Pplus_carry_spec; try rewrite Pdouble_minus_one_o_succ_eq_xI; - try rewrite IHp; try rewrite Pplus_xI_double_minus_one; - try reflexivity. - rewrite <- Psucc_o_double_minus_one_eq_xO; rewrite Pplus_one_succ_l; - reflexivity. + 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 = xO p. +Lemma Pplus_diag : forall p:positive, p + p = p~0. Proof. -intro x; induction x; simpl in |- *; try rewrite Pplus_carry_spec; - try rewrite IHx; reflexivity. + induction p as [p IHp| p IHp| ]; simpl; + try rewrite ?Pplus_carry_spec, ?IHp; reflexivity. Qed. (**********************************************************************) -(** Peano induction on binary positive positive numbers *) +(** Peano induction and recursion on binary positive positive numbers *) +(** (a nice proof from Conor McBride, see "The view from the left") *) -Fixpoint plus_iter (x y:positive) {struct x} : positive := - match x with - | xH => Psucc y - | xO x => plus_iter x (plus_iter x y) - | xI x => plus_iter x (plus_iter x (Psucc y)) +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. -Lemma plus_iter_eq_plus : forall p q:positive, plus_iter p q = p + q. -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 |- *; reflexivity || (do 2 rewrite IHp); - rewrite Pplus_assoc; rewrite Pplus_diag; try reflexivity. -rewrite Pplus_carry_spec; rewrite <- Pplus_succ_permute_r; reflexivity. -rewrite Pplus_one_succ_r; reflexivity. -Qed. +Fixpoint peanoView_xI p (q:PeanoView p) : PeanoView (p~1) := + match q in PeanoView x return PeanoView (x~1) with + | PeanoOne => PeanoSucc _ (PeanoSucc _ PeanoOne) + | PeanoSucc _ q => PeanoSucc _ (PeanoSucc _ (peanoView_xI _ q)) + end. + +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. -Lemma plus_iter_xO : forall p:positive, plus_iter p p = xO p. +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. -intro; rewrite <- Pplus_diag; apply plus_iter_eq_plus. + apply eq_dep_eq_dec. + decide equality. Qed. -Lemma plus_iter_xI : forall p:positive, Psucc (plus_iter p p) = xI p. +Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. Proof. -intro; rewrite xI_succ_xO; rewrite <- Pplus_diag; - apply (f_equal (A:=positive)); apply plus_iter_eq_plus. + 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. -Lemma iterate_add : - forall P:positive -> Type, - (forall n:positive, P n -> P (Psucc n)) -> - forall p q:positive, P q -> P (plus_iter p q). -Proof. -intros P H; induction p; simpl in |- *; intros. -apply IHp; apply IHp; apply H; assumption. -apply IHp; apply IHp; assumption. -apply H; assumption. -Defined. +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). -(** Peano induction *) +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 Pind : - forall P:positive -> Prop, - P xH -> (forall n:positive, P n -> P (Psucc n)) -> forall p:positive, P p. +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. -intros P H1 Hsucc n; induction n. -rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption. -rewrite <- plus_iter_xO; apply iterate_add; assumption. -assumption. + trivial. Qed. -(** Peano recursion *) +Definition Prec (P:positive->Set) := Prect P. -Definition Prec (A:Set) (a:A) (f:positive -> A -> A) : - positive -> A := - (fix Prec (p:positive) : A := - match p with - | xH => a - | xO p => iterate_add (fun _ => A) f p p (Prec p) - | xI p => f (plus_iter p p) (iterate_add (fun _ => A) f p p (Prec p)) - end). +(** Peano induction *) + +Definition Pind (P:positive->Prop) := Prect P. (** Peano case analysis *) Theorem Pcase : - forall P:positive -> Prop, - P xH -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p. + forall P:positive -> Prop, + P 1 -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p. Proof. -intros; apply Pind; auto. + intros; apply Pind; auto. Qed. -(* -Check - (let fact := Prec positive xH (fun p r => Psucc p * r) in - let seven := xI (xI xH) in - let five_thousand_forty := - xO (xO (xO (xO (xI (xI (xO (xI (xI (xI (xO (xO xH))))))))))) in - refl_equal _:fact seven = five_thousand_forty). -*) - (**********************************************************************) (** Properties of multiplication on binary positive numbers *) (** One is right neutral for multiplication *) -Lemma Pmult_1_r : forall p:positive, p * xH = p. +Lemma Pmult_1_r : forall p:positive, p * 1 = p. Proof. -intro x; induction x; simpl in |- *. - rewrite IHx; reflexivity. - rewrite IHx; reflexivity. + 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 * xO q = xO (p * q). +Lemma Pmult_xO_permute_r : forall p q:positive, p * q~0 = (p * q)~0. Proof. -intros x y; induction x; simpl in |- *. - rewrite IHx; reflexivity. - rewrite IHx; reflexivity. - reflexivity. + intros p q; induction p; simpl; do 2 (f_equal; auto). Qed. -Lemma Pmult_xI_permute_r : forall p q:positive, p * xI q = p + xO (p * q). +Lemma Pmult_xI_permute_r : forall p q:positive, p * q~1 = p + (p * q)~0. Proof. -intros x y; induction x; simpl in |- *. - rewrite IHx; do 2 rewrite Pplus_assoc; rewrite Pplus_comm with (p := y); - reflexivity. - rewrite IHx; reflexivity. - reflexivity. + 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 x y; induction y; simpl in |- *. - rewrite <- IHy; apply Pmult_xI_permute_r. - rewrite <- IHy; apply Pmult_xO_permute_r. - apply Pmult_1_r. + 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 x y z; induction x; simpl in |- *. - rewrite IHx; rewrite <- Pplus_assoc with (q := xO (x * y)); - rewrite Pplus_assoc with (p := xO (x * y)); - rewrite Pplus_comm with (p := xO (x * y)); - rewrite <- Pplus_assoc with (q := xO (x * y)); - rewrite Pplus_assoc with (q := z); reflexivity. - rewrite IHx; reflexivity. + 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. + forall p q r:positive, (p + q) * r = p * r + q * r. Proof. -intros x y z; do 3 rewrite Pmult_comm with (q := z); apply Pmult_plus_distr_l. + 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. -intro x; induction x as [x| x| ]; simpl in |- *; intros y z. - rewrite IHx; rewrite Pmult_plus_distr_r; reflexivity. - rewrite IHx; reflexivity. + 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, xI p * r <> xO q * r. +Lemma Pmult_xI_mult_xO_discr : forall p q r:positive, p~1 * r <> q~0 * r. Proof. -intros x y z; induction z as [| z IHz| ]; try discriminate. -intro H; apply IHz; clear IHz. -do 2 rewrite Pmult_xO_permute_r in H. -injection H; clear H; intro H; exact H. + 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, xO p * q <> q. +Lemma Pmult_xO_discr : forall p q:positive, p~0 * q <> q. Proof. -intros x y; induction y; try discriminate. -rewrite Pmult_xO_permute_r; injection; assumption. + 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. -intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ]; - intros z H; reflexivity || apply (f_equal (A:=positive)) || apply False_ind. - simpl in H; apply IHp with (xO z); simpl in |- *; - do 2 rewrite 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 (xO z); simpl in |- *; do 2 rewrite 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). + 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 x y z H; apply Pmult_reg_r with (r := z). -rewrite Pmult_comm with (p := x); rewrite Pmult_comm with (p := y); - assumption. + 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 = xH -> p = xH. +Lemma Pmult_1_inversion_l : forall p q:positive, p * q = 1 -> p = 1. Proof. -intros x y; destruct x as [p| p| ]; simpl in |- *. - destruct y as [p0| p0| ]; intro; discriminate. - intro; discriminate. - reflexivity. + intros [p|p| ] [q|q| ] H; destr_eq H; auto. 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. + forall p q:positive, (p ?= q) Gt <> Eq /\ (p ?= q) Lt <> Eq. Proof. -intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ]; - split; simpl in |- *; auto; discriminate || (elim (IHp q); auto). + 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. -intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ]; - simpl in |- *; auto; intro H; - [ rewrite (IHp q); trivial - | absurd ((p ?= q) Gt = Eq); - [ elim (Pcompare_not_Eq p q); auto | assumption ] - | discriminate H - | absurd ((p ?= q) Lt = Eq); - [ elim (Pcompare_not_Eq p q); auto | assumption ] - | rewrite (IHp q); auto - | discriminate H - | discriminate H - | discriminate H ]. + 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_Gt_Lt : - forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt. + forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt. Proof. -intro x; induction x as [x Hrecx| x Hrecx| ]; intro y; - [ induction y as [y Hrecy| y Hrecy| ] - | induction y as [y Hrecy| y Hrecy| ] - | induction y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; - auto; discriminate || intros H; discriminate H. + 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. + forall p q:positive, (p ?= q) Lt = Gt -> (p ?= q) Eq = Gt. Proof. -intro x; induction x as [x Hrecx| x Hrecx| ]; intro y; - [ induction y as [y Hrecy| y Hrecy| ] - | induction y as [y Hrecy| y Hrecy| ] - | induction y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; - auto; discriminate || intros H; discriminate H. + 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. + forall p q:positive, (p ?= q) Lt = Lt -> (p ?= q) Eq = Lt \/ p = q. Proof. -intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ]; - simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); - auto; intros E; rewrite E; auto. + 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. + 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. -intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ]; - simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); - auto; intros E; rewrite E; auto. + 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. -simple induction r; auto. + 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) ]. - -Theorem Pcompare_refl : forall p:positive, (p ?= p) Eq = Eq. -intro x; induction x as [x Hrecx| x Hrecx| ]; auto. -Qed. + [ 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). + forall (p q:positive) (r:comparison), + CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r). 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| ] ]; intro r; - reflexivity || - (symmetry in |- *; assumption) || discriminate H || simpl in |- *; - apply IHp || (try rewrite IHp); try reflexivity. + 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; change Eq with (CompOpp Eq) in |- *. -rewrite <- Pcompare_antisym; rewrite H; reflexivity. + 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; change Eq with (CompOpp Eq) in |- *. -rewrite <- Pcompare_antisym; rewrite H; reflexivity. + 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; change Eq with (CompOpp Eq) in |- *. -rewrite <- Pcompare_antisym; rewrite H; reflexivity. + 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) in |- *. -symmetry in |- *; apply Pcompare_antisym. + intros; change Eq at 1 with (CompOpp Eq). + symmetry; apply Pcompare_antisym. +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. (**********************************************************************) (** 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. + forall p:positive_mask, Pdouble_mask p = IsNul -> p = IsNul. Proof. -destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ]. + destruct p; simpl; intros; trivial; discriminate. Qed. Lemma double_plus_one_zero_discr : - forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul. + forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul. Proof. -simple induction p; intros; discriminate. + destruct p; discriminate. Qed. Lemma double_plus_one_eq_one_inversion : - forall p:positive_mask, Pdouble_plus_one_mask p = IsPos xH -> p = IsNul. + forall p:positive_mask, Pdouble_plus_one_mask p = IsPos 1 -> p = IsNul. Proof. -destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ]. + destruct p; simpl; intros; trivial; discriminate. Qed. Lemma double_eq_one_discr : - forall p:positive_mask, Pdouble_mask p <> IsPos xH. + forall p:positive_mask, Pdouble_mask p <> IsPos 1. Proof. -simple induction p; intros; discriminate. + destruct p; discriminate. Qed. Theorem Pminus_mask_diag : forall p:positive, Pminus_mask p p = IsNul. Proof. -intro x; induction x as [p IHp| p IHp| ]; - [ simpl in |- *; rewrite IHp; simpl in |- *; trivial - | simpl in |- *; rewrite IHp; auto - | auto ]. + 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 xH -> Pminus_mask_carry p q = IsNul. -Proof. -intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ]; - simpl in |- *; intro H; try discriminate H; - [ absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH); - [ apply double_eq_one_discr | assumption ] - | assert (Heq : Pminus_mask p q = IsNul); - [ apply double_plus_one_eq_one_inversion; assumption - | rewrite Heq; reflexivity ] - | assert (Heq : Pminus_mask_carry p q = IsNul); - [ apply double_plus_one_eq_one_inversion; assumption - | rewrite Heq; reflexivity ] - | absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH); - [ apply double_eq_one_discr | assumption ] - | destruct p; simpl in |- *; - [ discriminate H | discriminate H | reflexivity ] ]. + 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 -> + forall p q:positive, + (p ?= q) Eq = Gt -> exists h : positive, - Pminus_mask p q = IsPos h /\ - q + h = p /\ (h = xH \/ Pminus_mask_carry p q = IsPos (Ppred h)). -Proof. -intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ]; - simpl in |- *; intro H; try discriminate H. - destruct (IHp q H) as [z [H4 [H6 H7]]]; exists (xO z); split. - rewrite H4; reflexivity. - split. - simpl in |- *; rewrite H6; reflexivity. - right; clear H6; destruct (ZL11 z) as [H8| H8]; - [ rewrite H8; rewrite H8 in H4; rewrite ZL10; - [ reflexivity | assumption ] - | clear H4; destruct H7 as [H9| H9]; - [ absurd (z = xH); assumption - | rewrite H9; clear H9; destruct z as [p0| p0| ]; - [ reflexivity | reflexivity | absurd (xH = xH); trivial ] ] ]. - case Pcompare_Gt_Gt with (1 := H); - [ intros H3; elim (IHp q H3); intros z H4; exists (xI z); elim H4; - intros H5 H6; elim H6; intros H7 H8; split; - [ simpl in |- *; rewrite H5; auto - | split; - [ simpl in |- *; rewrite H7; trivial - | right; - change (Pdouble_mask (Pminus_mask p q) = IsPos (Ppred (xI z))) - in |- *; rewrite H5; auto ] ] - | intros H3; exists xH; rewrite H3; split; - [ simpl in |- *; rewrite Pminus_mask_diag; auto | split; auto ] ]. - exists (xO p); auto. - destruct (IHp q) as [z [H4 [H6 H7]]]. - apply Pcompare_Lt_Gt; assumption. - destruct (ZL11 z) as [vZ| ]; - [ exists xH; split; - [ rewrite ZL10; [ reflexivity | rewrite vZ in H4; assumption ] - | split; - [ simpl in |- *; rewrite Pplus_one_succ_r; rewrite <- vZ; - rewrite H6; trivial - | auto ] ] - | exists (xI (Ppred z)); destruct H7 as [| H8]; - [ absurd (z = xH); assumption - | split; - [ rewrite H8; trivial - | split; - [ simpl in |- *; rewrite Pplus_carry_pred_eq_plus; - [ rewrite H6; trivial | assumption ] - | right; rewrite H8; reflexivity ] ] ] ]. - destruct (IHp q H) as [z [H4 [H6 H7]]]. - exists (xO z); split; - [ rewrite H4; auto - | split; - [ simpl in |- *; rewrite H6; reflexivity - | right; - change - (Pdouble_plus_one_mask (Pminus_mask_carry p q) = - IsPos (Pdouble_minus_one z)) in |- *; - destruct (ZL11 z) as [H8| H8]; - [ rewrite H8; simpl in |- *; - assert (H9 : Pminus_mask_carry p q = IsNul); - [ apply ZL10; rewrite <- H8; assumption - | rewrite H9; reflexivity ] - | destruct H7 as [H9| H9]; - [ absurd (z = xH); auto - | rewrite H9; destruct z as [p0| p0| ]; simpl in |- *; - [ reflexivity - | reflexivity - | absurd (xH = xH); [ assumption | reflexivity ] ] ] ] ] ]. - exists (Pdouble_minus_one p); split; - [ reflexivity - | clear IHp; split; - [ destruct p; simpl in |- *; - [ reflexivity - | rewrite Psucc_o_double_minus_one_eq_xO; reflexivity - | reflexivity ] - | destruct p; [ right | right | left ]; reflexivity ] ]. + 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. + 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 x y H; elim Pminus_mask_Gt with (1 := H); intros z H1; elim H1; - intros H2 H3; elim H3; intros H4 H5; unfold Pminus in |- *; - rewrite H2; exact H4. + 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 019ef5f7..6ece00d7 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -6,11 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArith.v 9210 2006-10-05 10:12:15Z barras $ *) +(* $Id: NArith.v 10751 2008-04-04 10:23:35Z herbelin $ *) (** Library for binary natural numbers *) Require Export BinPos. Require Export BinNat. +Require Export Nnat. +Require Export Ndigits. Require Export NArithRing. diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index df2da25b..5bd9a378 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndec.v 8733 2006-04-25 22:52:18Z letouzey $ i*) +(*i $Id: Ndec.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Import Bool. Require Import Sumbool. @@ -37,6 +37,13 @@ Proof. induction p; destruct p'; simpl; intros; try discriminate; auto. Qed. +Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'. +Proof. + intros. + apply Pcompare_Eq_eq. + apply Peqb_Pcompare; auto. +Qed. + Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true. Proof. intros; rewrite <- (Pcompare_Eq_eq _ _ H). @@ -208,205 +215,220 @@ Qed. (** A boolean order on [N] *) -Definition Nle (a b:N) := leb (nat_of_N a) (nat_of_N b). +Definition Nleb (a b:N) := leb (nat_of_N a) (nat_of_N b). -Lemma Nle_Ncompare : forall a b, Nle a b = true <-> Ncompare a b <> Gt. +Lemma Nleb_Nle : forall a b, Nleb a b = true <-> Nle a b. Proof. - intros; rewrite nat_of_Ncompare. - unfold Nle; apply leb_compare. + intros; unfold Nle; rewrite nat_of_Ncompare. + unfold Nleb; apply leb_compare. Qed. -Lemma Nle_refl : forall a, Nle a a = true. +Lemma Nleb_refl : forall a, Nleb a a = true. Proof. - intro. unfold Nle in |- *. apply leb_correct. apply le_n. + intro. unfold Nleb in |- *. apply leb_correct. apply le_n. Qed. -Lemma Nle_antisym : - forall a b, Nle a b = true -> Nle b a = true -> a = b. +Lemma Nleb_antisym : + forall a b, Nleb a b = true -> Nleb b a = true -> a = b. Proof. - unfold Nle in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b). + unfold Nleb in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b). rewrite (le_antisym _ _ (leb_complete _ _ H) (leb_complete _ _ H0)). reflexivity. Qed. -Lemma Nle_trans : - forall a b c, Nle a b = true -> Nle b c = true -> Nle a c = true. +Lemma Nleb_trans : + forall a b c, Nleb a b = true -> Nleb b c = true -> Nleb a c = true. Proof. - unfold Nle in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b). + unfold Nleb in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b). apply leb_complete. assumption. apply leb_complete. assumption. Qed. -Lemma Nle_lt_trans : +Lemma Nleb_ltb_trans : forall a b c, - Nle a b = true -> Nle c b = false -> Nle c a = false. + Nleb a b = true -> Nleb c b = false -> Nleb c a = false. Proof. - unfold Nle in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b). + unfold Nleb in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b). apply leb_complete. assumption. apply leb_complete_conv. assumption. Qed. -Lemma Nlt_le_trans : +Lemma Nltb_leb_trans : forall a b c, - Nle b a = false -> Nle b c = true -> Nle c a = false. + Nleb b a = false -> Nleb b c = true -> Nleb c a = false. Proof. - unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b). + unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b). apply leb_complete_conv. assumption. apply leb_complete. assumption. Qed. -Lemma Nlt_trans : +Lemma Nltb_trans : forall a b c, - Nle b a = false -> Nle c b = false -> Nle c a = false. + Nleb b a = false -> Nleb c b = false -> Nleb c a = false. Proof. - unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b). + unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b). apply leb_complete_conv. assumption. apply leb_complete_conv. assumption. Qed. -Lemma Nlt_le_weak : forall a b:N, Nle b a = false -> Nle a b = true. +Lemma Nltb_leb_weak : forall a b:N, Nleb b a = false -> Nleb a b = true. Proof. - unfold Nle in |- *. intros. apply leb_correct. apply lt_le_weak. + unfold Nleb in |- *. intros. apply leb_correct. apply lt_le_weak. apply leb_complete_conv. assumption. Qed. -Lemma Nle_double_mono : +Lemma Nleb_double_mono : forall a b, - Nle a b = true -> Nle (Ndouble a) (Ndouble b) = true. + Nleb a b = true -> Nleb (Ndouble a) (Ndouble b) = true. Proof. - unfold Nle in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct. + unfold Nleb in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct. simpl in |- *. apply plus_le_compat. apply leb_complete. assumption. apply plus_le_compat. apply leb_complete. assumption. apply le_n. Qed. -Lemma Nle_double_plus_one_mono : +Lemma Nleb_double_plus_one_mono : forall a b, - Nle a b = true -> - Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true. + Nleb a b = true -> + Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true. Proof. - unfold Nle in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one. + unfold Nleb in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one. apply leb_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply leb_complete. assumption. apply plus_le_compat. apply leb_complete. assumption. apply le_n. Qed. -Lemma Nle_double_mono_conv : +Lemma Nleb_double_mono_conv : forall a b, - Nle (Ndouble a) (Ndouble b) = true -> Nle a b = true. + Nleb (Ndouble a) (Ndouble b) = true -> Nleb a b = true. Proof. - unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro. + unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply leb_complete. assumption. Qed. -Lemma Nle_double_plus_one_mono_conv : +Lemma Nleb_double_plus_one_mono_conv : forall a b, - Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true -> - Nle a b = true. + Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true -> + Nleb a b = true. Proof. - unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one. + unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one. intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply leb_complete. assumption. Qed. -Lemma Nlt_double_mono : +Lemma Nltb_double_mono : forall a b, - Nle a b = false -> Nle (Ndouble a) (Ndouble b) = false. + Nleb a b = false -> Nleb (Ndouble a) (Ndouble b) = false. Proof. - intros. elim (sumbool_of_bool (Nle (Ndouble a) (Ndouble b))). intro H0. - rewrite (Nle_double_mono_conv _ _ H0) in H. discriminate H. + intros. elim (sumbool_of_bool (Nleb (Ndouble a) (Ndouble b))). intro H0. + rewrite (Nleb_double_mono_conv _ _ H0) in H. discriminate H. trivial. Qed. -Lemma Nlt_double_plus_one_mono : +Lemma Nltb_double_plus_one_mono : forall a b, - Nle a b = false -> - Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false. + Nleb a b = false -> + Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false. Proof. - intros. elim (sumbool_of_bool (Nle (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0. - rewrite (Nle_double_plus_one_mono_conv _ _ H0) in H. discriminate H. + intros. elim (sumbool_of_bool (Nleb (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0. + rewrite (Nleb_double_plus_one_mono_conv _ _ H0) in H. discriminate H. trivial. Qed. -Lemma Nlt_double_mono_conv : +Lemma Nltb_double_mono_conv : forall a b, - Nle (Ndouble a) (Ndouble b) = false -> Nle a b = false. + Nleb (Ndouble a) (Ndouble b) = false -> Nleb a b = false. Proof. - intros. elim (sumbool_of_bool (Nle a b)). intro H0. rewrite (Nle_double_mono _ _ H0) in H. + intros. elim (sumbool_of_bool (Nleb a b)). intro H0. rewrite (Nleb_double_mono _ _ H0) in H. discriminate H. trivial. Qed. -Lemma Nlt_double_plus_one_mono_conv : +Lemma Nltb_double_plus_one_mono_conv : forall a b, - Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false -> - Nle a b = false. + Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false -> + Nleb a b = false. Proof. - intros. elim (sumbool_of_bool (Nle a b)). intro H0. - rewrite (Nle_double_plus_one_mono _ _ H0) in H. discriminate H. + intros. elim (sumbool_of_bool (Nleb a b)). intro H0. + rewrite (Nleb_double_plus_one_mono _ _ H0) in H. discriminate H. trivial. Qed. -(* A [min] function over [N] *) +(* An alternate [min] function over [N] *) -Definition Nmin (a b:N) := if Nle a b then a else b. +Definition Nmin' (a b:N) := if Nleb a b then a else b. + +Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b. +Proof. + unfold Nmin, Nmin', Nleb; intros. + rewrite nat_of_Ncompare. + generalize (leb_compare (nat_of_N a) (nat_of_N b)); + destruct (nat_compare (nat_of_N a) (nat_of_N b)); + destruct (leb (nat_of_N a) (nat_of_N b)); intuition. + lapply H1; intros; discriminate. + lapply H1; intros; discriminate. +Qed. Lemma Nmin_choice : forall a b, {Nmin a b = a} + {Nmin a b = b}. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. left. rewrite H. - reflexivity. - intro H. right. rewrite H. reflexivity. + unfold Nmin in *; intros; destruct (Ncompare a b); auto. Qed. -Lemma Nmin_le_1 : forall a b, Nle (Nmin a b) a = true. +Lemma Nmin_le_1 : forall a b, Nleb (Nmin a b) a = true. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H. - apply Nle_refl. - intro H. rewrite H. apply Nlt_le_weak. assumption. + intros; rewrite Nmin_Nmin'. + unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H. + apply Nleb_refl. + intro H. rewrite H. apply Nltb_leb_weak. assumption. Qed. -Lemma Nmin_le_2 : forall a b, Nle (Nmin a b) b = true. +Lemma Nmin_le_2 : forall a b, Nleb (Nmin a b) b = true. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H. assumption. - intro H. rewrite H. apply Nle_refl. + intros; rewrite Nmin_Nmin'. + unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H. assumption. + intro H. rewrite H. apply Nleb_refl. Qed. Lemma Nmin_le_3 : - forall a b c, Nle a (Nmin b c) = true -> Nle a b = true. + forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H. + intros; rewrite Nmin_Nmin' in *. + unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. - intro H0. rewrite H0 in H. apply Nlt_le_weak. apply Nle_lt_trans with (b := c); assumption. + intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption. Qed. Lemma Nmin_le_4 : - forall a b c, Nle a (Nmin b c) = true -> Nle a c = true. + forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H. - apply Nle_trans with (b := b); assumption. + intros; rewrite Nmin_Nmin' in *. + unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. + apply Nleb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. Qed. Lemma Nmin_le_5 : forall a b c, - Nle a b = true -> Nle a c = true -> Nle a (Nmin b c) = true. + Nleb a b = true -> Nleb a c = true -> Nleb a (Nmin b c) = true. Proof. intros. elim (Nmin_choice b c). intro H1. rewrite H1. assumption. intro H1. rewrite H1. assumption. Qed. Lemma Nmin_lt_3 : - forall a b c, Nle (Nmin b c) a = false -> Nle b a = false. + forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H. + intros; rewrite Nmin_Nmin' in *. + unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. - intro H0. rewrite H0 in H. apply Nlt_trans with (b := c); assumption. + intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption. Qed. Lemma Nmin_lt_4 : - forall a b c, Nle (Nmin b c) a = false -> Nle c a = false. + forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false. Proof. - unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H. - apply Nlt_le_trans with (b := b); assumption. + intros; rewrite Nmin_Nmin' in *. + unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. + apply Nltb_leb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. Qed. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index ed8ced5b..dcdb5f92 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndigits.v 8736 2006-04-26 21:18:44Z letouzey $ i*) +(*i $Id: Ndigits.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Import Bool. Require Import Bvector. @@ -577,13 +577,6 @@ Qed. (** Number of digits in a number *) -Fixpoint Psize (p:positive) : nat := - match p with - | xH => 1%nat - | xI p => S (Psize p) - | xO p => S (Psize p) - end. - Definition Nsize (n:N) : nat := match n with | N0 => 0%nat | Npos p => Psize p diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v index d5bfc15c..af90b8e7 100644 --- a/theories/NArith/Ndist.v +++ b/theories/NArith/Ndist.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndist.v 8733 2006-04-25 22:52:18Z letouzey $ i*) +(*i $Id: Ndist.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Import Arith. Require Import Min. diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 94f50bd0..bc3711ee 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -6,15 +6,21 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Nnat.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Nnat.v 10739 2008-04-01 14:45:20Z 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. *) @@ -108,6 +114,30 @@ Proof. 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. @@ -175,3 +205,176 @@ Proof. pattern n' at 1; rewrite <- (nat_of_N_of_nat n'). symmetry; apply nat_of_Ncompare. Qed. + +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. + unfold nat_compare. + 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. + +Lemma N_of_min : + forall n n', N_of_nat (min n n') = Nmin (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_Nmin. + apply N_of_nat_of_N. +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. + unfold nat_compare. + 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. + +Lemma N_of_max : + forall n n', N_of_nat (max n n') = Nmax (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_Nmax. + apply N_of_nat_of_N. +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. +Proof. + destruct n; simpl; auto; symmetry; apply Zpos_eq_Z_of_nat_o_nat_of_P. +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. + +Lemma Z_of_N_eq_rev : forall n m, Z_of_N n = Z_of_N m -> n = m. +Proof. + intros [|n] [|m]; simpl; intros; try discriminate; congruence. +Qed. + +Lemma Z_of_N_eq_iff : forall n m, n = m <-> Z_of_N n = Z_of_N m. +Proof. + split; [apply Z_of_N_eq | apply Z_of_N_eq_rev]. +Qed. + +Lemma Z_of_N_le : forall n m, (n<=m)%N -> (Z_of_N n <= Z_of_N m)%Z. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_le_rev : forall n m, (Z_of_N n <= Z_of_N m)%Z -> (n<=m)%N. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_le_iff : forall n m, (n<=m)%N <-> (Z_of_N n <= Z_of_N m)%Z. +Proof. + split; [apply Z_of_N_le | apply Z_of_N_le_rev]. +Qed. + +Lemma Z_of_N_lt : forall n m, (n<m)%N -> (Z_of_N n < Z_of_N m)%Z. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_lt_rev : forall n m, (Z_of_N n < Z_of_N m)%Z -> (n<m)%N. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_lt_iff : forall n m, (n<m)%N <-> (Z_of_N n < Z_of_N m)%Z. +Proof. + split; [apply Z_of_N_lt | apply Z_of_N_lt_rev]. +Qed. + +Lemma Z_of_N_ge : forall n m, (n>=m)%N -> (Z_of_N n >= Z_of_N m)%Z. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_ge_rev : forall n m, (Z_of_N n >= Z_of_N m)%Z -> (n>=m)%N. +Proof. + intros [|n] [|m]; simpl; auto. +Qed. + +Lemma Z_of_N_ge_iff : forall n m, (n>=m)%N <-> (Z_of_N n >= Z_of_N m)%Z. +Proof. + split; [apply Z_of_N_ge | apply Z_of_N_ge_rev]. +Qed. + +Lemma Z_of_N_gt : forall n m, (n>m)%N -> (Z_of_N n > Z_of_N m)%Z. +Proof. + intros [|n] [|m]; simpl; auto. +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. + +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. + +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. + +Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z. +Proof. + destruct z; simpl; auto. +Qed. + +Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z. +Proof. + destruct n; intro; discriminate. +Qed. + +Lemma Z_of_N_plus : 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. + +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. + +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. + +Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). +Proof. + intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S. +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). +Proof. + intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min. +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. + diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v index 88abc700..2c007398 100644 --- a/theories/NArith/Pnat.v +++ b/theories/NArith/Pnat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Pnat.v 5920 2004-07-16 20:01:26Z herbelin $ i*) +(*i $Id: Pnat.v 9883 2007-06-07 18:44:59Z letouzey $ i*) Require Import BinPos. @@ -14,7 +14,7 @@ Require Import BinPos. (** Properties of the injection from binary positive numbers to Peano natural numbers *) -(** Original development by Pierre Crégut, CNET, Lannion, France *) +(** Original development by Pierre Crégut, CNET, Lannion, France *) Require Import Le. Require Import Lt. diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v new file mode 100644 index 00000000..9669eacd --- /dev/null +++ b/theories/Numbers/BigNumPrelude.v @@ -0,0 +1,372 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: BigNumPrelude.v 11013 2008-05-28 18:17:30Z letouzey $ i*) + +(** * BigNumPrelude *) + +(** Auxillary functions & theorems used for arbitrary precision efficient + numbers. *) + + +Require Import ArithRing. +Require Export ZArith. +Require Export Znumtheory. +Require Export Zpow_facts. + +(* *** Nota Bene *** + All results that were general enough has been moved in ZArith. + Only remain here specialized lemmas and compatibility elements. + (P.L. 5/11/2007). +*) + + +Open Local Scope Z_scope. + +(* For compatibility of scripts, weaker version of some lemmas of Zdiv *) + +Lemma Zlt0_not_eq : forall n, 0<n -> n<>0. +Proof. + auto with zarith. +Qed. + +Definition Zdiv_mult_cancel_r a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). +Definition Zdiv_mult_cancel_l a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). +Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). + +(* Automation *) + +Hint Extern 2 (Zle _ _) => + (match goal with + |- Zpos _ <= Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) + end). + +Hint Extern 2 (Zlt _ _) => + (match goal with + |- Zpos _ < Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H) + end). + + +Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. + +(************************************** + Properties of order and product + **************************************) + + Theorem beta_lex: forall a b c d beta, + a * beta + b <= c * beta + d -> + 0 <= b < beta -> 0 <= d < beta -> + a <= c. + Proof. + intros a b c d beta H1 (H3, H4) (H5, H6). + assert (a - c < 1); auto with zarith. + apply Zmult_lt_reg_r with beta; auto with zarith. + apply Zle_lt_trans with (d - b); auto with zarith. + rewrite Zmult_minus_distr_r; auto with zarith. + Qed. + + Theorem beta_lex_inv: forall a b c d beta, + a < c -> 0 <= b < beta -> + 0 <= d < beta -> + a * beta + b < c * beta + d. + Proof. + intros a b c d beta H1 (H3, H4) (H5, H6). + case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith. + intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto. + Qed. + + Lemma beta_mult : forall h l beta, + 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. + Proof. + intros h l beta H1 H2;split. auto with zarith. + rewrite <- (Zplus_0_r (beta^2)); rewrite Zpower_2; + apply beta_lex_inv;auto with zarith. + Qed. + + Lemma Zmult_lt_b : + forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. + Proof. + 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. + Qed. + + Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, + 1 < beta -> + 0 <= wc < beta -> + 0 <= xh < beta -> + 0 <= xl < beta -> + 0 <= yh < beta -> + 0 <= yl < beta -> + 0 <= cc < beta^2 -> + wc*beta^2 + cc = xh*yl + xl*yh -> + 0 <= wc <= 1. + Proof. + intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. + assert (H8 := Zmult_lt_b beta xh yl H2 H5). + assert (H9 := Zmult_lt_b beta xl yh H3 H4). + split;auto with zarith. + apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith. + Qed. + + Theorem mult_add_ineq: forall x y cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= cross < beta -> + 0 <= x * y + cross < beta^2. + Proof. + intros x y cross beta HH HH1 HH2. + split; auto with zarith. + apply Zle_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. + apply Zplus_le_compat; auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + rewrite Zpower_2; auto with zarith. + Qed. + + Theorem mult_add_ineq2: forall x y c cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= c*beta + cross <= 2*beta - 2 -> + 0 <= x * y + (c*beta + cross) < beta^2. + Proof. + intros x y c cross beta HH HH1 HH2. + split; auto with zarith. + apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. + apply Zplus_le_compat; auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + rewrite Zpower_2; auto with zarith. + Qed. + +Theorem mult_add_ineq3: forall x y c cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= cross <= beta - 2 -> + 0 <= c <= 1 -> + 0 <= x * y + (c*beta + cross) < beta^2. + Proof. + intros x y c cross beta HH HH1 HH2 HH3. + apply mult_add_ineq2;auto with zarith. + split;auto with zarith. + apply Zle_trans with (1*beta+cross);auto with zarith. + Qed. + +Hint Rewrite Zmult_1_r Zmult_0_r Zmult_1_l Zmult_0_l Zplus_0_l Zplus_0_r Zminus_0_r: rm10. + + +(************************************** + Properties of Zdiv and Zmod +**************************************) + +Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. + Proof. + intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. + case (Zle_or_lt b a); intros H4; auto with zarith. + rewrite Zmod_small; auto with zarith. + Qed. + + + Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Zlt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zplus_mod; auto with zarith. + rewrite Zmod_small with (a := t); auto with zarith. + apply Zmod_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); + try ring. + apply Zplus_le_lt_compat; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + try rewrite <- Zmult_minus_distr_r. + rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + auto with zarith. + rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + Theorem Zmod_shift_r: + forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t. + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Zlt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zplus_mod; auto with zarith. + rewrite Zmod_small with (a := t); auto with zarith. + apply Zmod_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. + apply Zplus_le_lt_compat; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + try rewrite <- Zmult_minus_distr_r. + repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; + auto with zarith. + apply Zmult_le_compat_l; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + Theorem Zdiv_shift_r: + forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (Eq: t < 2 ^ b); auto with zarith. + apply Zlt_le_trans with (1 := H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b); + auto with zarith. + rewrite <- Zplus_assoc. + rewrite <- Zmod_shift_r; auto with zarith. + rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. + rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + + Lemma shift_unshift_mod : forall n p a, + 0 <= a < 2^n -> + 0 <= p <= n -> + a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. + Proof. + intros n p a H1 H2. + pattern (a*2^p) at 1;replace (a*2^p) with + (a*2^p/2^n * 2^n + a*2^p mod 2^n). + 2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq. + replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. + replace (2^n) with (2^(n-p)*2^p). + symmetry;apply Zdiv_mult_cancel_r. + destruct H1;trivial. + cut (0 < 2^p); auto with zarith. + rewrite <- Zpower_exp. + replace (n-p+p) with n;trivial. ring. + omega. omega. + apply Zlt_gt. apply Zpower_gt_0;auto with zarith. + Qed. + + + Lemma shift_unshift_mod_2 : forall n p a, (0<=p<=n)%Z -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros. + rewrite Zmod_small. + rewrite Zmod_eq by (auto with zarith). + unfold Zminus at 1. + rewrite Z_div_plus_l by (auto with zarith). + assert (2^n = 2^(n-p)*2^p). + rewrite <- Zpower_exp by (auto with zarith). + replace (n-p+p) with n; auto with zarith. + rewrite H0. + rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). + rewrite (Zmult_comm (2^(n-p))), Zmult_assoc. + rewrite Zopp_mult_distr_l. + rewrite Z_div_mult by (auto with zarith). + symmetry; apply Zmod_eq; auto with zarith. + + remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Zlt_le_trans with (2^n); auto with zarith. + rewrite <- (Zmult_1_r (2^n)) at 1. + apply Zmult_le_compat; auto with zarith. + cut (0 < 2 ^ (n-p)); auto with zarith. + Qed. + + Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. + Proof. + intros p x Hle;destruct (Z_le_gt_dec 0 p). + apply Zdiv_le_lower_bound;auto with zarith. + replace (2^p) with 0. + destruct x;compute;intro;discriminate. + destruct p;trivial;discriminate z. + Qed. + + Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. + Proof. + intros p x y H;destruct (Z_le_gt_dec 0 p). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with y;auto with zarith. + rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. + 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. + Qed. + + Theorem Zgcd_div_pos a b: + (0 < b)%Z -> (0 < Zgcd a b)%Z -> (0 < b / Zgcd a b)%Z. + Proof. + intros a b Ha Hg. + case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto. + apply Z_div_pos; auto with zarith. + intros H; generalize Ha. + pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite <- H; auto with zarith. + assert (F := (Zgcd_is_gcd a b)); inversion F; auto. + Qed. + +Theorem Zbounded_induction : + (forall Q : Z -> Prop, forall b : Z, + Q 0 -> + (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> + forall n, 0 <= n -> n < b -> Q n)%Z. +Proof. +intros Q b Q0 QS. +set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). +assert (H : forall n, 0 <= n -> Q' n). +apply natlike_rec2; unfold Q'. +destruct (Zle_or_lt b 0) as [H | H]. now right. left; now split. +intros n H IH. destruct IH as [[IH1 IH2] | IH]. +destruct (Zle_or_lt (b - 1) n) as [H1 | H1]. +right; auto with zarith. +left. split; [auto with zarith | now apply (QS n)]. +right; auto with zarith. +unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. +assumption. apply Zle_not_lt in H3. false_hyp H2 H3. +Qed. + +Lemma Zsquare_le : forall x, x <= x*x. +Proof. +intros. +destruct (Z_lt_le_dec 0 x). +pattern x at 1; rewrite <- (Zmult_1_l x). +apply Zmult_le_compat; auto with zarith. +apply Zle_trans with 0; auto with zarith. +rewrite <- Zmult_opp_opp. +apply Zmult_le_0_compat; auto with zarith. +Qed. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v new file mode 100644 index 00000000..528d78c3 --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -0,0 +1,375 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(* $Id: CyclicAxioms.v 11012 2008-05-28 16:34:43Z letouzey $ *) + +(** * Signature and specification of a bounded integer structure *) + +(** This file specifies how to represent [Z/nZ] when [n=2^d], + [d] being the number of digits of these bounded integers. *) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import DoubleType. + +Open Local Scope Z_scope. + +(** First, a description via an operator record and a spec record. *) + +Section Z_nZ_Op. + + Variable znz : Type. + + Record znz_op := mk_znz_op { + + (* 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 *) + + (* Basic numbers *) + znz_0 : znz; + znz_1 : znz; + znz_Bm1 : znz; (* [2^digits-1], which is equivalent to [-1] *) + + (* Comparison *) + znz_compare : znz -> znz -> comparison; + znz_eq0 : znz -> 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; + + (* 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; + + znz_mod_gt : znz -> znz -> znz; (* specialized version of [znz_mod] *) + znz_mod : znz -> znz -> znz; + + 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)] + 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; + + znz_is_even : znz -> 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). + + 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_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_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. + + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[|| x ||]" := + (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). + + Record znz_spec := mk_znz_spec { + + (* 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; + + (* Basic numbers *) + spec_0 : [|w0|] = 0; + spec_1 : [|w1|] = 1; + spec_Bm1 : [|wBm1|] = 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; + (* 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_add_carry : + forall x y, [|w_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_sub_carry : + forall x y, [|w_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|]; + + (* Special divisions operations *) + spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_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 + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div : forall a b, 0 < [|b|] -> + let (q,r) := w_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_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|]; + + + (* shift operations *) + spec_head00: forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_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; + spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; + spec_add_mul_div : forall x y p, + [|p|] <= Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB; + spec_pos_mod : forall w p, + [|w_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; + spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := w_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 + }. + +End Z_nZ_Spec. + +(** Generic construction of double words *) + +Section WW. + + Variable w : Type. + Variable w_op : znz_op w. + Variable op_spec : znz_spec w_op. + + 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 znz_W0 h := + if w_eq0 h then W0 else WW h w_0. + + Definition znz_0W l := + if w_eq0 l then W0 else WW w_0 l. + + Definition znz_WW h l := + if w_eq0 h then znz_0W l else WW h l. + + Lemma spec_W0 : forall h, + zn2z_to_Z wB w_to_Z (znz_W0 h) = (w_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. + Qed. + + Lemma spec_0W : forall l, + zn2z_to_Z wB w_to_Z (znz_0W l) = w_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. + 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. + 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. + simpl; auto. + Qed. + +End WW. + +(** Injecting [Z] numbers into a cyclic structure *) + +Section znz_of_pos. + + Variable w : Type. + Variable w_op : znz_op w. + Variable op_spec : znz_spec w_op. + + Notation "[| x |]" := (znz_to_Z w_op x) (at level 0, x at level 99). + + 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. + + Theorem znz_of_pos_correct: + forall p, Zpos p < base (znz_digits w_op) -> [|(snd (znz_of_pos w_op p))|] = Zpos p. + intros p Hp. + generalize (spec_of_pos op_spec p). + case (znz_of_pos w_op 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. + case p1; simpl; intros; red; simpl; intros; discriminate. + unfold base; auto with zarith. + case (spec_to_Z op_spec 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. + intros p; case p; simpl; try rewrite spec_0; auto. + intros; rewrite znz_of_pos_correct; auto with zarith. + intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto. + Qed. +End znz_of_pos. + + +(** 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. +End CyclicType. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v new file mode 100644 index 00000000..22f6d95b --- /dev/null +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -0,0 +1,236 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZCyclic.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NZAxioms. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import CyclicAxioms. + +(** * From [CyclicType] to [NZAxiomsSig] *) + +(** A [Z/nZ] representation given by a module type [CyclicType] + implements [NZAxiomsSig], e.g. the common properties between + N and Z with no ordering. Notice that the [n] in [Z/nZ] is + a power of 2. +*) + +Module NZCyclicAxiomsMod (Import Cyclic : CyclicType) <: NZAxiomsSig. + +Open Local Scope Z_scope. + +Definition NZ := w. + +Definition NZ_to_Z : NZ -> Z := znz_to_Z w_op. +Definition Z_to_NZ : Z -> NZ := znz_of_Z w_op. +Notation Local wB := (base w_op.(znz_digits)). + +Notation Local "[| x |]" := (w_op.(znz_to_Z) x) (at level 0, x at level 99). + +Definition NZeq (n m : NZ) := [| n |] = [| m |]. +Definition NZ0 := w_op.(znz_0). +Definition NZsucc := w_op.(znz_succ). +Definition NZpred := w_op.(znz_pred). +Definition NZadd := w_op.(znz_add). +Definition NZsub := w_op.(znz_sub). +Definition NZmul := w_op.(znz_mul). + +Theorem NZeq_equiv : equiv NZ NZeq. +Proof. +unfold equiv, reflexive, symmetric, transitive, NZeq; repeat split; intros; auto. +now transitivity [| y |]. +Qed. + +Add Relation NZ NZeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Proof. +unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_succ). now rewrite H. +Qed. + +Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Proof. +unfold NZeq; intros n m H. do 2 rewrite w_spec.(spec_pred). now rewrite H. +Qed. + +Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Proof. +unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_add). +now rewrite H1, H2. +Qed. + +Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Proof. +unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_sub). +now rewrite H1, H2. +Qed. + +Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. +Proof. +unfold NZeq; intros n1 n2 H1 m1 m2 H2. do 2 rewrite w_spec.(spec_mul). +now rewrite H1, H2. +Qed. + +Delimit Scope IntScope with Int. +Bind Scope IntScope with NZ. +Open Local Scope IntScope. +Notation "x == y" := (NZeq x y) (at level 70) : IntScope. +Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope. +Notation "0" := NZ0 : IntScope. +Notation "'S'" := NZsucc : IntScope. +Notation "'P'" := NZpred : IntScope. +(*Notation "1" := (S 0) : IntScope.*) +Notation "x + y" := (NZadd x y) : IntScope. +Notation "x - y" := (NZsub x y) : IntScope. +Notation "x * y" := (NZmul x y) : IntScope. + +Theorem gt_wB_1 : 1 < wB. +Proof. +unfold base. +apply Zpower_gt_1; unfold Zlt; auto with zarith. +Qed. + +Theorem gt_wB_0 : 0 < wB. +Proof. +pose proof gt_wB_1; auto with zarith. +Qed. + +Lemma NZsucc_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]]. +Qed. + +Lemma NZpred_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]]. +Qed. + +Lemma NZ_to_Z_mod : forall n : NZ, [| n |] mod wB = [| n |]. +Proof. +intro n; rewrite Zmod_small. reflexivity. apply w_spec.(spec_to_Z). +Qed. + +Theorem NZpred_succ : forall n : NZ, P (S n) == n. +Proof. +intro n; unfold NZsucc, NZpred, NZeq. rewrite w_spec.(spec_pred), w_spec.(spec_succ). +rewrite <- NZpred_mod_wB. +replace ([| n |] + 1 - 1)%Z with [| n |] by auto with zarith. apply NZ_to_Z_mod. +Qed. + +Lemma Z_to_NZ_0 : Z_to_NZ 0%Z == 0%Int. +Proof. +unfold NZeq, NZ_to_Z, Z_to_NZ. rewrite znz_of_Z_correct. +symmetry; apply w_spec.(spec_0). +exact w_spec. split; [auto with zarith |apply gt_wB_0]. +Qed. + +Section Induction. + +Variable A : NZ -> Prop. +Hypothesis A_wd : predicate_wd NZeq A. +Hypothesis A0 : A 0. +Hypothesis AS : forall n : NZ, A n <-> A (S n). (* Below, we use only -> direction *) + +Add Morphism A with signature NZeq ==> iff as A_morph. +Proof. apply A_wd. Qed. + +Let B (n : Z) := A (Z_to_NZ n). + +Lemma B0 : B 0. +Proof. +unfold B. now rewrite Z_to_NZ_0. +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)) using relation NZeq. assumption. +unfold NZeq. rewrite w_spec.(spec_succ). +unfold NZ_to_Z, Z_to_NZ. +do 2 (rewrite znz_of_Z_correct; [ | exact w_spec | auto with zarith]). +symmetry; apply Zmod_small; auto with zarith. +Qed. + +Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. +Proof. +intros n [H1 H2]. +apply Zbounded_induction with wB. +apply B0. apply BS. assumption. assumption. +Qed. + +Theorem NZinduction : forall n : NZ, A n. +Proof. +intro n. setoid_replace n with (Z_to_NZ (NZ_to_Z n)) using relation NZeq. +apply B_holds. apply w_spec.(spec_to_Z). +unfold NZeq, NZ_to_Z, Z_to_NZ; rewrite znz_of_Z_correct. +reflexivity. +exact w_spec. +apply w_spec.(spec_to_Z). +Qed. + +End Induction. + +Theorem NZadd_0_l : forall n : NZ, 0 + n == n. +Proof. +intro n; unfold NZadd, NZ0, NZeq. rewrite w_spec.(spec_add). rewrite w_spec.(spec_0). +rewrite Zplus_0_l. rewrite Zmod_small; [reflexivity | apply w_spec.(spec_to_Z)]. +Qed. + +Theorem NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m). +Proof. +intros n m; unfold NZadd, NZsucc, NZeq. rewrite w_spec.(spec_add). +do 2 rewrite w_spec.(spec_succ). rewrite w_spec.(spec_add). +rewrite NZsucc_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. +Qed. + +Theorem NZsub_0_r : forall n : NZ, n - 0 == n. +Proof. +intro n; unfold NZsub, NZ0, NZeq. rewrite w_spec.(spec_sub). +rewrite w_spec.(spec_0). rewrite Zminus_0_r. apply NZ_to_Z_mod. +Qed. + +Theorem NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m). +Proof. +intros n m; unfold NZsub, NZsucc, NZpred, NZeq. +rewrite w_spec.(spec_pred). do 2 rewrite w_spec.(spec_sub). +rewrite w_spec.(spec_succ). rewrite Zminus_mod_idemp_r. +rewrite Zminus_mod_idemp_l. +now replace ([|n|] - ([|m|] + 1))%Z with ([|n|] - [|m|] - 1)%Z by auto with zarith. +Qed. + +Theorem NZmul_0_l : forall n : NZ, 0 * n == 0. +Proof. +intro n; unfold NZmul, NZ0, NZ, NZeq. rewrite w_spec.(spec_mul). +rewrite w_spec.(spec_0). now rewrite Zmult_0_l. +Qed. + +Theorem NZmul_succ_l : forall n m : NZ, (S n) * m == n * m + m. +Proof. +intros n m; unfold NZmul, NZsucc, NZadd, NZeq. rewrite w_spec.(spec_mul). +rewrite w_spec.(spec_add), w_spec.(spec_mul), w_spec.(spec_succ). +rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l. +now rewrite Zmult_plus_distr_l, Zmult_1_l. +Qed. + +End NZCyclicAxiomsMod. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v new file mode 100644 index 00000000..61d8d0fb --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -0,0 +1,318 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleAdd.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section DoubleAdd. + Variable w : Type. + Variable w_0 : w. + Variable w_1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable ww_1 : zn2z w. + Variable w_succ_c : w -> carry w. + Variable w_add_c : w -> w -> carry w. + Variable w_add_carry_c : w -> w -> carry w. + Variable w_succ : w -> w. + Variable w_add : w -> w -> w. + Variable w_add_carry : w -> w -> w. + + Definition ww_succ_c x := + match x with + | W0 => C0 ww_1 + | WW xh xl => + match w_succ_c xl with + | C0 l => C0 (WW xh l) + | C1 l => + match w_succ_c xh with + | C0 h => C0 (WW h w_0) + | C1 h => C1 W0 + end + end + end. + + Definition ww_succ x := + match x with + | W0 => ww_1 + | WW xh xl => + match w_succ_c xl with + | C0 l => WW xh l + | C1 l => w_W0 (w_succ xh) + end + end. + + Definition ww_add_c x y := + match x, y with + | W0, _ => C0 y + | _, W0 => C0 x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Variable R : Type. + Variable f0 f1 : zn2z w -> R. + + Definition ww_add_c_cont x y := + match x, y with + | W0, _ => f0 y + | _, W0 => f0 x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => f0 (WW h l) + | C1 h => f1 (w_WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => f0 (WW h l) + | C1 h => f1 (w_WW h l) + end + end + end. + + (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas + de debordement *) + Definition ww_add x y := + match x, y with + | W0, _ => y + | _, W0 => x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => WW (w_add xh yh) l + | C1 l => WW (w_add_carry xh yh) l + end + end. + + Definition ww_add_carry_c x y := + match x, y with + | W0, W0 => C0 ww_1 + | W0, WW yh yl => ww_succ_c (WW yh yl) + | WW xh xl, W0 => ww_succ_c (WW xh xl) + | WW xh xl, WW yh yl => + match w_add_carry_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Definition ww_add_carry x y := + match x, y with + | W0, W0 => ww_1 + | W0, WW yh yl => ww_succ (WW yh yl) + | WW xh xl, W0 => ww_succ (WW xh xl) + | WW xh xl, WW yh yl => + match w_add_carry_c xl yl with + | C0 l => WW (w_add xh yh) l + | C1 l => WW (w_add_carry xh yh) l + end + end. + + (*Section DoubleProof.*) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. + 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. + Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. + Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. + Variable spec_w_add_carry : + forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + + Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1. + Proof. + destruct x as [ |xh xl];simpl. apply spec_ww_1. + generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l]; + intro H;unfold interp_carry in H. simpl;rewrite H;ring. + rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l. + assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. + rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; + intro H1;unfold interp_carry in H1. + simpl;rewrite H1;rewrite spec_w_0;ring. + unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. + assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. + rewrite H2;ring. + Qed. + + Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. + Proof. + destruct x as [ |xh xl];simpl;trivial. + destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;trivial. + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1. trivial. + repeat rewrite Zmult_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1. + simpl;ring. + repeat rewrite Zmult_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring. + Qed. + + Section Cont. + Variable P : zn2z w -> zn2z w -> R -> Prop. + Variable x y : zn2z w. + Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r). + Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r). + + Lemma spec_ww_add_c_cont : P x y (ww_add_c_cont x y). + Proof. + destruct x as [ |xh xl];simpl;trivial. + apply spec_f0;trivial. + destruct y as [ |yh yl];simpl. + apply spec_f0;simpl;rewrite Zplus_0_r;trivial. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + intros H;unfold interp_carry in H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *. + apply spec_f0. simpl;rewrite H;rewrite H1;ring. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. + rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + rewrite Zmult_1_l in H1;rewrite H1;ring. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h]; intros H1;unfold interp_carry in *. + apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc;rewrite H;ring. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc;rewrite H;ring. + Qed. + + End Cont. + + Lemma spec_ww_add_carry_c : + forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1. + Proof. + destruct x as [ |xh xl];intro y;simpl. + exact (spec_ww_succ_c y). + destruct y as [ |yh yl];simpl. + rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)). + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + unfold interp_carry;rewrite spec_w_WW; + repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. + rewrite spec_ww_1;rewrite Zmod_small;trivial. + split;[intro;discriminate|apply wwB_pos]. + rewrite <- Zplus_assoc;generalize (spec_w_succ_c xl); + destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H. + rewrite Zmod_small;trivial. + rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z. + assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0. + assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega. + rewrite H0;rewrite Zplus_0_r;rewrite <- Zmult_plus_distr_l;rewrite wwB_wBwB. + rewrite Zpower_2; rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite spec_w_W0;rewrite spec_w_succ;trivial. + Qed. + + Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Proof. + destruct x as [ |xh xl];intros y;simpl. + rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. + destruct y as [ |yh yl]. + change [[W0]] with 0;rewrite Zplus_0_r. + rewrite Zmod_small;trivial. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). + simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + unfold interp_carry;intros H;simpl;rewrite <- H. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. + Qed. + + Lemma spec_ww_add_carry : + forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. + Proof. + destruct x as [ |xh xl];intros y;simpl. + exact (spec_ww_succ y). + destruct y as [ |yh yl]. + change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)). + simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. + Qed. + +(* End DoubleProof. *) +End DoubleAdd. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v new file mode 100644 index 00000000..952516ac --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -0,0 +1,446 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleBase.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. + +Open Local Scope Z_scope. + +Section DoubleBase. + Variable w : Type. + Variable w_0 : w. + Variable w_1 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_digits : positive. + Variable w_zdigits: w. + Variable w_add: w -> w -> zn2z w. + Variable w_to_Z : w -> Z. + Variable w_compare : w -> w -> comparison. + + Definition ww_digits := xO w_digits. + + Definition ww_zdigits := w_add w_zdigits w_zdigits. + + Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z. + + Definition ww_1 := WW w_0 w_1. + + Definition ww_Bm1 := WW w_Bm1 w_Bm1. + + Definition ww_WW xh xl : zn2z (zn2z w) := + match xh, xl with + | W0, W0 => W0 + | _, _ => WW xh xl + end. + + Definition ww_W0 h : zn2z (zn2z w) := + match h with + | W0 => W0 + | _ => WW h W0 + end. + + Definition ww_0W l : zn2z (zn2z w) := + match l with + | W0 => W0 + | _ => WW W0 l + end. + + Definition double_WW (n:nat) := + match n return word w n -> word w n -> word w (S n) with + | O => w_WW + | S n => + fun (h l : zn2z (word w n)) => + match h, l with + | W0, W0 => W0 + | _, _ => WW h l + 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). + + Fixpoint double_to_Z (n:nat) : word w n -> Z := + match n return word w n -> Z with + | O => w_to_Z + | S n => zn2z_to_Z (double_wB n) (double_to_Z n) + end. + + Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) := + match n return word w (S n) with + | O => x + | S n1 => WW W0 (extend_aux n1 x) + end. + + Definition extend (n:nat) (x:w) : word w (S n) := + let r := w_0W x in + match r with + | W0 => W0 + | _ => extend_aux n r + end. + + Definition double_0 n : word w n := + match n return word w n with + | O => w_0 + | S _ => W0 + end. + + Definition double_split (n:nat) (x:zn2z (word w n)) := + match x with + | W0 => + match n return word w n * word w n with + | O => (w_0,w_0) + | S _ => (W0, W0) + end + | WW h l => (h,l) + end. + + Definition ww_compare x y := + match x, y with + | W0, W0 => Eq + | W0, WW yh yl => + match w_compare w_0 yh with + | Eq => w_compare w_0 yl + | _ => Lt + end + | WW xh xl, W0 => + match w_compare xh w_0 with + | Eq => w_compare xl w_0 + | _ => Gt + end + | WW xh xl, WW yh yl => + match w_compare xh yh with + | Eq => w_compare xl yl + | Lt => Lt + | Gt => Gt + end + end. + + + (* Return the low part of the composed word*) + Fixpoint get_low (n : nat) {struct n}: + word w n -> w := + match n return (word w n -> w) with + | 0%nat => fun x => x + | S n1 => + fun x => + match x with + | W0 => w_0 + | WW _ x1 => get_low n1 x1 + end + end. + + + Section DoubleProof. + Notation wB := (base w_digits). + Notation wwB := (base ww_digits). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99). + Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + 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_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. + + Lemma wwB_wBwB : wwB = wB^2. + Proof. + unfold base, ww_digits;rewrite Zpower_2; rewrite (Zpos_xO w_digits). + replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits). + apply Zpower_exp; unfold Zge;simpl;intros;discriminate. + ring. + Qed. + + Lemma spec_ww_1 : [[ww_1]] = 1. + Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed. + + Lemma spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. + Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. + + Lemma lt_0_wB : 0 < wB. + Proof. + unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity. + unfold Zle;intros H;discriminate H. + Qed. + + Lemma lt_0_wwB : 0 < wwB. + Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed. + + Lemma wB_pos: 1 < wB. + Proof. + unfold base;apply Zlt_le_trans with (2^1). unfold Zlt;reflexivity. + apply Zpower_le_monotone. unfold Zlt;reflexivity. + split;unfold Zle;intros H. discriminate H. + clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. + destruct w_digits; discriminate H. + Qed. + + Lemma wwB_pos: 1 < wwB. + Proof. + assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1). + rewrite Zpower_2. + apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]). + apply Zlt_le_weak;trivial. + Qed. + + Theorem wB_div_2: 2 * (wB / 2) = wB. + Proof. + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + spec_to_Z;unfold base. + assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). + pattern 2 at 2; rewrite <- Zpower_1_r. + rewrite <- Zpower_exp; auto with zarith. + f_equal; auto with zarith. + case w_digits; compute; intros; discriminate. + rewrite H; f_equal; auto with zarith. + rewrite Zmult_comm; apply Z_div_mult; auto with zarith. + Qed. + + Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. + Proof. + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + spec_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + pattern wB at 1; rewrite <- wB_div_2; auto. + rewrite <- Zmult_assoc. + repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith. + Qed. + + Lemma mod_wwB : forall z x, + (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. + Proof. + intros z x. + rewrite Zplus_mod. + pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite (Zmod_small [|x|]). + apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z. + apply Z_mod_lt;apply Zlt_gt;apply lt_0_wB. + destruct (spec_to_Z x);split;trivial. + change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB. + rewrite Zpower_2;rewrite <- (Zplus_0_r (wB*wB));apply beta_lex_inv. + apply lt_0_wB. apply spec_to_Z. split;[apply Zle_refl | apply lt_0_wB]. + Qed. + + Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|]. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith. + rewrite Z_div_mult;auto with zarith. + destruct (spec_to_Z x);trivial. + Qed. + + Lemma wB_div_plus : forall x y p, + 0 <= p -> + ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + intros x y p Hp;rewrite Zpower_exp;auto with zarith. + rewrite <- Zdiv_Zdiv;auto with zarith. + rewrite wB_div;trivial. + Qed. + + Lemma lt_wB_wwB : wB < wwB. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + unfold base;apply Zpower_lt_monotone;auto with zarith. + assert (0 < Zpos w_digits). compute;reflexivity. + unfold ww_digits;rewrite Zpos_xO;auto with zarith. + Qed. + + Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. + Proof. + intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB. + Qed. + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + destruct x as [ |h l];simpl. + split;[apply Zle_refl|apply lt_0_wwB]. + assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split. + apply Zplus_le_0_compat;auto with zarith. + rewrite <- (Zplus_0_r wwB);rewrite wwB_wBwB; rewrite Zpower_2; + apply beta_lex_inv;auto with zarith. + Qed. + + 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)). + symmetry; apply Zpower_exp;intro;discriminate. + ring. + Qed. + + Lemma double_wB_pos: + forall n, 0 <= double_wB n. + Proof. + intros n; unfold double_wB, base; auto with zarith. + Qed. + + Lemma double_wB_more_digits: + forall n, wB <= double_wB n. + 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. + intros n H1; rewrite <- double_wB_wwB. + apply Zle_trans with (wB * 1). + rewrite Zmult_1_r; apply Zle_refl. + apply Zmult_le_compat; auto with zarith. + apply Zle_trans with wB; auto with zarith. + unfold base. + rewrite <- (Zpower_0_r 2). + apply Zpower_le_monotone2; auto with zarith. + unfold base; auto with zarith. + Qed. + + Lemma spec_double_to_Z : + forall n (x:word w n), 0 <= [!n | x!] < double_wB n. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + induction n;intros. exact (spec_to_Z x). + unfold double_to_Z;fold double_to_Z. + destruct x;unfold zn2z_to_Z. + unfold double_wB,base;split;auto with zarith. + assert (U0:= IHn w0);assert (U1:= IHn w1). + split;auto with zarith. + apply Zlt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n). + assert (double_to_Z n w0*double_wB n <= (double_wB n - 1)*double_wB n). + apply Zmult_le_compat_r;auto with zarith. + auto with zarith. + rewrite <- double_wB_wwB. + replace ((double_wB n - 1) * double_wB n + double_wB n) with (double_wB n * double_wB n); + [auto with zarith | ring]. + Qed. + + Lemma spec_get_low: + forall n x, + [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. + Proof. + clear spec_w_1 spec_w_Bm1. + intros n; elim n; auto; clear n. + intros n Hrec x; case x; clear x; auto. + intros xx yy H1; simpl in H1. + assert (F1: [!n | xx!] = 0). + case (Zle_lt_or_eq 0 ([!n | xx!])); auto. + case (spec_double_to_Z n xx); auto. + intros F2. + assert (F3 := double_wB_more_digits n). + assert (F4: 0 <= [!n | yy!]). + case (spec_double_to_Z n yy); auto. + assert (F5: 1 * wB <= [!n | xx!] * double_wB n); + auto with zarith. + apply Zmult_le_compat; auto with zarith. + unfold base; auto with zarith. + simpl get_low; simpl double_to_Z. + generalize H1; clear H1. + rewrite F1; rewrite Zmult_0_l; rewrite Zplus_0_l. + intros H1; apply Hrec; auto. + Qed. + + Lemma spec_double_WW : forall n (h l : word w n), + [!S n|double_WW n h l!] = [!n|h!] * double_wB n + [!n|l!]. + Proof. + induction n;simpl;intros;trivial. + destruct h;auto. + destruct l;auto. + Qed. + + Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. + Proof. induction n;simpl;trivial. Qed. + + Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. + Proof. + intros n x;assert (H:= spec_w_0W x);unfold extend. + destruct (w_0W x);simpl;trivial. + rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). + Qed. + + Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0. + Proof. destruct n;trivial. Qed. + + Lemma spec_double_split : forall n x, + let (h,l) := double_split n x in + [!S n|x!] = [!n|h!] * double_wB n + [!n|l!]. + Proof. + destruct x;simpl;auto. + destruct n;simpl;trivial. + rewrite spec_w_0;trivial. + Qed. + + Lemma wB_lex_inv: forall a b c d, + a < c -> + a * wB + [|b|] < c * wB + [|d|]. + Proof. + intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. + Qed. + + Lemma spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + 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. + apply wB_lex_inv;trivial. + absurd (0 <= [|yh|]). apply Zgt_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. + 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. + apply wB_lex_inv;trivial. + apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. + Qed. + + + End DoubleProof. + +End DoubleBase. + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v new file mode 100644 index 00000000..cca32a59 --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -0,0 +1,885 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleCyclic.v 11012 2008-05-28 16:34:43Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. +Require Import DoubleAdd. +Require Import DoubleSub. +Require Import DoubleMul. +Require Import DoubleSqrt. +Require Import DoubleLift. +Require Import DoubleDivn1. +Require Import DoubleDiv. +Require Import CyclicAxioms. + +Open Local 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). + + 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_0 := w_op.(znz_0). + Let w_1 := w_op.(znz_1). + Let w_Bm1 := 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). + + 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_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_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). + + Let _zn2z := zn2z w. + + Let wB := base w_digits. + + Let w_Bm2 := w_pred w_Bm1. + + Let ww_1 := ww_1 w_0 w_1. + Let ww_Bm1 := ww_Bm1 w_Bm1. + + Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end. + + Let _ww_digits := xO w_digits. + + Let _ww_zdigits := w_add2 w_zdigits w_zdigits. + + 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 ww_of_pos p := + match w_of_pos p with + | (N0, l) => (N0, WW w_0 l) + | (Npos ph,l) => + let (n,h) := w_of_pos ph in (n, w_WW h l) + end. + + Let head0 := + Eval lazy beta delta [ww_head0] in + ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. + + Let tail0 := + 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). + + (* ** Comparison ** *) + Let compare := + Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. + + Let eq0 (x:zn2z w) := + match x with + | W0 => true + | _ => false + end. + + (* ** Opposites ** *) + Let opp_c := + Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry. + + Let opp := + Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp. + + Let opp_carry := + Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. + + (* ** Additions ** *) + + Let succ_c := + Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c. + + Let add_c := + Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. + + Let add_carry_c := + Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in + ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. + + Let succ := + Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. + + Let add := + Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. + + Let add_carry := + Eval lazy beta iota delta [ww_add_carry ww_succ] in + ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. + + (* ** Subtractions ** *) + + Let pred_c := + Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. + + Let sub_c := + Eval lazy beta iota delta [ww_sub_c ww_opp_c] in + ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. + + Let sub_carry_c := + Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in + ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c. + + Let pred := + Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. + + Let sub := + Eval lazy beta iota delta [ww_sub ww_opp] in + ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. + + Let sub_carry := + Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in + ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred + w_sub w_sub_carry. + + + (* ** Multiplication ** *) + + Let mul_c := + Eval lazy beta iota delta [ww_mul_c double_mul_c] in + ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry. + + Let karatsuba_c := + Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in + ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c + add_c add add_carry sub_c sub. + + Let mul := + Eval lazy beta delta [ww_mul] in + ww_mul w_W0 w_add w_mul_c w_mul add. + + Let square_c := + Eval lazy beta delta [ww_square_c] in + ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry. + + (* Division operation *) + + Let div32 := + Eval lazy beta iota delta [w_div32] in + w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. + + Let div21 := + 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 add_mul_div := + Eval lazy beta delta [ww_add_mul_div] in + ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low. + + Let div_gt := + Eval lazy beta delta [ww_div_gt] in + ww_div_gt 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. + + Let div := + Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. + + Let mod_gt := + Eval lazy beta delta [ww_mod_gt] in + ww_mod_gt 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_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. + + Let mod_ := + Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. + + Let pos_mod := + Eval lazy beta delta [ww_pos_mod] in + ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. + + Let is_even := + Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. + + Let sqrt2 := + Eval lazy beta delta [ww_sqrt2] in + ww_sqrt2 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_zdigits w_add_c w_sqrt2 w_pred pred_c + pred add_c add sub_c add_mul_div. + + Let sqrt := + Eval lazy beta delta [ww_sqrt] in + ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits + _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. + + Let gcd_gt_fix := + Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in + ww_gcd_gt_aux 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 add_mul_div + w_zdigits. + + Let gcd_cont := + Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. + + Let gcd_gt := + Eval lazy beta delta [ww_gcd_gt] in + ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. + + Let gcd := + Eval lazy beta delta [ww_gcd] in + ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. + + (* ** Record of operators on 2 words *) + + Definition mk_zn2z_op := + mk_znz_op _ww_digits _ww_zdigits + to_Z ww_of_pos head0 tail0 + W0 ww_1 ww_Bm1 + compare eq0 + opp_c opp opp_carry + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c + pred sub sub_carry + mul_c mul square_c + div21 div_gt div + mod_gt mod_ + gcd_gt gcd + add_mul_div + pos_mod + is_even + sqrt2 + sqrt. + + Definition mk_zn2z_op_karatsuba := + mk_znz_op _ww_digits _ww_zdigits + to_Z ww_of_pos head0 tail0 + W0 ww_1 ww_Bm1 + compare eq0 + opp_c opp opp_carry + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c + pred sub sub_carry + karatsuba_c mul square_c + div21 div_gt div + mod_gt mod_ + gcd_gt gcd + add_mul_div + pos_mod + is_even + sqrt2 + sqrt. + + (* Proof *) + Variable op_spec : znz_spec w_op. + + 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). + + Ltac wwauto := unfold ww_to_Z; auto. + + Let wwB := base _ww_digits. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Notation "[+| c |]" := + (interp_carry 1 wwB to_Z c) (at level 0, x at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wwB to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). + + Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. + Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed. + + Let spec_ww_of_pos : forall p, + 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). + replace wwB with (wB*wB). + unfold wB,w_to_Z,w_digits;clear H;destruct n;ring. + symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). + Qed. + + Let spec_ww_0 : [|W0|] = 0. + Proof. reflexivity. Qed. + + Let spec_ww_1 : [|ww_1|] = 1. + Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed. + + Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. + 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. + 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. + Proof. destruct x;simpl;intros;trivial;discriminate. Qed. + + Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. + Proof. + refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); + auto. + Qed. + + Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. + Proof. + refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp + w_digits w_to_Z _ _ _ _ _); + auto. + Qed. + + Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. + Proof. + refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _); + wwauto. + Qed. + + Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. + Proof. + refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. + Proof. + refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto. + Qed. + + Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1. + Proof. + refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c + w_digits w_to_Z _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB. + Proof. + refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _); + wwauto. + Qed. + + Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. + Proof. + refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. + Proof. + refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ + w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. + Proof. + refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z + _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. + Proof. + refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c + w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. + Proof. + refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB. + Proof. + refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z + _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB. + Proof. + refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp + w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB. + Proof. + refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _); + wwauto. + Qed. + + Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|]. + Proof. + refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits + w_to_Z _ _ _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|]. + Proof. + refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + _ _ _ _ _ _ _ _ _ _ _ _); wwauto. + unfold w_digits; apply spec_more_than_1_digit; auto. + exact (spec_compare op_spec). + Qed. + + Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. + Proof. + refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); + wwauto. + Qed. + + Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. + Proof. + refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add + add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto. + Qed. + + Let spec_w_div32 : forall a1 a2 a3 b1 b2, + wB / 2 <= (w_to_Z b1) -> + [|WW a1 a2|] < [|WW b1 b2|] -> + let (q, r) := div32 a1 a2 a3 b1 b2 in + (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) = + (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\ + 0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2. + Proof. + refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + 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). + 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). + Qed. + + Let spec_ww_div21 : forall a1 a2 b, + wwB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div21 a1 a2 b in + [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z + _ _ _ _ _ _ _);wwauto. + Qed. + + 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 w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0. + unfold w_0; rewrite 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. + 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. + intros xh xl; simpl. + rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith. + rewrite Zmod_small; auto with zarith. + unfold wB, base; auto with zarith. + Qed. + + Let spec_ww_digits: + [|_ww_zdigits|] = Zpos (xO w_digits). + Proof. + unfold w_to_Z, _ww_zdigits. + rewrite spec_add2. + unfold w_to_Z, w_zdigits, w_digits. + rewrite spec_zdigits; auto. + rewrite Zpos_xO; auto with zarith. + Qed. + + + Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. + Proof. + 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). + Qed. + + Let spec_ww_head0 : forall x, 0 < [|x|] -> + wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. + Proof. + 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). + Qed. + + Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. + Proof. + 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). + Qed. + + + Let spec_ww_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. + 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). + Qed. + + Lemma spec_ww_add_mul_div : forall x y p, + [|p|] <= Zpos _ww_digits -> + [| add_mul_div p x y |] = + ([|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 + sub w_digits w_zdigits low w_to_Z + _ _ _ _ _ _ _ _ _ _ _);wwauto. + exact (spec_zdigits op_spec). + Qed. + + Let spec_ww_div_gt : forall a b, + [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := div_gt a b in + [|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 + 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). + 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 spec_w_div32. + exact (spec_zdigits op_spec). + exact spec_ww_digits. + exact spec_ww_1. + exact spec_ww_add_mul_div. + Qed. + + Let spec_ww_div : forall a b, 0 < [|b|] -> + let (q,r) := div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_mod_gt : forall a b, + [|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 + 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 spec_ww_add_mul_div. + Qed. + + Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. + Proof. + refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto. + Qed. + + 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 _ + 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 + 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 spec_ww_add_mul_div. + refine (@spec_gcd_cont w 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 + _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 + 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 spec_ww_add_mul_div. + refine (@spec_gcd_cont w 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, + match is_even x with + true => [|x|] mod 2 = 0 + | 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). + Qed. + + Let spec_ww_sqrt2 : forall x y, + wwB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros x y H. + refine (@spec_ww_sqrt2 w 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). + 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 + 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). + Qed. + + Lemma mk_znz2_spec : znz_spec mk_zn2z_op. + Proof. + apply mk_znz_spec;auto. + exact spec_ww_add_mul_div. + + refine (@spec_ww_pos_mod w 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). + unfold w_to_Z, w_zdigits. + rewrite (spec_zdigits op_spec). + rewrite <- Zpos_xO; exact spec_ww_digits. + Qed. + + Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba. + Proof. + apply mk_znz_spec;auto. + exact spec_ww_add_mul_div. + refine (@spec_ww_pos_mod w 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). + unfold w_to_Z, w_zdigits. + rewrite (spec_zdigits op_spec). + rewrite <- Zpos_xO; exact spec_ww_digits. + Qed. + +End Z_2nZ. + +Section MulAdd. + + Variable w: Type. + Variable op: znz_op w. + Variable sop: znz_spec op. + + Definition mul_add:= w_mul_add (znz_0 op) (znz_succ op) (znz_add_c op) (znz_mul_c op). + + Notation "[| x |]" := (znz_to_Z op 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). + + + Lemma spec_mul_add: forall x y z, + let (zh, zl) := mul_add x y z in + [||WW zh zl||] = [|x|] * [|y|] + [|z|]. + 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). + Qed. + +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. +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. +End DoubleCyclicKaratsuba. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v new file mode 100644 index 00000000..075aef59 --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -0,0 +1,1540 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleDiv.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. +Require Import DoubleDivn1. +Require Import DoubleAdd. +Require Import DoubleSub. + +Open Local Scope Z_scope. + +Ltac zarith := auto with zarith. + + +Section POS_MOD. + + Variable w:Type. + Variable w_0 : w. + Variable w_digits : positive. + Variable w_zdigits : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_pos_mod : w -> w -> w. + Variable w_compare : w -> w -> comparison. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + Variable w_0W : w -> zn2z w. + Variable low: zn2z w -> w. + Variable ww_sub: zn2z w -> zn2z w -> zn2z w. + Variable ww_zdigits : zn2z w. + + + Definition ww_pos_mod p x := + let zdigits := w_0W w_zdigits in + match x with + | W0 => W0 + | WW xh xl => + match ww_compare p zdigits with + | Eq => w_WW w_0 xl + | Lt => w_WW w_0 (w_pos_mod (low p) xl) + | Gt => + match ww_compare p ww_zdigits with + | Lt => + let n := low (ww_sub p zdigits) in + w_WW (w_pos_mod n xh) xl + | _ => x + end + end + end. + + + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + + Variable spec_w_0 : [|w_0|] = 0. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + + Variable spec_pos_mod : forall w p, + [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + + 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. + Variable spec_ww_sub: forall x y, + [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + + Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. + Variable spec_low: forall x, [| low x|] = [[x]] mod wB. + Variable spec_ww_zdigits : [[ww_zdigits]] = 2 * [|w_zdigits|]. + Variable spec_ww_digits : ww_digits w_digits = xO w_digits. + + + Hint Rewrite spec_w_0 spec_w_WW : w_rewrite. + + Lemma spec_ww_pos_mod : forall w p, + [[ww_pos_mod p w]] = [[w]] mod (2 ^ [[p]]). + assert (HHHHH:= lt_0_wB w_digits). + assert (F0: forall x y, x - y + y = x); auto with zarith. + 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; + rewrite spec_w_0W; rewrite spec_zdigits; fold wB; + intros H1. + rewrite H1; simpl ww_to_Z. + autorewrite with w_rewrite rm10. + rewrite Zplus_mod; auto with zarith. + rewrite Z_mod_mult; auto with zarith. + autorewrite with rm10. + rewrite Zmod_mod; auto with zarith. + rewrite Zmod_small; auto with zarith. + autorewrite with w_rewrite rm10. + simpl ww_to_Z. + rewrite spec_pos_mod. + assert (HH0: [|low p|] = [[p]]). + rewrite spec_low. + apply Zmod_small; auto with zarith. + case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith. + apply Zlt_le_trans with (1 := H1). + unfold base; apply Zpower2_le_lin; auto with zarith. + rewrite HH0. + rewrite Zplus_mod; auto with zarith. + unfold base. + rewrite <- (F0 (Zpos w_digits) [[p]]). + rewrite Zpower_exp; auto with zarith. + rewrite Zmult_assoc. + 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_zdigits; intros H2. + replace (2^[[p]]) with wwB. + rewrite Zmod_small; auto with zarith. + unfold base; rewrite H2. + rewrite spec_ww_digits; auto. + assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = + [[p]] - Zpos w_digits). + rewrite spec_low. + rewrite spec_ww_sub. + rewrite spec_w_0W; rewrite spec_zdigits. + rewrite <- Zmod_div_mod; auto with zarith. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zlt_le_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. + exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. + rewrite spec_ww_digits; + apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith. + simpl ww_to_Z; autorewrite with w_rewrite. + rewrite spec_pos_mod; rewrite HH0. + pattern [|xh|] at 2; + rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); + auto with zarith. + rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l. + unfold base; rewrite <- Zmult_assoc; rewrite <- Zpower_exp; + auto with zarith. + rewrite F0; auto with zarith. + rewrite <- Zplus_assoc; rewrite Zplus_mod; auto with zarith. + rewrite Z_mod_mult; auto with zarith. + autorewrite with rm10. + rewrite Zmod_mod; auto with zarith. + apply sym_equal; apply Zmod_small; auto with zarith. + case (spec_to_Z xh); intros U1 U2. + case (spec_to_Z xl); intros U3 U4. + split; auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + match goal with |- 0 <= ?X mod ?Y => + case (Z_mod_lt X Y); auto with zarith + end. + match goal with |- ?X mod ?Y * ?U + ?Z < ?T => + apply Zle_lt_trans with ((Y - 1) * U + Z ); + [case (Z_mod_lt X Y); auto with zarith | idtac] + end. + match goal with |- ?X * ?U + ?Y < ?Z => + apply Zle_lt_trans with (X * U + (U - 1)) + end. + apply Zplus_le_compat_l; auto with zarith. + case (spec_to_Z xl); unfold base; auto with zarith. + rewrite Zmult_minus_distr_r; rewrite <- Zpower_exp; auto with zarith. + rewrite F0; auto with zarith. + rewrite Zmod_small; auto with zarith. + case (spec_to_w_Z (WW xh xl)); intros U1 U2. + split; auto with zarith. + apply Zlt_le_trans with (1:= U2). + unfold base; rewrite spec_ww_digits. + apply Zpower_le_monotone; auto with zarith. + split; auto with zarith. + rewrite Zpos_xO; auto with zarith. + Qed. + +End POS_MOD. + +Section DoubleDiv32. + + Variable w : Type. + Variable w_0 : w. + Variable w_Bm1 : w. + Variable w_Bm2 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_add_c : w -> w -> carry w. + Variable w_add_carry_c : w -> w -> carry w. + Variable w_add : w -> w -> w. + Variable w_add_carry : w -> w -> w. + Variable w_pred : w -> w. + Variable w_sub : w -> w -> w. + Variable w_mul_c : w -> w -> zn2z w. + Variable w_div21 : w -> w -> w -> w*w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + + Definition w_div32 a1 a2 a3 b1 b2 := + Eval lazy beta iota delta [ww_add_c_cont ww_add] in + match w_compare a1 b1 with + | Lt => + let (q,r) := w_div21 a1 a2 b1 in + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + | C0 r1 => (q,r1) + | C1 r1 => + let q := w_pred q in + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) + (fun r2 => (q,r2)) + r1 (WW b1 b2) + end + | Eq => + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) + (fun r => (w_Bm1,r)) + (WW (w_sub a2 b2) a3) (WW b1 b2) + | Gt => (w_0, W0) (* cas absurde *) + end. + + (* Proof *) + + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_w_Bm2 : [|w_Bm2|] = wB - 2. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + 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. + 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. + + Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. + Variable spec_w_add_carry : + forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + + Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Theorem wB_div2: forall x, wB/2 <= x -> wB <= 2 * x. + intros x H; rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + Qed. + + Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m. + Proof. + intros n m H1 H2;apply Zmult_lt_0_reg_r with n;trivial. + destruct (Zle_lt_or_eq _ _ H1);trivial. + subst;rewrite Zmult_0_r in H2;discriminate H2. + Qed. + + Theorem spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]. + Proof. + intros a1 a2 a3 b1 b2 Hle Hlt. + assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). + Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. + rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_assoc;rewrite <- Zmult_plus_distr_l. + change (w_div32 a1 a2 a3 b1 b2) with + match w_compare a1 b1 with + | Lt => + let (q,r) := w_div21 a1 a2 b1 in + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + | C0 r1 => (q,r1) + | C1 r1 => + let q := w_pred q in + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) + (fun r2 => (q,r2)) + r1 (WW b1 b2) + end + | Eq => + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) + (fun r => (w_Bm1,r)) + (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). + simpl in Hlt. + rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. + assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). + simpl;rewrite spec_sub. + assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring. + assert (0 <= [|a2|] - [|b2|] + wB < wB). omega. + rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) H1 H0). + rewrite wwB_wBwB;ring. + assert (U2 := wB_pos w_digits). + eapply spec_ww_add_c_cont with (P := + fun (x y:zn2z w) (res:w*zn2z w) => + let (q, r) := res in + ([|a1|] * wB + [|a2|]) * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. + rewrite H0;intros r. + repeat + (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); + simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. + assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). + Spec_ww_to_Z r;split;zarith. + rewrite H1. + assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). + rewrite wwB_wBwB; rewrite Zpower_2; zarith. + assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0). + split. apply Zlt_le_trans with (([|a2|] - [|b2|]) * wB);zarith. + rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring]. + apply Zmult_lt_compat_r;zarith. + apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. + replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with + (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring]. + assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. + replace 0 with (0*wB);zarith. + replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) + + ([|b1|] * wB + [|b2|]) - wwB) with + (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]); + [zarith | ring]. + rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB + 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). + split. rewrite H1;rewrite Hcmp;ring. trivial. + Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. + rewrite H0;intros r;repeat + (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); + simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. + assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. + split. rewrite H2;rewrite Hcmp;ring. + split. Spec_ww_to_Z r;zarith. + rewrite H2. + assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith. + apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. + replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with + (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring]. + assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. + replace 0 with (0*wB);zarith. + (* Cas Lt *) + assert (Hdiv21 := spec_div21 a2 Hle Hcmp); + destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21. + rewrite H. + assert (Hq := spec_to_Z q). + generalize + (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2)); + destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2)) + as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); + unfold interp_carry;intros H1. + rewrite H1. + split. ring. split. + rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. + apply Zle_lt_trans with ([|r|] * wB + [|a3|]). + assert ( 0 <= [|q|] * [|b2|]);zarith. + apply beta_lex_inv;zarith. + assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB). + rewrite <- H1;ring. + Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. + assert (0 < [|q|] * [|b2|]). zarith. + assert (0 < [|q|]). + apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. + eapply spec_ww_add_c_cont with (P := + fun (x y:zn2z w) (res:w*zn2z w) => + let (q0, r0) := res in + ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] = + [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\ + 0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto. + intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto); + simpl ww_to_Z;intros H7. + assert (0 < [|q|] - 1). + assert (1 <= [|q|]). zarith. + destruct (Zle_lt_or_eq _ _ H6);zarith. + rewrite <- H8 in H2;rewrite H2 in H7. + assert (0 < [|b1|]*wB). apply Zmult_lt_0_compat;zarith. + Spec_ww_to_Z r2. zarith. + rewrite (Zmod_small ([|q|] -1));zarith. + rewrite (Zmod_small ([|q|] -1 -1));zarith. + assert ([[r2]] + ([|b1|] * wB + [|b2|]) = + wwB * 1 + + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). + rewrite H7;rewrite H2;ring. + assert + ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + < [|b1|]*wB + [|b2|]). + Spec_ww_to_Z r2;omega. + Spec_ww_to_Z (WW b1 b2). simpl in HH5. + assert + (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + < wwB). split;try omega. + replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. + assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). + rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega. + rewrite <- (Zmod_unique + ([[r2]] + ([|b1|] * wB + [|b2|])) + wwB + 1 + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|])) + H10 H8). + split. ring. zarith. + intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7. + rewrite (Zmod_small ([|q|] -1));zarith. + split. + replace [[r2]] with ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB). + rewrite H2; ring. rewrite <- H7; ring. + Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega. + simpl in Hlt. + assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith. + assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith. + Qed. + + +End DoubleDiv32. + +Section DoubleDiv21. + Variable w : Type. + Variable w_0 : w. + + Variable w_0W : w -> zn2z w. + Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. + + Variable ww_1 : zn2z w. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + Variable ww_sub : zn2z w -> zn2z w -> zn2z w. + + + Definition ww_div21 a1 a2 b := + match a1 with + | W0 => + match ww_compare a2 b with + | Gt => (ww_1, ww_sub a2 b) + | Eq => (ww_1, W0) + | Lt => (W0, a2) + end + | WW a1h a1l => + match a2 with + | W0 => + match b with + | W0 => (W0,W0) (* cas absurde *) + | WW b1 b2 => + let (q1, r) := w_div32 a1h a1l w_0 b1 b2 in + match r with + | W0 => (WW q1 w_0, W0) + | WW r1 r2 => + let (q2, s) := w_div32 r1 r2 w_0 b1 b2 in + (WW q1 q2, s) + end + end + | WW a2h a2l => + match b with + | W0 => (W0,W0) (* cas absurde *) + | WW b1 b2 => + let (q1, r) := w_div32 a1h a1l a2h b1 b2 in + match r with + | W0 => (WW q1 w_0, w_0W a2l) + | WW r1 r2 => + let (q2, s) := w_div32 r1 r2 a2l b1 b2 in + (WW q1 q2, s) + end + end + end + end. + + (* Proof *) + + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 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. + Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + + Theorem wwB_div: wwB = 2 * (wwB / 2). + Proof. + rewrite wwB_div_2; rewrite Zmult_assoc; rewrite wB_div_2; auto. + rewrite <- Zpower_2; apply wwB_wBwB. + Qed. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Theorem spec_ww_div21 : forall a1 a2 b, + wwB/2 <= [[b]] -> + [[a1]] < [[b]] -> + let (q,r) := ww_div21 a1 a2 b in + [[a1]] *wwB+[[a2]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. + Proof. + assert (U:= lt_0_wB w_digits). + assert (U1:= lt_0_wwB w_digits). + 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. + rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith. + split. ring. + assert (wwB <= 2*[[b]]);zarith. + rewrite wwB_div;zarith. + intros a1h a1l. Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2. + destruct a2 as [ |a3 a4]; + (destruct b as [ |b1 b2];[unfold Zle in Eq;discriminate Eq|idtac]); + try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2; + intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q1 r H0 + end; (assert (Eq1: wB / 2 <= [|b1|]);[ + apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; + autorewrite with rm10;repeat rewrite (Zmult_comm wB); + rewrite <- wwB_div_2; trivial + | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; + try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r; + intros (H1,H2) ]). + split;[rewrite wwB_wBwB; rewrite Zpower_2 | trivial]. + rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H1;ring. + destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. + split;[rewrite wwB_wBwB | trivial]. + rewrite Zpower_2. + rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; + rewrite <- Zpower_2. + rewrite <- wwB_wBwB;rewrite H1. + rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4. + repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]). + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. + split;[rewrite wwB_wBwB | split;zarith]. + replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) + with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). + rewrite H1;ring. rewrite wwB_wBwB;ring. + change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. + assert (1 <= wB/2);zarith. + assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith. + destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. + split;trivial. + replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with + (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); + [rewrite H1 | rewrite wwB_wBwB;ring]. + replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with + (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); + [rewrite H4;simpl|rewrite wwB_wBwB];ring. + Qed. + +End DoubleDiv21. + +Section DoubleDivGt. + Variable w : Type. + Variable w_digits : positive. + Variable w_0 : w. + + Variable w_WW : w -> w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_eq0 : w -> bool. + Variable w_opp_c : w -> carry w. + Variable w_opp w_opp_carry : w -> w. + Variable w_sub_c : w -> w -> carry w. + Variable w_sub w_sub_carry : w -> w -> w. + + Variable w_div_gt : w -> w -> w*w. + Variable w_mod_gt : w -> w -> w. + Variable w_gcd_gt : w -> w -> w. + Variable w_add_mul_div : w -> w -> w -> w. + Variable w_head0 : w -> w. + Variable w_div21 : w -> w -> w -> w * w. + Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. + + + Variable _ww_zdigits : zn2z w. + Variable ww_1 : zn2z w. + Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. + + Variable w_zdigits : w. + + Definition ww_div_gt_aux ah al bh bl := + Eval lazy beta iota delta [ww_sub ww_opp] in + let p := w_head0 bh in + match w_compare p w_0 with + | Gt => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + (WW w_0 q, ww_add_mul_div + (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) + | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) + end. + + Definition ww_div_gt a b := + Eval lazy beta iota delta [ww_div_gt_aux double_divn1 + double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux + double_split double_0 double_WW] in + match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then + let (q,r) := w_div_gt al bl in + (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end. + + Definition ww_mod_gt_aux ah al bh bl := + Eval lazy beta iota delta [ww_sub ww_opp] in + let p := w_head0 bh in + match w_compare p w_0 with + | Gt => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r + | _ => + ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) + end. + + Definition ww_mod_gt a b := + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux + double_split double_0 double_WW snd] in + match a, b with + | W0, _ => W0 + | _, W0 => W0 + | WW ah al, WW bh bl => + if w_eq0 ah then w_0W (w_mod_gt al bl) + else + match w_compare w_0 bh with + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 a bl) + | Lt => ww_mod_gt_aux ah al bh bl + | Gt => W0 (* cas absurde *) + end + end. + + Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux + double_split double_0 double_WW snd] in + match w_compare w_0 bh with + | Eq => + match w_compare w_0 bl with + | Eq => WW ah al (* normalement n'arrive pas si forme normale *) + | Lt => + let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 (WW ah al) bl in + WW w_0 (w_gcd_gt bl m) + | Gt => W0 (* absurde *) + end + | Lt => + let m := ww_mod_gt_aux ah al bh bl in + match m with + | W0 => WW bh bl + | WW mh ml => + match w_compare w_0 mh with + | Eq => + match w_compare w_0 ml with + | Eq => WW bh bl + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 (WW bh bl) ml in + WW w_0 (w_gcd_gt ml r) + end + | Lt => + let r := ww_mod_gt_aux bh bl mh ml in + match r with + | W0 => m + | WW rh rl => cont mh ml rh rl + end + | Gt => W0 (* absurde *) + end + end + | Gt => W0 (* absurde *) + end. + + Fixpoint ww_gcd_gt_aux + (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) + {struct p} : zn2z w := + ww_gcd_gt_body + (fun mh ml rh rl => match p with + | xH => cont mh ml rh rl + | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl + | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl + end) ah al bh bl. + + + (* Proof *) + + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. + + 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. + Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. + + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. + Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. + Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. + + Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + Variable spec_sub_carry : + forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + + Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := w_div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|w_mod_gt a b|] = [|a|] mod [|b|]. + Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. + + Variable spec_add_mul_div : forall x y p, + [|p|] <= Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ ([|p|])) + + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. + Variable spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. + + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + + Variable spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]. + + Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. + + Variable spec_ww_digits_ : [[_ww_zdigits]] = Zpos (xO w_digits). + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_ww_add_mul_div : forall x y p, + [[p]] <= Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^[[p]]) + + [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Lemma to_Z_div_minus_p : forall x p, + 0 < [|p|] < Zpos w_digits -> + 0 <= [|x|] / 2 ^ (Zpos w_digits - [|p|]) < 2 ^ [|p|]. + Proof. + intros x p H;Spec_w_to_Z x. + split. apply Zdiv_le_lower_bound;zarith. + apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + ring_simplify ([|p|] + (Zpos w_digits - [|p|])); unfold base in HH;zarith. + Qed. + Hint Resolve to_Z_div_minus_p : zarith. + + Lemma spec_ww_div_gt_aux : forall ah al bh bl, + [[WW ah al]] > [[WW bh bl]] -> + 0 < [|bh|] -> + let (q,r) := ww_div_gt_aux ah al bh bl in + [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\ + 0 <= [[r]] < [[WW bh bl]]. + Proof. + intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux. + change + (let (q, r) := let p := w_head0 bh in + match w_compare p w_0 with + | Gt => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + (WW w_0 q, ww_add_mul_div + (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) + | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) + 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_w_0; intros HH. + generalize Hh; rewrite HH; simpl Zpower; + rewrite Zmult_1_l; intros (HH1, HH2); clear HH. + assert (wwB <= 2*[[WW bh bl]]). + apply Zle_trans with (2*[|bh|]*wB). + rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat_r; zarith. + rewrite <- wB_div_2; apply Zmult_le_compat_l; zarith. + simpl ww_to_Z;rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. + Spec_w_to_Z bl;zarith. + Spec_ww_to_Z (WW ah al). + rewrite spec_ww_sub;eauto. + simpl;rewrite spec_ww_1;rewrite Zmult_1_l;simpl. + simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith. + case (spec_to_Z (w_head0 bh)); auto with zarith. + assert ([|w_head0 bh|] < Zpos w_digits). + destruct (Z_lt_ge_dec [|w_head0 bh|] (Zpos w_digits));trivial. + elimtype False. + assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith. + apply Zle_ge; replace wB with (wB * 1);try ring. + Spec_w_to_Z bh;apply Zmult_le_compat;zarith. + unfold base;apply Zpower_le_monotone;zarith. + assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith. + assert (Hb:= Zlt_le_weak _ _ H). + generalize (spec_add_mul_div w_0 ah Hb) + (spec_add_mul_div ah al Hb) + (spec_add_mul_div al w_0 Hb) + (spec_add_mul_div bh bl Hb) + (spec_add_mul_div bl w_0 Hb); + rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l; + rewrite Zdiv_0_l;repeat rewrite Zplus_0_r. + Spec_w_to_Z ah;Spec_w_to_Z bh. + unfold base;repeat rewrite Zmod_shift_r;zarith. + assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); + assert (H5:=to_Z_div_minus_p bl HHHH). + rewrite Zmult_comm in Hh. + assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. + unfold base in H0;rewrite Zmod_small;zarith. + fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. + intros U1 U2 U3 V1 V2. + generalize (@spec_w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) + (w_add_mul_div (w_head0 bh) ah al) + (w_add_mul_div (w_head0 bh) al w_0) + (w_add_mul_div (w_head0 bh) bh bl) + (w_add_mul_div (w_head0 bh) bl w_0)). + destruct (w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) + (w_add_mul_div (w_head0 bh) ah al) + (w_add_mul_div (w_head0 bh) al w_0) + (w_add_mul_div (w_head0 bh) bh bl) + (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). + rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. + rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). + unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. + replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with + ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. + fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3. + rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. + rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). + rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. + replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with + ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. + intros Hd;destruct Hd;zarith. + simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1. + assert ([|ah|] / 2 ^ (Zpos (w_digits) - [|w_head0 bh|]) < wB/2);zarith. + apply Zdiv_lt_upper_bound;zarith. + unfold base. + replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2). + rewrite Z_div_mult;zarith. rewrite <- Zpower_exp;zarith. + apply Zlt_le_trans with wB;zarith. + unfold base;apply Zpower_le_monotone;zarith. + pattern 2 at 2;replace 2 with (2^1);trivial. + rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial. + change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite + Zmult_0_l;rewrite Zplus_0_l. + replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry + _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]). + assert (0 < 2^[|w_head0 bh|]). apply Zpower_gt_0;zarith. + split. + rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith. + rewrite H1;rewrite Zmult_assoc;apply Z_div_plus_l;trivial. + split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. + rewrite spec_ww_add_mul_div. + rewrite spec_ww_sub; auto with zarith. + rewrite spec_ww_digits_. + change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith. + simpl ww_to_Z;rewrite Zmult_0_l;rewrite Zplus_0_l. + rewrite spec_w_0W. + rewrite (fun x y => Zmod_small (x-y)); auto with zarith. + ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])). + rewrite Zmod_small;zarith. + split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. + Spec_ww_to_Z r. + apply Zlt_le_trans with wwB;zarith. + rewrite <- (Zmult_1_r wwB);apply Zmult_le_compat;zarith. + split; auto with zarith. + apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith. + unfold base, ww_digits; rewrite (Zpos_xO w_digits). + apply Zpower2_lt_lin; auto with zarith. + rewrite spec_ww_sub; auto with zarith. + rewrite spec_ww_digits_; rewrite spec_w_0W. + rewrite Zmod_small;zarith. + rewrite Zpos_xO; split; auto with zarith. + apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith. + unfold base, ww_digits; rewrite (Zpos_xO w_digits). + apply Zpower2_lt_lin; auto with zarith. + Qed. + + Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + let (q,r) := ww_div_gt a b in + [[a]] = [[q]] * [[b]] + [[r]] /\ + 0 <= [[r]] < [[b]]. + Proof. + intros a b Hgt Hpos;unfold ww_div_gt. + change (let (q,r) := match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then + let (q,r) := w_div_gt al bl in + (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). + destruct a as [ |ah al]. simpl in Hgt;omega. + destruct b as [ |bh bl]. simpl in Hpos;omega. + Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. + assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). + simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. + simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. + 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_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). + rewrite spec_w_0W;unfold ww_to_Z;trivial. + apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. + rewrite spec_w_0 in Hcmp;elimtype False;omega. + Qed. + + Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, + ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl). + Proof. + intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux. + case w_compare; auto. + case w_div32; auto. + Qed. + + Lemma spec_ww_mod_gt_aux : forall ah al bh bl, + [[WW ah al]] > [[WW bh bl]] -> + 0 < [|bh|] -> + [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]]. + Proof. + intros. rewrite spec_ww_mod_gt_aux_eq;trivial. + assert (H3 := spec_ww_div_gt_aux ah al bl H H0). + destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3. + destruct H3;apply Zmod_unique with [[q]];zarith. + rewrite H1;ring. + Qed. + + Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] -> + [|w_mod_gt a b|] = [|snd (w_div_gt a b)|]. + Proof. + intros a b Hgt Hpos. + rewrite spec_mod_gt;trivial. + assert (H:=spec_div_gt Hgt Hpos). + destruct (w_div_gt a b) as (q,r);simpl. + rewrite Zmult_comm in H;destruct H. + symmetry;apply Zmod_unique with [|q|];trivial. + Qed. + + Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. + Proof. + intros a b Hgt Hpos. + change (ww_mod_gt a b) with + (match a, b with + | W0, _ => W0 + | _, W0 => W0 + | WW ah al, WW bh bl => + if w_eq0 ah then w_0W (w_mod_gt al bl) + else + match w_compare w_0 bh with + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 a bl) + | Lt => ww_mod_gt_aux ah al bh bl + | Gt => W0 (* cas absurde *) + end end). + change (ww_div_gt a b) with + (match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then + let (q,r) := w_div_gt al bl in + (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end). + destruct a as [ |ah al];trivial. + destruct b as [ |bh bl];trivial. + Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. + assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). + simpl in Hgt;rewrite H in Hgt;trivial. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. + simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. + 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_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 + (WW ah al) bl);simpl;trivial. + rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial. + trivial. + Qed. + + Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[a]] mod [[b]]. + Proof. + intros a b Hgt Hpos. + assert (H:= spec_ww_div_gt a b Hgt Hpos). + rewrite (spec_ww_mod_gt_eq a b Hgt Hpos). + destruct (ww_div_gt a b)as(q,r);destruct H. + apply Zmod_unique with[[q]];simpl;trivial. + rewrite Zmult_comm;trivial. + Qed. + + Lemma Zis_gcd_mod : forall a b d, + 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. + Proof. + intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). + pattern a at 1;rewrite (Z_div_mod_eq a b). + ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. + Qed. + + Lemma spec_ww_gcd_gt_aux_body : + forall ah al bh bl n cont, + [[WW bh bl]] <= 2^n -> + [[WW ah al]] > [[WW bh bl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. + Proof. + intros ah al bh bl n cont Hlog Hgt Hcont. + change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with + | Eq => + match w_compare w_0 bl with + | Eq => WW ah al (* normalement n'arrive pas si forme normale *) + | Lt => + let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 (WW ah al) bl in + WW w_0 (w_gcd_gt bl m) + | Gt => W0 (* absurde *) + end + | Lt => + let m := ww_mod_gt_aux ah al bh bl in + match m with + | W0 => WW bh bl + | WW mh ml => + match w_compare w_0 mh with + | Eq => + match w_compare w_0 ml with + | Eq => WW bh bl + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + w_compare w_sub 1 (WW bh bl) ml in + WW w_0 (w_gcd_gt ml r) + end + | Lt => + let r := ww_mod_gt_aux bh bl mh ml in + match r with + | W0 => m + | WW rh rl => cont mh ml rh rl + end + | Gt => W0 (* absurde *) + end + 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 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. + 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 + 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 Hbl). + apply spec_gcd_gt. + 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;elimtype False;omega. + rewrite spec_w_0 in Hbh;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. + 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 + spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). + apply spec_gcd_gt. + 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;elimtype False;omega. + rewrite spec_w_0 in Hmh. 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). + assert (H3 : 0 < [[WW mh ml]]). + simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith. + apply Zmult_lt_0_compat;zarith. + apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. + destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. + simpl;apply Hcont. simpl in H1;rewrite H1. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + destruct (Z_mod_lt x y);zarith end. + apply Zle_trans with (2^n/2). + apply Zdiv_le_lower_bound;zarith. + apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith. + assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)). + assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]). + apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. + pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. + destruct (Zle_lt_or_eq _ _ H4'). + assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = + [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). + simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. + assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). + simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Zmult_1_r;zarith. + simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8; + zarith. + assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith. + rewrite <- H4 in H3';rewrite Zmult_0_r in H3';simpl in H3';zarith. + pattern n at 1;replace n with (n-1+1);try ring. + rewrite Zpower_exp;zarith. change (2^1) with 2. + 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;elimtype False;zarith. + rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith. + Qed. + + Lemma spec_ww_gcd_gt_aux : + forall p cont n, + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 2^n -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> + [[WW bh bl]] <= 2^(Zpos p + n) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] + [[ww_gcd_gt_aux p cont ah al bh bl]]. + Proof. + induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux. + assert (0 < Zpos p). unfold Zlt;reflexivity. + apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n); + trivial;rewrite Zpos_xI. + intros. apply IHp with (n := Zpos p + n);zarith. + intros. apply IHp with (n := n );zarith. + apply Zle_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith. + apply Zpower_le_monotone2;zarith. + assert (0 < Zpos p). unfold Zlt;reflexivity. + apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial. + rewrite (Zpos_xO p). + intros. apply IHp with (n := Zpos p + n - 1);zarith. + intros. apply IHp with (n := n -1 );zarith. + intros;apply Hcont;zarith. + apply Zle_trans with (2^(n-1));zarith. + apply Zpower_le_monotone2;zarith. + apply Zle_trans with (2 ^ (Zpos p + n -1));zarith. + apply Zpower_le_monotone2;zarith. + apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith. + apply Zpower_le_monotone2;zarith. + apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. + rewrite Zplus_comm;trivial. + ring_simplify (n + 1 - 1);trivial. + Qed. + +End DoubleDivGt. + +Section DoubleDiv. + + Variable w : Type. + Variable w_digits : positive. + Variable ww_1 : zn2z w. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + + Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. + Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. + + Definition ww_div a b := + match ww_compare a b with + | Gt => ww_div_gt a b + | Eq => (ww_1, W0) + | Lt => (W0, a) + end. + + Definition ww_mod a b := + match ww_compare a b with + | Gt => ww_mod_gt a b + | Eq => W0 + | Lt => a + end. + + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + 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. + 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]] /\ + 0 <= [[r]] < [[b]]. + Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[a]] mod [[b]]. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Lemma spec_ww_div : forall a b, 0 < [[b]] -> + let (q,r) := ww_div a b in + [[a]] = [[q]] * [[b]] + [[r]] /\ + 0 <= [[r]] < [[b]]. + Proof. + intros a b Hpos;unfold ww_div. + assert (H:=spec_ww_compare a b);destruct (ww_compare a b). + simpl;rewrite spec_ww_1;split;zarith. + simpl;split;[ring|Spec_ww_to_Z a;zarith]. + apply spec_ww_div_gt;trivial. + 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). + 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. + Qed. + + + Variable w_0 : w. + Variable w_1 : w. + Variable w_compare : w -> w -> comparison. + Variable w_eq0 : w -> bool. + Variable w_gcd_gt : w -> w -> w. + Variable _ww_digits : positive. + Variable spec_ww_digits_ : _ww_digits = xO w_digits. + Variable ww_gcd_gt_fix : + positive -> (w -> w -> w -> w -> zn2z w) -> + w -> w -> w -> w -> zn2z w. + + 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. + 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|]. + Variable spec_gcd_gt_fix : + forall p cont n, + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 2^n -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> + [[WW bh bl]] <= 2^(Zpos p + n) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] + [[ww_gcd_gt_fix p cont ah al bh bl]]. + + Definition gcd_cont (xh xl yh yl:w) := + match w_compare w_1 yl with + | Eq => ww_1 + | _ => WW xh xl + end. + + Lemma spec_gcd_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 1 -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. + Proof. + intros xh xl yh yl Hgt' Hle. simpl in Hle. + assert ([|yh|] = 0). + change 1 with (0*wB+1) in Hle. + 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). + 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; elimtype False;zarith. + assert ([|yl|] = 0). Spec_w_to_Z yl;zarith. + rewrite H0;simpl;apply Zis_gcd_0;trivial. + Qed. + + + Variable cont : w -> w -> w -> w -> zn2z w. + Variable spec_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 1 -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. + + Definition ww_gcd_gt a b := + match a, b with + | W0, _ => b + | _, W0 => a + | WW ah al, WW bh bl => + if w_eq0 ah then (WW w_0 (w_gcd_gt al bl)) + else ww_gcd_gt_fix _ww_digits cont ah al bh bl + end. + + Definition ww_gcd a b := + Eval lazy beta delta [ww_gcd_gt] in + match ww_compare a b with + | Gt => ww_gcd_gt a b + | Eq => a + | Lt => ww_gcd_gt b a + end. + + Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] -> + Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]]. + Proof. + intros a b Hgt;unfold ww_gcd_gt. + destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. + destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. + simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. + simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. + rewrite H1;simpl;auto. clear H. + apply spec_gcd_gt_fix with (n:= 0);trivial. + rewrite Zplus_0_r;rewrite spec_ww_digits_. + change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith. + Qed. + + Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. + Proof. + intros a b. + change (ww_gcd a b) with + (match ww_compare a b with + | Gt => ww_gcd_gt a b + | Eq => a + | Lt => ww_gcd_gt b a + end). + assert (Hcmp := spec_ww_compare a b);destruct (ww_compare a b). + 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. + apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith. + apply spec_ww_gcd_gt;zarith. + Qed. + +End DoubleDiv. + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v new file mode 100644 index 00000000..d6f6a05f --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -0,0 +1,528 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleDivn1.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section GENDIVN1. + + Variable w : Type. + Variable w_digits : positive. + Variable w_zdigits : w. + Variable w_0 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_head0 : w -> w. + Variable w_add_mul_div : w -> w -> w -> w. + Variable w_div21 : w -> w -> w -> w * w. + Variable w_compare : w -> w -> comparison. + Variable w_sub : w -> w -> w. + + + + (* ** For proofs ** *) + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). + + Variable spec_to_Z : forall x, 0 <= [| x |] < wB. + Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. + Variable spec_0 : [|w_0|] = 0. + Variable spec_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. + Variable spec_add_mul_div : forall x y p, + [|p|] <= Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|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. + Variable spec_sub: forall x y, + [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + + + + Section DIVAUX. + Variable b2p : w. + Variable b2p_le : wB/2 <= [|b2p|]. + + Definition double_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h := + let (hh,hl) := double_split w_0 n h in + let (qh,rh) := divn1 r hh in + let (ql,rl) := divn1 rh hl in + (double_WW w_WW n qh ql, rl). + + Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w := + match n return w -> word w n -> word w n * w with + | O => fun r x => w_div21 r x b2p + | S n => double_divn1_0_aux n (double_divn1_0 n) + end. + + Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), + let (h, l) := double_split w_0 n x in + [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!]. + Proof (spec_double_split w_0 w_digits w_to_Z spec_0). + + Lemma spec_double_divn1_0 : forall n r a, + [|r|] < [|b2p|] -> + let (q,r') := double_divn1_0 n r a in + [|r|] * double_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\ + 0 <= [|r'|] < [|b2p|]. + Proof. + induction n;intros. + exact (spec_div21 a b2p_le H). + simpl (double_divn1_0 (S n) r a); unfold double_divn1_0_aux. + assert (H1 := spec_split n a);destruct (double_split w_0 n a) as (hh,hl). + rewrite H1. + assert (H2 := IHn r hh H);destruct (double_divn1_0 n r hh) as (qh,rh). + destruct H2. + assert ([|rh|] < [|b2p|]). omega. + assert (H4 := IHn rh hl H3);destruct (double_divn1_0 n rh hl) as (ql,rl). + destruct H4;split;trivial. + rewrite spec_double_WW;trivial. + rewrite <- double_wB_wwB. + rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite H0;rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc. + rewrite H4;ring. + Qed. + + Definition double_modn1_0_aux n (modn1:w -> word w n -> w) r h := + let (hh,hl) := double_split w_0 n h in modn1 (modn1 r hh) hl. + + Fixpoint double_modn1_0 (n:nat) : w -> word w n -> w := + match n return w -> word w n -> w with + | O => fun r x => snd (w_div21 r x b2p) + | S n => double_modn1_0_aux n (double_modn1_0 n) + end. + + Lemma spec_double_modn1_0 : forall n r x, + double_modn1_0 n r x = snd (double_divn1_0 n r x). + Proof. + induction n;simpl;intros;trivial. + unfold double_modn1_0_aux, double_divn1_0_aux. + destruct (double_split w_0 n x) as (hh,hl). + rewrite (IHn r hh). + destruct (double_divn1_0 n r hh) as (qh,rh);simpl. + rewrite IHn. destruct (double_divn1_0 n rh hl);trivial. + Qed. + + Variable p : w. + Variable p_bounded : [|p|] <= Zpos w_digits. + + Lemma spec_add_mul_divp : forall x y, + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. + Proof. + intros;apply spec_add_mul_div;auto. + Qed. + + Definition double_divn1_p_aux n + (divn1 : w -> word w n -> word w n -> word w n * w) r h l := + let (hh,hl) := double_split w_0 n h in + let (lh,ll) := double_split w_0 n l in + let (qh,rh) := divn1 r hh hl in + let (ql,rl) := divn1 rh hl lh in + (double_WW w_WW n qh ql, rl). + + Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := + match n return w -> word w n -> word w n -> word w n * w with + | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p + | 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). + 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. + Qed. + + Lemma spec_double_divn1_p : forall n r h l, + [|r|] < [|b2p|] -> + 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|]))) + 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. + 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). + unfold double_divn1_p_aux. + assert (H1 := spec_split n h);destruct (double_split w_0 n h) as (hh,hl). + rewrite H1. rewrite <- double_wB_wwB. + assert (H2 := spec_split n l);destruct (double_split w_0 n l) as (lh,ll). + rewrite H2. + 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 + (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 + 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 + 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 + 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 + 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. + split;[rewrite spec_double_WW;trivial;ring|trivial]. + assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh); + unfold double_wB,base in Uhh. + assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl); + unfold double_wB,base in Uhl. + assert (Ulh := spec_double_to_Z w_digits w_to_Z spec_to_Z n lh); + unfold double_wB,base in Ulh. + assert (Ull := spec_double_to_Z w_digits w_to_Z spec_to_Z n ll); + unfold double_wB,base in Ull. + 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)). + 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!])); + 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))) + 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). + 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)). + rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] + + [!n|hl!] / 2 ^ (Zpos (double_digits 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. + 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. + 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. + Qed. + + Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= + let (hh,hl) := double_split w_0 n h in + let (lh,ll) := double_split w_0 n l in + modn1 (modn1 r hh hl) hl lh. + + Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w := + match n return w -> word w n -> word w n -> w with + | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) + | S n => double_modn1_p_aux n (double_modn1_p n) + end. + + Lemma spec_double_modn1_p : forall n r h l , + double_modn1_p n r h l = snd (double_divn1_p n r h l). + Proof. + induction n;simpl;intros;trivial. + unfold double_modn1_p_aux, double_divn1_p_aux. + destruct(double_split w_0 n h)as(hh,hl);destruct(double_split w_0 n l) as (lh,ll). + rewrite (IHn r hh hl);destruct (double_divn1_p n r hh hl) as (qh,rh). + rewrite IHn;simpl;destruct (double_divn1_p n rh hl lh);trivial. + Qed. + + End DIVAUX. + + Fixpoint high (n:nat) : word w n -> w := + match n return word w n -> w with + | O => fun a => a + | S n => + fun (a:zn2z (word w n)) => + match a with + | W0 => w_0 + | WW h l => high n h + end + end. + + Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits 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). + 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). + Proof. + induction n;intros. + unfold high,double_digits,double_to_Z. + 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). + assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt). + destruct x;unfold high;fold high. + unfold double_to_Z,zn2z_to_Z;rewrite spec_0. + rewrite Zdiv_0_l;trivial. + assert (U0 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w0); + 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)). + 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. + Qed. + + Definition double_divn1 (n:nat) (a:word w n) (b:w) := + let p := w_head0 b in + match w_compare p w_0 with + | Gt => + let b2p := w_add_mul_div p b w_0 in + let ha := high n a in + let k := w_sub w_zdigits p in + let lsr_n := w_add_mul_div k w_0 in + let r0 := w_add_mul_div p w_0 ha in + let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in + (q, lsr_n r) + | _ => double_divn1_0 b n w_0 a + end. + + Lemma spec_double_divn1 : forall n a b, + 0 < [|b|] -> + let (q,r) := double_divn1 n a b in + [!n|a!] = [!n|q!] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + 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_0; intros H2; auto with zarith. + assert (Hv1: wB/2 <= [|b|]). + generalize H0; rewrite H2; rewrite Zpower_0_r; + rewrite Zmult_1_l; auto. + assert (Hv2: [|w_0|] < [|b|]). + rewrite spec_0; auto. + generalize (spec_double_divn1_0 Hv1 n a Hv2). + rewrite spec_0;rewrite Zmult_0_l; rewrite Zplus_0_l; auto. + contradict H2; auto with zarith. + assert (HHHH : 0 < [|w_head0 b|]); auto with zarith. + assert ([|w_head0 b|] < Zpos w_digits). + case (Zle_or_lt (Zpos w_digits) [|w_head0 b|]); auto; intros HH. + assert (2 ^ [|w_head0 b|] < wB). + apply Zle_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith. + replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail). + apply Zmult_le_compat;auto with zarith. + assert (wB <= 2^[|w_head0 b|]). + unfold base;apply Zpower_le_monotone;auto with zarith. omega. + assert ([|w_add_mul_div (w_head0 b) b w_0|] = + 2 ^ [|w_head0 b|] * [|b|]). + rewrite (spec_add_mul_div b w_0); auto with zarith. + rewrite spec_0;rewrite Zdiv_0_l; try omega. + rewrite Zplus_0_r; rewrite Zmult_comm. + rewrite Zmod_small; auto with zarith. + assert (H5 := spec_to_Z (high n a)). + assert + ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] + <[|w_add_mul_div (w_head0 b) b w_0|]). + rewrite H4. + rewrite spec_add_mul_div;auto with zarith. + rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. + assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with wB;auto with zarith. + pattern wB at 1;replace wB with (wB*1);try ring. + apply Zmult_le_compat;auto with zarith. + assert (H6 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|])); + auto with zarith. + rewrite Zmod_small;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with wB;auto with zarith. + apply Zle_trans with (2 ^ [|w_head0 b|] * [|b|] * 2). + rewrite <- wB_div_2; try omega. + apply Zmult_le_compat;auto with zarith. + pattern 2 at 1;rewrite <- Zpower_1_r. + apply Zpower_le_monotone;split;auto with zarith. + rewrite <- H4 in H0. + assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. + assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6). + destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n + (w_add_mul_div (w_head0 b) w_0 (high n a)) a + (double_0 w_0 n)) as (q,r). + assert (U:= spec_double_digits n). + rewrite spec_double_0 in H7;trivial;rewrite Zdiv_0_l in H7. + rewrite Zplus_0_r in H7. + 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|])). + 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 + + (Zpos w_digits - [|w_head0 b|])) + with (Zpos (double_digits 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. + apply Zdiv_le_upper_bound;auto with zarith. + pattern ([|high n a|]) at 1;rewrite <- Zmult_1_r. + apply Zmult_le_compat;auto with zarith. + rewrite H8 in H7;unfold double_wB,base in H7. + rewrite <- shift_unshift_mod in H7;auto with zarith. + rewrite H4 in H7. + assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] + = [|r|]/2^[|w_head0 b|]). + rewrite spec_add_mul_div. + rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. + replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) + with ([|w_head0 b|]). + rewrite Zmod_small;auto with zarith. + assert (H9 := spec_to_Z r). + split;auto with zarith. + apply Zle_lt_trans with ([|r|]);auto with zarith. + apply Zdiv_le_upper_bound;auto with zarith. + pattern ([|r|]) at 1;rewrite <- Zmult_1_r. + apply Zmult_le_compat;auto with zarith. + assert (H10 := Zpower_gt_0 2 ([|w_head0 b|]));auto with zarith. + rewrite spec_sub. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + case (spec_to_Z w_zdigits); auto with zarith. + rewrite spec_sub. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + case (spec_to_Z w_zdigits); auto with zarith. + case H7; intros H71 H72. + split. + rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. + rewrite H71;rewrite H9. + replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) + with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); + try (ring;fail). + rewrite Z_div_plus_l;auto with zarith. + assert (H10 := spec_to_Z + (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; + auto with zarith. + rewrite H9. + apply Zdiv_lt_upper_bound;auto with zarith. + rewrite Zmult_comm;auto with zarith. + exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a). + Qed. + + + Definition double_modn1 (n:nat) (a:word w n) (b:w) := + let p := w_head0 b in + match w_compare p w_0 with + | Gt => + let b2p := w_add_mul_div p b w_0 in + let ha := high n a in + let k := w_sub w_zdigits p in + let lsr_n := w_add_mul_div k w_0 in + let r0 := w_add_mul_div p w_0 ha in + let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in + lsr_n r + | _ => double_modn1_0 b n w_0 a + end. + + Lemma spec_double_modn1_aux : forall n a b, + 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_0; intros H2; auto with zarith. + apply spec_double_modn1_0. + apply spec_double_modn1_0. + rewrite spec_double_modn1_p. + destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n + (w_add_mul_div (w_head0 b) w_0 (high n a)) a (double_0 w_0 n));simpl;trivial. + Qed. + + Lemma spec_double_modn1 : forall n a b, 0 < [|b|] -> + [|double_modn1 n a b|] = [!n|a!] mod [|b|]. + Proof. + intros n a b H;assert (H1 := spec_double_divn1 n a H). + assert (H2 := spec_double_modn1_aux n a b). + rewrite H2;destruct (double_divn1 n a b) as (q,r). + simpl;apply Zmod_unique with (double_to_Z w_digits w_to_Z n q);auto with zarith. + destruct H1 as (h1,h2);rewrite h1;ring. + Qed. + +End GENDIVN1. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v new file mode 100644 index 00000000..50c72487 --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -0,0 +1,487 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleLift.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section DoubleLift. + Variable w : Type. + Variable w_0 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + Variable w_head0 : w -> w. + Variable w_tail0 : w -> w. + Variable w_add: w -> w -> zn2z w. + Variable w_add_mul_div : w -> w -> w -> w. + Variable ww_sub: zn2z w -> zn2z w -> zn2z w. + Variable w_digits : positive. + Variable ww_Digits : positive. + Variable w_zdigits : w. + Variable ww_zdigits : zn2z w. + Variable low: zn2z w -> w. + + Definition ww_head0 x := + match x with + | W0 => ww_zdigits + | WW xh xl => + match w_compare w_0 xh with + | Eq => w_add w_zdigits (w_head0 xl) + | _ => w_0W (w_head0 xh) + end + end. + + + Definition ww_tail0 x := + match x with + | W0 => ww_zdigits + | WW xh xl => + match w_compare w_0 xl with + | Eq => w_add w_zdigits (w_tail0 xh) + | _ => w_0W (w_tail0 xl) + end + end. + + + (* 0 < p < ww_digits *) + Definition ww_add_mul_div p x y := + let zdigits := w_0W w_zdigits in + match x, y with + | W0, W0 => W0 + | W0, WW yh yl => + match ww_compare p zdigits with + | Eq => w_0W yh + | Lt => w_0W (w_add_mul_div (low p) w_0 yh) + | Gt => + let n := low (ww_sub p zdigits) in + w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl) + end + | WW xh xl, W0 => + match ww_compare p zdigits with + | Eq => w_W0 xl + | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) + | Gt => + let n := low (ww_sub p zdigits) in + w_W0 (w_add_mul_div n xl w_0) + end + | WW xh xl, WW yh yl => + match ww_compare p zdigits with + | Eq => w_WW xl yh + | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) + | Gt => + let n := low (ww_sub p zdigits) in + w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) + end + end. + + Section DoubleProof. + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + 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. + Variable spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + 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|] -> + wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. + Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. + Variable spec_w_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). + Variable spec_w_add_mul_div : forall x y p, + [|p|] <= Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. + Variable spec_w_add: forall x y, + [[w_add x y]] = [|x|] + [|y|]. + Variable spec_ww_sub: forall x y, + [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + + Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. + Variable spec_low: forall x, [| low x|] = [[x]] mod wB. + + Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. + + Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. + Ltac zarith := auto with zarith lift. + + Lemma spec_ww_head00 : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits. + Proof. + intros x; case x; unfold ww_head0. + intros HH; rewrite spec_ww_zdigits; auto. + intros xh xl; simpl; intros Hx. + case (spec_to_Z xh); intros Hx1 Hx2. + case (spec_to_Z xl); intros Hy1 Hy2. + assert (F1: [|xh|] = 0). + case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3. + absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. + apply Zlt_le_trans with (1 := Hy3); auto with zarith. + pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]). + apply Zplus_le_compat_r; auto with zarith. + case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3. + 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. + intros H; simpl. + rewrite spec_w_add; rewrite spec_w_head00. + rewrite spec_zdigits; rewrite spec_ww_digits. + rewrite Zpos_xO; auto with zarith. + rewrite F1 in Hx; auto with zarith. + rewrite spec_w_0; auto with zarith. + rewrite spec_w_0; auto with zarith. + Qed. + + Lemma spec_ww_head0 : forall x, 0 < [[x]] -> + wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. + Proof. + clear spec_ww_zdigits. + 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. + case (spec_to_Z w_zdigits); + case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. + rewrite spec_w_add. + rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. + case (spec_w_head0 H); intros H1 H2. + rewrite Zpower_2; fold wB; rewrite <- Zmult_assoc; split. + apply Zmult_le_compat_l; auto with zarith. + apply Zmult_lt_compat_l; auto with zarith. + assert (H1 := spec_w_head0 H0). + rewrite spec_w_0W. + split. + rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. + apply Zle_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB). + rewrite Zmult_comm; zarith. + assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith. + assert (H2:=spec_to_Z xl);apply Zmult_le_0_compat;zarith. + case (spec_to_Z (w_head0 xh)); intros H2 _. + generalize ([|w_head0 xh|]) H1 H2;clear H1 H2; + intros p H1 H2. + assert (Eq1 : 2^p < wB). + rewrite <- (Zmult_1_r (2^p));apply Zle_lt_trans with (2^p*[|xh|]);zarith. + assert (Eq2: p < Zpos w_digits). + destruct (Zle_or_lt (Zpos w_digits) p);trivial;contradict Eq1. + apply Zle_not_lt;unfold base;apply Zpower_le_monotone;zarith. + assert (Zpos w_digits = p + (Zpos w_digits - p)). ring. + rewrite Zpower_2. + unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith. + rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith. + rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. + apply Zmult_lt_reg_r with (2 ^ p); zarith. + rewrite <- Zpower_exp;zarith. + rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. + assert (H1 := spec_to_Z xh);zarith. + Qed. + + Lemma spec_ww_tail00 : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits. + Proof. + intros x; case x; unfold ww_tail0. + intros HH; rewrite spec_ww_zdigits; auto. + intros xh xl; simpl; intros Hx. + case (spec_to_Z xh); intros Hx1 Hx2. + case (spec_to_Z xl); intros Hy1 Hy2. + assert (F1: [|xh|] = 0). + case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3. + absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. + apply Zlt_le_trans with (1 := Hy3); auto with zarith. + pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]). + apply Zplus_le_compat_r; auto with zarith. + case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3. + 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. + assert (F2: [|xl|] = 0). + rewrite F1 in Hx; auto with zarith. + generalize (spec_compare w_0 xl); case w_compare. + intros H; simpl. + rewrite spec_w_add; rewrite spec_w_tail00; auto. + rewrite spec_zdigits; rewrite spec_ww_digits. + rewrite Zpos_xO; auto with zarith. + rewrite spec_w_0; auto with zarith. + rewrite spec_w_0; auto with zarith. + Qed. + + Lemma spec_ww_tail0 : forall x, 0 < [[x]] -> + exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]]. + Proof. + 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 <- 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. + case (@spec_w_tail0 xh). + apply Zmult_lt_reg_r with wB; auto with zarith. + unfold base; auto with zarith. + intros z (Hz1, Hz2); exists z; split; auto. + rewrite spec_w_add; rewrite (fun x => Zplus_comm [|x|]). + rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. + rewrite Zmult_assoc; rewrite <- Hz2; auto. + + case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. + case (spec_w_tail0 H0); intros z (Hz1, Hz2). + assert (Hp: [|w_tail0 xl|] < Zpos w_digits). + case (Zle_or_lt (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1. + absurd (2 ^ (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]). + apply Zlt_not_le. + case (spec_to_Z xl); intros HH3 HH4. + apply Zle_lt_trans with (2 := HH4). + apply Zle_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith. + rewrite Hz2. + apply Zmult_le_compat_r; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split. + apply Zplus_le_0_compat; auto. + apply Zmult_le_0_compat; auto with zarith. + case (spec_to_Z xh); auto. + rewrite spec_w_0W. + rewrite (Zmult_plus_distr_r 2); rewrite <- Zplus_assoc. + rewrite Zmult_plus_distr_l; rewrite <- Hz2. + apply f_equal2 with (f := Zplus); auto. + rewrite (Zmult_comm 2). + repeat rewrite <- Zmult_assoc. + apply f_equal2 with (f := Zmult); auto. + case (spec_to_Z (w_tail0 xl)); intros HH3 HH4. + pattern 2 at 2; rewrite <- Zpower_1_r. + lazy beta; repeat rewrite <- Zpower_exp; auto with zarith. + unfold base; apply f_equal with (f := Zpower 2); auto with zarith. + + contradict H0; case (spec_to_Z xl); auto with zarith. + Qed. + + Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r + spec_w_W0 spec_w_0W spec_w_WW spec_w_0 + (wB_div w_digits w_to_Z spec_to_Z) + (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. + Ltac w_rewrite := autorewrite with w_rewrite;trivial. + + Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p, + let zdigits := w_0W w_zdigits in + [[p]] <= Zpos (xO w_digits) -> + [[match ww_compare p zdigits with + | Eq => w_WW xl yh + | Lt => w_WW (w_add_mul_div (low p) xh xl) + (w_add_mul_div (low p) xl yh) + | Gt => + let n := low (ww_sub p zdigits) in + w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) + end]] = + ([[WW xh xl]] * (2^[[p]]) + + [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. + Proof. + clear spec_ww_zdigits. + intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits). + case (spec_to_w_Z p); intros Hv1 Hv2. + replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). + 2 : rewrite Zpos_xO;ring. + replace (Zpos w_digits + Zpos w_digits - [[p]]) with + (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. + intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); + 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 H1; unfold zdigits; rewrite spec_w_0W. + rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r. + simpl ww_to_Z; w_rewrite;zarith. + fold wB. + rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc. + rewrite <- Zpower_2. + rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. + simpl ww_to_Z; w_rewrite;zarith. + assert (HH0: [|low p|] = [[p]]). + rewrite spec_low. + apply Zmod_small. + case (spec_to_w_Z p); intros HH1 HH2; split; auto. + generalize H1; unfold zdigits; rewrite spec_w_0W; + rewrite spec_zdigits; intros tmp. + apply Zlt_le_trans with (1 := tmp). + unfold base. + apply Zpower2_le_lin; auto with zarith. + 2: generalize H1; unfold zdigits; rewrite spec_w_0W; + rewrite spec_zdigits; auto with zarith. + generalize H1; unfold zdigits; rewrite spec_w_0W; + rewrite spec_zdigits; auto; clear H1; intros H1. + assert (HH: [|low p|] <= Zpos w_digits). + rewrite HH0; auto with zarith. + repeat rewrite spec_w_add_mul_div with (1 := HH). + rewrite HH0. + rewrite Zmult_plus_distr_l. + pattern ([|xl|] * 2 ^ [[p]]) at 2; + rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. + replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + unfold base at 5;rewrite <- Zmod_shift_r;zarith. + unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); + fold wB;fold wwB;zarith. + rewrite wwB_wBwB;rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. + unfold ww_digits;rewrite Zpos_xO;zarith. apply Z_mod_lt;zarith. + split;zarith. apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + 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. + clear H1. + assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits). + rewrite spec_low. + rewrite spec_ww_sub. + unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits. + rewrite <- Zmod_div_mod; auto with zarith. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. + exists wB; unfold base. + unfold ww_digits; rewrite (Zpos_xO w_digits). + rewrite <- Zpower_exp; auto with zarith. + apply f_equal with (f := fun x => 2 ^ x); auto with zarith. + assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits). + rewrite HH0; auto with zarith. + replace (Zpos w_digits + (Zpos w_digits - [[p]])) with + (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith. + lazy zeta; simpl ww_to_Z; w_rewrite;zarith. + repeat rewrite spec_w_add_mul_div;zarith. + rewrite HH0. + pattern wB at 5;replace wB with + (2^(([[p]] - Zpos w_digits) + + (Zpos w_digits - ([[p]] - Zpos w_digits)))). + rewrite Zpower_exp;zarith. rewrite Zmult_assoc. + rewrite Z_div_plus_l;zarith. + rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits) + (n := Zpos w_digits);zarith. fold wB. + set (u := [[p]] - Zpos w_digits). + replace [[p]] with (u + Zpos w_digits);zarith. + rewrite Zpower_exp;zarith. rewrite Zmult_assoc. fold wB. + repeat rewrite Zplus_assoc. rewrite <- Zmult_plus_distr_l. + repeat rewrite <- Zplus_assoc. + unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); + fold wB;fold wwB;zarith. + unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) + (b:= Zpos w_digits);fold wB;fold wwB;zarith. + rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. + rewrite Zmult_plus_distr_l. + replace ([|xh|] * wB * 2 ^ u) with + ([|xh|]*2^u*wB). 2:ring. + repeat rewrite <- Zplus_assoc. + rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)). + rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. + unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. + unfold u; split;zarith. + split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + fold u. + ring_simplify (u + (Zpos w_digits - u)); fold + wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith. + unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. + unfold u; split;zarith. + unfold u; split;zarith. + apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + fold u. + ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. + unfold u;zarith. + unfold u;zarith. + set (u := [[p]] - Zpos w_digits). + ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. + Qed. + + Lemma spec_ww_add_mul_div : forall x y p, + [[p]] <= Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^[[p]]) + + [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. + Proof. + clear spec_ww_zdigits. + intros x y p H. + destruct x as [ |xh xl]; + [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0) + |assert (H1 := @spec_ww_add_mul_div_aux xh xl)]; + (destruct y as [ |yh yl]; + [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)]; + 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_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]]). + rewrite spec_low. + apply Zmod_small. + case (spec_to_w_Z p); intros HH1 HH2; split; auto. + apply Zlt_le_trans with (1 := H1). + unfold base; apply Zpower2_le_lin; auto with zarith. + rewrite HH0; auto with zarith. + replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. + intros Heq;rewrite <- Heq;clear Heq. + generalize (spec_ww_compare p (w_0W w_zdigits)); + case ww_compare; intros H1; w_rewrite. + 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. + rewrite spec_low. + rewrite spec_ww_sub; w_rewrite; intros H1. + rewrite <- Zmod_div_mod; auto with zarith. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. + unfold base; auto with zarith. + unfold base; auto with zarith. + exists wB; unfold base. + unfold ww_digits; rewrite (Zpos_xO w_digits). + rewrite <- Zpower_exp; auto with zarith. + apply f_equal with (f := fun x => 2 ^ x); auto with zarith. + case (spec_to_Z xh); auto with zarith. + Qed. + + End DoubleProof. + +End DoubleLift. + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v new file mode 100644 index 00000000..c7d83acc --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -0,0 +1,628 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleMul.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section DoubleMul. + Variable w : Type. + Variable w_0 : w. + Variable w_1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_succ : w -> w. + Variable w_add_c : w -> w -> carry w. + Variable w_add : w -> w -> w. + Variable w_sub: w -> w -> w. + Variable w_mul_c : w -> w -> zn2z w. + Variable w_mul : w -> w -> w. + Variable w_square_c : w -> zn2z w. + Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add : zn2z w -> zn2z w -> zn2z w. + Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_sub : zn2z w -> zn2z w -> zn2z w. + + (* ** Multiplication ** *) + + (* (xh*B+xl) (yh*B + yl) + xh*yh = hh = |hhh|hhl|B2 + xh*yl +xl*yh = cc = |cch|ccl|B + xl*yl = ll = |llh|lll + *) + + Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := + match x, y with + | W0, _ => W0 + | _, W0 => W0 + | WW xh xl, WW yh yl => + let hh := w_mul_c xh yh in + let ll := w_mul_c xl yl in + let (wc,cc) := cross xh xl yh yl hh ll in + match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end + end. + + Definition ww_mul_c := + double_mul_c + (fun xh xl yh yl hh ll=> + match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end). + + Definition w_2 := w_add w_1 w_1. + + Definition kara_prod xh xl yh yl hh ll := + match ww_add_c hh ll with + C0 m => + match w_compare xl xh with + Eq => (w_0, m) + | Lt => + match w_compare yl yh with + Eq => (w_0, m) + | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) + | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with + C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) + end + end + | Gt => + match w_compare yl yh with + Eq => (w_0, m) + | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with + C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) + end + | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh) (w_sub yl yh))) + end + end + | C1 m => + match w_compare xl xh with + Eq => (w_1, m) + | Lt => + match w_compare yl yh with + Eq => (w_1, m) + | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with + C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) + end + | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with + C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) + end + end + | Gt => + match w_compare yl yh with + Eq => (w_1, m) + | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with + C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) + end + | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with + C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1) + end + end + end + end. + + Definition ww_karatsuba_c := double_mul_c kara_prod. + + Definition ww_mul x y := + match x, y with + | W0, _ => W0 + | _, W0 => W0 + | WW xh xl, WW yh yl => + let ccl := w_add (w_mul xh yl) (w_mul xl yh) in + ww_add (w_W0 ccl) (w_mul_c xl yl) + end. + + Definition ww_square_c x := + match x with + | W0 => W0 + | WW xh xl => + let hh := w_square_c xh in + let ll := w_square_c xl in + let xhxl := w_mul_c xh xl in + let (wc,cc) := + match ww_add_c xhxl xhxl with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end in + match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end + end. + + Section DoubleMulAddn1. + Variable w_mul_add : w -> w -> w -> w * w. + + Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := + match n return word w n -> w -> w -> w * word w n with + | O => w_mul_add + | S n1 => + let mul_add := double_mul_add_n1 n1 in + fun x y r => + match x with + | W0 => (w_0,extend w_0W n1 r) + | WW xh xl => + let (rl,l) := mul_add xl y r in + let (rh,h) := mul_add xh y rl in + (rh, double_WW w_WW n1 h l) + end + end. + + End DoubleMulAddn1. + + Section DoubleMulAddmn1. + Variable wn: Type. + Variable extend_n : w -> wn. + Variable wn_0W : wn -> zn2z wn. + Variable wn_WW : wn -> wn -> zn2z wn. + Variable w_mul_add_n1 : wn -> w -> w -> w*wn. + Fixpoint double_mul_add_mn1 (m:nat) : + word wn m -> w -> w -> w*word wn m := + match m return word wn m -> w -> w -> w*word wn m with + | O => w_mul_add_n1 + | S m1 => + let mul_add := double_mul_add_mn1 m1 in + fun x y r => + match x with + | W0 => (w_0,extend wn_0W m1 (extend_n r)) + | WW xh xl => + let (rl,l) := mul_add xl y r in + let (rh,h) := mul_add xh y rl in + (rh, double_WW wn_WW m1 h l) + end + end. + + End DoubleMulAddmn1. + + Definition w_mul_add x y r := + match w_mul_c x y with + | W0 => (w_0, r) + | WW h l => + match w_add_c l r with + | C0 lr => (h,lr) + | C1 lr => (w_succ h, lr) + end + end. + + + (*Section DoubleProof. *) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). + + Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + + Variable spec_more_than_1_digit: 1 < Zpos w_digits. + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + 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. + 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. + Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + + Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. + Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB. + Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. + + Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. + Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Variable spec_ww_add_carry : + forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. + Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. + Proof. intros x;apply spec_ww_to_Z;auto. Qed. + + Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2. + Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed. + + Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult. + Ltac zarith := auto with zarith mult. + + Lemma wBwB_lex: forall a b c d, + a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> + a <= c. + Proof. + intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. + Qed. + + Lemma wBwB_lex_inv: forall a b c d, + a < c -> + a * wB^2 + [[b]] < c * wB^2 + [[d]]. + Proof. + intros a b c d H; apply beta_lex_inv; zarith. + Qed. + + Lemma sum_mul_carry : forall xh xl yh yl wc cc, + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + 0 <= [|wc|] <= 1. + Proof. + intros. + apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith. + apply wB_pos. + Qed. + + Theorem mult_add_ineq: forall xH yH crossH, + 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. + Proof. + intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. + Qed. + + Hint Resolve mult_add_ineq : mult. + + Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, + [[hh]] = [|xh|] * [|yh|] -> + [[ll]] = [|xl|] * [|yl|] -> + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + [||match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). + Proof. + intros;assert (U1 := wB_pos w_digits). + replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with + ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). + 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. + assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). + destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. + rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; + rewrite wwB_wBwB. ring. + rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith. + simpl ww_to_Z in H1. assert (U:=spec_to_Z cch). + assert ([|wc|]*wB + [|cch|] <= 2*wB - 3). + destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial. + assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2). + ring_simplify ((2*wB - 4)*wB + 2). + assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). + assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). + omega. + generalize H3;clear H3;rewrite <- H1. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc; + rewrite <- Zmult_plus_distr_l. + assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). + apply Zmult_le_compat;zarith. + rewrite Zmult_plus_distr_l in H3. + intros. assert (U2 := spec_to_Z ccl);omega. + generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) + as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l; + simpl zn2z_to_Z; + try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW; + rewrite Zmod_small;rewrite wwB_wBwB;intros. + rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith. + rewrite Zplus_assoc;rewrite Zmult_plus_distr_l. + rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring. + repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith. + Qed. + + Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w, + (forall xh xl yh yl hh ll, + [[hh]] = [|xh|]*[|yh|] -> + [[ll]] = [|xl|]*[|yl|] -> + let (wc,cc) := cross xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> + forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]]. + Proof. + intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. + destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial. + assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl). + generalize (Hcross _ _ _ _ _ _ H1 H2). + destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc). + intros;apply spec_mul_aux;trivial. + rewrite <- wwB_wBwB;trivial. + Qed. + + Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. + Proof. + intros x y;unfold ww_mul_c;apply spec_double_mul_c. + intros xh xl yh yl hh ll H1 H2. + generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)); + destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c]; + unfold interp_carry;repeat rewrite spec_w_mul_c;intros H; + (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring. + Qed. + + Lemma spec_w_2: [|w_2|] = 2. + unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl. + apply Zmod_small; split; auto with zarith. + rewrite <- (Zpower_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith. + Qed. + + Lemma kara_prod_aux : forall xh xl yh yl, + xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh. + Proof. intros;ring. Qed. + + Lemma spec_kara_prod : forall xh xl yh yl hh ll, + [[hh]] = [|xh|]*[|yh|] -> + [[ll]] = [|xl|]*[|yl|] -> + let (wc,cc) := kara_prod xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. + Proof. + intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; + rewrite <- H; rewrite <- H0; unfold kara_prod. + assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); + 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; + 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 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). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + split; auto with zarith. + simpl in Hz; rewrite Hz; rewrite H; rewrite H0. + rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. + apply Zle_lt_trans with ([[z]]-0); auto with zarith. + unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. + apply Zmult_le_0_compat; auto with zarith. + 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + 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 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + 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). + rewrite spec_w_0; try (ring; fail). + repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + split. + match goal with |- context[(?x - ?y) * (?z - ?t)] => + replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] + end. + simpl in Hz; rewrite Hz; rewrite H; rewrite H0. + rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. + apply Zle_lt_trans with ([[z]]-0); auto with zarith. + unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. + 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; + try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). + generalize (spec_w_compare yl yh); case (w_compare yl yh); 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. + generalize Hz2; clear Hz2; unfold interp_carry. + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + rewrite spec_w_2; unfold interp_carry in Hz2. + apply trans_equal with (wwB + (1 * wwB + [[z1]])). + 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; + 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + rewrite spec_w_2; unfold interp_carry in Hz2. + apply trans_equal with (wwB + (1 * wwB + [[z1]])). + ring. + rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; 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; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. + match goal with |- context[(?x - ?y) * (?z - ?t)] => + replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] + end. + generalize Hz2; clear Hz2; unfold interp_carry. + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_small; auto with zarith; try (ring; fail). + Qed. + + Lemma sub_carry : forall xh xl yh yl z, + 0 <= z -> + [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> + z < wwB. + Proof. + intros xh xl yh yl z Hle Heq. + destruct (Z_le_gt_dec wwB z);auto with zarith. + generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). + generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). + rewrite <- wwB_wBwB;intros H1 H2. + assert (H3 := wB_pos w_digits). + assert (2*wB <= wwB). + rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith. + omega. + Qed. + + Ltac Spec_ww_to_Z x := + let H:= fresh "H" in + assert (H:= spec_ww_to_Z x). + + Ltac Zmult_lt_b x y := + let H := fresh "H" in + assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). + + Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]]. + Proof. + intros x y; unfold ww_karatsuba_c;apply spec_double_mul_c. + intros; apply spec_kara_prod; auto. + Qed. + + Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB. + Proof. + assert (U:= lt_0_wB w_digits). + assert (U1:= lt_0_wwB w_digits). + intros x y; case x; auto; intros xh xl. + case y; auto. + simpl; rewrite Zmult_0_r; rewrite Zmod_small; auto with zarith. + intros yh yl;simpl. + repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c + || rewrite spec_w_add || rewrite spec_w_mul). + rewrite <- Zplus_mod; auto with zarith. + repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r). + rewrite <- Zmult_mod_distr_r; auto with zarith. + rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith. + rewrite Zplus_mod; auto with zarith. + rewrite Zmod_mod; auto with zarith. + rewrite <- Zplus_mod; auto with zarith. + match goal with |- ?X mod _ = _ => + rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|]) + end; auto with zarith. + f_equal; auto; rewrite wwB_wBwB; ring. + Qed. + + Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]]. + Proof. + destruct x as [ |xh xl];simpl;trivial. + case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end;intros wc cc Heq. + apply (spec_mul_aux xh xl xh xl wc cc);trivial. + generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq. + rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl)); + unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq; + rewrite (Zmult_comm [|xl|]);subst. + rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial. + rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial. + Qed. + + Section DoubleMulAddn1Proof. + + Variable w_mul_add : w -> w -> w -> w * w. + Variable spec_w_mul_add : forall x y r, + let (h,l):= w_mul_add x y r in + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + + Lemma spec_double_mul_add_n1 : forall n x y r, + let (h,l) := double_mul_add_n1 w_mul_add n x y r in + [|h|]*double_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|]. + Proof. + induction n;intros x y r;trivial. + exact (spec_w_mul_add x y r). + unfold double_mul_add_n1;destruct x as[ |xh xl]; + fold(double_mul_add_n1 w_mul_add). + rewrite spec_w_0;rewrite spec_extend;simpl;trivial. + assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l). + assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h). + rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial. + rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H. + rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite U;ring. + Qed. + + End DoubleMulAddn1Proof. + + Lemma spec_w_mul_add : forall x y r, + let (h,l):= w_mul_add x y r in + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + Proof. + intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); + destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. + rewrite spec_w_0;trivial. + assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold + interp_carry in U;try rewrite Zmult_1_l in H;simpl. + rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small. + rewrite <- Zplus_assoc;rewrite <- U;ring. + simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). + rewrite <- H in H1. + assert (H2:=spec_to_Z h);split;zarith. + case H1;clear H1;intro H1;clear H1. + replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring. + intros H0;assert (U1:= wB_pos w_digits). + assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith. + Qed. + +(* End DoubleProof. *) + +End DoubleMul. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v new file mode 100644 index 00000000..043ff351 --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -0,0 +1,1389 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleSqrt.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section DoubleSqrt. + Variable w : Type. + Variable w_is_even : w -> bool. + Variable w_compare : w -> w -> comparison. + Variable w_0 : w. + Variable w_1 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_sub : w -> w -> w. + Variable w_sub_c : w -> w -> carry w. + Variable w_square_c : w -> zn2z w. + Variable w_div21 : w -> w -> w -> w * w. + Variable w_add_mul_div : w -> w -> w -> w. + Variable w_digits : positive. + Variable w_zdigits : w. + Variable ww_zdigits : zn2z w. + Variable w_add_c : w -> w -> carry w. + Variable w_sqrt2 : w -> w -> w * carry w. + Variable w_pred : w -> w. + Variable ww_pred_c : zn2z w -> carry (zn2z w). + Variable ww_pred : zn2z w -> zn2z w. + Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add : zn2z w -> zn2z w -> zn2z w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. + Variable ww_head0 : zn2z w -> zn2z w. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + Variable low : zn2z w -> w. + + Let wwBm1 := ww_Bm1 w_Bm1. + + Definition ww_is_even x := + match x with + | W0 => true + | WW xh xl => w_is_even xl + end. + + Let w_div21c x y z := + match w_compare x z with + | Eq => + match w_compare y z with + Eq => (C1 w_1, w_0) + | Gt => (C1 w_1, w_sub y z) + | Lt => (C1 w_0, y) + end + | Gt => + let x1 := w_sub x z in + let (q, r) := w_div21 x1 y z in + (C1 q, r) + | Lt => + let (q, r) := w_div21 x y z in + (C0 q, r) + end. + + Let w_div2s x y s := + match x with + C1 x1 => + let x2 := w_sub x1 s in + let (q, r) := w_div21c x2 y s in + match q with + C0 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) + else + (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) + | C1 q1 => + if w_is_even q1 then + (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) + else + (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) + end + | C0 x1 => + let (q, r) := w_div21c x1 y s in + match q with + C0 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) + else + (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) + | C1 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) + else + (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) + end + end. + + Definition split x := + match x with + | W0 => (w_0,w_0) + | WW h l => (h,l) + end. + + Definition ww_sqrt2 x y := + let (x1, x2) := split x in + let (y1, y2) := split y in + let ( q, r) := w_sqrt2 x1 x2 in + let (q1, r1) := w_div2s r y1 q in + match q1 with + C0 q1 => + let q2 := w_square_c q1 in + let a := WW q q1 in + match r1 with + C1 r2 => + match ww_sub_c (WW r2 y2) q2 with + C0 r3 => (a, C1 r3) + | C1 r3 => (a, C0 r3) + end + | C0 r2 => + match ww_sub_c (WW r2 y2) q2 with + C0 r3 => (a, C0 r3) + | C1 r3 => + let a2 := ww_add_mul_div (w_0W w_1) a W0 in + match ww_pred_c a2 with + C0 a3 => + (ww_pred a, ww_add_c a3 r3) + | C1 a3 => + (ww_pred a, C0 (ww_add a3 r3)) + end + end + end + | C1 q1 => + let a1 := WW q w_Bm1 in + let a2 := ww_add_mul_div (w_0W w_1) a1 wwBm1 in + (a1, ww_add_c a2 y) + end. + + Definition ww_is_zero x := + match ww_compare W0 x with + Eq => true + | _ => false + end. + + Definition ww_head1 x := + let p := ww_head0 x in + if (ww_is_even p) then p else ww_pred p. + + Definition ww_sqrt x := + if (ww_is_zero x) then W0 + else + let p := ww_head1 x in + match ww_compare p W0 with + | Gt => + match ww_add_mul_div p x W0 with + W0 => W0 + | WW x1 x2 => + let (r, _) := w_sqrt2 x1 x2 in + WW w_0 (w_add_mul_div + (w_sub w_zdigits + (low (ww_add_mul_div (ww_pred ww_zdigits) + W0 p))) w_0 r) + end + | _ => + match x with + W0 => W0 + | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) + end + end. + + + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). + + Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_w_zdigits : [|w_zdigits|] = Zpos w_digits. + Variable spec_more_than_1_digit: 1 < Zpos w_digits. + + Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos (xO w_digits). + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + 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_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, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Variable spec_w_add_mul_div : forall x y p, + [|p|] <= Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (Zpower 2 ((Zpos w_digits) - [|p|]))) mod wB. + Variable spec_ww_add_mul_div : forall x y p, + [[p]] <= Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^ [[p]]) + + [[y]] / (2^ (Zpos (xO w_digits) - [[p]]))) mod wwB. + Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. + Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Variable spec_w_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := w_sqrt2 x y in + [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + Variable spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. + 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. + 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. + + Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. + Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. + + + Hint Rewrite spec_w_0 spec_w_1 w_Bm1 spec_w_WW spec_w_sub + spec_w_div21 spec_w_add_mul_div spec_ww_Bm1 + spec_w_add_c spec_w_sqrt2: w_rewrite. + + Lemma spec_ww_is_even : forall x, + if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. +clear spec_more_than_1_digit. +intros x; case x; simpl ww_is_even. + simpl. + rewrite Zmod_small; auto with zarith. + intros w1 w2; simpl. + unfold base. + rewrite Zplus_mod; auto with zarith. + rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith. + rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. + apply spec_w_is_even; auto with zarith. + apply Zdivide_mult_r; apply Zpower_divide; auto with zarith. + red; simpl; auto. + Qed. + + + Theorem spec_w_div21c : forall a1 a2 b, + wB/2 <= [|b|] -> + let (q,r) := w_div21c a1 a2 b in + [|a1|] * wB + [|a2|] = [+|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. + intros a1 a2 b Hb; unfold w_div21c. + assert (H: 0 < [|b|]); auto with zarith. + assert (U := wB_pos w_digits). + 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. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H1; rewrite H2; ring. + autorewrite with w_rewrite; auto with zarith. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H2; ring. + destruct (spec_to_Z a2);auto with zarith. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H2; rewrite Zmod_small; auto with zarith. + ring. + destruct (spec_to_Z a2);auto with zarith. + rewrite spec_w_sub; auto with zarith. + destruct (spec_to_Z a2) as [H3 H4];auto with zarith. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + assert ([|a2|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + intros H1. + match goal with |- context[w_div21 ?y ?z ?t] => + generalize (@spec_w_div21 y z t Hb H1); + case (w_div21 y z t); simpl; autorewrite with w_rewrite; + auto + end. + intros H1. + assert (H2: [|w_sub a1 b|] < [|b|]). + rewrite spec_w_sub; auto with zarith. + rewrite Zmod_small; auto with zarith. + assert ([|a1|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + destruct (spec_to_Z a1);auto with zarith. + destruct (spec_to_Z a1);auto with zarith. + match goal with |- context[w_div21 ?y ?z ?t] => + generalize (@spec_w_div21 y z t Hb H2); + case (w_div21 y z t); autorewrite with w_rewrite; + auto + end. + intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]). + rewrite Zmod_small; auto with zarith. + intros (H3, H4); split; auto. + rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc; rewrite <- H3; ring. + split; auto with zarith. + assert ([|a1|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + destruct (spec_to_Z a1);auto with zarith. + destruct (spec_to_Z a1);auto with zarith. + simpl; case wB; auto. + Qed. + + Theorem C0_id: forall p, [+|C0 p|] = [|p|]. + intros p; simpl; auto. + Qed. + + Theorem add_mult_div_2: forall w, + [|w_add_mul_div (w_pred w_zdigits) w_0 w|] = [|w|] / 2. + intros w1. + assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). + rewrite spec_pred; rewrite spec_w_zdigits. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zlt_le_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. + rewrite spec_w_add_mul_div; auto with zarith. + autorewrite with w_rewrite rm10. + match goal with |- context[?X - ?Y] => + replace (X - Y) with 1 + end. + rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. + destruct (spec_to_Z w1) as [H1 H2];auto with zarith. + split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite Hp; ring. + Qed. + + Theorem add_mult_div_2_plus_1: forall w, + [|w_add_mul_div (w_pred w_zdigits) w_1 w|] = + [|w|] / 2 + 2 ^ Zpos (w_digits - 1). + intros w1. + assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). + rewrite spec_pred; rewrite spec_w_zdigits. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zlt_le_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. + autorewrite with w_rewrite rm10; auto with zarith. + match goal with |- context[?X - ?Y] => + replace (X - Y) with 1 + end; rewrite Hp; try ring. + rewrite Zpos_minus; auto with zarith. + rewrite Zmax_right; auto with zarith. + rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. + destruct (spec_to_Z w1) as [H1 H2];auto with zarith. + split; auto with zarith. + unfold base. + match goal with |- _ < _ ^ ?X => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp + end. + rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. + assert (tmp: forall p, 1 + (p -1) - 1 = p - 1); auto with zarith; + rewrite tmp; clear tmp; auto with zarith. + match goal with |- ?X + ?Y < _ => + assert (Y < X); auto with zarith + end. + apply Zdiv_lt_upper_bound; auto with zarith. + pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; + auto with zarith. + assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith; + rewrite tmp; clear tmp; auto with zarith. + Qed. + + Theorem add_mult_mult_2: forall w, + [|w_add_mul_div w_1 w w_0|] = 2 * [|w|] mod wB. + intros w1. + autorewrite with w_rewrite rm10; auto with zarith. + rewrite Zpower_1_r; auto with zarith. + rewrite Zmult_comm; auto. + Qed. + + Theorem ww_add_mult_mult_2: forall w, + [[ww_add_mul_div (w_0W w_1) w W0]] = 2 * [[w]] mod wwB. + intros w1. + rewrite spec_ww_add_mul_div; auto with zarith. + autorewrite with w_rewrite rm10. + rewrite spec_w_0W; rewrite spec_w_1. + rewrite Zpower_1_r; auto with zarith. + rewrite Zmult_comm; auto. + rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. + red; simpl; intros; discriminate. + Qed. + + Theorem ww_add_mult_mult_2_plus_1: forall w, + [[ww_add_mul_div (w_0W w_1) w wwBm1]] = + (2 * [[w]] + 1) mod wwB. + intros w1. + rewrite spec_ww_add_mul_div; auto with zarith. + rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. + rewrite Zpower_1_r; auto with zarith. + f_equal; auto. + rewrite Zmult_comm; f_equal; auto. + autorewrite with w_rewrite rm10. + unfold ww_digits, base. + apply sym_equal; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1); + auto with zarith. + unfold ww_digits; split; auto with zarith. + match goal with |- 0 <= ?X - 1 => + assert (0 < X); auto with zarith + end. + apply Zpower_gt_0; auto with zarith. + match goal with |- 0 <= ?X - 1 => + assert (0 < X); auto with zarith; red; reflexivity + end. + unfold ww_digits; autorewrite with rm10. + assert (tmp: forall p q r, p + (q - r) = p + q - r); auto with zarith; + rewrite tmp; clear tmp. + assert (tmp: forall p, p + p = 2 * p); auto with zarith; + rewrite tmp; clear tmp. + f_equal; auto. + pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; + auto with zarith. + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite tmp; clear tmp; auto. + match goal with |- ?X - 1 >= 0 => + assert (0 < X); auto with zarith; red; reflexivity + end. + rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. + red; simpl; intros; discriminate. + Qed. + + Theorem Zplus_mod_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1. + intros a1 b1 H; rewrite Zplus_mod; auto with zarith. + rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith. + apply Zmod_mod; auto. + Qed. + + Lemma C1_plus_wB: forall x, [+|C1 x|] = wB + [|x|]. + unfold interp_carry; auto with zarith. + Qed. + + Theorem spec_w_div2s : forall a1 a2 b, + wB/2 <= [|b|] -> [+|a1|] <= 2 * [|b|] -> + let (q,r) := w_div2s a1 a2 b in + [+|a1|] * wB + [|a2|] = [+|q|] * (2 * [|b|]) + [+|r|] /\ 0 <= [+|r|] < 2 * [|b|]. + intros a1 a2 b H. + assert (HH: 0 < [|b|]); auto with zarith. + assert (U := wB_pos w_digits). + apply Zlt_le_trans with (2 := H); auto with zarith. + apply Zlt_le_trans with 1; auto with zarith. + apply Zdiv_le_lower_bound; auto with zarith. + unfold w_div2s; case a1; intros w0 H0. + match goal with |- context[w_div21c ?y ?z ?t] => + generalize (@spec_w_div21c y z t H); + case (w_div21c y z t); autorewrite with w_rewrite; + auto + end. + intros c w1; case c. + simpl interp_carry; intros w2 (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + rewrite add_mult_div_2. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + repeat rewrite C0_id. + rewrite add_mult_div_2. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + intros w2; rewrite C1_plus_wB. + intros (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1. + repeat rewrite C0_id. + rewrite add_mult_div_2_plus_1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_1_r; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + rewrite Zmax_right; auto with zarith. + ring. + repeat rewrite C0_id. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite add_mult_div_2_plus_1. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1. + unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_1_r; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + rewrite Zmax_right; auto with zarith. + ring. + repeat rewrite C1_plus_wB in H0. + rewrite C1_plus_wB. + match goal with |- context[w_div21c ?y ?z ?t] => + generalize (@spec_w_div21c y z t H); + case (w_div21c y z t); autorewrite with w_rewrite; + auto + end. + intros c w1; case c. + intros w2 (Hw1, Hw2); rewrite C0_id in Hw1. + rewrite <- Zplus_mod_one in Hw1; auto with zarith. + rewrite Zmod_small in Hw1; auto with zarith. + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + intros H1; split; auto with zarith. + rewrite add_mult_div_2_plus_1. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_1_r; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + rewrite Zmax_right; auto with zarith. + ring. + repeat rewrite C0_id. + rewrite add_mult_div_2_plus_1. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_1_r; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + rewrite Zmax_right; auto with zarith. + ring. + split; auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + intros w2; rewrite C1_plus_wB. + rewrite <- Zplus_mod_one; auto with zarith. + rewrite Zmod_small; auto with zarith. + intros (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros H1; split; auto with zarith. + rewrite add_mult_div_2. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + repeat (rewrite C0_id || rewrite C1_plus_wB). + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite add_mult_div_2. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + split; auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + Qed. + + Theorem wB_div_4: 4 * (wB / 4) = wB. + Proof. + unfold base. + assert (2 ^ Zpos w_digits = + 4 * (2 ^ (Zpos w_digits - 2))). + change 4 with (2 ^ 2). + rewrite <- Zpower_exp; auto with zarith. + f_equal; auto with zarith. + rewrite H. + rewrite (fun x => (Zmult_comm 4 (2 ^x))). + rewrite Z_div_mult; auto with zarith. + Qed. + + Theorem Zsquare_mult: forall p, p ^ 2 = p * p. + intros p; change 2 with (1 + 1); rewrite Zpower_exp; + try rewrite Zpower_1_r; auto with zarith. + Qed. + + Theorem Zsquare_pos: forall p, 0 <= p ^ 2. + intros p; case (Zle_or_lt 0 p); intros H1. + rewrite Zsquare_mult; apply Zmult_le_0_compat; auto with zarith. + rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. + apply Zmult_le_0_compat; auto with zarith. + Qed. + + Lemma spec_split: forall x, + [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. + intros x; case x; simpl; autorewrite with w_rewrite; + auto with zarith. + Qed. + + Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB. + Proof. + intros x y; rewrite wwB_wBwB; rewrite Zpower_2. + generalize (spec_to_Z x); intros U. + generalize (spec_to_Z y); intros U1. + apply Zle_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_r || rewrite Zmult_minus_distr_l); + auto with zarith. + Qed. + Hint Resolve mult_wwB. + + Lemma spec_ww_sqrt2 : forall x y, + wwB/ 4 <= [[x]] -> + let (s,r) := ww_sqrt2 x y in + [||WW x y||] = [[s]] ^ 2 + [+[r]] /\ + [+[r]] <= 2 * [[s]]. + intros x y H; unfold ww_sqrt2. + repeat match goal with |- context[split ?x] => + generalize (spec_split x); case (split x) + end; simpl fst; simpl snd. + intros w0 w1 Hw0 w2 w3 Hw1. + assert (U: wB/4 <= [|w2|]). + case (Zle_or_lt (wB / 4) [|w2|]); auto; intros H1. + contradict H; apply Zlt_not_le. + rewrite wwB_wBwB; rewrite Zpower_2. + pattern wB at 1; rewrite <- wB_div_4; rewrite <- Zmult_assoc; + rewrite Zmult_comm. + rewrite Z_div_mult; auto with zarith. + rewrite <- Hw1. + match goal with |- _ < ?X => + pattern X; rewrite <- Zplus_0_r; apply beta_lex_inv; + auto with zarith + end. + destruct (spec_to_Z w3);auto with zarith. + generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3). + intros w4 c (H1, H2). + assert (U1: wB/2 <= [|w4|]). + case (Zle_or_lt (wB/2) [|w4|]); auto with zarith. + intros U1. + assert (U2 : [|w4|] <= wB/2 -1); auto with zarith. + assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith. + match goal with |- ?X ^ 2 <= ?Y => + rewrite Zsquare_mult; + replace Y with ((wB/2 - 1) * (wB/2 -1)) + end. + apply Zmult_le_compat; auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + pattern wB at 4 5; rewrite <- wB_div_2. + rewrite Zmult_assoc. + replace ((wB / 4) * 2) with (wB / 2). + ring. + pattern wB at 1; rewrite <- wB_div_4. + change 4 with (2 * 2). + rewrite <- Zmult_assoc; rewrite (Zmult_comm 2). + rewrite Z_div_mult; try ring; auto with zarith. + assert (U4 : [+|c|] <= wB -2); auto with zarith. + apply Zle_trans with (1 := H2). + match goal with |- ?X <= ?Y => + replace Y with (2 * (wB/ 2 - 1)); auto with zarith + end. + pattern wB at 2; rewrite <- wB_div_2; auto with zarith. + match type of H1 with ?X = _ => + assert (U5: X < wB / 4 * wB) + end. + rewrite H1; auto with zarith. + contradict U; apply Zlt_not_le. + apply Zmult_lt_reg_r with wB; auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + apply Zle_lt_trans with (2 := U5). + unfold ww_to_Z, zn2z_to_Z. + destruct (spec_to_Z w3);auto with zarith. + generalize (@spec_w_div2s c w0 w4 U1 H2). + case (w_div2s c w0 w4). + intros c0; case c0; intros w5; + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros c1; case c1; intros w6; + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros (H3, H4). + match goal with |- context [ww_sub_c ?y ?z] => + generalize (spec_ww_sub_c y z); case (ww_sub_c y z) + end. + intros z; change [-[C0 z]] with ([[z]]). + change [+[C0 z]] with ([[z]]). + intros H5; rewrite spec_w_square_c in H5; + auto. + split. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite H5. + unfold ww_to_Z, zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + rewrite H5. + unfold ww_to_Z, zn2z_to_Z. + match goal with |- ?X - ?Y * ?Y <= _ => + assert (V := Zsquare_pos Y); + rewrite Zsquare_mult in V; + apply Zle_trans with X; auto with zarith; + clear V + end. + match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) => + apply Zle_trans with ((2 * Z - 1) * wB + wB); auto with zarith + end. + destruct (spec_to_Z w1);auto with zarith. + match goal with |- ?X <= _ => + replace X with (2 * [|w4|] * wB); auto with zarith + end. + rewrite Zmult_plus_distr_r; rewrite Zmult_assoc. + destruct (spec_to_Z w5); auto with zarith. + ring. + intros z; replace [-[C1 z]] with (- wwB + [[z]]). + 2: simpl; case wwB; auto with zarith. + intros H5; rewrite spec_w_square_c in H5; + auto. + match goal with |- context [ww_pred_c ?y] => + generalize (spec_ww_pred_c y); case (ww_pred_c y) + end. + intros z1; change [-[C0 z1]] with ([[z1]]). + rewrite ww_add_mult_mult_2. + rewrite spec_ww_add_c. + rewrite spec_ww_pred. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); + auto with zarith. + intros Hz1; rewrite Zmod_small; auto with zarith. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + split. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + rewrite Hz1. + unfold ww_to_Z; simpl zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + rewrite Hz1. + destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). + assert (0 < [[WW w4 w5]]); auto with zarith. + apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. + autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. + apply Zmult_lt_reg_r with 2; auto with zarith. + autorewrite with rm10. + rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. + case (spec_to_Z w5);auto with zarith. + case (spec_to_Z w5);auto with zarith. + simpl. + assert (V2 := spec_to_Z w5);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. + split; auto with zarith. + assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith. + apply Zle_trans with (2 * ([|w4|] * wB)). + rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; auto with zarith. + assert (V2 := spec_to_Z w5);auto with zarith. + simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. + intros z1; change [-[C1 z1]] with (-wwB + [[z1]]). + match goal with |- context[([+[C0 ?z]])] => + change [+[C0 z]] with ([[z]]) + end. + rewrite spec_ww_add; auto with zarith. + rewrite spec_ww_pred; auto with zarith. + rewrite ww_add_mult_mult_2. + rename V1 into VV1. + assert (VV2: 0 < [[WW w4 w5]]); auto with zarith. + apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. + autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. + apply Zmult_lt_reg_r with 2; auto with zarith. + autorewrite with rm10. + rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. + assert (VV3 := spec_to_Z w5);auto with zarith. + assert (VV3 := spec_to_Z w5);auto with zarith. + simpl. + assert (VV3 := spec_to_Z w5);auto with zarith. + assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith. + apply Zle_trans with (2 * ([|w4|] * wB)). + rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; auto with zarith. + case (spec_to_Z w5);auto with zarith. + simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); + auto with zarith. + intros Hz1; rewrite Zmod_small; auto with zarith. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + match type of Hz1 with -?X + ?Y = -?X + ?Z - 1 => + assert (V1: Y = Z - 1); + [replace (Z - 1) with (X + (-X + Z -1)); + [rewrite <- Hz1 | idtac]; ring + | idtac] + end. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + [[z1]] + [[z]]); + auto with zarith. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + split. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + rewrite Hz1. + unfold ww_to_Z; simpl zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith. + split; auto with zarith. + rewrite (Zplus_comm (-wwB)); rewrite <- Zplus_assoc. + rewrite H5. + match goal with |- 0 <= ?X + (?Y - ?Z) => + apply Zle_trans with (X - Z); auto with zarith + end. + 2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith. + rewrite V1. + match goal with |- 0 <= ?X - 1 - ?Y => + assert (Y < X); auto with zarith + end. + apply Zlt_le_trans with wwB; auto with zarith. + intros (H3, H4). + match goal with |- context [ww_sub_c ?y ?z] => + generalize (spec_ww_sub_c y z); case (ww_sub_c y z) + end. + intros z; change [-[C0 z]] with ([[z]]). + match goal with |- context[([+[C1 ?z]])] => + replace [+[C1 z]] with (wwB + [[z]]) + end. + 2: simpl; case wwB; auto. + intros H5; rewrite spec_w_square_c in H5; + auto. + split. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite H5. + unfold ww_to_Z; simpl zn2z_to_Z. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + simpl ww_to_Z. + rewrite H5. + simpl ww_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ => + apply Zle_trans with (X * Y + (Z * Y + T - 0)); + auto with zarith + end. + assert (V := Zsquare_pos [|w5|]); + rewrite Zsquare_mult in V; auto with zarith. + autorewrite with rm10. + match goal with |- _ <= 2 * (?U * ?V + ?W) => + apply Zle_trans with (2 * U * V + 0); + auto with zarith + end. + match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ => + replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T); + try ring + end. + apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w1);auto with zarith. + destruct (spec_to_Z w5);auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + intros z; replace [-[C1 z]] with (- wwB + [[z]]). + 2: simpl; case wwB; auto with zarith. + intros H5; rewrite spec_w_square_c in H5; + auto. + match goal with |- context[([+[C0 ?z]])] => + change [+[C0 z]] with ([[z]]) + end. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + simpl ww_to_Z. + rewrite <- Hw1. + simpl ww_to_Z in H1; rewrite H1. + rewrite <- Hw0. + split. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + simpl ww_to_Z. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + rewrite V. + simpl ww_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ => + apply Zle_trans with ((Z * Y + T - 0) + X * Y); + auto with zarith + end. + assert (V1 := Zsquare_pos [|w5|]); + rewrite Zsquare_mult in V1; auto with zarith. + autorewrite with rm10. + match goal with |- _ <= 2 * (?U * ?V + ?W) => + apply Zle_trans with (2 * U * V + 0); + auto with zarith + end. + match goal with |- (?Z * ?Y + ?T) + ?X * ?Y <= _ => + replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T); + try ring + end. + apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w1);auto with zarith. + destruct (spec_to_Z w5);auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + case Zle_lt_or_eq with (1 := H2); clear H2; intros H2. + intros c1 (H3, H4). + match type of H3 with ?X = ?Y => + absurd (X < Y) + end. + apply Zle_not_lt; rewrite <- H3; auto with zarith. + rewrite Zmult_plus_distr_l. + apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); + auto with zarith. + apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + assert (V1 := spec_to_Z w5);auto with zarith. + rewrite (Zmult_comm wB); auto with zarith. + assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith. + intros c1 (H3, H4); rewrite H2 in H3. + match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V => + assert (VV: (Y = (T * U) + V)); + [replace Y with ((X + Y) - X); + [rewrite H3; ring | ring] | idtac] + end. + assert (V1 := spec_to_Z w0);auto with zarith. + assert (V2 := spec_to_Z w5);auto with zarith. + case (Zle_lt_or_eq 0 [|w5|]); auto with zarith; intros V3. + match type of VV with ?X = ?Y => + absurd (X < Y) + end. + apply Zle_not_lt; rewrite <- VV; auto with zarith. + apply Zlt_le_trans with wB; auto with zarith. + match goal with |- _ <= ?X + _ => + apply Zle_trans with X; auto with zarith + end. + match goal with |- _ <= _ * ?X => + apply Zle_trans with (1 * X); auto with zarith + end. + autorewrite with rm10. + rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + rewrite <- V3 in VV; generalize VV; autorewrite with rm10; + clear VV; intros VV. + rewrite spec_ww_add_c; auto with zarith. + rewrite ww_add_mult_mult_2_plus_1. + match goal with |- context[?X mod wwB] => + rewrite <- Zmod_unique with (q := 1) (r := -wwB + X) + end; auto with zarith. + simpl ww_to_Z. + rewrite spec_w_Bm1; auto with zarith. + split. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + rewrite <- Hw1. + simpl ww_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H2. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. + assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. + simpl ww_to_Z; unfold ww_to_Z. + rewrite spec_w_Bm1; auto with zarith. + split. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) => + assert (X <= 2 * Z * T); auto with zarith + end. + apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + match goal with |- _ + ?X < _ => + replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring + end. + assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith. + rewrite <- Zmult_assoc; apply Zmult_le_compat_l; auto with zarith. + rewrite wwB_wBwB; rewrite Zpower_2. + apply Zmult_le_compat_r; auto with zarith. + case (spec_to_Z w4);auto with zarith. + 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); + 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. + Qed. + + Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. + pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2. + rewrite <- wB_div_2. + match goal with |- context[(2 * ?X) * (2 * ?Z)] => + replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring + end. + rewrite Z_div_mult; auto with zarith. + rewrite Zmult_assoc; rewrite wB_div_2. + rewrite wwB_div_2; ring. + Qed. + + + Lemma spec_ww_head1 + : forall x : zn2z w, + (ww_is_even (ww_head1 x) = true) /\ + (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). + assert (U := wB_pos w_digits). + intros x; unfold ww_head1. + generalize (spec_ww_is_even (ww_head0 x)); case_eq (ww_is_even (ww_head0 x)). + intros HH H1; rewrite HH; split; auto. + intros H2. + generalize (spec_ww_head0 x H2); case (ww_head0 x); autorewrite with rm10. + intros (H3, H4); split; auto with zarith. + apply Zle_trans with (2 := H3). + apply Zdiv_le_compat_l; auto with zarith. + intros xh xl (H3, H4); split; auto with zarith. + apply Zle_trans with (2 := H3). + apply Zdiv_le_compat_l; auto with zarith. + intros H1. + case (spec_to_w_Z (ww_head0 x)); intros Hv1 Hv2. + assert (Hp0: 0 < [[ww_head0 x]]). + generalize (spec_ww_is_even (ww_head0 x)); rewrite H1. + generalize Hv1; case [[ww_head0 x]]. + rewrite Zmod_small; auto with zarith. + intros; assert (0 < Zpos p); auto with zarith. + red; simpl; auto. + intros p H2; case H2; auto. + assert (Hp: [[ww_pred (ww_head0 x)]] = [[ww_head0 x]] - 1). + rewrite spec_ww_pred. + rewrite Zmod_small; auto with zarith. + intros H2; split. + generalize (spec_ww_is_even (ww_pred (ww_head0 x))); + case ww_is_even; auto. + rewrite Hp. + rewrite Zminus_mod; auto with zarith. + rewrite H2; repeat rewrite Zmod_small; auto with zarith. + intros H3; rewrite Hp. + case (spec_ww_head0 x); auto; intros Hv3 Hv4. + assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). + intros u Hu. + pattern 2 at 1; rewrite <- Zpower_1_r. + rewrite <- Zpower_exp; auto with zarith. + ring_simplify (1 + (u - 1)); auto with zarith. + split; auto with zarith. + apply Zmult_le_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite wwB_4_2. + rewrite Zmult_assoc; rewrite Hu; auto with zarith. + apply Zle_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith; + rewrite Hu; auto with zarith. + apply Zmult_le_compat_r; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + Qed. + + Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB. + apply sym_equal; apply Zdiv_unique with 0; + auto with zarith. + rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith. + rewrite wwB_wBwB; ring. + Qed. + + Lemma spec_ww_sqrt : forall x, + [[ww_sqrt x]] ^ 2 <= [[x]] < ([[ww_sqrt x]] + 1) ^ 2. + assert (U := wB_pos w_digits). + intro x; unfold ww_sqrt. + generalize (spec_ww_is_zero x); case (ww_is_zero x). + 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; + simpl ww_to_Z; autorewrite with rm10. + generalize H1; case x. + intros HH; contradict HH; simpl ww_to_Z; auto with zarith. + intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. + intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. + generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. + intros (H4, H5). + assert (V: wB/4 <= [|w0|]). + apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. + rewrite <- wwB_4_wB_4; auto. + generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. + case (w_sqrt2 w0 w1); intros w2 c. + simpl ww_to_Z; simpl fst. + case c; unfold interp_carry; autorewrite with rm10. + intros w3 (H6, H7); rewrite H6. + assert (V1 := spec_to_Z w3);auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. + match goal with |- ?X < ?Z => + replace Z with (X + 1); auto with zarith + end. + repeat rewrite Zsquare_mult; ring. + intros w3 (H6, H7); rewrite H6. + assert (V1 := spec_to_Z w3);auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. + match goal with |- ?X < ?Z => + replace Z with (X + 1); auto with zarith + end. + repeat rewrite Zsquare_mult; ring. + intros HH; case (spec_to_w_Z (ww_head1 x)); auto with zarith. + intros Hv1. + case (spec_ww_head1 x); intros Hp1 Hp2. + generalize (Hp2 H1); clear Hp2; intros Hp2. + assert (Hv2: [[ww_head1 x]] <= Zpos (xO w_digits)). + case (Zle_or_lt (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1. + case Hp2; intros _ HH2; contradict HH2. + apply Zle_not_lt; unfold base. + apply Zle_trans with (2 ^ [[ww_head1 x]]). + apply Zpower_le_monotone; auto with zarith. + pattern (2 ^ [[ww_head1 x]]) at 1; + rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])). + apply Zmult_le_compat_l; auto with zarith. + generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); + case ww_add_mul_div. + simpl ww_to_Z; autorewrite with w_rewrite rm10. + rewrite Zmod_small; auto with zarith. + intros H2; case (Zmult_integral _ _ (sym_equal H2)); clear H2; intros H2. + rewrite H2; unfold Zpower, Zpower_pos; simpl; auto with zarith. + match type of H2 with ?X = ?Y => + absurd (Y < X); try (rewrite H2; auto with zarith; fail) + end. + apply Zpower_gt_0; auto with zarith. + split; auto with zarith. + case Hp2; intros _ tmp; apply Zle_lt_trans with (2 := tmp); + clear tmp. + rewrite Zmult_comm; apply Zmult_le_compat_r; auto with zarith. + assert (Hv0: [[ww_head1 x]] = 2 * ([[ww_head1 x]]/2)). + pattern [[ww_head1 x]] at 1; rewrite (Z_div_mod_eq [[ww_head1 x]] 2); + auto with zarith. + generalize (spec_ww_is_even (ww_head1 x)); rewrite Hp1; + intros tmp; rewrite tmp; rewrite Zplus_0_r; auto. + intros w0 w1; autorewrite with w_rewrite rm10. + rewrite Zmod_small; auto with zarith. + 2: rewrite Zmult_comm; auto with zarith. + intros H2. + assert (V: wB/4 <= [|w0|]). + apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. + simpl ww_to_Z in H2; rewrite H2. + rewrite <- wwB_4_wB_4; auto with zarith. + rewrite Zmult_comm; auto with zarith. + assert (V1 := spec_to_Z w1);auto with zarith. + generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. + case (w_sqrt2 w0 w1); intros w2 c. + case (spec_to_Z w2); intros HH1 HH2. + simpl ww_to_Z; simpl fst. + assert (Hv3: [[ww_pred ww_zdigits]] + = Zpos (xO w_digits) - 1). + rewrite spec_ww_pred; rewrite spec_ww_zdigits. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. + assert (Hv4: [[ww_head1 x]]/2 < wB). + apply Zle_lt_trans with (Zpos w_digits). + apply Zmult_le_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite <- Hv0; rewrite <- Zpos_xO; auto. + unfold base; apply Zpower2_lt_lin; auto with zarith. + assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] + = [[ww_head1 x]]/2). + rewrite spec_ww_add_mul_div. + simpl ww_to_Z; autorewrite with rm10. + rewrite Hv3. + ring_simplify (Zpos (xO w_digits) - (Zpos (xO w_digits) - 1)). + rewrite Zpower_1_r. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + apply Zlt_le_trans with (1 := Hv4); auto with zarith. + unfold base; apply Zpower_le_monotone; auto with zarith. + split; unfold ww_digits; try rewrite Zpos_xO; auto with zarith. + rewrite Hv3; auto with zarith. + assert (Hv6: [|low(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))|] + = [[ww_head1 x]]/2). + rewrite spec_low. + rewrite Hv5; rewrite Zmod_small; auto with zarith. + rewrite spec_w_add_mul_div; auto with zarith. + rewrite spec_w_sub; auto with zarith. + rewrite spec_w_0. + simpl ww_to_Z; autorewrite with rm10. + rewrite Hv6; rewrite spec_w_zdigits. + rewrite (fun x y => Zmod_small (x - y)). + ring_simplify (Zpos w_digits - (Zpos w_digits - [[ww_head1 x]] / 2)). + rewrite Zmod_small. + simpl ww_to_Z in H2; rewrite H2; auto with zarith. + intros (H4, H5); split. + apply Zmult_le_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. + rewrite H4. + apply Zle_trans with ([|w2|] ^ 2); auto with zarith. + rewrite Zmult_comm. + pattern [[ww_head1 x]] at 1; + rewrite Hv0; auto with zarith. + rewrite (Zmult_comm 2); rewrite Zpower_mult; + auto with zarith. + assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); + try (intros; repeat rewrite Zsquare_mult; ring); + rewrite tmp; clear tmp. + apply Zpower_le_monotone3; auto with zarith. + split; auto with zarith. + pattern [|w2|] at 2; + rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); + auto with zarith. + match goal with |- ?X <= ?X + ?Y => + assert (0 <= Y); auto with zarith + end. + case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. + case c; unfold interp_carry; autorewrite with rm10; + intros w3; assert (V3 := spec_to_Z w3);auto with zarith. + apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. + rewrite H4. + apply Zle_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith. + apply Zlt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith. + match goal with |- ?X < ?Y => + replace Y with (X + 1); auto with zarith + end. + repeat rewrite (Zsquare_mult); ring. + rewrite Zmult_comm. + pattern [[ww_head1 x]] at 1; rewrite Hv0. + rewrite (Zmult_comm 2); rewrite Zpower_mult; + auto with zarith. + assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); + try (intros; repeat rewrite Zsquare_mult; ring); + rewrite tmp; clear tmp. + apply Zpower_le_monotone3; auto with zarith. + split; auto with zarith. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]]/2))); + auto with zarith. + rewrite <- Zplus_assoc; rewrite Zmult_plus_distr_r. + autorewrite with rm10; apply Zplus_le_compat_l; auto with zarith. + case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]]/2))); auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|]); auto with zarith. + apply Zdiv_le_upper_bound; auto with zarith. + pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0); + auto with zarith. + apply Zmult_le_compat_l; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zpower_0_r; autorewrite with rm10; auto. + split; auto with zarith. + rewrite Hv0 in Hv2; rewrite (Zpos_xO w_digits) in Hv2; auto with zarith. + apply Zle_lt_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. + rewrite spec_w_sub; auto with zarith. + rewrite Hv6; rewrite spec_w_zdigits; auto with zarith. + assert (Hv7: 0 < [[ww_head1 x]]/2); auto with zarith. + rewrite Zmod_small; auto with zarith. + split; auto with zarith. + assert ([[ww_head1 x]]/2 <= Zpos w_digits); auto with zarith. + apply Zmult_le_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite <- Hv0; rewrite <- Zpos_xO; auto with zarith. + apply Zle_lt_trans with (Zpos w_digits); auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. + Qed. + +End DoubleSqrt. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v new file mode 100644 index 00000000..269d62bb --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -0,0 +1,357 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleSub.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import DoubleBase. + +Open Local Scope Z_scope. + +Section DoubleSub. + Variable w : Type. + Variable w_0 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable ww_Bm1 : zn2z w. + Variable w_opp_c : w -> carry w. + Variable w_opp_carry : w -> w. + Variable w_pred_c : w -> carry w. + Variable w_sub_c : w -> w -> carry w. + Variable w_sub_carry_c : w -> w -> carry w. + Variable w_opp : w -> w. + Variable w_pred : w -> w. + Variable w_sub : w -> w -> w. + Variable w_sub_carry : w -> w -> w. + + (* ** Opposites ** *) + Definition ww_opp_c x := + match x with + | W0 => C0 W0 + | WW xh xl => + match w_opp_c xl with + | C0 _ => + match w_opp_c xh with + | C0 h => C0 W0 + | C1 h => C1 (WW h w_0) + end + | C1 l => C1 (WW (w_opp_carry xh) l) + end + end. + + Definition ww_opp x := + match x with + | W0 => W0 + | WW xh xl => + match w_opp_c xl with + | C0 _ => WW (w_opp xh) w_0 + | C1 l => WW (w_opp_carry xh) l + end + end. + + Definition ww_opp_carry x := + match x with + | W0 => ww_Bm1 + | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl) + end. + + Definition ww_pred_c x := + match x with + | W0 => C1 ww_Bm1 + | WW xh xl => + match w_pred_c xl with + | C0 l => C0 (w_WW xh l) + | C1 _ => + match w_pred_c xh with + | C0 h => C0 (WW h w_Bm1) + | C1 _ => C1 ww_Bm1 + end + end + end. + + Definition ww_pred x := + match x with + | W0 => ww_Bm1 + | WW xh xl => + match w_pred_c xl with + | C0 l => w_WW xh l + | C1 l => WW (w_pred xh) w_Bm1 + end + end. + + Definition ww_sub_c x y := + match y, x with + | W0, _ => C0 x + | WW yh yl, W0 => ww_opp_c (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_c xl yl with + | C0 l => + match w_sub_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_sub_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (WW h l) + end + end + end. + + Definition ww_sub x y := + match y, x with + | W0, _ => x + | WW yh yl, W0 => ww_opp (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_c xl yl with + | C0 l => w_WW (w_sub xh yh) l + | C1 l => WW (w_sub_carry xh yh) l + end + end. + + Definition ww_sub_carry_c x y := + match y, x with + | W0, W0 => C1 ww_Bm1 + | W0, WW xh xl => ww_pred_c (WW xh xl) + | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) + | WW yh yl, WW xh xl => + match w_sub_carry_c xl yl with + | C0 l => + match w_sub_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_sub_carry_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Definition ww_sub_carry x y := + match y, x with + | W0, W0 => ww_Bm1 + | W0, WW xh xl => ww_pred (WW xh xl) + | WW yh yl, W0 => ww_opp_carry (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_carry_c xl yl with + | C0 l => w_WW (w_sub xh yh) l + | C1 l => w_WW (w_sub_carry xh yh) l + end + end. + + (*Section DoubleProof.*) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_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). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. + Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. + Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. + + Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1. + Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. + Variable spec_sub_carry_c : + forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. + + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + Variable spec_sub_carry : + forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + + + Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. + Proof. + destruct x as [ |xh xl];simpl. reflexivity. + rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H; + rewrite Zopp_mult_distr_l. + assert ([|l|] = 0). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) + as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. + assert ([|h|] = 0). + assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. + rewrite H2;reflexivity. + simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring. + unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry; + ring. + Qed. + + Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. reflexivity. + rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l. + generalize (spec_opp_c xl);destruct (w_opp_c xl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. + rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB. + assert ([|l|] = 0). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;rewrite Zplus_0_r; rewrite Zpower_2; + rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite spec_opp;trivial. + apply Zmod_unique with (q:= -1). + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)). + rewrite spec_opp_carry;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1. + Proof. + destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring. + rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. + Proof. + destruct x as [ |xh xl];unfold ww_pred_c. + unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring. + simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)). + 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l]; + intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + assert ([|l|] = wB - 1). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). + generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; + intros H1;unfold interp_carry in H1;rewrite <- H1. + simpl;rewrite spec_w_Bm1;ring. + assert ([|h|] = wB - 1). + assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. + rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + Proof. + destruct y as [ |yh yl];simpl. ring. + destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. + generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; + unfold interp_carry in H;rewrite <- H. + generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; + unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; + try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). + generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; + try rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_sub_carry_c : + forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. + Proof. + destruct y as [ |yh yl];simpl. + unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x). + destruct x as [ |xh xl]. + unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; + repeat rewrite spec_opp_carry;ring. + simpl ww_to_Z. + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; + unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; + try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). + generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; + simpl ww_to_Z; try rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. + apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. + rewrite spec_ww_Bm1;ring. + replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. + generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; + unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. + rewrite Zmod_small. apply spec_w_WW. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] + -1) with ([|xh|] - 1). + assert ([|l|] = wB - 1). + assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. + rewrite (mod_wwB w_digits w_to_Z);trivial. + rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial. + Qed. + + Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + Proof. + destruct y as [ |yh yl];simpl. + ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. + destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. + generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; + unfold interp_carry in H;rewrite <- H. + rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z). + rewrite spec_sub;trivial. + simpl ww_to_Z;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. + Qed. + + Lemma spec_ww_sub_carry : + forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB. + Proof. + destruct y as [ |yh yl];simpl. + ring_simplify ([[x]] - 0);exact (spec_ww_pred x). + destruct x as [ |xh xl];simpl. + apply Zmod_unique with (-1). + apply spec_ww_to_Z;trivial. + fold (ww_opp_carry (WW yh yl)). + rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; + intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. + Qed. + +(* End DoubleProof. *) + +End DoubleSub. + + + + + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v new file mode 100644 index 00000000..28d40094 --- /dev/null +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -0,0 +1,71 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: DoubleType.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Set Implicit Arguments. + +Require Import ZArith. +Open Local Scope Z_scope. + +Definition base digits := Zpower 2 (Zpos digits). + +Section Carry. + + Variable A : Type. + + Inductive carry := + | C0 : A -> carry + | C1 : A -> carry. + + Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := + match c with + | C0 x => interp x + | C1 x => sign*B + interp x + end. + +End Carry. + +Section Zn2Z. + + Variable znz : Type. + + (** From a type [znz] representing a cyclic structure Z/nZ, + we produce a representation of Z/2nZ by pairs of elements of [znz] + (plus a special case for zero). High half of the new number comes + first. + *) + + Inductive zn2z := + | W0 : zn2z + | WW : znz -> znz -> zn2z. + + Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := + match x with + | W0 => 0 + | WW xh xl => w_to_Z xh * wB + w_to_Z xl + end. + +End Zn2Z. + +Implicit 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], + whose leafs are either W0 (if depth < n) or elements of w + (if depth = n). +*) + +Fixpoint word (w:Type) (n:nat) : Type := + match n with + | O => w + | S n => zn2z (word w n) + end. + diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v new file mode 100644 index 00000000..4d655eac --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -0,0 +1,2516 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Cyclic31.v 11034 2008-06-02 08:15:34Z thery $ i*) + +(** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *) + +(** +Author: Arnaud Spiwack (+ Pierre Letouzey) +*) + +Require Import List. +Require Import Min. +Require Export Int31. +Require Import Znumtheory. +Require Import Zgcd_alt. +Require Import Zpow_facts. +Require Import BigNumPrelude. +Require Import CyclicAxioms. +Require Import ROmega. + +Open Scope nat_scope. +Open Scope int31_scope. + +Section Basics. + + (** * Basic results about [iszero], [shiftl], [shiftr] *) + + Lemma iszero_eq0 : forall x, iszero x = true -> x=0. + Proof. + destruct x; simpl; intros. + repeat + match goal with H:(if ?d then _ else _) = true |- _ => + destruct d; try discriminate + end. + reflexivity. + Qed. + + Lemma iszero_not_eq0 : forall x, iszero x = false -> x<>0. + Proof. + intros x H Eq; rewrite Eq in H; simpl in *; discriminate. + Qed. + + Lemma sneakl_shiftr : forall x, + x = sneakl (firstr x) (shiftr x). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma sneakr_shiftl : forall x, + x = sneakr (firstl x) (shiftl x). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma twice_zero : forall x, + twice x = 0 <-> twice_plus_one x = 1. + Proof. + destruct x; simpl in *; split; + intro H; injection H; intros; subst; auto. + Qed. + + Lemma twice_or_twice_plus_one : forall x, + x = twice (shiftr x) \/ x = twice_plus_one (shiftr x). + Proof. + intros; case_eq (firstr x); intros. + destruct x; simpl in *; rewrite H; auto. + destruct x; simpl in *; rewrite H; auto. + Qed. + + + + (** * Iterated shift to the right *) + + Definition nshiftr n x := iter_nat n _ shiftr x. + + Lemma nshiftr_S : + forall n x, nshiftr (S n) x = shiftr (nshiftr n x). + Proof. + reflexivity. + Qed. + + Lemma nshiftr_S_tail : + forall n x, nshiftr (S n) x = nshiftr n (shiftr x). + Proof. + induction n; simpl; auto. + intros; rewrite nshiftr_S, IHn, nshiftr_S; auto. + Qed. + + Lemma nshiftr_n_0 : forall n, nshiftr n 0 = 0. + Proof. + induction n; simpl; auto. + rewrite nshiftr_S, IHn; auto. + Qed. + + Lemma nshiftr_size : forall x, nshiftr size x = 0. + Proof. + destruct x; simpl; auto. + Qed. + + Lemma nshiftr_above_size : forall k x, size<=k -> + nshiftr k x = 0. + Proof. + intros. + replace k with ((k-size)+size)%nat by omega. + induction (k-size)%nat; auto. + rewrite nshiftr_size; auto. + simpl; rewrite nshiftr_S, IHn; auto. + Qed. + + (** * Iterated shift to the left *) + + Definition nshiftl n x := iter_nat n _ shiftl x. + + Lemma nshiftl_S : + forall n x, nshiftl (S n) x = shiftl (nshiftl n x). + Proof. + reflexivity. + Qed. + + Lemma nshiftl_S_tail : + forall n x, nshiftl (S n) x = nshiftl n (shiftl x). + Proof. + induction n; simpl; auto. + intros; rewrite nshiftl_S, IHn, nshiftl_S; auto. + Qed. + + Lemma nshiftl_n_0 : forall n, nshiftl n 0 = 0. + Proof. + induction n; simpl; auto. + rewrite nshiftl_S, IHn; auto. + Qed. + + Lemma nshiftl_size : forall x, nshiftl size x = 0. + Proof. + destruct x; simpl; auto. + Qed. + + Lemma nshiftl_above_size : forall k x, size<=k -> + nshiftl k x = 0. + Proof. + intros. + replace k with ((k-size)+size)%nat by omega. + induction (k-size)%nat; auto. + rewrite nshiftl_size; auto. + simpl; rewrite nshiftl_S, IHn; auto. + Qed. + + Lemma firstr_firstl : + forall x, firstr x = firstl (nshiftl (pred size) x). + Proof. + destruct x; simpl; auto. + Qed. + + Lemma firstl_firstr : + forall x, firstl x = firstr (nshiftr (pred size) x). + Proof. + destruct x; simpl; auto. + Qed. + + (** More advanced results about [nshiftr] *) + + Lemma nshiftr_predsize_0_firstl : forall x, + nshiftr (pred size) x = 0 -> firstl x = D0. + Proof. + destruct x; compute; intros H; injection H; intros; subst; auto. + Qed. + + Lemma nshiftr_0_propagates : forall n p x, n <= p -> + nshiftr n x = 0 -> nshiftr p x = 0. + Proof. + intros. + replace p with ((p-n)+n)%nat by omega. + induction (p-n)%nat. + simpl; auto. + simpl; rewrite nshiftr_S; rewrite IHn0; auto. + Qed. + + Lemma nshiftr_0_firstl : forall n x, n < size -> + nshiftr n x = 0 -> firstl x = D0. + Proof. + intros. + apply nshiftr_predsize_0_firstl. + apply nshiftr_0_propagates with n; auto; omega. + Qed. + + (** * Some induction principles over [int31] *) + + (** Not used for the moment. Are they really useful ? *) + + Lemma int31_ind_sneakl : forall P : int31->Prop, + P 0 -> + (forall x d, P x -> P (sneakl d x)) -> + forall x, P x. + Proof. + intros. + assert (forall n, n<=size -> P (nshiftr (size - n) x)). + induction n; intros. + rewrite nshiftr_size; auto. + rewrite sneakl_shiftr. + apply H0. + change (P (nshiftr (S (size - S n)) x)). + replace (S (size - S n))%nat with (size - n)%nat by omega. + apply IHn; omega. + change x with (nshiftr (size-size) x); auto. + Qed. + + Lemma int31_ind_twice : forall P : int31->Prop, + P 0 -> + (forall x, P x -> P (twice x)) -> + (forall x, P x -> P (twice_plus_one x)) -> + forall x, P x. + Proof. + induction x using int31_ind_sneakl; auto. + destruct d; auto. + Qed. + + + (** * Some generic results about [recr] *) + + Section Recr. + + (** [recr] satisfies the fixpoint equation used for its definition. *) + + Variable (A:Type)(case0:A)(caserec:digits->int31->A->A). + + Lemma recr_aux_eqn : forall n x, iszero x = false -> + recr_aux (S n) A case0 caserec x = + caserec (firstr x) (shiftr x) (recr_aux n A case0 caserec (shiftr x)). + Proof. + intros; simpl; rewrite H; auto. + Qed. + + Lemma recr_aux_converges : + forall n p x, n <= size -> n <= p -> + recr_aux n A case0 caserec (nshiftr (size - n) x) = + recr_aux p A case0 caserec (nshiftr (size - n) x). + Proof. + induction n. + simpl; intros. + rewrite nshiftr_size; destruct p; simpl; auto. + intros. + destruct p. + inversion H0. + unfold recr_aux; fold recr_aux. + destruct (iszero (nshiftr (size - S n) x)); auto. + f_equal. + change (shiftr (nshiftr (size - S n) x)) with (nshiftr (S (size - S n)) x). + replace (S (size - S n))%nat with (size - n)%nat by omega. + apply IHn; auto with arith. + Qed. + + Lemma recr_eqn : forall x, iszero x = false -> + recr A case0 caserec x = + caserec (firstr x) (shiftr x) (recr A case0 caserec (shiftr x)). + Proof. + intros. + unfold recr. + change x with (nshiftr (size - size) x). + rewrite (recr_aux_converges size (S size)); auto with arith. + rewrite recr_aux_eqn; auto. + Qed. + + (** [recr] is usually equivalent to a variant [recrbis] + written without [iszero] check. *) + + Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + let si := shiftr i in + caserec (firstr i) si (recrbis_aux next A case0 caserec si) + end. + + Definition recrbis := recrbis_aux size. + + Hypothesis case0_caserec : caserec D0 0 case0 = case0. + + Lemma recrbis_aux_equiv : forall n x, + recrbis_aux n A case0 caserec x = recr_aux n A case0 caserec x. + Proof. + induction n; simpl; auto; intros. + case_eq (iszero x); intros; [ | f_equal; auto ]. + rewrite (iszero_eq0 _ H); simpl; auto. + replace (recrbis_aux n A case0 caserec 0) with case0; auto. + clear H IHn; induction n; simpl; congruence. + Qed. + + Lemma recrbis_equiv : forall x, + recrbis A case0 caserec x = recr A case0 caserec x. + Proof. + intros; apply recrbis_aux_equiv; auto. + Qed. + + End Recr. + + (** * Incrementation *) + + Section Incr. + + (** Variant of [incr] via [recrbis] *) + + Let Incr (b : digits) (si rec : int31) := + match b with + | D0 => sneakl D1 si + | D1 => sneakl D0 rec + end. + + Definition incrbis_aux n x := recrbis_aux n _ In Incr x. + + Lemma incrbis_aux_equiv : forall x, incrbis_aux size x = incr x. + Proof. + unfold incr, recr, incrbis_aux; fold Incr; intros. + apply recrbis_aux_equiv; auto. + Qed. + + (** Recursive equations satisfied by [incr] *) + + Lemma incr_eqn1 : + forall x, firstr x = D0 -> incr x = twice_plus_one (shiftr x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0); simpl; auto. + unfold incr; rewrite recr_eqn; fold incr; auto. + rewrite H; auto. + Qed. + + Lemma incr_eqn2 : + forall x, firstr x = D1 -> incr x = twice (incr (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in H; simpl in H; discriminate. + unfold incr; rewrite recr_eqn; fold incr; auto. + rewrite H; auto. + Qed. + + Lemma incr_twice : forall x, incr (twice x) = twice_plus_one x. + Proof. + intros. + rewrite incr_eqn1; destruct x; simpl; auto. + Qed. + + Lemma incr_twice_plus_one_firstl : + forall x, firstl x = D0 -> incr (twice_plus_one x) = twice (incr x). + Proof. + intros. + rewrite incr_eqn2; [ | destruct x; simpl; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + (** The previous result is actually true even without the + constraint on [firstl], but this is harder to prove + (see later). *) + + End Incr. + + (** * Conversion to [Z] : the [phi] function *) + + Section Phi. + + (** Variant of [phi] via [recrbis] *) + + Let Phi := fun b (_:int31) => + match b with D0 => Zdouble | D1 => Zdouble_plus_one end. + + Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x. + + Lemma phibis_aux_equiv : forall x, phibis_aux size x = phi x. + Proof. + unfold phi, recr, phibis_aux; fold Phi; intros. + apply recrbis_aux_equiv; auto. + Qed. + + (** Recursive equations satisfied by [phi] *) + + Lemma phi_eqn1 : forall x, firstr x = D0 -> + phi x = Zdouble (phi (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0); simpl; auto. + intros; unfold phi; rewrite recr_eqn; fold phi; auto. + rewrite H; auto. + Qed. + + Lemma phi_eqn2 : forall x, firstr x = D1 -> + phi x = Zdouble_plus_one (phi (shiftr x)). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in H; simpl in H; discriminate. + intros; unfold phi; rewrite recr_eqn; fold phi; auto. + rewrite H; auto. + Qed. + + Lemma phi_twice_firstl : forall x, firstl x = D0 -> + phi (twice x) = Zdouble (phi x). + Proof. + intros. + rewrite phi_eqn1; auto; [ | destruct x; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> + phi (twice_plus_one x) = Zdouble_plus_one (phi x). + Proof. + intros. + rewrite phi_eqn2; auto; [ | destruct x; auto ]. + f_equal; f_equal. + destruct x; simpl in *; rewrite H; auto. + Qed. + + End Phi. + + (** [phi x] is positive and lower than [2^31] *) + + Lemma phibis_aux_pos : forall n x, (0 <= phibis_aux n x)%Z. + Proof. + induction n. + simpl; unfold phibis_aux; simpl; auto with zarith. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr x)). + destruct (firstr x). + specialize IHn with (shiftr x); rewrite Zdouble_mult; omega. + specialize IHn with (shiftr x); rewrite Zdouble_plus_one_mult; omega. + Qed. + + Lemma phibis_aux_bounded : + forall n x, n <= size -> + (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z_of_nat n))%Z. + Proof. + induction n. + simpl; unfold phibis_aux; simpl; auto with zarith. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr (nshiftr (size - S n) x))). + assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). + replace (size - n)%nat with (S (size - (S n))) by omega. + simpl; auto. + rewrite H0. + assert (H1 : n <= size) by omega. + specialize (IHn x H1). + set (y:=phibis_aux n (nshiftr (size - n) x)) in *. + rewrite inj_S, Zpower_Zsucc; auto with zarith. + case_eq (firstr (nshiftr (size - S n) x)); intros. + rewrite Zdouble_mult; auto with zarith. + rewrite Zdouble_plus_one_mult; auto with zarith. + Qed. + + Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z_of_nat size))%Z. + Proof. + intros. + rewrite <- phibis_aux_equiv. + split. + apply phibis_aux_pos. + change x with (nshiftr (size-size) x). + apply phibis_aux_bounded; auto. + Qed. + + Lemma phibis_aux_lowerbound : + forall n x, firstr (nshiftr n x) = D1 -> + (2 ^ Z_of_nat n <= phibis_aux (S n) x)%Z. + Proof. + induction n. + intros. + unfold nshiftr in H; simpl in *. + unfold phibis_aux, recrbis_aux. + rewrite H, Zdouble_plus_one_mult; omega. + + intros. + remember (S n) as m. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux m (shiftr x)). + subst m. + rewrite inj_S, Zpower_Zsucc; auto with zarith. + assert (2^(Z_of_nat n) <= phibis_aux (S n) (shiftr x))%Z. + apply IHn. + rewrite <- nshiftr_S_tail; auto. + destruct (firstr x). + change (Zdouble (phibis_aux (S n) (shiftr x))) with + (2*(phibis_aux (S n) (shiftr x)))%Z. + omega. + rewrite Zdouble_plus_one_mult; omega. + Qed. + + Lemma phi_lowerbound : + forall x, firstl x = D1 -> (2^(Z_of_nat (pred size)) <= phi x)%Z. + Proof. + intros. + generalize (phibis_aux_lowerbound (pred size) x). + rewrite <- firstl_firstr. + change (S (pred size)) with size; auto. + rewrite phibis_aux_equiv; auto. + Qed. + + (** * Equivalence modulo [2^n] *) + + Section EqShiftL. + + (** After killing [n] bits at the left, are the numbers equal ?*) + + Definition EqShiftL n x y := + nshiftl n x = nshiftl n y. + + Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y. + Proof. + unfold EqShiftL; intros; unfold nshiftl; simpl; split; auto. + Qed. + + Lemma EqShiftL_size : forall k x y, size<=k -> EqShiftL k x y. + Proof. + red; intros; rewrite 2 nshiftl_above_size; auto. + Qed. + + Lemma EqShiftL_le : forall k k' x y, k <= k' -> + EqShiftL k x y -> EqShiftL k' x y. + Proof. + unfold EqShiftL; intros. + replace k' with ((k'-k)+k)%nat by omega. + remember (k'-k)%nat as n. + clear Heqn H k'. + induction n; simpl; auto. + rewrite 2 nshiftl_S; f_equal; auto. + Qed. + + Lemma EqShiftL_firstr : forall k x y, k < size -> + EqShiftL k x y -> firstr x = firstr y. + Proof. + intros. + rewrite 2 firstr_firstl. + f_equal. + apply EqShiftL_le with k; auto. + unfold size. + auto with arith. + Qed. + + Lemma EqShiftL_twice : forall k x y, + EqShiftL k (twice x) (twice y) <-> EqShiftL (S k) x y. + Proof. + intros; unfold EqShiftL. + rewrite 2 nshiftl_S_tail; split; auto. + Qed. + + (** * From int31 to list of digits. *) + + (** Lower (=rightmost) bits comes first. *) + + Definition i2l := recrbis _ nil (fun d _ rec => d::rec). + + Lemma i2l_length : forall x, length (i2l x) = size. + Proof. + intros; reflexivity. + Qed. + + Fixpoint lshiftl l x := + match l with + | nil => x + | d::l => sneakl d (lshiftl l x) + end. + + Definition l2i l := lshiftl l On. + + Lemma l2i_i2l : forall x, l2i (i2l x) = x. + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_sneakr : forall x d, + i2l (sneakr d x) = tail (i2l x) ++ d::nil. + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_sneakl : forall x d, + i2l (sneakl d x) = d :: removelast (i2l x). + Proof. + destruct x; compute; auto. + Qed. + + Lemma i2l_l2i : forall l, length l = size -> + i2l (l2i l) = l. + Proof. + repeat (destruct l as [ |? l]; [intros; discriminate | ]). + destruct l; [ | intros; discriminate]. + intros _; compute; auto. + Qed. + + Fixpoint cstlist (A:Type)(a:A) n := + match n with + | O => nil + | S n => a::cstlist _ a n + end. + + Lemma i2l_nshiftl : forall n x, n<=size -> + i2l (nshiftl n x) = cstlist _ D0 n ++ firstn (size-n) (i2l x). + Proof. + induction n. + intros. + assert (firstn (size-0) (i2l x) = i2l x). + rewrite <- minus_n_O, <- (i2l_length x). + induction (i2l x); simpl; f_equal; auto. + rewrite H0; clear H0. + reflexivity. + + intros. + rewrite nshiftl_S. + unfold shiftl; rewrite i2l_sneakl. + simpl cstlist. + rewrite <- app_comm_cons; f_equal. + rewrite IHn; [ | omega]. + rewrite removelast_app. + f_equal. + replace (size-n)%nat with (S (size - S n))%nat by omega. + rewrite removelast_firstn; auto. + rewrite i2l_length; omega. + generalize (firstn_length (size-n) (i2l x)). + rewrite i2l_length. + intros H0 H1; rewrite H1 in H0. + rewrite min_l in H0 by omega. + simpl length in H0. + omega. + Qed. + + (** [i2l] can be used to define a relation equivalent to [EqShiftL] *) + + Lemma EqShiftL_i2l : forall k x y, + EqShiftL k x y <-> firstn (size-k) (i2l x) = firstn (size-k) (i2l y). + Proof. + intros. + destruct (le_lt_dec size k). + split; intros. + replace (size-k)%nat with O by omega. + unfold firstn; auto. + apply EqShiftL_size; auto. + + unfold EqShiftL. + assert (k <= size) by omega. + split; intros. + assert (i2l (nshiftl k x) = i2l (nshiftl k y)) by (f_equal; auto). + rewrite 2 i2l_nshiftl in H1; auto. + eapply app_inv_head; eauto. + assert (i2l (nshiftl k x) = i2l (nshiftl k y)). + rewrite 2 i2l_nshiftl; auto. + f_equal; auto. + rewrite <- (l2i_i2l (nshiftl k x)), <- (l2i_i2l (nshiftl k y)). + f_equal; auto. + Qed. + + (** This equivalence allows to prove easily the following delicate + result *) + + Lemma EqShiftL_twice_plus_one : forall k x y, + EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y. + Proof. + intros. + destruct (le_lt_dec size k). + split; intros; apply EqShiftL_size; auto. + + rewrite 2 EqShiftL_i2l. + unfold twice_plus_one. + rewrite 2 i2l_sneakl. + replace (size-k)%nat with (S (size - S k))%nat by omega. + remember (size - S k)%nat as n. + remember (i2l x) as lx. + remember (i2l y) as ly. + simpl. + rewrite 2 firstn_removelast. + split; intros. + injection H; auto. + f_equal; auto. + subst ly n; rewrite i2l_length; omega. + subst lx n; rewrite i2l_length; omega. + Qed. + + Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> + EqShiftL (S k) (shiftr x) (shiftr y). + Proof. + intros. + destruct (le_lt_dec size (S k)). + apply EqShiftL_size; auto. + case_eq (firstr x); intros. + rewrite <- EqShiftL_twice. + unfold twice; rewrite <- H0. + rewrite <- sneakl_shiftr. + rewrite (EqShiftL_firstr k x y); auto. + rewrite <- sneakl_shiftr; auto. + omega. + rewrite <- EqShiftL_twice_plus_one. + unfold twice_plus_one; rewrite <- H0. + rewrite <- sneakl_shiftr. + rewrite (EqShiftL_firstr k x y); auto. + rewrite <- sneakl_shiftr; auto. + omega. + Qed. + + Lemma EqShiftL_incrbis : forall n k x y, n<=size -> + (n+k=S size)%nat -> + EqShiftL k x y -> + EqShiftL k (incrbis_aux n x) (incrbis_aux n y). + Proof. + induction n; simpl; intros. + red; auto. + destruct (eq_nat_dec k size). + subst k; apply EqShiftL_size; auto. + unfold incrbis_aux; simpl; + fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)). + + rewrite (EqShiftL_firstr k x y); auto; try omega. + case_eq (firstr y); intros. + rewrite EqShiftL_twice_plus_one. + apply EqShiftL_shiftr; auto. + + rewrite EqShiftL_twice. + apply IHn; try omega. + apply EqShiftL_shiftr; auto. + Qed. + + Lemma EqShiftL_incr : forall x y, + EqShiftL 1 x y -> EqShiftL 1 (incr x) (incr y). + Proof. + intros. + rewrite <- 2 incrbis_aux_equiv. + apply EqShiftL_incrbis; auto. + Qed. + + End EqShiftL. + + (** * More equations about [incr] *) + + Lemma incr_twice_plus_one : + forall x, incr (twice_plus_one x) = twice (incr x). + Proof. + intros. + rewrite incr_eqn2; [ | destruct x; simpl; auto]. + apply EqShiftL_incr. + red; destruct x; simpl; auto. + Qed. + + Lemma incr_firstr : forall x, firstr (incr x) <> firstr x. + Proof. + intros. + case_eq (firstr x); intros. + rewrite incr_eqn1; auto. + destruct (shiftr x); simpl; discriminate. + rewrite incr_eqn2; auto. + destruct (incr (shiftr x)); simpl; discriminate. + Qed. + + Lemma incr_inv : forall x y, + incr x = twice_plus_one y -> x = twice y. + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H0) in *; simpl in *. + change (incr 0) with 1 in H. + symmetry; rewrite twice_zero; auto. + case_eq (firstr x); intros. + rewrite incr_eqn1 in H; auto. + clear H0; destruct x; destruct y; simpl in *. + injection H; intros; subst; auto. + elim (incr_firstr x). + rewrite H1, H; destruct y; simpl; auto. + Qed. + + (** * Conversion from [Z] : the [phi_inv] function *) + + (** First, recursive equations *) + + Lemma phi_inv_double_plus_one : forall z, + phi_inv (Zdouble_plus_one z) = twice_plus_one (phi_inv z). + Proof. + destruct z; simpl; auto. + induction p; simpl. + rewrite 2 incr_twice; auto. + rewrite incr_twice, incr_twice_plus_one. + f_equal. + apply incr_inv; auto. + auto. + Qed. + + Lemma phi_inv_double : forall z, + phi_inv (Zdouble z) = twice (phi_inv z). + Proof. + destruct z; simpl; auto. + rewrite incr_twice_plus_one; auto. + Qed. + + Lemma phi_inv_incr : forall z, + phi_inv (Zsucc z) = incr (phi_inv z). + Proof. + destruct z. + simpl; auto. + simpl; auto. + induction p; simpl; auto. + rewrite Pplus_one_succ_r, IHp, incr_twice_plus_one; auto. + rewrite incr_twice; auto. + simpl; auto. + destruct p; simpl; auto. + rewrite incr_twice; auto. + f_equal. + rewrite incr_twice_plus_one; auto. + induction p; simpl; auto. + rewrite incr_twice; auto. + f_equal. + rewrite incr_twice_plus_one; auto. + Qed. + + (** [phi_inv o inv], the always-exact and easy-to-prove trip : + from int31 to Z and then back to int31. *) + + Lemma phi_inv_phi_aux : + forall n x, n <= size -> + phi_inv (phibis_aux n (nshiftr (size-n) x)) = + nshiftr (size-n) x. + Proof. + induction n. + intros; simpl. + rewrite nshiftr_size; auto. + intros. + unfold phibis_aux, recrbis_aux; fold recrbis_aux; + fold (phibis_aux n (shiftr (nshiftr (size-S n) x))). + assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). + replace (size - n)%nat with (S (size - (S n))); auto; omega. + rewrite H0. + case_eq (firstr (nshiftr (size - S n) x)); intros. + + rewrite phi_inv_double. + rewrite IHn by omega. + rewrite <- H0. + remember (nshiftr (size - S n) x) as y. + destruct y; simpl in H1; rewrite H1; auto. + + rewrite phi_inv_double_plus_one. + rewrite IHn by omega. + rewrite <- H0. + remember (nshiftr (size - S n) x) as y. + destruct y; simpl in H1; rewrite H1; auto. + Qed. + + Lemma phi_inv_phi : forall x, phi_inv (phi x) = x. + Proof. + intros. + rewrite <- phibis_aux_equiv. + replace x with (nshiftr (size - size) x) by auto. + apply phi_inv_phi_aux; auto. + Qed. + + (** The other composition [phi o phi_inv] is harder to prove correct. + In particular, an overflow can happen, so a modulo is needed. + For the moment, we proceed via several steps, the first one + being a detour to [positive_to_in31]. *) + + (** * [positive_to_int31] *) + + (** A variant of [p2i] with [twice] and [twice_plus_one] instead of + [2*i] and [2*i+1] *) + + Fixpoint p2ibis n p : (N*int31)%type := + match n with + | O => (Npos p, On) + | S n => match p with + | xO p => let (r,i) := p2ibis n p in (r, twice i) + | xI p => let (r,i) := p2ibis n p in (r, twice_plus_one i) + | xH => (N0, In) + end + end. + + Lemma p2ibis_bounded : forall n p, + nshiftr n (snd (p2ibis n p)) = 0. + Proof. + induction n. + simpl; intros; auto. + simpl; intros. + destruct p; simpl. + + specialize IHn with p. + destruct (p2ibis n p); simpl in *. + rewrite nshiftr_S_tail. + destruct (le_lt_dec size n). + rewrite nshiftr_above_size; auto. + assert (H:=nshiftr_0_firstl _ _ l IHn). + replace (shiftr (twice_plus_one i)) with i; auto. + destruct i; simpl in *; rewrite H; auto. + + specialize IHn with p. + destruct (p2ibis n p); simpl in *. + rewrite nshiftr_S_tail. + destruct (le_lt_dec size n). + rewrite nshiftr_above_size; auto. + assert (H:=nshiftr_0_firstl _ _ l IHn). + replace (shiftr (twice i)) with i; auto. + destruct i; simpl in *; rewrite H; auto. + + rewrite nshiftr_S_tail; auto. + replace (shiftr In) with 0; auto. + 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. + Proof. + induction n; intros. + simpl; rewrite Pmult_1_r; auto. + replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by + (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; + auto with zarith). + rewrite (Zmult_comm 2). + assert (n<=size) by omega. + destruct p; simpl; [ | | auto]; + specialize (IHn p H0); + generalize (p2ibis_bounded n p); + destruct (p2ibis n p) as (r,i); simpl in *; intros. + + change (Zpos p~1) with (2*Zpos p + 1)%Z. + rewrite phi_twice_plus_one_firstl, Zdouble_plus_one_mult. + rewrite IHn; ring. + apply (nshiftr_0_firstl n); auto; try omega. + + change (Zpos p~0) with (2*Zpos p)%Z. + rewrite phi_twice_firstl. + change (Zdouble (phi i)) with (2*(phi i))%Z. + rewrite IHn; ring. + apply (nshiftr_0_firstl n); auto; try omega. + Qed. + + (** We now prove that this [p2ibis] is related to [phi_inv_positive] *) + + Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> + EqShiftL (size-n) (phi_inv_positive p) (snd (p2ibis n p)). + Proof. + induction n. + intros. + apply EqShiftL_size; auto. + intros. + simpl p2ibis; destruct p; [ | | red; auto]; + specialize IHn with p; + destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; + rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; + replace (S (size - S n))%nat with (size - n)%nat by omega; + apply IHn; omega. + Qed. + + (** This gives the expected result about [phi o phi_inv], at least + for the positive case. *) + + Lemma phi_phi_inv_positive : forall p, + phi (phi_inv_positive p) = (Zpos p) mod (2^(Z_of_nat size)). + Proof. + intros. + replace (phi_inv_positive p) with (snd (p2ibis size p)). + rewrite (p2ibis_spec size p) by auto. + rewrite Zplus_comm, Z_mod_plus. + symmetry; apply Zmod_small. + apply phi_bounded. + auto with zarith. + symmetry. + rewrite <- EqShiftL_zero. + apply (phi_inv_positive_p2ibis size p); auto. + Qed. + + (** 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. + Proof. + intros. + unfold mul31. + rewrite <- Zdouble_mult, <- phi_twice_firstl, phi_inv_phi; auto. + Qed. + + Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> + Twon*x+In = twice_plus_one x. + Proof. + intros. + rewrite double_twice_firstl; auto. + unfold add31. + rewrite phi_twice_firstl, <- Zdouble_plus_one_mult, + <- phi_twice_plus_one_firstl, phi_inv_phi; auto. + Qed. + + Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> + p2i n p = p2ibis n p. + Proof. + induction n; simpl; auto; intros. + destruct p; auto; specialize IHn with p; + generalize (p2ibis_bounded n p); + rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; + f_equal; auto. + apply double_twice_plus_one_firstl. + apply (nshiftr_0_firstl n); auto; omega. + apply double_twice_firstl. + apply (nshiftr_0_firstl n); auto; omega. + Qed. + + Lemma positive_to_int31_phi_inv_positive : forall p, + snd (positive_to_int31 p) = phi_inv_positive p. + Proof. + intros; unfold positive_to_int31. + rewrite p2i_p2ibis; auto. + symmetry. + rewrite <- EqShiftL_zero. + apply (phi_inv_positive_p2ibis size); auto. + 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. + Proof. + unfold positive_to_int31. + intros; rewrite p2i_p2ibis; auto. + apply p2ibis_spec; auto. + Qed. + + (** Thanks to the result about [phi o phi_inv_positive], we can + now establish easily the most general results about + [phi o twice] and so one. *) + + Lemma phi_twice : forall x, + phi (twice x) = (Zdouble (phi x)) mod 2^(Z_of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_double. + assert (0 <= Zdouble (phi x))%Z. + rewrite Zdouble_mult; generalize (phi_bounded x); omega. + destruct (Zdouble (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + Lemma phi_twice_plus_one : forall x, + phi (twice_plus_one x) = (Zdouble_plus_one (phi x)) mod 2^(Z_of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_double_plus_one. + assert (0 <= Zdouble_plus_one (phi x))%Z. + rewrite Zdouble_plus_one_mult; generalize (phi_bounded x); omega. + destruct (Zdouble_plus_one (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + Lemma phi_incr : forall x, + phi (incr x) = (Zsucc (phi x)) mod 2^(Z_of_nat size). + Proof. + intros. + pattern x at 1; rewrite <- (phi_inv_phi x). + rewrite <- phi_inv_incr. + assert (0 <= Zsucc (phi x))%Z. + change (Zsucc (phi x)) with ((phi x)+1)%Z; + generalize (phi_bounded x); omega. + destruct (Zsucc (phi x)). + simpl; auto. + apply phi_phi_inv_positive. + compute in H; elim H; auto. + Qed. + + (** With the previous results, we can deal with [phi o phi_inv] even + in the negative case *) + + Lemma phi_phi_inv_negative : + forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z_of_nat size). + Proof. + induction p. + + simpl complement_negative. + rewrite phi_incr in IHp. + 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. + rewrite <- Zminus_mod_idemp_l, <- Zmult_mod_idemp_r, IHp. + rewrite Zmult_mod_idemp_r, Zminus_mod_idemp_l; auto with zarith. + + simpl complement_negative. + rewrite incr_twice_plus_one, phi_twice. + remember (phi (incr (complement_negative p))) as q. + rewrite Zdouble_mult, IHp, Zmult_mod_idemp_r; auto with zarith. + + simpl; auto. + Qed. + + Lemma phi_phi_inv : + forall z, phi (phi_inv z) = z mod 2 ^ (Z_of_nat size). + Proof. + destruct z. + simpl; auto. + apply phi_phi_inv_positive. + apply phi_phi_inv_negative. + Qed. + +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 + | Lt => addmuldiv31 p 0 (addmuldiv31 (31-p) i 0) + | _ => i + end. + +(** 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) + (fun i => 0 - i) + (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. + + Open Local Scope Z_scope. + + Notation "[| x |]" := (phi x) (at level 0, x at level 99). + + Notation Local wB := (2 ^ (Z_of_nat size)). + + Lemma wB_pos : wB > 0. + Proof. + auto with zarith. + Qed. + + Notation "[+| c |]" := + (interp_carry 1 wB phi c) (at level 0, x at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wB phi c) (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wB phi x) (at level 0, x at level 99). + + Lemma spec_zdigits : [| 31 |] = 31. + Proof. + reflexivity. + Qed. + + Lemma spec_more_than_1_digit: 1 < 31. + Proof. + auto with zarith. + Qed. + + Lemma spec_0 : [| 0 |] = 0. + Proof. + reflexivity. + Qed. + + Lemma spec_1 : [| 1 |] = 1. + Proof. + reflexivity. + Qed. + + Lemma spec_Bm1 : [| 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. + + (** Addition *) + + Lemma spec_add_c : forall x y, [+|add31c x y|] = [|x|] + [|y|]. + Proof. + intros; unfold add31c, add31, interp_carry; rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X+Y) mod wB ?= X+Y <> Eq -> [+|C1 (phi_inv (X+Y))|] = X+Y). + unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros. + destruct (Z_lt_le_dec (X+Y) wB). + contradict H1; auto using Zmod_small with zarith. + rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). + rewrite Zmod_small; romega. + + generalize (Zcompare_Eq_eq ((X+Y) mod wB) (X+Y)); intros Heq. + destruct Zcompare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_succ_c : forall x, [+|add31c x 1|] = [|x|] + 1. + Proof. + intros; apply spec_add_c. + Qed. + + Lemma spec_add_carry_c : forall x y, [+|add31carryc x y|] = [|x|] + [|y|] + 1. + Proof. + intros. + unfold add31carryc, interp_carry; rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X+Y+1) mod wB ?= X+Y+1 <> Eq -> [+|C1 (phi_inv (X+Y+1))|] = X+Y+1). + unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros. + destruct (Z_lt_le_dec (X+Y+1) wB). + contradict H1; auto using Zmod_small with zarith. + rewrite <- (Z_mod_plus_full (X+Y+1) (-1) wB). + rewrite Zmod_small; romega. + + generalize (Zcompare_Eq_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq. + destruct Zcompare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_add : forall x y, [|x+y|] = ([|x|] + [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_add_carry : + forall x y, [|x+y+1|] = ([|x|] + [|y|] + 1) mod wB. + Proof. + unfold add31; intros. + repeat rewrite phi_phi_inv. + apply Zplus_mod_idemp_l. + Qed. + + Lemma spec_succ : forall x, [|x+1|] = ([|x|] + 1) mod wB. + Proof. + intros; rewrite <- spec_1; apply spec_add. + Qed. + + (** Substraction *) + + Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|]. + Proof. + unfold sub31c, sub31, interp_carry; intros. + rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X-Y) mod wB ?= X-Y <> Eq -> [-|C1 (phi_inv (X-Y))|] = X-Y). + unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros. + destruct (Z_lt_le_dec (X-Y) 0). + rewrite <- (Z_mod_plus_full (X-Y) 1 wB). + rewrite Zmod_small; romega. + contradict H1; apply Zmod_small; romega. + + generalize (Zcompare_Eq_eq ((X-Y) mod wB) (X-Y)); intros Heq. + destruct Zcompare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_sub_carry_c : forall x y, [-|sub31carryc x y|] = [|x|] - [|y|] - 1. + Proof. + unfold sub31carryc, sub31, interp_carry; intros. + rewrite phi_phi_inv. + generalize (phi_bounded x)(phi_bounded y); intros. + set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y. + + assert ((X-Y-1) mod wB ?= X-Y-1 <> Eq -> [-|C1 (phi_inv (X-Y-1))|] = X-Y-1). + unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros. + destruct (Z_lt_le_dec (X-Y-1) 0). + rewrite <- (Z_mod_plus_full (X-Y-1) 1 wB). + rewrite Zmod_small; romega. + contradict H1; apply Zmod_small; romega. + + generalize (Zcompare_Eq_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq. + destruct Zcompare; intros; + [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. + Qed. + + Lemma spec_sub : forall x y, [|x-y|] = ([|x|] - [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_sub_carry : + forall x y, [|x-y-1|] = ([|x|] - [|y|] - 1) mod wB. + Proof. + unfold sub31; intros. + repeat rewrite phi_phi_inv. + apply Zminus_mod_idemp_l. + Qed. + + Lemma spec_opp_c : forall x, [-|sub31c 0 x|] = -[|x|]. + Proof. + intros; apply spec_sub_c. + Qed. + + Lemma spec_opp : forall x, [|0 - x|] = (-[|x|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_opp_carry : forall x, [|0 - x - 1|] = wB - [|x|] - 1. + Proof. + unfold sub31; intros. + repeat rewrite phi_phi_inv. + change [|1|] with 1; change [|0|] with 0. + rewrite <- (Z_mod_plus_full (0-[|x|]) 1 wB). + rewrite Zminus_mod_idemp_l. + rewrite Zmod_small; generalize (phi_bounded x); romega. + Qed. + + Lemma spec_pred_c : forall x, [-|sub31c x 1|] = [|x|] - 1. + Proof. + intros; apply spec_sub_c. + Qed. + + Lemma spec_pred : forall x, [|x-1|] = ([|x|] - 1) mod wB. + Proof. + intros; apply spec_sub. + Qed. + + (** Multiplication *) + + Lemma phi2_phi_inv2 : forall x, [||phi_inv2 x||] = x mod (wB^2). + Proof. + assert (forall z, (z / wB) mod wB * wB + z mod wB = z mod wB ^ 2). + intros. + assert ((z/wB) mod wB = z/wB - (z/wB/wB)*wB). + rewrite (Z_div_mod_eq (z/wB) wB wB_pos) at 2; ring. + assert (z mod wB = z - (z/wB)*wB). + rewrite (Z_div_mod_eq z wB wB_pos) at 2; ring. + rewrite H. + rewrite H0 at 1. + ring_simplify. + rewrite Zdiv_Zdiv; auto with zarith. + rewrite (Z_div_mod_eq z (wB*wB)) at 2; auto with zarith. + change (wB*wB) with (wB^2); ring. + + unfold phi_inv2. + destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; + change base with wB; auto. + Qed. + + Lemma spec_mul_c : forall x y, [|| mul31c x y ||] = [|x|] * [|y|]. + Proof. + unfold mul31c; intros. + rewrite phi2_phi_inv2. + apply Zmod_small. + generalize (phi_bounded x)(phi_bounded y); intros. + change (wB^2) with (wB * wB). + auto using Zmult_lt_compat with zarith. + Qed. + + Lemma spec_mul : forall x y, [|x*y|] = ([|x|] * [|y|]) mod wB. + Proof. + intros; apply phi_phi_inv. + Qed. + + Lemma spec_square_c : forall x, [|| mul31c x x ||] = [|x|] * [|x|]. + Proof. + intros; apply spec_mul_c. + Qed. + + (** Division *) + + Lemma spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div3121 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + unfold div3121; intros. + generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros. + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4). + unfold Zdiv; destruct (Zdiv_eucl (phi2 a1 a2) [|b|]); simpl. + rewrite ?phi_phi_inv. + destruct 1; intros. + unfold phi2 in *. + change base with wB; change base with wB in H5. + change (Zpower_pos 2 31) with wB; change (Zpower_pos 2 31) with wB in H. + rewrite H5, Zmult_comm. + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z mod wB) with z; auto with zarith. + symmetry; apply Zmod_small. + split. + apply H7; change base with wB; auto with zarith. + apply Zmult_gt_0_lt_reg_r with [|b|]. + omega. + rewrite Zmult_comm. + apply Zle_lt_trans with ([|b|]*z+z0). + omega. + rewrite <- H5. + apply Zle_lt_trans with ([|a1|]*wB+(wB-1)). + omega. + replace ([|a1|]*wB+(wB-1)) with (wB*([|a1|]+1)-1) by ring. + assert (wB*([|a1|]+1) <= wB*[|b|]); try omega. + apply Zmult_le_compat; omega. + Qed. + + Lemma spec_div : forall a b, 0 < [|b|] -> + let (q,r) := div31 a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + unfold div31; intros. + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod [|a|] [|b|] H0) (Z_div_pos [|a|] [|b|] H0). + unfold Zdiv; destruct (Zdiv_eucl [|a|] [|b|]); simpl. + rewrite ?phi_phi_inv. + destruct 1; intros. + rewrite H1, Zmult_comm. + generalize (phi_bounded a)(phi_bounded b); intros. + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z mod wB) with z; auto with zarith. + symmetry; apply Zmod_small. + split; auto with zarith. + apply Zle_lt_trans with [|a|]; auto with zarith. + rewrite H1. + apply Zle_trans with ([|b|]*z); try omega. + rewrite <- (Zmult_1_l z) at 1. + apply Zmult_le_compat; auto with zarith. + Qed. + + Lemma spec_mod : forall a b, 0 < [|b|] -> + [|let (_,r) := (a/b)%int31 in r|] = [|a|] mod [|b|]. + Proof. + unfold div31; intros. + assert ([|b|]>0) by (auto with zarith). + unfold Zmod. + generalize (Z_div_mod [|a|] [|b|] H0). + destruct (Zdiv_eucl [|a|] [|b|]); simpl. + rewrite ?phi_phi_inv. + destruct 1; intros. + generalize (phi_bounded b); intros. + apply Zmod_small; omega. + Qed. + + Lemma phi_gcd : forall i j, + [|gcd31 i j|] = Zgcdn (2*size) [|j|] [|i|]. + Proof. + unfold gcd31. + induction (2*size)%nat; intros. + reflexivity. + simpl. + unfold compare31. + change [|On|] with 0. + generalize (phi_bounded j)(phi_bounded i); intros. + case_eq [|j|]; intros. + simpl; intros. + generalize (Zabs_spec [|i|]); omega. + simpl. + rewrite IHn, H1; f_equal. + rewrite spec_mod, H1; auto. + rewrite H1; compute; auto. + rewrite H1 in H; destruct H as [H _]; compute in H; elim H; auto. + Qed. + + Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd31 a b|]. + Proof. + intros. + rewrite phi_gcd. + apply Zis_gcd_sym. + apply Zgcdn_is_gcd. + unfold Zgcd_bound. + generalize (phi_bounded b). + destruct [|b|]. + unfold size; auto with zarith. + intros (_,H). + cut (Psize p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto]. + intros (H,_); compute in H; elim H; auto. + Qed. + + Lemma iter_int31_iter_nat : forall A f i a, + iter_int31 i A f a = iter_nat (Zabs_nat [|i|]) A f a. + Proof. + intros. + unfold iter_int31. + rewrite <- recrbis_equiv; auto; unfold recrbis. + rewrite <- phibis_aux_equiv. + + revert i a; induction size. + simpl; auto. + simpl; intros. + case_eq (firstr i); intros H; rewrite 2 IHn; + unfold phibis_aux; simpl; rewrite H; fold (phibis_aux n (shiftr i)); + generalize (phibis_aux_pos n (shiftr i)); intros; + set (z := phibis_aux n (shiftr i)) in *; clearbody z; + rewrite <- iter_nat_plus. + + f_equal. + rewrite Zdouble_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. + symmetry; apply Zabs_nat_Zplus; auto with zarith. + + change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = + iter_nat (Zabs_nat (Zdouble_plus_one z)) A f a); f_equal. + rewrite Zdouble_plus_one_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. + rewrite Zabs_nat_Zplus; auto with zarith. + rewrite Zabs_nat_Zplus; auto with zarith. + change (Zabs_nat 1) with 1%nat; omega. + Qed. + + Fixpoint addmuldiv31_alt n i j := + match n with + | O => i + | S n => addmuldiv31_alt n (sneakl (firstl j) i) (shiftl j) + end. + + Lemma addmuldiv31_equiv : forall p x y, + addmuldiv31 p x y = addmuldiv31_alt (Zabs_nat [|p|]) x y. + Proof. + intros. + unfold addmuldiv31. + rewrite iter_int31_iter_nat. + set (n:=Zabs_nat [|p|]); clearbody n; clear p. + revert x y; induction n. + simpl; auto. + intros. + simpl addmuldiv31_alt. + replace (S n) with (n+1)%nat by (rewrite plus_comm; auto). + rewrite iter_nat_plus; simpl; auto. + Qed. + + Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 -> + [| addmuldiv31 p x y |] = + ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos 31) - [|p|]))) mod wB. + Proof. + intros. + rewrite addmuldiv31_equiv. + assert ([|p|] = Z_of_nat (Zabs_nat [|p|])). + rewrite inj_Zabs_nat; symmetry; apply Zabs_eq. + destruct (phi_bounded p); auto. + rewrite H0; rewrite H0 in H; clear H0; rewrite Zabs_nat_Z_of_nat. + set (n := Zabs_nat [|p|]) in *; clearbody n. + assert (n <= 31)%nat. + rewrite inj_le_iff; auto with zarith. + clear p H; revert x y. + + induction n. + simpl; intros. + change (Zpower_pos 2 31) with (2^31). + rewrite Zmult_1_r. + replace ([|y|] / 2^31) with 0. + rewrite Zplus_0_r. + symmetry; apply Zmod_small; apply phi_bounded. + symmetry; apply Zdiv_small; apply phi_bounded. + + simpl addmuldiv31_alt; intros. + rewrite IHn; [ | omega ]. + case_eq (firstl y); intros. + + rewrite phi_twice, Zdouble_mult. + rewrite phi_twice_firstl; auto. + change (Zdouble [|y|]) with (2*[|y|]). + rewrite inj_S, Zpower_Zsucc; auto with zarith. + rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod. + f_equal. + apply Zplus_eq_compat. + ring. + replace (31-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring. + rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith. + rewrite Zmult_comm, Z_div_mult; auto with zarith. + + rewrite phi_twice_plus_one, Zdouble_plus_one_mult. + rewrite phi_twice; auto. + change (Zdouble [|y|]) with (2*[|y|]). + rewrite inj_S, Zpower_Zsucc; auto with zarith. + rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod. + rewrite Zmult_plus_distr_l, Zmult_1_l, <- Zplus_assoc. + f_equal. + apply Zplus_eq_compat. + ring. + assert ((2*[|y|]) mod wB = 2*[|y|] - wB). + admit. + rewrite H1. + replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by + (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring). + unfold Zminus; rewrite Zopp_mult_distr_l. + rewrite Z_div_plus; auto with zarith. + ring_simplify. + replace (31+-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring. + rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith. + 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|]). + Proof. + unfold w_pos_mod, znz_pos_mod, int31_op, compare31. + change [|31|] with 31%Z. + assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p). + intros. + generalize (phi_bounded w). + symmetry; apply Zmod_small. + split; auto with zarith. + apply Zlt_le_trans with wB; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + intros. + case_eq ([|p|] ?= 31); intros; + [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | + apply H; change ([|p|]>31)%Z in H0; auto with zarith ]. + change ([|p|]<31) in H0. + rewrite spec_add_mul_div by auto with zarith. + change [|0|] with 0%Z; rewrite Zmult_0_l, Zplus_0_l. + generalize (phi_bounded p)(phi_bounded w); intros. + assert (31-[|p|]<wB). + apply Zle_lt_trans with 31%Z; auto with zarith. + compute; auto. + assert ([|31-p|]=31-[|p|]). + unfold sub31; rewrite phi_phi_inv. + change [|31|] with 31%Z. + apply Zmod_small; auto with zarith. + rewrite spec_add_mul_div by (rewrite H4; auto with zarith). + change [|0|] with 0%Z; rewrite Zdiv_0_l, Zplus_0_r. + rewrite H4. + apply shift_unshift_mod_2; auto with zarith. + Qed. + + + (** Shift operations *) + + Lemma spec_head00: forall x, [|x|] = 0 -> [|head031 x|] = Zpos 31. + Proof. + intros. + generalize (phi_inv_phi x). + rewrite H; simpl. + intros H'; rewrite <- H'. + simpl; auto. + Qed. + + Fixpoint head031_alt n x := + match n with + | O => 0%nat + | S n => match firstl x with + | D0 => S (head031_alt n (shiftl x)) + | D1 => 0%nat + end + end. + + Lemma head031_equiv : + forall x, [|head031 x|] = Z_of_nat (head031_alt size x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H). + simpl; auto. + + 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). + assert (size <= 31)%nat by auto with arith. + + revert x H; induction size; intros. + simpl; auto. + unfold recl_aux; fold recl_aux. + unfold head031_alt; fold head031_alt. + rewrite H. + assert ([|phi_inv (Z_of_nat (31-S n))|] = Z_of_nat (31 - S n)). + rewrite phi_phi_inv. + apply Zmod_small. + split. + change 0 with (Z_of_nat O); apply inj_le; omega. + apply Zle_lt_trans with (Z_of_nat 31). + apply inj_le; omega. + compute; auto. + case_eq (firstl x); intros; auto. + rewrite plus_Sn_m, plus_n_Sm. + replace (S (31 - S n)) with (31 - n)%nat by omega. + rewrite <- IHn; [ | omega | ]. + f_equal; f_equal. + unfold add31. + rewrite H1. + f_equal. + change [|In|] with 1. + replace (31-n)%nat with (S (31 - S n))%nat by omega. + rewrite inj_S; ring. + + clear - H H2. + rewrite (sneakr_shiftl x) in H. + rewrite H2 in H. + case_eq (iszero (shiftl x)); intros; auto. + rewrite (iszero_eq0 _ H0) in H; discriminate. + Qed. + + Lemma phi_nz : forall x, 0 < [|x|] <-> x <> 0%int31. + Proof. + split; intros. + red; intro; subst x; discriminate. + assert ([|x|]<>0%Z). + contradict H. + rewrite <- (phi_inv_phi x); rewrite H; auto. + generalize (phi_bounded x); auto with zarith. + Qed. + + Lemma spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|head031 x|]) * [|x|] < wB. + Proof. + intros. + rewrite head031_equiv. + assert (nshiftl size x = 0%int31). + apply nshiftl_size. + revert x H H0. + unfold size at 2 5. + induction size. + simpl Z_of_nat. + intros. + compute in H0; rewrite H0 in H; discriminate. + + intros. + simpl head031_alt. + case_eq (firstl x); intros. + rewrite (inj_S (head031_alt n (shiftl x))), Zpower_Zsucc; auto with zarith. + rewrite <- Zmult_assoc, Zmult_comm, <- Zmult_assoc, <-(Zmult_comm 2). + rewrite <- Zdouble_mult, <- (phi_twice_firstl _ H1). + apply IHn. + + rewrite phi_nz; rewrite phi_nz in H; contradict H. + change twice with shiftl in H. + rewrite (sneakr_shiftl x), H1, H; auto. + + rewrite <- nshiftl_S_tail; auto. + + change (2^(Z_of_nat 0)) with 1; rewrite Zmult_1_l. + generalize (phi_bounded x); unfold size; split; auto with zarith. + change (2^(Z_of_nat 31)/2) with (2^(Z_of_nat (pred size))). + apply phi_lowerbound; auto. + Qed. + + Lemma spec_tail00: forall x, [|x|] = 0 -> [|tail031 x|] = Zpos 31. + Proof. + intros. + generalize (phi_inv_phi x). + rewrite H; simpl. + intros H'; rewrite <- H'. + simpl; auto. + Qed. + + Fixpoint tail031_alt n x := + match n with + | O => 0%nat + | S n => match firstr x with + | D0 => S (tail031_alt n (shiftr x)) + | D1 => 0%nat + end + end. + + Lemma tail031_equiv : + forall x, [|tail031 x|] = Z_of_nat (tail031_alt size x). + Proof. + intros. + case_eq (iszero x); intros. + rewrite (iszero_eq0 _ H). + simpl; auto. + + 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). + assert (size <= 31)%nat by auto with arith. + + revert x H; induction size; intros. + simpl; auto. + unfold recr_aux; fold recr_aux. + unfold tail031_alt; fold tail031_alt. + rewrite H. + assert ([|phi_inv (Z_of_nat (31-S n))|] = Z_of_nat (31 - S n)). + rewrite phi_phi_inv. + apply Zmod_small. + split. + change 0 with (Z_of_nat O); apply inj_le; omega. + apply Zle_lt_trans with (Z_of_nat 31). + apply inj_le; omega. + compute; auto. + case_eq (firstr x); intros; auto. + rewrite plus_Sn_m, plus_n_Sm. + replace (S (31 - S n)) with (31 - n)%nat by omega. + rewrite <- IHn; [ | omega | ]. + f_equal; f_equal. + unfold add31. + rewrite H1. + f_equal. + change [|In|] with 1. + replace (31-n)%nat with (S (31 - S n))%nat by omega. + rewrite inj_S; ring. + + clear - H H2. + rewrite (sneakl_shiftr x) in H. + rewrite H2 in H. + case_eq (iszero (shiftr x)); intros; auto. + rewrite (iszero_eq0 _ H0) in H; discriminate. + Qed. + + Lemma spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail031 x|]). + Proof. + intros. + rewrite tail031_equiv. + assert (nshiftr size x = 0%int31). + apply nshiftr_size. + revert x H H0. + induction size. + simpl Z_of_nat. + intros. + compute in H0; rewrite H0 in H; discriminate. + + intros. + simpl tail031_alt. + case_eq (firstr x); intros. + rewrite (inj_S (tail031_alt n (shiftr x))), Zpower_Zsucc; auto with zarith. + destruct (IHn (shiftr x)) as (y & Hy1 & Hy2). + + rewrite phi_nz; rewrite phi_nz in H; contradict H. + rewrite (sneakl_shiftr x), H1, H; auto. + + rewrite <- nshiftr_S_tail; auto. + + exists y; split; auto. + rewrite phi_eqn1; auto. + rewrite Zdouble_mult, Hy2; ring. + + exists [|shiftr x|]. + split. + generalize (phi_bounded (shiftr x)); auto with zarith. + rewrite phi_eqn2; auto. + rewrite Zdouble_plus_one_mult; simpl; ring. + Qed. + + (* Sqrt *) + + (* Direct transcription of an old proof + of a fortran program in boyer-moore *) + + Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). + Proof. + intros a; case (Z_mod_lt a 2); auto with zarith. + intros H1; rewrite Zmod_eq_full; auto with zarith. + Qed. + + Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + (j * k) + j <= ((j + k)/2 + 1) ^ 2. + Proof. + intros j k Hj; generalize Hj k; pattern j; apply natlike_ind; + auto; clear k j Hj. + intros _ k Hk; repeat rewrite Zplus_0_l. + apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. + intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. + rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l. + generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); + unfold Zsucc. + rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + intros k Hk _. + replace ((Zsucc j + Zsucc k) / 2) with ((j + k)/2 + 1). + generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). + unfold Zsucc; repeat rewrite Zpower_2; + repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. + auto with zarith. + rewrite Zplus_comm, <- Z_div_plus_full_l; auto with zarith. + apply f_equal2 with (f := Zdiv); auto with zarith. + Qed. + + Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. + Proof. + intros i j Hi Hj. + assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith). + apply Zlt_le_trans with (2 := sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij). + pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith. + Qed. + + Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. + Proof. + intros i Hi. + assert (H1: 0 <= i - 2) by auto with zarith. + assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. + replace i with (1* 2 + (i - 2)); auto with zarith. + rewrite Zpower_2, Z_div_plus_full_l; auto with zarith. + generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). + rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. + auto with zarith. + generalize (quotient_by_2 i). + rewrite Zpower_2 in H2 |- *; + repeat (rewrite Zmult_plus_distr_l || + rewrite Zmult_plus_distr_r || + rewrite Zmult_1_l || rewrite Zmult_1_r). + auto with zarith. + Qed. + + Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. + Proof. + intros i j Hi Hj Hd; rewrite Zpower_2. + apply Zle_trans with (j * (i/j)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + Qed. + + Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j -> (j + (i/j))/2 < j. + Proof. + intros i j Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto. + intros H1; contradict H; apply Zle_not_lt. + assert (2 * j <= j + (i/j)); auto with zarith. + apply Zle_trans with (2 * ((j + (i/j))/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + Qed. + + (* George's trick *) + Inductive ZcompareSpec (i j: Z): comparison -> Prop := + ZcompareSpecEq: i = j -> ZcompareSpec i j Eq + | ZcompareSpecLt: i < j -> ZcompareSpec i j Lt + | ZcompareSpecGt: j < i -> ZcompareSpec i j Gt. + + Lemma Zcompare_spec i j: ZcompareSpec i j (i ?= j). + Proof. + intros i j; case_eq (Zcompare i j); intros H. + apply ZcompareSpecEq; apply Zcompare_Eq_eq; auto. + apply ZcompareSpecLt; auto. + apply ZcompareSpecGt; apply Zgt_lt; auto. + Qed. + + Lemma sqrt31_step_def rec i j: + sqrt31_step rec i j = + match (fst (i/j) ?= j)%int31 with + Lt => rec i (fst ((j + fst(i/j))/2))%int31 + | _ => j + end. + Proof. + intros rec i j; unfold sqrt31_step; case div31; intros. + simpl; case compare31; auto. + Qed. + + Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. + intros i j Hj; generalize (spec_div i j Hj). + case div31; intros q r; simpl fst. + intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. + rewrite H1; ring. + Qed. + + Lemma sqrt31_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + 2 * [|j|] < wB -> + (forall j1 : int31, + 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|sqrt31_step rec i j|] ^ 2 <= [|i|] < ([|sqrt31_step rec i j|] + 1) ^ 2. + Proof. + assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). + intros rec i j 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; + 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|]). + split. + case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1. + replace ([|j|] + [|i|]/[|j|]) with + (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]) ; auto with zarith. + rewrite <- Hj1, Zdiv_1_r. + replace (1 + [|i|])%Z with (1 * 2 + ([|i|] - 1))%Z; try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|i|] - 1) /2)%Z by (apply Z_div_pos; auto with zarith). + change ([|2|]) with 2%Z; auto with zarith. + apply sqrt_test_false; auto with zarith. + rewrite spec_add, div31_phi; auto. + apply sym_equal; apply Zmod_small. + split; auto with zarith. + replace [|j + fst (i / j)%int31|] with ([|j|] + [|i|] / [|j|]). + apply sqrt_main; auto with zarith. + rewrite spec_add, div31_phi; auto. + apply sym_equal; apply Zmod_small. + split; auto with zarith. + Qed. + + Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> + [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z_of_nat size) -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z_of_nat size) -> + [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> + [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2. + Proof. + intros n; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec i j Hi Hj Hij H31 HHrec. + apply sqrt31_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite inj_S, Zpower_Zsucc. + apply Zle_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith. + apply Zle_0_nat. + Qed. + + Lemma spec_sqrt : forall x, + [|sqrt31 x|] ^ 2 <= [|x|] < ([|sqrt31 x|] + 1) ^ 2. + Proof. + intros i; unfold sqrt31. + generalize (spec_compare 1 i); case compare31; change [|1|] with 1; + intros Hi; auto with zarith. + repeat rewrite Zpower_2; auto with zarith. + apply iter31_sqrt_correct; auto with zarith. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + replace ([|i|]) with (1 * 2 + ([|i|] - 2))%Z; try ring. + assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply sqrt_init; auto. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply Zle_lt_trans with ([|i|]). + apply Z_mult_div_ge; auto with zarith. + case (phi_bounded i); auto. + intros j2 H1 H2; contradict H2; apply Zlt_not_le. + rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + apply Zle_lt_trans with ([|i|]); auto with zarith. + assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). + apply Zle_trans with (2 * ([|i|]/2)); auto with zarith. + apply Z_mult_div_ge; auto with zarith. + case (phi_bounded i); unfold size; auto with zarith. + change [|0|] with 0; auto with zarith. + case (phi_bounded i); repeat rewrite Zpower_2; auto with zarith. + Qed. + + Lemma sqrt312_step_def rec ih il j: + sqrt312_step rec ih il j = + match (ih ?= j)%int31 with + Eq => j + | Gt => j + | _ => + match (fst (div3121 ih il j) ?= j)%int31 with + Lt => let m := match j +c fst (div3121 ih il j) with + C0 m1 => fst (m1/2)%int31 + | C1 m1 => (fst (m1/2) + v30)%int31 + end in rec ih il m + | _ => j + end + end. + Proof. + intros rec ih il j; unfold sqrt312_step; case div3121; intros. + simpl; case compare31; auto. + Qed. + + Lemma sqrt312_lower_bound ih il j: + phi2 ih il < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. + Proof. + intros ih il j H1. + case (phi_bounded j); intros Hbj _. + case (phi_bounded il); intros Hbil _. + case (phi_bounded ih); intros Hbih Hbih1. + assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. + apply Zlt_square_simpl; auto with zarith. + repeat rewrite <-Zpower_2; apply Zle_lt_trans with (2 := H1). + apply Zle_trans with ([|ih|] * base)%Z; unfold phi2, base; + try rewrite Zpower_2; auto with zarith. + Qed. + + Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> + [|fst (div3121 ih il j)|] = phi2 ih il/[|j|])%Z. + Proof. + intros ih il j Hj Hj1. + generalize (spec_div21 ih il j Hj Hj1). + case div3121; intros q r (Hq, Hr). + apply Zdiv_unique with (phi r); auto with zarith. + simpl fst; apply trans_equal with (1 := Hq); ring. + Qed. + + Lemma sqrt312_step_correct rec ih il j: + 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] < [|j|] -> phi2 ih il < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> + [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il + < ([|sqrt312_step rec ih il j|] + 1) ^ 2. + Proof. + assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). + intros rec ih il j Hih Hj Hij Hrec; rewrite sqrt312_step_def. + assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto). + case (phi_bounded ih); intros Hih1 _. + case (phi_bounded il); intros Hil1 _. + case (phi_bounded j); intros _ Hj1. + assert (Hp3: (0 < phi2 ih il)). + 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. + split; auto. + apply sqrt_test_true; auto. + unfold phi2, base; auto with zarith. + unfold phi2; rewrite Hc1. + assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + 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 div312_phi; auto; intros Hc; + try (split; auto; apply sqrt_test_true; auto with zarith; fail). + apply Hrec. + assert (Hf1: 0 <= phi2 ih il/ [|j|]) by (apply Z_div_pos; auto with zarith). + case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. + 2: contradict Hc; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. + assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). + replace ([|j|] + phi2 ih il/ [|j|])%Z with + (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith. + assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). + apply sqrt_test_false; auto with zarith. + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + rewrite div31_phi; change [|2|] with 2%Z; auto with zarith. + intros HH; rewrite HH; clear HH; auto with zarith. + rewrite spec_add, div31_phi; change [|2|] with 2%Z; auto. + rewrite Zmult_1_l; intros HH. + rewrite Zplus_comm, <- Z_div_plus_full_l; auto with zarith. + change (phi v30 * 2) with (2 ^ Z_of_nat size). + rewrite HH, Zmod_small; auto with zarith. + replace (phi + match j +c fst (div3121 ih il j) with + | C0 m1 => fst (m1 / 2)%int31 + | C1 m1 => fst (m1 / 2)%int31 + v30 + end) with ((([|j|] + (phi2 ih il)/([|j|]))/2)). + apply sqrt_main; auto with zarith. + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + rewrite div31_phi; auto with zarith. + intros HH; rewrite HH; auto with zarith. + intros HH; rewrite <- HH. + change (1 * 2 ^ Z_of_nat size) with (phi (v30) * 2). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite Zplus_comm. + rewrite spec_add, Zmod_small. + rewrite div31_phi; auto. + split; auto with zarith. + case (phi_bounded (fst (r/2)%int31)); + case (phi_bounded v30); auto with zarith. + rewrite div31_phi; change (phi 2) with 2%Z; auto. + change (2 ^Z_of_nat size) with (base/2 + phi v30). + assert (phi r / 2 < base/2); auto with zarith. + apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. + change (base/2 * 2) with base. + apply Zle_lt_trans with (phi r). + rewrite Zmult_comm; apply Z_mult_div_ge; auto with zarith. + case (phi_bounded r); auto with zarith. + contradict Hij; apply Zle_not_lt. + assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. + apply Zle_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. + assert (0 <= 1 + [|j|]); auto with zarith. + apply Zmult_le_compat; auto with zarith. + change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). + apply Zle_trans with ([|ih|] * base); auto with zarith. + unfold phi2, base; auto with zarith. + split; auto. + apply sqrt_test_true; auto. + unfold phi2, base; auto with zarith. + apply Zle_ge; apply Zle_trans with (([|j|] * base)/[|j|]). + rewrite Zmult_comm, Z_div_mult; auto with zarith. + apply Zge_le; apply Z_div_ge; auto with zarith. + Qed. + + Lemma iter312_sqrt_correct n rec ih il j: + 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + phi2 ih il < ([|j1|] + 1) ^ 2 -> + [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> + [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il + < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. + Proof. + intros n; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. + intros; apply Hrec; auto with zarith. + rewrite Zpower_0_r; auto with zarith. + intros n Hrec rec ih il j Hi Hj Hij HHrec. + apply sqrt312_step_correct; auto. + intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. + intros j3 Hj3 Hpj3. + apply HHrec; auto. + rewrite inj_S, Zpower_Zsucc. + apply Zle_trans with (2 ^Z_of_nat n + [|j2|])%Z; auto with zarith. + apply Zle_0_nat. + Qed. + + Lemma spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := sqrt312 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros ih il Hih; unfold sqrt312. + change [||WW ih il||] with (phi2 ih il). + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + (intros s; ring). + assert (Hb: 0 <= base) by (red; intros HH; discriminate). + assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2). + change ((phi Tn + 1) ^ 2) with (2^62). + apply Zle_lt_trans with ((2^31 -1) * base + (2^31 - 1)); auto with zarith. + 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. + 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. + apply Zlt_not_le. + change [|Tn|] with 2147483647; auto with zarith. + change (2 ^ Z_of_nat 31) with 2147483648; auto with zarith. + case (phi_bounded j1); auto with zarith. + set (s := iter312_sqrt 31 (fun _ _ j : int31 => j) ih il Tn). + intros Hs1 Hs2. + generalize (spec_mul_c s s); case mul31c. + simpl zn2z_to_Z; intros HH. + assert ([|s|] = 0). + case (Zmult_integral _ _ (sym_equal HH)); auto. + contradict Hs2; apply Zle_not_lt; rewrite H. + change ((0 + 1) ^ 2) with 1. + apply Zle_trans with (2 ^ Z_of_nat size / 4 * base). + simpl; auto with zarith. + apply Zle_trans with ([|ih|] * base); auto with zarith. + unfold phi2; case (phi_bounded il); auto with zarith. + intros ih1 il1. + change [||WW ih1 il1||] with (phi2 ih1 il1). + intros Hihl1. + generalize (spec_sub_c il il1). + case sub31c; intros il2 Hil2. + simpl interp_carry in Hil2. + generalize (spec_compare ih ih1); case compare31. + unfold interp_carry. + intros H1; split. + rewrite Zpower_2, <- Hihl1. + unfold phi2; ring[Hil2 H1]. + replace [|il2|] with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2; rewrite H1, Hil2; ring. + unfold interp_carry. + intros H1; contradict Hs1. + apply Zlt_not_le; rewrite Zpower_2, <-Hihl1. + unfold phi2. + case (phi_bounded il); intros _ H2. + apply Zlt_le_trans with (([|ih|] + 1) * base + 0). + rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith. + case (phi_bounded il1); intros H3 _. + apply Zplus_le_compat; auto with zarith. + unfold interp_carry; change (1 * 2 ^ Z_of_nat size) with base. + rewrite Zpower_2, <- Hihl1, Hil2. + intros H1. + case (Zle_lt_or_eq ([|ih1|] + 1) ([|ih|])); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). + unfold phi2. + case (phi_bounded il); intros Hpil _. + assert (Hl1l: [|il1|] <= [|il|]). + case (phi_bounded il2); rewrite Hil2; auto with zarith. + assert ([|ih1|] * base + 2 * [|s|] + 1 <= [|ih|] * base); auto with zarith. + case (phi_bounded s); change (2 ^ Z_of_nat size) with base; intros _ Hps. + case (phi_bounded ih1); intros Hpih1 _; auto with zarith. + apply Zle_trans with (([|ih1|] + 2) * base); auto with zarith. + rewrite Zmult_plus_distr_l. + assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. + rewrite Hihl1, Hbin; auto. + intros H2; split. + unfold phi2; rewrite <- H2; ring. + replace (base + ([|il|] - [|il1|])) with (phi2 ih il - ([|s|] * [|s|])). + rewrite <-Hbin in Hs2; auto with zarith. + rewrite <- Hihl1; unfold phi2; rewrite <- H2; ring. + unfold interp_carry in Hil2 |- *. + unfold interp_carry; change (1 * 2 ^ Z_of_nat size) with base. + assert (Hsih: [|ih - 1|] = [|ih|] - 1). + rewrite spec_sub, Zmod_small; auto; change [|1|] with 1. + 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 Hsih. + intros H1; split. + rewrite Zpower_2, <- Hihl1. + unfold phi2; rewrite <-H1. + apply trans_equal with ([|ih|] * base + [|il1|] + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2. + change (2 ^ Z_of_nat size) with base; ring. + replace [|il2|] with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2. + rewrite <-H1. + ring_simplify. + apply trans_equal with (base + ([|il|] - [|il1|])). + ring. + rewrite <-Hil2. + change (2 ^ Z_of_nat size) with base; ring. + rewrite Hsih; intros H1. + assert (He: [|ih|] = [|ih1|]). + apply Zle_antisym; auto with zarith. + case (Zle_or_lt [|ih1|] [|ih|]); auto; intros H2. + contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, <-Hihl1. + unfold phi2. + case (phi_bounded il); change (2 ^ Z_of_nat size) with base; + intros _ Hpil1. + apply Zlt_le_trans with (([|ih|] + 1) * base). + rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith. + case (phi_bounded il1); intros Hpil2 _. + apply Zle_trans with (([|ih1|]) * base); auto with zarith. + rewrite Zpower_2, <-Hihl1; unfold phi2; rewrite <-He. + contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, <-Hihl1. + unfold phi2; rewrite He. + assert (phi il - phi il1 < 0); auto with zarith. + rewrite <-Hil2. + case (phi_bounded il2); auto with zarith. + intros H1. + rewrite Zpower_2, <-Hihl1. + case (Zle_lt_or_eq ([|ih1|] + 2) [|ih|]); auto with zarith. + intros H2; contradict Hs2; apply Zle_not_lt. + replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). + unfold phi2. + assert ([|ih1|] * base + 2 * phi s + 1 <= [|ih|] * base + ([|il|] - [|il1|])); + auto with zarith. + rewrite <-Hil2. + change (-1 * 2 ^ Z_of_nat size) with (-base). + case (phi_bounded il2); intros Hpil2 _. + apply Zle_trans with ([|ih|] * base + - base); auto with zarith. + case (phi_bounded s); change (2 ^ Z_of_nat size) with base; intros _ Hps. + assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. + apply Zle_trans with ([|ih1|] * base + 2 * base); auto with zarith. + assert (Hi: ([|ih1|] + 3) * base <= [|ih|] * base); auto with zarith. + rewrite Zmult_plus_distr_l in Hi; auto with zarith. + rewrite Hihl1, Hbin; auto. + intros H2; unfold phi2; rewrite <-H2. + split. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2. + change (-1 * 2 ^ Z_of_nat size) with (-base); ring. + replace (base + [|il2|]) with (phi2 ih il - phi2 ih1 il1). + rewrite Hihl1. + rewrite <-Hbin in Hs2; auto with zarith. + unfold phi2; rewrite <-H2. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + rewrite <-Hil2. + change (-1 * 2 ^ Z_of_nat size) with (-base); ring. + Qed. + + (** [iszero] *) + + Let w_eq0 := int31_op.(znz_eq0). + + Lemma spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. + Proof. + clear; unfold w_eq0, znz_eq0; simpl. + unfold compare31; simpl; intros. + change [|0|] with 0 in H. + apply Zcompare_Eq_eq. + now destruct ([|x|] ?= 0). + Qed. + + (* 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. + Proof. + unfold w_is_even; simpl; intros. + generalize (spec_div x 2). + destruct (x/2)%int31 as (q,r); intros. + unfold compare31. + change [|2|] with 2 in H. + change [|0|] with 0. + 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. + 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. + + +Module Int31Cyclic <: CyclicType. + Definition w := int31. + Definition w_op := int31_op. + Definition w_spec := int31_spec. +End Int31Cyclic. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v new file mode 100644 index 00000000..154b436b --- /dev/null +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -0,0 +1,469 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: Int31.v 11072 2008-06-08 16:13:37Z 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 + arithmetic. In fact it is more general than that. The only reason + for this use of 31 is the underlying mecanism for hardware-efficient + computations by A. Spiwack. Apart from this, a switch to, say, + 63-bit integers is now just a matter of replacing every occurences + of 31 by 63. This is actually made possible by the use of + dependently-typed n-ary constructions for the inductive type + [int31], its constructor [I31] and any pattern matching on it. + If you modify this file, please preserve this genericity. *) + +Definition size := 31%nat. + +(** Digits *) + +Inductive digits : Type := D0 | D1. + +(** The type of 31-bit integers *) + +(** The type [int31] has a unique constructor [I31] that expects + 31 arguments of type [digits]. *) + +Inductive int31 : Type := I31 : nfun digits size int31. + +(* spiwack: Registration of the type of integers, so that the matchs in + the functions below perform dynamic decompilation (otherwise some segfault + occur when they are applied to one non-closed term and one closed term). *) +Register digits as int31 bits in "coq_int31" by True. +Register int31 as int31 type in "coq_int31" by True. + +Delimit Scope int31_scope with int31. +Bind Scope int31_scope with int31. +Open Scope int31_scope. + +(** * Constants *) + +(** Zero is [I31 D0 ... D0] *) +Definition On : int31 := Eval compute in napply_cst _ _ D0 size I31. + +(** One is [I31 D0 ... D0 D1] *) +Definition In : int31 := Eval compute in (napply_cst _ _ D0 (size-1) I31) D1. + +(** The biggest integer is [I31 D1 ... D1], corresponding to [(2^size)-1] *) +Definition Tn : int31 := Eval compute in napply_cst _ _ D1 size I31. + +(** Two is [I31 D0 ... D0 D1 D0] *) +Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D0. + +(** * Bits manipulation *) + + +(** [sneakr b x] shifts [x] to the right by one bit. + Rightmost digit is lost while leftmost digit becomes [b]. + Pseudo-code is + [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ] +*) + +Definition sneakr : digits -> int31 -> int31 := Eval compute in + fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)). + +(** [sneakl b x] shifts [x] to the left by one bit. + Leftmost digit is lost while rightmost digit becomes [b]. + Pseudo-code is + [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ] +*) + +Definition sneakl : digits -> int31 -> int31 := Eval compute in + fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31). + + +(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct + consequences of [sneakl] and [sneakr]. *) + +Definition shiftl := sneakl D0. +Definition shiftr := sneakr D0. +Definition twice := sneakl D0. +Definition twice_plus_one := sneakl D1. + +(** [firstl x] returns the leftmost digit of number [x]. + Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *) + +Definition firstl : int31 -> digits := Eval compute in + int31_rect _ (fun d => napply_discard _ _ d (size-1)). + +(** [firstr x] returns the rightmost digit of number [x]. + Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *) + +Definition firstr : int31 -> digits := Eval compute in + int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)). + +(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is + [ match x with (I31 D0 ... D0) => true | _ => false end ] *) + +Definition iszero : int31 -> bool := Eval compute in + let f d b := match d with D0 => b | D1 => false end + in int31_rect _ (nfold_bis _ _ f true size). + +(* NB: DO NOT transform the above match in a nicer (if then else). + It seems to work, but later "unfold iszero" takes forever. *) + + +(** [base] is [2^31], obtained via iterations of [Zdouble]. + It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 + (see below) *) + +Definition base := Eval compute in + iter_nat size Z Zdouble 1%Z. + +(** * Recursors *) + +Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + if iszero i then + case0 + else + let si := shiftl i in + caserec (firstl i) si (recl_aux next A case0 caserec si) + end. + +Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + (i:int31) : A := + match n with + | O => case0 + | S next => + if iszero i then + case0 + else + let si := shiftr i in + caserec (firstr i) si (recr_aux next A case0 caserec si) + end. + +Definition recl := recl_aux size. +Definition recr := recr_aux size. + +(** * Conversions *) + +(** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *) + +Definition phi : int31 -> Z := + recr Z (0%Z) + (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end). + +(** From positive to int31. An abstract definition could be : + [ phi_inv (2n) = 2*(phi_inv n) /\ + phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *) + +Fixpoint phi_inv_positive p := + match p with + | xI q => twice_plus_one (phi_inv_positive q) + | xO q => twice (phi_inv_positive q) + | xH => In + end. + +(** The negative part : 2-complement *) + +Fixpoint complement_negative p := + match p with + | xI q => twice (complement_negative q) + | xO q => twice_plus_one (complement_negative q) + | xH => twice Tn + end. + +(** A simple incrementation function *) + +Definition incr : int31 -> int31 := + recr int31 In + (fun b si rec => match b with + | D0 => sneakl D1 si + | D1 => sneakl D0 rec end). + +(** We can now define the conversion from Z to int31. *) + +Definition phi_inv : Z -> int31 := fun n => + match n with + | Z0 => On + | Zpos p => phi_inv_positive p + | Zneg p => incr (complement_negative p) + end. + +(** [phi_inv2] is similar to [phi_inv] but returns a double word + [zn2z int31] *) + +Definition phi_inv2 n := + match n with + | Z0 => W0 + | _ => WW (phi_inv (n/base)%Z) (phi_inv n) + end. + +(** [phi2] is similar to [phi] but takes a double word (two args) *) + +Definition phi2 nh nl := + ((phi nh)*base+(phi nl))%Z. + +(** * Addition *) + +(** Addition modulo [2^31] *) + +Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)). +Notation "n + m" := (add31 n m) : int31_scope. + +(** Addition with carry (the result is thus exact) *) + +(* spiwack : when executed in non-compiled*) +(* mode, (phi n)+(phi m) is computed twice*) +(* it may be considered to optimize it *) + +Definition add31c (n m : int31) := + let npm := n+m in + match (phi npm ?= (phi n)+(phi m))%Z with + | Eq => C0 npm + | _ => C1 npm + end. +Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. + +(** Addition plus one with carry (the result is thus exact) *) + +Definition add31carryc (n m : int31) := + let npmpone_exact := ((phi n)+(phi m)+1)%Z in + let npmpone := phi_inv npmpone_exact in + match (phi npmpone ?= npmpone_exact)%Z with + | Eq => C0 npmpone + | _ => C1 npmpone + end. + +(** * Substraction *) + +(** Subtraction modulo [2^31] *) + +Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)). +Notation "n - m" := (sub31 n m) : int31_scope. + +(** Subtraction with carry (thus exact) *) + +Definition sub31c (n m : int31) := + let nmm := n-m in + match (phi nmm ?= (phi n)-(phi m))%Z with + | Eq => C0 nmm + | _ => C1 nmm + end. +Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope. + +(** subtraction minus one with carry (thus exact) *) + +Definition sub31carryc (n m : int31) := + let nmmmone_exact := ((phi n)-(phi m)-1)%Z in + let nmmmone := phi_inv nmmmone_exact in + match (phi nmmmone ?= nmmmone_exact)%Z with + | Eq => C0 nmmmone + | _ => C1 nmmmone + end. + + +(** Multiplication *) + +(** multiplication modulo [2^31] *) + +Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)). +Notation "n * m" := (mul31 n m) : int31_scope. + +(** multiplication with double word result (thus exact) *) + +Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)). +Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope. + + +(** * Division *) + +(** Division of a double size word modulo [2^31] *) + +Definition div3121 (nh nl m : int31) := + let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in + (phi_inv q, phi_inv r). + +(** Division modulo [2^31] *) + +Definition div31 (n m : int31) := + let (q,r) := Zdiv_eucl (phi n) (phi m) in + (phi_inv q, phi_inv r). +Notation "n / m" := (div31 n m) : int31_scope. + + +(** * Unsigned comparison *) + +Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. +Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. + + +(** Computing the [i]-th iterate of a function: + [iter_int31 i A f = f^i] *) + +Definition iter_int31 i A f := + recr (A->A) (fun x => x) + (fun b si rec => match b with + | D0 => fun x => rec (rec x) + | D1 => fun x => f (rec (rec x)) + end) + i. + +(** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]: + [addmuldiv31 p i j = i*2^p+j/2^(31-p)] (modulo [2^31]) *) + +Definition addmuldiv31 p i j := + let (res, _ ) := + iter_int31 p (int31*int31) + (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j)) + (i,j) + in + res. + + +Register add31 as int31 plus in "coq_int31" by True. +Register add31c as int31 plusc in "coq_int31" by True. +Register add31carryc as int31 pluscarryc in "coq_int31" by True. +Register sub31 as int31 minus in "coq_int31" by True. +Register sub31c as int31 minusc in "coq_int31" by True. +Register sub31carryc as int31 minuscarryc in "coq_int31" by True. +Register mul31 as int31 times in "coq_int31" by True. +Register mul31c as int31 timesc in "coq_int31" by True. +Register div3121 as int31 div21 in "coq_int31" by True. +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. + +(** Square root functions using newton iteration + we use a very naive upper-bound on the iteration + 2^31 instead of the usual 31. +**) + + + +Definition sqrt31_step (rec: int31 -> int31 -> int31) (i j: int31) := +Eval lazy delta [Twon] in + let (quo,_) := i/j in + match quo ?= j with + Lt => rec i (fst ((j + quo)/Twon)) + | _ => j + end. + +Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) + (i j: int31) {struct n} : int31 := + sqrt31_step + (match n with + O => rec + | S n => (iter31_sqrt n (iter31_sqrt n rec)) + end) i j. + +Definition sqrt31 i := +Eval lazy delta [On In Twon] in + match compare31 In i with + Gt => On + | Eq => In + | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon)) + end. + +Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On). + +Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) + (ih il j: int31) := +Eval lazy delta [Twon v30] in + match ih ?= j with Eq => j | Gt => j | _ => + let (quo,_) := div3121 ih il j in + match quo ?= j with + Lt => let m := match j +c quo with + C0 m1 => fst (m1/Twon) + | C1 m1 => fst (m1/Twon) + v30 + end in rec ih il m + | _ => j + end end. + +Fixpoint iter312_sqrt (n: nat) + (rec: int31 -> int31 -> int31 -> int31) + (ih il j: int31) {struct n} : int31 := + sqrt312_step + (match n with + O => rec + | S n => (iter312_sqrt n (iter312_sqrt n rec)) + end) ih il j. + +Definition sqrt312 ih il := +Eval lazy delta [On In] in + let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in + match s *c s with + W0 => (On, C0 On) (* impossible *) + | WW ih1 il1 => + match il -c il1 with + C0 il2 => + match ih ?= ih1 with + Gt => (s, C1 il2) + | _ => (s, C0 il2) + end + | C1 il2 => + match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *) + Gt => (s, C1 il2) + | _ => (s, C0 il2) + end + end + end. + + +Fixpoint p2i n p : (N*int31)%type := + match n with + | O => (Npos p, On) + | S n => match p with + | xO p => let (r,i) := p2i n p in (r, Twon*i) + | xI p => let (r,i) := p2i n p in (r, Twon*i+In) + | xH => (N0, In) + end + end. + +Definition positive_to_int31 (p:positive) := p2i size p. + +(** Constant 31 converted into type int31. + It is used as default answer for numbers of zeros + in [head0] and [tail0] *) + +Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size). + +Definition head031 (i:int31) := + recl _ (fun _ => T31) + (fun b si rec n => match b with + | D0 => rec (add31 n In) + | D1 => n + end) + i On. + +Definition tail031 (i:int31) := + recr _ (fun _ => T31) + (fun b si rec n => match b with + | D0 => rec (add31 n In) + | D1 => n + end) + i On. + +Register head031 as int31 head0 in "coq_int31" by True. +Register tail031 as int31 tail0 in "coq_int31" by True. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v new file mode 100644 index 00000000..7c770e97 --- /dev/null +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -0,0 +1,946 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* $Id: ZModulo.v 11033 2008-06-01 22:56:50Z letouzey $ *) + +(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] + as defined abstractly in CyclicAxioms. *) + +(** Even if the construction provided here is not reused for building + the efficient arbitrary precision numbers, it provides a simple + implementation of CyclicAxioms, hence ensuring its coherence. *) + +Set Implicit Arguments. + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import DoubleType. +Require Import CyclicAxioms. + +Open Local Scope Z_scope. + +Section ZModulo. + + Variable digits : positive. + Hypothesis digits_ne_1 : digits <> 1%positive. + + Definition wB := base digits. + + Definition znz := Z. + Definition znz_digits := digits. + Definition znz_zdigits := Zpos digits. + Definition znz_to_Z x := x mod wB. + + Notation "[| x |]" := (znz_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). + + Notation "[-| c |]" := + (interp_carry (-1) wB znz_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). + + Lemma spec_more_than_1_digit: 1 < Zpos digits. + Proof. + unfold znz_digits. + generalize digits_ne_1; destruct digits; auto. + destruct 1; auto. + Qed. + Let digits_gt_1 := spec_more_than_1_digit. + + Lemma wB_pos : wB > 0. + Proof. + unfold wB, base; auto with zarith. + Qed. + Hint Resolve wB_pos. + + Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. + Proof. + unfold znz_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. + Qed. + Hint Resolve spec_to_Z_1 spec_to_Z_2. + + Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. + Proof. + auto. + Qed. + + Definition znz_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))|]. + Proof. + intros; unfold znz_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. + assert (0 <= z). + replace z with (Zpos p / wB) by + (symmetry; apply Zdiv_unique with z0; auto). + apply Z_div_pos; auto with zarith. + replace (Z_of_N (N_of_Z z)) with z by + (destruct z; simpl; auto; elim H1; auto). + rewrite Zmult_comm; auto. + Qed. + + Lemma spec_zdigits : [|znz_zdigits|] = Zpos znz_digits. + Proof. + unfold znz_to_Z, znz_zdigits, znz_digits. + 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. + + Lemma spec_0 : [|znz_0|] = 0. + Proof. + unfold znz_to_Z, znz_0. + apply Zmod_small; generalize wB_pos; auto with zarith. + Qed. + + Lemma spec_1 : [|znz_1|] = 1. + Proof. + unfold znz_to_Z, znz_1. + 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. + Proof. + unfold znz_to_Z, znz_Bm1. + apply Zmod_small; split; auto with zarith. + unfold wB, base. + cut (1 <= 2 ^ Zpos digits); auto with zarith. + apply Zle_trans with (Zpos digits); auto with zarith. + apply Zpower2_le_lin; auto with zarith. + Qed. + + Definition znz_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. + + Definition znz_eq0 x := + match [|x|] with Z0 => true | _ => false end. + + Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0. + Proof. + unfold znz_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. + + Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|]. + Proof. + intros; unfold znz_opp_c, znz_to_Z; auto. + case_eq (znz_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. + 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. + Proof. + intros; unfold znz_opp, znz_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. + Proof. + intros; unfold znz_opp_carry, znz_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. + rewrite <- (Z_mod_same_full wB). + rewrite Zplus_mod_idemp_l. + replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega. + apply Zmod_small. + generalize (Z_mod_lt x wB wB_pos); omega. + Qed. + + Definition znz_succ_c x := + let y := Zsucc x in + if znz_eq0 y then C1 0 else C0 y. + + Definition znz_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 := + 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. + + Lemma Zmod_equal : + forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. + Proof. + intros. + generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Zplus_0_r. + remember ((x-y)/z) as k. + intros H1; symmetry in H1; rewrite <- Zeq_plus_swap in H1. + subst x. + rewrite Zplus_comm, Zmult_comm, Z_mod_plus; auto. + Qed. + + Lemma spec_succ_c : forall x, [+|znz_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. + + rewrite Zmult_1_l. + replace (wB + 0 mod wB) with wB by auto with zarith. + symmetry; rewrite Zeq_plus_swap. + assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). + replace (wB-1) with ((wB-1) mod wB) by + (apply Zmod_small; generalize wB_pos; omega). + rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. + apply Zmod_equal; auto. + + assert ((x+1) mod wB <> 0). + unfold znz_eq0, znz_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. + rewrite <- Zplus_mod_idemp_l; rewrite H0. + replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto. + rewrite <- Zplus_mod_idemp_l. + apply Zmod_small. + generalize (Z_mod_lt x wB wB_pos); omega. + Qed. + + Lemma spec_add_c : forall x y, [+|znz_add_c x y|] = [|x|] + [|y|]. + Proof. + intros; unfold znz_add_c, znz_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. + rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap. + apply Zmod_small; + 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. + Proof. + intros; unfold znz_add_carry_c, znz_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. + rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap. + apply Zmod_small; + 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. + Proof. + intros; unfold znz_succ, znz_to_Z, Zsucc. + symmetry; apply Zplus_mod_idemp_l. + Qed. + + Lemma spec_add : forall x y, [|znz_add x y|] = ([|x|] + [|y|]) mod wB. + Proof. + intros; unfold znz_add, znz_to_Z; apply Zplus_mod. + Qed. + + Lemma spec_add_carry : + forall x y, [|znz_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + Proof. + intros; unfold znz_add_carry, znz_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 znz_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 := + 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. + + Lemma spec_pred_c : forall x, [-|znz_pred_c x|] = [|x|] - 1. + Proof. + intros; unfold znz_pred_c, znz_to_Z, interp_carry. + case_eq (znz_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). + 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|]. + Proof. + intros; unfold znz_sub_c, znz_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)). + omega. + symmetry; apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + + apply Zmod_small. + 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. + Proof. + intros; unfold znz_sub_carry_c, znz_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)). + omega. + symmetry; apply Zmod_small. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + + apply Zmod_small. + 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. + Proof. + intros; unfold znz_pred, znz_to_Z, Zpred. + rewrite <- Zplus_mod_idemp_l; auto. + Qed. + + Lemma spec_sub : forall x y, [|znz_sub x y|] = ([|x|] - [|y|]) mod wB. + Proof. + intros; unfold znz_sub, znz_to_Z; apply Zminus_mod. + Qed. + + Lemma spec_sub_carry : + forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + Proof. + intros; unfold znz_sub_carry, znz_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 := + 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. + + Definition znz_mul := Zmult. + + Definition znz_square_c x := znz_mul_c x x. + + Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|]. + Proof. + intros; unfold znz_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). + destruct 1; injection H; clear H; intros. + rewrite H0. + assert ([|l|] = l). + apply Zmod_small; auto. + assert ([|h|] = h). + apply Zmod_small. + subst h. + split. + apply Z_div_pos; auto with zarith. + 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. + 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. + Proof. + intros; unfold znz_mul, znz_to_Z; apply Zmult_mod. + Qed. + + Lemma spec_square_c : forall x, [|| znz_square_c x||] = [|x|] * [|x|]. + Proof. + intros x; exact (spec_mul_c x x). + Qed. + + Definition znz_div x y := Zdiv_eucl [|x|] [|y|]. + + Lemma spec_div : forall a b, 0 < [|b|] -> + let (q,r) := znz_div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros; unfold znz_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. + generalize (Z_div_mod [|a|] [|b|] H0). + destruct Zdiv_eucl as (q,r); destruct 1; intros. + injection H1; clear H1; intros. + assert ([|r|]=r). + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + auto with zarith. + assert ([|q|]=q). + apply Zmod_small. + subst q. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Zlt_le_trans with (wB*1). + rewrite Zmult_1_r; auto with zarith. + apply Zmult_le_compat; generalize wB_pos; auto with zarith. + rewrite H5, H6; rewrite Zmult_comm; auto with zarith. + Qed. + + Definition znz_div_gt := znz_div. + + Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := znz_div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros. + apply spec_div; auto. + Qed. + + Definition znz_mod x y := [|x|] mod [|y|]. + Definition znz_mod_gt x y := [|x|] mod [|y|]. + + Lemma spec_mod : forall a b, 0 < [|b|] -> + [|znz_mod a b|] = [|a|] mod [|b|]. + Proof. + intros; unfold znz_mod. + 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|]. + Proof. + intros; apply spec_mod; auto. + Qed. + + Definition znz_gcd x y := Zgcd [|x|] [|y|]. + Definition znz_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 (Z_eq_dec (Zgcd a b) 0). + rewrite e; generalize (Zmax_spec a b); omega. + assert (0 <= q). + apply Zmult_le_reg_r with (Zgcd a b); auto with zarith. + destruct (Z_eq_dec q 0). + + subst q; simpl in *; subst a; simpl; auto. + generalize (Zmax_spec 0 b) (Zabs_spec b); omega. + + apply Zle_trans with a. + rewrite H1 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|]. + Proof. + intros; unfold znz_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|]). + apply Zgcd_is_gcd. + symmetry; apply Zmod_small. + split. + apply Zgcd_is_pos. + apply Zle_lt_trans with (Zmax [|a|] [|b|]). + apply Zgcd_bound; auto with zarith. + generalize (Zmax_spec [|a|] [|b|]); omega. + Qed. + + Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|znz_gcd_gt a b|]. + Proof. + intros. apply spec_gcd; auto. + Qed. + + Definition znz_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 + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros; unfold znz_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. + remember ([|a1|]*wB+[|a2|]) as a. + assert (Zdiv_eucl a [|b|] = (a/[|b|], a mod [|b|])). + unfold Zmod, Zdiv; destruct Zdiv_eucl; auto. + generalize (Z_div_mod a [|b|] H3). + destruct Zdiv_eucl as (q,r); destruct 1; intros. + injection H4; clear H4; intros. + assert ([|r|]=r). + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + auto with zarith. + assert ([|q|]=q). + apply Zmod_small. + subst q. + split. + apply Z_div_pos; auto with zarith. + subst a; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + subst a; auto with zarith. + subst a. + replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring. + apply Zlt_le_trans with ([|a1|]*wB+wB); auto with zarith. + 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|]))). + Lemma spec_add_mul_div : forall x y p, + [|p|] <= Zpos znz_digits -> + [| znz_add_mul_div p x y |] = + ([|x|] * (2 ^ [|p|]) + + [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))) mod wB. + Proof. + intros; unfold znz_add_mul_div; auto. + Qed. + + Definition znz_pos_mod p w := [|w|] mod (2 ^ [|p|]). + Lemma spec_pos_mod : forall w p, + [|znz_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). + Proof. + intros; unfold znz_pos_mod. + apply Zmod_small. + generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. + split. + destruct H; auto with zarith. + apply Zle_lt_trans with [|w|]; auto with zarith. + apply Zmod_le; auto with zarith. + Qed. + + Definition znz_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. + Proof. + intros; unfold znz_is_even; destruct Z_eq_dec; auto. + generalize (Z_mod_lt [|x|] 2); omega. + Qed. + + Definition znz_sqrt x := Zsqrt_plain [|x|]. + Lemma spec_sqrt : forall x, + [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2. + Proof. + intros. + unfold znz_sqrt. + repeat rewrite Zpower_2. + replace [|Zsqrt_plain [|x|]|] with (Zsqrt_plain [|x|]). + apply Zsqrt_interval; 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. + Qed. + + Definition znz_sqrt2 x y := + let z := [|x|]*wB+[|y|] in + match z with + | Z0 => (0, C0 0) + | Zpos p => + let (s,r,_,_) := sqrtrempos 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 + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros; unfold znz_sqrt2. + simpl zn2z_to_Z. + remember ([|x|]*wB+[|y|]) as z. + destruct z. + auto with zarith. + destruct sqrtrempos; intros. + assert (s < wB). + destruct (Z_lt_le_dec s wB); auto. + assert (wB * wB <= Zpos p). + rewrite e. + apply Zle_trans with (s*s); try omega. + apply Zmult_le_compat; generalize wB_pos; auto with zarith. + assert (Zpos p < wB*wB). + rewrite Heqz. + replace (wB*wB) with ((wB-1)*wB+wB) by ring. + apply Zplus_le_lt_compat; auto with zarith. + apply Zmult_le_compat; auto with zarith. + generalize (spec_to_Z x); auto with zarith. + generalize wB_pos; auto with zarith. + omega. + replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith). + destruct Z_lt_le_dec; unfold interp_carry. + replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith). + rewrite Zpower_2; auto with zarith. + replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith). + rewrite Zpower_2; omega. + + assert (0<=Zneg p). + rewrite Heqz; generalize wB_pos; auto with zarith. + compute in H0; elim H0; auto. + Qed. + + Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x. + Proof. + intros. + unfold two_p. + destruct x; simpl; auto. + apply two_power_pos_correct. + Qed. + + Definition znz_head0 x := match [|x|] with + | Z0 => znz_zdigits + | Zpos p => znz_zdigits - log_inf p - 1 + | _ => 0 + end. + + Lemma spec_head00: forall x, [|x|] = 0 -> [|znz_head0 x|] = Zpos znz_digits. + Proof. + unfold znz_head0; intros. + rewrite H; simpl. + apply spec_zdigits. + Qed. + + Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p. + Proof. + induction x; simpl; intros. + + assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). + cut (log_inf x < p - 1); [omega| ]. + apply IHx. + change (Zpos x~1) with (2*(Zpos x)+1) in H. + replace p with (Zsucc (p-1)) in H; auto with zarith. + rewrite Zpower_Zsucc in H; auto with zarith. + + assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). + cut (log_inf x < p - 1); [omega| ]. + apply IHx. + change (Zpos x~0) with (2*(Zpos x)) in H. + replace p with (Zsucc (p-1)) in H; auto with zarith. + rewrite Zpower_Zsucc in H; auto with zarith. + + simpl; intros; destruct p; compute; auto with zarith. + Qed. + + + Lemma spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ ([|znz_head0 x|]) * [|x|] < wB. + Proof. + intros; unfold znz_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). + split. + cut (log_inf p < znz_zdigits); try omega. + unfold znz_zdigits. + unfold wB, base in *. + apply log_inf_bounded; auto with zarith. + apply Zlt_trans with znz_zdigits. + omega. + unfold znz_zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. + + unfold znz_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 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 + by ring. + unfold wB, base, znz_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)))). + 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 + by ring. + unfold wB, base, znz_zdigits; auto with zarith. + Qed. + + Fixpoint Ptail p := match p with + | xO p => (Ptail p)+1 + | _ => 0 + end. + + Lemma Ptail_pos : forall p, 0 <= Ptail p. + Proof. + induction p; simpl; auto with zarith. + Qed. + Hint Resolve Ptail_pos. + + Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. + Proof. + induction p; try (compute; auto; fail). + intros; simpl. + assert (d <> xH). + intro; subst. + compute in H; destruct p; discriminate. + assert (Zsucc (Zpos (Ppred d)) = Zpos d). + simpl; f_equal. + rewrite <- Pplus_one_succ_r. + destruct (Psucc_pred d); auto. + rewrite H1 in H0; elim H0; auto. + assert (Ptail p < Zpos (Ppred d)). + apply IHp. + apply Zmult_lt_reg_r with 2; auto with zarith. + rewrite (Zmult_comm (Zpos p)). + change (2 * Zpos p) with (Zpos p~0). + rewrite Zmult_comm. + rewrite <- Zpower_Zsucc; auto with zarith. + rewrite H1; auto. + rewrite <- H1; omega. + Qed. + + Definition znz_tail0 x := + match [|x|] with + | Z0 => znz_zdigits + | Zpos p => Ptail p + | Zneg _ => 0 + end. + + Lemma spec_tail00: forall x, [|x|] = 0 -> [|znz_tail0 x|] = Zpos znz_digits. + Proof. + unfold znz_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|]). + Proof. + intros; unfold znz_tail0. + generalize (spec_to_Z x). + destruct [|x|]; try discriminate; intros. + assert ([|Ptail p|] = Ptail p). + apply Zmod_small. + split; auto. + unfold wB, base in *. + apply Zlt_trans with (Zpos digits). + apply Ptail_bounded; auto with zarith. + apply Zpower2_lt_lin; auto with zarith. + rewrite H1. + + clear; induction p. + exists (Zpos p); simpl; rewrite Pmult_1_r; auto with zarith. + destruct IHp as (y & Yp & Ye). + exists y. + split; auto. + change (Zpos p~0) with (2*Zpos p). + rewrite Ye. + change (Ptail p~0) with (Zsucc (Ptail p)). + rewrite Zpower_Zsucc; auto; ring. + + exists 0; simpl; auto with zarith. + Qed. + + (** 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 + spec_to_Z + spec_of_pos + spec_zdigits + spec_more_than_1_digit + + spec_0 + spec_1 + spec_Bm1 + + spec_compare + spec_eq0 + + spec_opp_c + spec_opp + spec_opp_carry + + spec_succ_c + spec_add_c + spec_add_carry_c + spec_succ + spec_add + spec_add_carry + + spec_pred_c + spec_sub_c + spec_sub_carry_c + spec_pred + spec_sub + spec_sub_carry + + spec_mul_c + spec_mul + spec_square_c + + spec_div21 + spec_div_gt + spec_div + + spec_mod_gt + spec_mod + + spec_gcd_gt + spec_gcd + + spec_head00 + spec_head0 + spec_tail00 + spec_tail0 + + spec_add_mul_div + spec_pos_mod + + spec_is_even + spec_sqrt2 + spec_sqrt. + +End ZModulo. + +(** A modular version of the previous construction. *) + +Module Type PositiveNotOne. + Parameter p : 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. +End ZModuloCyclicType. + diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v new file mode 100644 index 00000000..df941d90 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -0,0 +1,345 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export ZBase. + +Module ZAddPropFunct (Import ZAxiomsMod : ZAxiomsSig). +Module Export ZBasePropMod := ZBasePropFunct ZAxiomsMod. +Open Local Scope IntScope. + +Theorem Zadd_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 + m1 == n2 + m2. +Proof NZadd_wd. + +Theorem Zadd_0_l : forall n : Z, 0 + n == n. +Proof NZadd_0_l. + +Theorem Zadd_succ_l : forall n m : Z, (S n) + m == S (n + m). +Proof NZadd_succ_l. + +Theorem Zsub_0_r : forall n : Z, n - 0 == n. +Proof NZsub_0_r. + +Theorem Zsub_succ_r : forall n m : Z, n - (S m) == P (n - m). +Proof NZsub_succ_r. + +Theorem Zopp_0 : - 0 == 0. +Proof Zopp_0. + +Theorem Zopp_succ : forall n : Z, - (S n) == P (- n). +Proof Zopp_succ. + +(* Theorems that are valid for both natural numbers and integers *) + +Theorem Zadd_0_r : forall n : Z, n + 0 == n. +Proof NZadd_0_r. + +Theorem Zadd_succ_r : forall n m : Z, n + S m == S (n + m). +Proof NZadd_succ_r. + +Theorem Zadd_comm : forall n m : Z, n + m == m + n. +Proof NZadd_comm. + +Theorem Zadd_assoc : forall n m p : Z, n + (m + p) == (n + m) + p. +Proof NZadd_assoc. + +Theorem Zadd_shuffle1 : forall n m p q : Z, (n + m) + (p + q) == (n + p) + (m + q). +Proof NZadd_shuffle1. + +Theorem Zadd_shuffle2 : forall n m p q : Z, (n + m) + (p + q) == (n + q) + (m + p). +Proof NZadd_shuffle2. + +Theorem Zadd_1_l : forall n : Z, 1 + n == S n. +Proof NZadd_1_l. + +Theorem Zadd_1_r : forall n : Z, n + 1 == S n. +Proof NZadd_1_r. + +Theorem Zadd_cancel_l : forall n m p : Z, p + n == p + m <-> n == m. +Proof NZadd_cancel_l. + +Theorem Zadd_cancel_r : forall n m p : Z, n + p == m + p <-> n == m. +Proof NZadd_cancel_r. + +(* Theorems that are either not valid on N or have different proofs on N and Z *) + +Theorem Zadd_pred_l : forall n m : Z, P n + m == P (n + m). +Proof. +intros n m. +rewrite <- (Zsucc_pred n) at 2. +rewrite Zadd_succ_l. now rewrite Zpred_succ. +Qed. + +Theorem Zadd_pred_r : forall n m : Z, n + P m == P (n + m). +Proof. +intros n m; rewrite (Zadd_comm n (P m)), (Zadd_comm n m); +apply Zadd_pred_l. +Qed. + +Theorem Zadd_opp_r : forall n m : Z, n + (- m) == n - m. +Proof. +NZinduct m. +rewrite Zopp_0; rewrite Zsub_0_r; now rewrite Zadd_0_r. +intro m. rewrite Zopp_succ, Zsub_succ_r, Zadd_pred_r; now rewrite Zpred_inj_wd. +Qed. + +Theorem Zsub_0_l : forall n : Z, 0 - n == - n. +Proof. +intro n; rewrite <- Zadd_opp_r; now rewrite Zadd_0_l. +Qed. + +Theorem Zsub_succ_l : forall n m : Z, S n - m == S (n - m). +Proof. +intros n m; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_succ_l. +Qed. + +Theorem Zsub_pred_l : forall n m : Z, P n - m == P (n - m). +Proof. +intros n m. rewrite <- (Zsucc_pred n) at 2. +rewrite Zsub_succ_l; now rewrite Zpred_succ. +Qed. + +Theorem Zsub_pred_r : forall n m : Z, n - (P m) == S (n - m). +Proof. +intros n m. rewrite <- (Zsucc_pred m) at 2. +rewrite Zsub_succ_r; now rewrite Zsucc_pred. +Qed. + +Theorem Zopp_pred : forall n : Z, - (P n) == S (- n). +Proof. +intro n. rewrite <- (Zsucc_pred n) at 2. +rewrite Zopp_succ. now rewrite Zsucc_pred. +Qed. + +Theorem Zsub_diag : forall n : Z, n - n == 0. +Proof. +NZinduct n. +now rewrite Zsub_0_r. +intro n. rewrite Zsub_succ_r, Zsub_succ_l; now rewrite Zpred_succ. +Qed. + +Theorem Zadd_opp_diag_l : forall n : Z, - n + n == 0. +Proof. +intro n; now rewrite Zadd_comm, Zadd_opp_r, Zsub_diag. +Qed. + +Theorem Zadd_opp_diag_r : forall n : Z, n + (- n) == 0. +Proof. +intro n; rewrite Zadd_comm; apply Zadd_opp_diag_l. +Qed. + +Theorem Zadd_opp_l : forall n m : Z, - m + n == n - m. +Proof. +intros n m; rewrite <- Zadd_opp_r; now rewrite Zadd_comm. +Qed. + +Theorem Zadd_sub_assoc : forall n m p : Z, n + (m - p) == (n + m) - p. +Proof. +intros n m p; do 2 rewrite <- Zadd_opp_r; now rewrite Zadd_assoc. +Qed. + +Theorem Zopp_involutive : forall n : Z, - (- n) == n. +Proof. +NZinduct n. +now do 2 rewrite Zopp_0. +intro n. rewrite Zopp_succ, Zopp_pred; now rewrite Zsucc_inj_wd. +Qed. + +Theorem Zopp_add_distr : forall n m : Z, - (n + m) == - n + (- m). +Proof. +intros n m; NZinduct n. +rewrite Zopp_0; now do 2 rewrite Zadd_0_l. +intro n. rewrite Zadd_succ_l; do 2 rewrite Zopp_succ; rewrite Zadd_pred_l. +now rewrite Zpred_inj_wd. +Qed. + +Theorem Zopp_sub_distr : forall n m : Z, - (n - m) == - n + m. +Proof. +intros n m; rewrite <- Zadd_opp_r, Zopp_add_distr. +now rewrite Zopp_involutive. +Qed. + +Theorem Zopp_inj : forall n m : Z, - n == - m -> n == m. +Proof. +intros n m H. apply Zopp_wd in H. now do 2 rewrite Zopp_involutive in H. +Qed. + +Theorem Zopp_inj_wd : forall n m : Z, - n == - m <-> n == m. +Proof. +intros n m; split; [apply Zopp_inj | apply Zopp_wd]. +Qed. + +Theorem Zeq_opp_l : forall n m : Z, - n == m <-> n == - m. +Proof. +intros n m. now rewrite <- (Zopp_inj_wd (- n) m), Zopp_involutive. +Qed. + +Theorem Zeq_opp_r : forall n m : Z, n == - m <-> - n == m. +Proof. +symmetry; apply Zeq_opp_l. +Qed. + +Theorem Zsub_add_distr : forall n m p : Z, n - (m + p) == (n - m) - p. +Proof. +intros n m p; rewrite <- Zadd_opp_r, Zopp_add_distr, Zadd_assoc. +now do 2 rewrite Zadd_opp_r. +Qed. + +Theorem Zsub_sub_distr : forall n m p : Z, n - (m - p) == (n - m) + p. +Proof. +intros n m p; rewrite <- Zadd_opp_r, Zopp_sub_distr, Zadd_assoc. +now rewrite Zadd_opp_r. +Qed. + +Theorem sub_opp_l : forall n m : Z, - n - m == - m - n. +Proof. +intros n m. do 2 rewrite <- Zadd_opp_r. now rewrite Zadd_comm. +Qed. + +Theorem Zsub_opp_r : forall n m : Z, n - (- m) == n + m. +Proof. +intros n m; rewrite <- Zadd_opp_r; now rewrite Zopp_involutive. +Qed. + +Theorem Zadd_sub_swap : forall n m p : Z, n + m - p == n - p + m. +Proof. +intros n m p. rewrite <- Zadd_sub_assoc, <- (Zadd_opp_r n p), <- Zadd_assoc. +now rewrite Zadd_opp_l. +Qed. + +Theorem Zsub_cancel_l : forall n m p : Z, n - m == n - p <-> m == p. +Proof. +intros n m p. rewrite <- (Zadd_cancel_l (n - m) (n - p) (- n)). +do 2 rewrite Zadd_sub_assoc. rewrite Zadd_opp_diag_l; do 2 rewrite Zsub_0_l. +apply Zopp_inj_wd. +Qed. + +Theorem Zsub_cancel_r : forall n m p : Z, n - p == m - p <-> n == m. +Proof. +intros n m p. +stepl (n - p + p == m - p + p) by apply Zadd_cancel_r. +now do 2 rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r. +Qed. + +(* The next several theorems are devoted to moving terms from one side of +an equation to the other. The name contains the operation in the original +equation (add or sub) and the indication whether the left or right term +is moved. *) + +Theorem Zadd_move_l : forall n m p : Z, n + m == p <-> m == p - n. +Proof. +intros n m p. +stepl (n + m - n == p - n) by apply Zsub_cancel_r. +now rewrite Zadd_comm, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +Qed. + +Theorem Zadd_move_r : forall n m p : Z, n + m == p <-> n == p - m. +Proof. +intros n m p; rewrite Zadd_comm; now apply Zadd_move_l. +Qed. + +(* The two theorems above do not allow rewriting subformulas of the form +n - m == p to n == p + m since subtraction is in the right-hand side of +the equation. Hence the following two theorems. *) + +Theorem Zsub_move_l : forall n m p : Z, n - m == p <-> - m == p - n. +Proof. +intros n m p; rewrite <- (Zadd_opp_r n m); apply Zadd_move_l. +Qed. + +Theorem Zsub_move_r : forall n m p : Z, n - m == p <-> n == p + m. +Proof. +intros n m p; rewrite <- (Zadd_opp_r n m). now rewrite Zadd_move_r, Zsub_opp_r. +Qed. + +Theorem Zadd_move_0_l : forall n m : Z, n + m == 0 <-> m == - n. +Proof. +intros n m; now rewrite Zadd_move_l, Zsub_0_l. +Qed. + +Theorem Zadd_move_0_r : forall n m : Z, n + m == 0 <-> n == - m. +Proof. +intros n m; now rewrite Zadd_move_r, Zsub_0_l. +Qed. + +Theorem Zsub_move_0_l : forall n m : Z, n - m == 0 <-> - m == - n. +Proof. +intros n m. now rewrite Zsub_move_l, Zsub_0_l. +Qed. + +Theorem Zsub_move_0_r : forall n m : Z, n - m == 0 <-> n == m. +Proof. +intros n m. now rewrite Zsub_move_r, Zadd_0_l. +Qed. + +(* The following section is devoted to cancellation of like terms. The name +includes the first operator and the position of the term being canceled. *) + +Theorem Zadd_simpl_l : forall n m : Z, n + m - n == m. +Proof. +intros; now rewrite Zadd_sub_swap, Zsub_diag, Zadd_0_l. +Qed. + +Theorem Zadd_simpl_r : forall n m : Z, n + m - m == n. +Proof. +intros; now rewrite <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +Qed. + +Theorem Zsub_simpl_l : forall n m : Z, - n - m + n == - m. +Proof. +intros; now rewrite <- Zadd_sub_swap, Zadd_opp_diag_l, Zsub_0_l. +Qed. + +Theorem Zsub_simpl_r : forall n m : Z, n - m + m == n. +Proof. +intros; now rewrite <- Zsub_sub_distr, Zsub_diag, Zsub_0_r. +Qed. + +(* Now we have two sums or differences; the name includes the two operators +and the position of the terms being canceled *) + +Theorem Zadd_add_simpl_l_l : forall n m p : Z, (n + m) - (n + p) == m - p. +Proof. +intros n m p. now rewrite (Zadd_comm n m), <- Zadd_sub_assoc, +Zsub_add_distr, Zsub_diag, Zsub_0_l, Zadd_opp_r. +Qed. + +Theorem Zadd_add_simpl_l_r : forall n m p : Z, (n + m) - (p + n) == m - p. +Proof. +intros n m p. rewrite (Zadd_comm p n); apply Zadd_add_simpl_l_l. +Qed. + +Theorem Zadd_add_simpl_r_l : forall n m p : Z, (n + m) - (m + p) == n - p. +Proof. +intros n m p. rewrite (Zadd_comm n m); apply Zadd_add_simpl_l_l. +Qed. + +Theorem Zadd_add_simpl_r_r : forall n m p : Z, (n + m) - (p + m) == n - p. +Proof. +intros n m p. rewrite (Zadd_comm p m); apply Zadd_add_simpl_r_l. +Qed. + +Theorem Zsub_add_simpl_r_l : forall n m p : Z, (n - m) + (m + p) == n + p. +Proof. +intros n m p. now rewrite <- Zsub_sub_distr, Zsub_add_distr, Zsub_diag, +Zsub_0_l, Zsub_opp_r. +Qed. + +Theorem Zsub_add_simpl_r_r : forall n m p : Z, (n - m) + (p + m) == n + p. +Proof. +intros n m p. rewrite (Zadd_comm p m); apply Zsub_add_simpl_r_l. +Qed. + +(* Of course, there are many other variants *) + +End ZAddPropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v new file mode 100644 index 00000000..101ea634 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -0,0 +1,373 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export ZLt. + +Module ZAddOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). +Module Export ZOrderPropMod := ZOrderPropFunct ZAxiomsMod. +Open Local Scope IntScope. + +(* Theorems that are true on both natural numbers and integers *) + +Theorem Zadd_lt_mono_l : forall n m p : Z, n < m <-> p + n < p + m. +Proof NZadd_lt_mono_l. + +Theorem Zadd_lt_mono_r : forall n m p : Z, n < m <-> n + p < m + p. +Proof NZadd_lt_mono_r. + +Theorem Zadd_lt_mono : forall n m p q : Z, n < m -> p < q -> n + p < m + q. +Proof NZadd_lt_mono. + +Theorem Zadd_le_mono_l : forall n m p : Z, n <= m <-> p + n <= p + m. +Proof NZadd_le_mono_l. + +Theorem Zadd_le_mono_r : forall n m p : Z, n <= m <-> n + p <= m + p. +Proof NZadd_le_mono_r. + +Theorem Zadd_le_mono : forall n m p q : Z, n <= m -> p <= q -> n + p <= m + q. +Proof NZadd_le_mono. + +Theorem Zadd_lt_le_mono : forall n m p q : Z, n < m -> p <= q -> n + p < m + q. +Proof NZadd_lt_le_mono. + +Theorem Zadd_le_lt_mono : forall n m p q : Z, n <= m -> p < q -> n + p < m + q. +Proof NZadd_le_lt_mono. + +Theorem Zadd_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n + m. +Proof NZadd_pos_pos. + +Theorem Zadd_pos_nonneg : forall n m : Z, 0 < n -> 0 <= m -> 0 < n + m. +Proof NZadd_pos_nonneg. + +Theorem Zadd_nonneg_pos : forall n m : Z, 0 <= n -> 0 < m -> 0 < n + m. +Proof NZadd_nonneg_pos. + +Theorem Zadd_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n + m. +Proof NZadd_nonneg_nonneg. + +Theorem Zlt_add_pos_l : forall n m : Z, 0 < n -> m < n + m. +Proof NZlt_add_pos_l. + +Theorem Zlt_add_pos_r : forall n m : Z, 0 < n -> m < m + n. +Proof NZlt_add_pos_r. + +Theorem Zle_lt_add_lt : forall n m p q : Z, n <= m -> p + m < q + n -> p < q. +Proof NZle_lt_add_lt. + +Theorem Zlt_le_add_lt : forall n m p q : Z, n < m -> p + m <= q + n -> p < q. +Proof NZlt_le_add_lt. + +Theorem Zle_le_add_le : forall n m p q : Z, n <= m -> p + m <= q + n -> p <= q. +Proof NZle_le_add_le. + +Theorem Zadd_lt_cases : forall n m p q : Z, n + m < p + q -> n < p \/ m < q. +Proof NZadd_lt_cases. + +Theorem Zadd_le_cases : forall n m p q : Z, n + m <= p + q -> n <= p \/ m <= q. +Proof NZadd_le_cases. + +Theorem Zadd_neg_cases : forall n m : Z, n + m < 0 -> n < 0 \/ m < 0. +Proof NZadd_neg_cases. + +Theorem Zadd_pos_cases : forall n m : Z, 0 < n + m -> 0 < n \/ 0 < m. +Proof NZadd_pos_cases. + +Theorem Zadd_nonpos_cases : forall n m : Z, n + m <= 0 -> n <= 0 \/ m <= 0. +Proof NZadd_nonpos_cases. + +Theorem Zadd_nonneg_cases : forall n m : Z, 0 <= n + m -> 0 <= n \/ 0 <= m. +Proof NZadd_nonneg_cases. + +(* Theorems that are either not valid on N or have different proofs on N and Z *) + +Theorem Zadd_neg_neg : forall n m : Z, n < 0 -> m < 0 -> n + m < 0. +Proof. +intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_mono. +Qed. + +Theorem Zadd_neg_nonpos : forall n m : Z, n < 0 -> m <= 0 -> n + m < 0. +Proof. +intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_lt_le_mono. +Qed. + +Theorem Zadd_nonpos_neg : forall n m : Z, n <= 0 -> m < 0 -> n + m < 0. +Proof. +intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_lt_mono. +Qed. + +Theorem Zadd_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> n + m <= 0. +Proof. +intros n m H1 H2. rewrite <- (Zadd_0_l 0). now apply Zadd_le_mono. +Qed. + +(** Sub and order *) + +Theorem Zlt_0_sub : forall n m : Z, 0 < m - n <-> n < m. +Proof. +intros n m. stepl (0 + n < m - n + n) by symmetry; apply Zadd_lt_mono_r. +rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +Qed. + +Notation Zsub_pos := Zlt_0_sub (only parsing). + +Theorem Zle_0_sub : forall n m : Z, 0 <= m - n <-> n <= m. +Proof. +intros n m; stepl (0 + n <= m - n + n) by symmetry; apply Zadd_le_mono_r. +rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +Qed. + +Notation Zsub_nonneg := Zle_0_sub (only parsing). + +Theorem Zlt_sub_0 : forall n m : Z, n - m < 0 <-> n < m. +Proof. +intros n m. stepl (n - m + m < 0 + m) by symmetry; apply Zadd_lt_mono_r. +rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +Qed. + +Notation Zsub_neg := Zlt_sub_0 (only parsing). + +Theorem Zle_sub_0 : forall n m : Z, n - m <= 0 <-> n <= m. +Proof. +intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply Zadd_le_mono_r. +rewrite Zadd_0_l; now rewrite Zsub_simpl_r. +Qed. + +Notation Zsub_nonpos := Zle_sub_0 (only parsing). + +Theorem Zopp_lt_mono : forall n m : Z, n < m <-> - m < - n. +Proof. +intros n m. stepr (m + - m < m + - n) by symmetry; apply Zadd_lt_mono_l. +do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zlt_0_sub. +Qed. + +Theorem Zopp_le_mono : forall n m : Z, n <= m <-> - m <= - n. +Proof. +intros n m. stepr (m + - m <= m + - n) by symmetry; apply Zadd_le_mono_l. +do 2 rewrite Zadd_opp_r. rewrite Zsub_diag. symmetry; apply Zle_0_sub. +Qed. + +Theorem Zopp_pos_neg : forall n : Z, 0 < - n <-> n < 0. +Proof. +intro n; rewrite (Zopp_lt_mono n 0); now rewrite Zopp_0. +Qed. + +Theorem Zopp_neg_pos : forall n : Z, - n < 0 <-> 0 < n. +Proof. +intro n. rewrite (Zopp_lt_mono 0 n). now rewrite Zopp_0. +Qed. + +Theorem Zopp_nonneg_nonpos : forall n : Z, 0 <= - n <-> n <= 0. +Proof. +intro n; rewrite (Zopp_le_mono n 0); now rewrite Zopp_0. +Qed. + +Theorem Zopp_nonpos_nonneg : forall n : Z, - n <= 0 <-> 0 <= n. +Proof. +intro n. rewrite (Zopp_le_mono 0 n). now rewrite Zopp_0. +Qed. + +Theorem Zsub_lt_mono_l : forall n m p : Z, n < m <-> p - m < p - n. +Proof. +intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite <- Zadd_lt_mono_l. +apply Zopp_lt_mono. +Qed. + +Theorem Zsub_lt_mono_r : forall n m p : Z, n < m <-> n - p < m - p. +Proof. +intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_lt_mono_r. +Qed. + +Theorem Zsub_lt_mono : forall n m p q : Z, n < m -> q < p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply NZlt_trans with (m - p); +[now apply -> Zsub_lt_mono_r | now apply -> Zsub_lt_mono_l]. +Qed. + +Theorem Zsub_le_mono_l : forall n m p : Z, n <= m <-> p - m <= p - n. +Proof. +intros n m p; do 2 rewrite <- Zadd_opp_r; rewrite <- Zadd_le_mono_l; +apply Zopp_le_mono. +Qed. + +Theorem Zsub_le_mono_r : forall n m p : Z, n <= m <-> n - p <= m - p. +Proof. +intros n m p; do 2 rewrite <- Zadd_opp_r; apply Zadd_le_mono_r. +Qed. + +Theorem Zsub_le_mono : forall n m p q : Z, n <= m -> q <= p -> n - p <= m - q. +Proof. +intros n m p q H1 H2. +apply NZle_trans with (m - p); +[now apply -> Zsub_le_mono_r | now apply -> Zsub_le_mono_l]. +Qed. + +Theorem Zsub_lt_le_mono : forall n m p q : Z, n < m -> q <= p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply NZlt_le_trans with (m - p); +[now apply -> Zsub_lt_mono_r | now apply -> Zsub_le_mono_l]. +Qed. + +Theorem Zsub_le_lt_mono : forall n m p q : Z, n <= m -> q < p -> n - p < m - q. +Proof. +intros n m p q H1 H2. +apply NZle_lt_trans with (m - p); +[now apply -> Zsub_le_mono_r | now apply -> Zsub_lt_mono_l]. +Qed. + +Theorem Zle_lt_sub_lt : forall n m p q : Z, n <= m -> p - n < q - m -> p < q. +Proof. +intros n m p q H1 H2. apply (Zle_lt_add_lt (- m) (- n)); +[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r]. +Qed. + +Theorem Zlt_le_sub_lt : forall n m p q : Z, n < m -> p - n <= q - m -> p < q. +Proof. +intros n m p q H1 H2. apply (Zlt_le_add_lt (- m) (- n)); +[now apply -> Zopp_lt_mono | now do 2 rewrite Zadd_opp_r]. +Qed. + +Theorem Zle_le_sub_lt : forall n m p q : Z, n <= m -> p - n <= q - m -> p <= q. +Proof. +intros n m p q H1 H2. apply (Zle_le_add_le (- m) (- n)); +[now apply -> Zopp_le_mono | now do 2 rewrite Zadd_opp_r]. +Qed. + +Theorem Zlt_add_lt_sub_r : forall n m p : Z, n + p < m <-> n < m - p. +Proof. +intros n m p. stepl (n + p - p < m - p) by symmetry; apply Zsub_lt_mono_r. +now rewrite Zadd_simpl_r. +Qed. + +Theorem Zle_add_le_sub_r : forall n m p : Z, n + p <= m <-> n <= m - p. +Proof. +intros n m p. stepl (n + p - p <= m - p) by symmetry; apply Zsub_le_mono_r. +now rewrite Zadd_simpl_r. +Qed. + +Theorem Zlt_add_lt_sub_l : forall n m p : Z, n + p < m <-> p < m - n. +Proof. +intros n m p. rewrite Zadd_comm; apply Zlt_add_lt_sub_r. +Qed. + +Theorem Zle_add_le_sub_l : forall n m p : Z, n + p <= m <-> p <= m - n. +Proof. +intros n m p. rewrite Zadd_comm; apply Zle_add_le_sub_r. +Qed. + +Theorem Zlt_sub_lt_add_r : forall n m p : Z, n - p < m <-> n < m + p. +Proof. +intros n m p. stepl (n - p + p < m + p) by symmetry; apply Zadd_lt_mono_r. +now rewrite Zsub_simpl_r. +Qed. + +Theorem Zle_sub_le_add_r : forall n m p : Z, n - p <= m <-> n <= m + p. +Proof. +intros n m p. stepl (n - p + p <= m + p) by symmetry; apply Zadd_le_mono_r. +now rewrite Zsub_simpl_r. +Qed. + +Theorem Zlt_sub_lt_add_l : forall n m p : Z, n - m < p <-> n < m + p. +Proof. +intros n m p. rewrite Zadd_comm; apply Zlt_sub_lt_add_r. +Qed. + +Theorem Zle_sub_le_add_l : forall n m p : Z, n - m <= p <-> n <= m + p. +Proof. +intros n m p. rewrite Zadd_comm; apply Zle_sub_le_add_r. +Qed. + +Theorem Zlt_sub_lt_add : forall n m p q : Z, n - m < p - q <-> n + q < m + p. +Proof. +intros n m p q. rewrite Zlt_sub_lt_add_l. rewrite Zadd_sub_assoc. +now rewrite <- Zlt_add_lt_sub_r. +Qed. + +Theorem Zle_sub_le_add : forall n m p q : Z, n - m <= p - q <-> n + q <= m + p. +Proof. +intros n m p q. rewrite Zle_sub_le_add_l. rewrite Zadd_sub_assoc. +now rewrite <- Zle_add_le_sub_r. +Qed. + +Theorem Zlt_sub_pos : forall n m : Z, 0 < m <-> n - m < n. +Proof. +intros n m. stepr (n - m < n - 0) by now rewrite Zsub_0_r. apply Zsub_lt_mono_l. +Qed. + +Theorem Zle_sub_nonneg : forall n m : Z, 0 <= m <-> n - m <= n. +Proof. +intros n m. stepr (n - m <= n - 0) by now rewrite Zsub_0_r. apply Zsub_le_mono_l. +Qed. + +Theorem Zsub_lt_cases : forall n m p q : Z, n - m < p - q -> n < m \/ q < p. +Proof. +intros n m p q H. rewrite Zlt_sub_lt_add in H. now apply Zadd_lt_cases. +Qed. + +Theorem Zsub_le_cases : forall n m p q : Z, n - m <= p - q -> n <= m \/ q <= p. +Proof. +intros n m p q H. rewrite Zle_sub_le_add in H. now apply Zadd_le_cases. +Qed. + +Theorem Zsub_neg_cases : forall n m : Z, n - m < 0 -> n < 0 \/ 0 < m. +Proof. +intros n m H; rewrite <- Zadd_opp_r in H. +setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply Zopp_neg_pos). +now apply Zadd_neg_cases. +Qed. + +Theorem Zsub_pos_cases : forall n m : Z, 0 < n - m -> 0 < n \/ m < 0. +Proof. +intros n m H; rewrite <- Zadd_opp_r in H. +setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply Zopp_pos_neg). +now apply Zadd_pos_cases. +Qed. + +Theorem Zsub_nonpos_cases : forall n m : Z, n - m <= 0 -> n <= 0 \/ 0 <= m. +Proof. +intros n m H; rewrite <- Zadd_opp_r in H. +setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply Zopp_nonpos_nonneg). +now apply Zadd_nonpos_cases. +Qed. + +Theorem Zsub_nonneg_cases : forall n m : Z, 0 <= n - m -> 0 <= n \/ m <= 0. +Proof. +intros n m H; rewrite <- Zadd_opp_r in H. +setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply Zopp_nonneg_nonpos). +now apply Zadd_nonneg_cases. +Qed. + +Section PosNeg. + +Variable P : Z -> Prop. +Hypothesis P_wd : predicate_wd Zeq P. + +Add Morphism P with signature Zeq ==> iff as P_morph. Proof. exact P_wd. Qed. + +Theorem Z0_pos_neg : + P 0 -> (forall n : Z, 0 < n -> P n /\ P (- n)) -> forall n : Z, P n. +Proof. +intros H1 H2 n. destruct (Zlt_trichotomy n 0) as [H3 | [H3 | H3]]. +apply <- Zopp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3]. +now rewrite Zopp_involutive in H3. +now rewrite H3. +apply H2 in H3; now destruct H3. +Qed. + +End PosNeg. + +Ltac Z0_pos_neg n := induction_maker n ltac:(apply Z0_pos_neg). + +End ZAddOrderPropFunct. + + diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v new file mode 100644 index 00000000..c4a4b6b8 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -0,0 +1,65 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NZAxioms. + +Set Implicit Arguments. + +Module Type ZAxiomsSig. +Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig. + +Delimit Scope IntScope with Int. +Notation Z := NZ. +Notation Zeq := NZeq. +Notation Z0 := NZ0. +Notation Z1 := (NZsucc NZ0). +Notation S := NZsucc. +Notation P := NZpred. +Notation Zadd := NZadd. +Notation Zmul := NZmul. +Notation Zsub := NZsub. +Notation Zlt := NZlt. +Notation Zle := NZle. +Notation Zmin := NZmin. +Notation Zmax := NZmax. +Notation "x == y" := (NZeq x y) (at level 70) : IntScope. +Notation "x ~= y" := (~ NZeq x y) (at level 70) : IntScope. +Notation "0" := NZ0 : IntScope. +Notation "1" := (NZsucc NZ0) : IntScope. +Notation "x + y" := (NZadd x y) : IntScope. +Notation "x - y" := (NZsub x y) : IntScope. +Notation "x * y" := (NZmul x y) : IntScope. +Notation "x < y" := (NZlt x y) : IntScope. +Notation "x <= y" := (NZle x y) : IntScope. +Notation "x > y" := (NZlt y x) (only parsing) : IntScope. +Notation "x >= y" := (NZle y x) (only parsing) : IntScope. + +Parameter Zopp : Z -> Z. + +(*Notation "- 1" := (Zopp 1) : IntScope. +Check (-1).*) + +Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd. + +Notation "- x" := (Zopp x) (at level 35, right associativity) : IntScope. +Notation "- 1" := (Zopp (NZsucc NZ0)) : IntScope. + +Open Local Scope IntScope. + +(* Integers are obtained by postulating that every number has a predecessor *) +Axiom Zsucc_pred : forall n : Z, S (P n) == n. + +Axiom Zopp_0 : - 0 == 0. +Axiom Zopp_succ : forall n : Z, - (S n) == P (- n). + +End ZAxiomsSig. + diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v new file mode 100644 index 00000000..29e18548 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -0,0 +1,86 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export Decidable. +Require Export ZAxioms. +Require Import NZMulOrder. + +Module ZBasePropFunct (Import ZAxiomsMod : ZAxiomsSig). + +(* Note: writing "Export" instead of "Import" on the previous line leads to +some warnings about hiding repeated declarations and results in the loss of +notations in Zadd and later *) + +Open Local Scope IntScope. + +Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod. + +Theorem Zsucc_wd : forall n1 n2 : Z, n1 == n2 -> S n1 == S n2. +Proof NZsucc_wd. + +Theorem Zpred_wd : forall n1 n2 : Z, n1 == n2 -> P n1 == P n2. +Proof NZpred_wd. + +Theorem Zpred_succ : forall n : Z, P (S n) == n. +Proof NZpred_succ. + +Theorem Zeq_refl : forall n : Z, n == n. +Proof (proj1 NZeq_equiv). + +Theorem Zeq_symm : forall n m : Z, n == m -> m == n. +Proof (proj2 (proj2 NZeq_equiv)). + +Theorem Zeq_trans : forall n m p : Z, n == m -> m == p -> n == p. +Proof (proj1 (proj2 NZeq_equiv)). + +Theorem Zneq_symm : forall n m : Z, n ~= m -> m ~= n. +Proof NZneq_symm. + +Theorem Zsucc_inj : forall n1 n2 : Z, S n1 == S n2 -> n1 == n2. +Proof NZsucc_inj. + +Theorem Zsucc_inj_wd : forall n1 n2 : Z, S n1 == S n2 <-> n1 == n2. +Proof NZsucc_inj_wd. + +Theorem Zsucc_inj_wd_neg : forall n m : Z, S n ~= S m <-> n ~= m. +Proof NZsucc_inj_wd_neg. + +(* Decidability and stability of equality was proved only in NZOrder, but +since it does not mention order, we'll put it here *) + +Theorem Zeq_dec : forall n m : Z, decidable (n == m). +Proof NZeq_dec. + +Theorem Zeq_dne : forall n m : Z, ~ ~ n == m <-> n == m. +Proof NZeq_dne. + +Theorem Zcentral_induction : +forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, A z -> + (forall n : Z, A n <-> A (S n)) -> + forall n : Z, A n. +Proof NZcentral_induction. + +(* Theorems that are true for integers but not for natural numbers *) + +Theorem Zpred_inj : forall n m : Z, P n == P m -> n == m. +Proof. +intros n m H. apply NZsucc_wd in H. now do 2 rewrite Zsucc_pred in H. +Qed. + +Theorem Zpred_inj_wd : forall n1 n2 : Z, P n1 == P n2 <-> n1 == n2. +Proof. +intros n1 n2; split; [apply Zpred_inj | apply NZpred_wd]. +Qed. + +End ZBasePropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZDomain.v b/theories/Numbers/Integer/Abstract/ZDomain.v new file mode 100644 index 00000000..15beb2b9 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZDomain.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZDomain.v 10934 2008-05-15 21:58:20Z letouzey $ i*) + +Require Export NumPrelude. + +Module Type ZDomainSignature. + +Parameter Inline Z : Set. +Parameter Inline Zeq : Z -> Z -> Prop. +Parameter Inline e : Z -> Z -> bool. + +Axiom eq_equiv_e : forall x y : Z, Zeq x y <-> e x y. +Axiom eq_equiv : equiv Z Zeq. + +Add Relation Z Zeq + reflexivity proved by (proj1 eq_equiv) + symmetry proved by (proj2 (proj2 eq_equiv)) + transitivity proved by (proj1 (proj2 eq_equiv)) +as eq_rel. + +Delimit Scope IntScope with Int. +Bind Scope IntScope with Z. +Notation "x == y" := (Zeq x y) (at level 70) : IntScope. +Notation "x # y" := (~ Zeq x y) (at level 70) : IntScope. + +End ZDomainSignature. + +Module ZDomainProperties (Import ZDomainModule : ZDomainSignature). +Open Local Scope IntScope. + +Add Morphism e with signature Zeq ==> Zeq ==> eq_bool as e_wd. +Proof. +intros x x' Exx' y y' Eyy'. +case_eq (e x y); case_eq (e x' y'); intros H1 H2; trivial. +assert (x == y); [apply <- eq_equiv_e; now rewrite H2 | +assert (x' == y'); [rewrite <- Exx'; now rewrite <- Eyy' | +rewrite <- H1; assert (H3 : e x' y'); [now apply -> eq_equiv_e | now inversion H3]]]. +assert (x' == y'); [apply <- eq_equiv_e; now rewrite H1 | +assert (x == y); [rewrite Exx'; now rewrite Eyy' | +rewrite <- H2; assert (H3 : e x y); [now apply -> eq_equiv_e | now inversion H3]]]. +Qed. + +Theorem neq_symm : forall n m, n # m -> m # n. +Proof. +intros n m H1 H2; symmetry in H2; false_hyp H2 H1. +Qed. + +Theorem ZE_stepl : forall x y z : Z, x == y -> x == z -> z == y. +Proof. +intros x y z H1 H2; now rewrite <- H1. +Qed. + +Declare Left Step ZE_stepl. + +(* The right step lemma is just transitivity of Zeq *) +Declare Right Step (proj1 (proj2 eq_equiv)). + +End ZDomainProperties. + + diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v new file mode 100644 index 00000000..2a88a535 --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -0,0 +1,432 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZLt.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export ZMul. + +Module ZOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). +Module Export ZMulPropMod := ZMulPropFunct ZAxiomsMod. +Open Local Scope IntScope. + +(* Axioms *) + +Theorem Zlt_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 < m1 <-> n2 < m2). +Proof NZlt_wd. + +Theorem Zle_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> (n1 <= m1 <-> n2 <= m2). +Proof NZle_wd. + +Theorem Zmin_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmin n1 m1 == Zmin n2 m2. +Proof NZmin_wd. + +Theorem Zmax_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> Zmax n1 m1 == Zmax n2 m2. +Proof NZmax_wd. + +Theorem Zlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m. +Proof NZlt_eq_cases. + +Theorem Zlt_irrefl : forall n : Z, ~ n < n. +Proof NZlt_irrefl. + +Theorem Zlt_succ_r : forall n m : Z, n < S m <-> n <= m. +Proof NZlt_succ_r. + +Theorem Zmin_l : forall n m : Z, n <= m -> Zmin n m == n. +Proof NZmin_l. + +Theorem Zmin_r : forall n m : Z, m <= n -> Zmin n m == m. +Proof NZmin_r. + +Theorem Zmax_l : forall n m : Z, m <= n -> Zmax n m == n. +Proof NZmax_l. + +Theorem Zmax_r : forall n m : Z, n <= m -> Zmax n m == m. +Proof NZmax_r. + +(* Renaming theorems from NZOrder.v *) + +Theorem Zlt_le_incl : forall n m : Z, n < m -> n <= m. +Proof NZlt_le_incl. + +Theorem Zlt_neq : forall n m : Z, n < m -> n ~= m. +Proof NZlt_neq. + +Theorem Zle_neq : forall n m : Z, n < m <-> n <= m /\ n ~= m. +Proof NZle_neq. + +Theorem Zle_refl : forall n : Z, n <= n. +Proof NZle_refl. + +Theorem Zlt_succ_diag_r : forall n : Z, n < S n. +Proof NZlt_succ_diag_r. + +Theorem Zle_succ_diag_r : forall n : Z, n <= S n. +Proof NZle_succ_diag_r. + +Theorem Zlt_0_1 : 0 < 1. +Proof NZlt_0_1. + +Theorem Zle_0_1 : 0 <= 1. +Proof NZle_0_1. + +Theorem Zlt_lt_succ_r : forall n m : Z, n < m -> n < S m. +Proof NZlt_lt_succ_r. + +Theorem Zle_le_succ_r : forall n m : Z, n <= m -> n <= S m. +Proof NZle_le_succ_r. + +Theorem Zle_succ_r : forall n m : Z, n <= S m <-> n <= m \/ n == S m. +Proof NZle_succ_r. + +Theorem Zneq_succ_diag_l : forall n : Z, S n ~= n. +Proof NZneq_succ_diag_l. + +Theorem Zneq_succ_diag_r : forall n : Z, n ~= S n. +Proof NZneq_succ_diag_r. + +Theorem Znlt_succ_diag_l : forall n : Z, ~ S n < n. +Proof NZnlt_succ_diag_l. + +Theorem Znle_succ_diag_l : forall n : Z, ~ S n <= n. +Proof NZnle_succ_diag_l. + +Theorem Zle_succ_l : forall n m : Z, S n <= m <-> n < m. +Proof NZle_succ_l. + +Theorem Zlt_succ_l : forall n m : Z, S n < m -> n < m. +Proof NZlt_succ_l. + +Theorem Zsucc_lt_mono : forall n m : Z, n < m <-> S n < S m. +Proof NZsucc_lt_mono. + +Theorem Zsucc_le_mono : forall n m : Z, n <= m <-> S n <= S m. +Proof NZsucc_le_mono. + +Theorem Zlt_asymm : forall n m, n < m -> ~ m < n. +Proof NZlt_asymm. + +Notation Zlt_ngt := Zlt_asymm (only parsing). + +Theorem Zlt_trans : forall n m p : Z, n < m -> m < p -> n < p. +Proof NZlt_trans. + +Theorem Zle_trans : forall n m p : Z, n <= m -> m <= p -> n <= p. +Proof NZle_trans. + +Theorem Zle_lt_trans : forall n m p : Z, n <= m -> m < p -> n < p. +Proof NZle_lt_trans. + +Theorem Zlt_le_trans : forall n m p : Z, n < m -> m <= p -> n < p. +Proof NZlt_le_trans. + +Theorem Zle_antisymm : forall n m : Z, n <= m -> m <= n -> n == m. +Proof NZle_antisymm. + +Theorem Zlt_1_l : forall n m : Z, 0 < n -> n < m -> 1 < m. +Proof NZlt_1_l. + +(** Trichotomy, decidability, and double negation elimination *) + +Theorem Zlt_trichotomy : forall n m : Z, n < m \/ n == m \/ m < n. +Proof NZlt_trichotomy. + +Notation Zlt_eq_gt_cases := Zlt_trichotomy (only parsing). + +Theorem Zlt_gt_cases : forall n m : Z, n ~= m <-> n < m \/ n > m. +Proof NZlt_gt_cases. + +Theorem Zle_gt_cases : forall n m : Z, n <= m \/ n > m. +Proof NZle_gt_cases. + +Theorem Zlt_ge_cases : forall n m : Z, n < m \/ n >= m. +Proof NZlt_ge_cases. + +Theorem Zle_ge_cases : forall n m : Z, n <= m \/ n >= m. +Proof NZle_ge_cases. + +(** Instances of the previous theorems for m == 0 *) + +Theorem Zneg_pos_cases : forall n : Z, n ~= 0 <-> n < 0 \/ n > 0. +Proof. +intro; apply Zlt_gt_cases. +Qed. + +Theorem Znonpos_pos_cases : forall n : Z, n <= 0 \/ n > 0. +Proof. +intro; apply Zle_gt_cases. +Qed. + +Theorem Zneg_nonneg_cases : forall n : Z, n < 0 \/ n >= 0. +Proof. +intro; apply Zlt_ge_cases. +Qed. + +Theorem Znonpos_nonneg_cases : forall n : Z, n <= 0 \/ n >= 0. +Proof. +intro; apply Zle_ge_cases. +Qed. + +Theorem Zle_ngt : forall n m : Z, n <= m <-> ~ n > m. +Proof NZle_ngt. + +Theorem Znlt_ge : forall n m : Z, ~ n < m <-> n >= m. +Proof NZnlt_ge. + +Theorem Zlt_dec : forall n m : Z, decidable (n < m). +Proof NZlt_dec. + +Theorem Zlt_dne : forall n m, ~ ~ n < m <-> n < m. +Proof NZlt_dne. + +Theorem Znle_gt : forall n m : Z, ~ n <= m <-> n > m. +Proof NZnle_gt. + +Theorem Zlt_nge : forall n m : Z, n < m <-> ~ n >= m. +Proof NZlt_nge. + +Theorem Zle_dec : forall n m : Z, decidable (n <= m). +Proof NZle_dec. + +Theorem Zle_dne : forall n m : Z, ~ ~ n <= m <-> n <= m. +Proof NZle_dne. + +Theorem Znlt_succ_r : forall n m : Z, ~ m < S n <-> n < m. +Proof NZnlt_succ_r. + +Theorem Zlt_exists_pred : + forall z n : Z, z < n -> exists k : Z, n == S k /\ z <= k. +Proof NZlt_exists_pred. + +Theorem Zlt_succ_iter_r : + forall (n : nat) (m : Z), m < NZsucc_iter (Datatypes.S n) m. +Proof NZlt_succ_iter_r. + +Theorem Zneq_succ_iter_l : + forall (n : nat) (m : Z), NZsucc_iter (Datatypes.S n) m ~= m. +Proof NZneq_succ_iter_l. + +(** Stronger variant of induction with assumptions n >= 0 (n < 0) +in the induction step *) + +Theorem Zright_induction : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, A z -> + (forall n : Z, z <= n -> A n -> A (S n)) -> + forall n : Z, z <= n -> A n. +Proof NZright_induction. + +Theorem Zleft_induction : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, A z -> + (forall n : Z, n < z -> A (S n) -> A n) -> + forall n : Z, n <= z -> A n. +Proof NZleft_induction. + +Theorem Zright_induction' : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, n <= z -> A n) -> + (forall n : Z, z <= n -> A n -> A (S n)) -> + forall n : Z, A n. +Proof NZright_induction'. + +Theorem Zleft_induction' : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, z <= n -> A n) -> + (forall n : Z, n < z -> A (S n) -> A n) -> + forall n : Z, A n. +Proof NZleft_induction'. + +Theorem Zstrong_right_induction : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) -> + forall n : Z, z <= n -> A n. +Proof NZstrong_right_induction. + +Theorem Zstrong_left_induction : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) -> + forall n : Z, n <= z -> A n. +Proof NZstrong_left_induction. + +Theorem Zstrong_right_induction' : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, n <= z -> A n) -> + (forall n : Z, z <= n -> (forall m : Z, z <= m -> m < n -> A m) -> A n) -> + forall n : Z, A n. +Proof NZstrong_right_induction'. + +Theorem Zstrong_left_induction' : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, + (forall n : Z, z <= n -> A n) -> + (forall n : Z, n <= z -> (forall m : Z, m <= z -> S n <= m -> A m) -> A n) -> + forall n : Z, A n. +Proof NZstrong_left_induction'. + +Theorem Zorder_induction : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, A z -> + (forall n : Z, z <= n -> A n -> A (S n)) -> + (forall n : Z, n < z -> A (S n) -> A n) -> + forall n : Z, A n. +Proof NZorder_induction. + +Theorem Zorder_induction' : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall z : Z, A z -> + (forall n : Z, z <= n -> A n -> A (S n)) -> + (forall n : Z, n <= z -> A n -> A (P n)) -> + forall n : Z, A n. +Proof NZorder_induction'. + +Theorem Zorder_induction_0 : + forall A : Z -> Prop, predicate_wd Zeq A -> + A 0 -> + (forall n : Z, 0 <= n -> A n -> A (S n)) -> + (forall n : Z, n < 0 -> A (S n) -> A n) -> + forall n : Z, A n. +Proof NZorder_induction_0. + +Theorem Zorder_induction'_0 : + forall A : Z -> Prop, predicate_wd Zeq A -> + A 0 -> + (forall n : Z, 0 <= n -> A n -> A (S n)) -> + (forall n : Z, n <= 0 -> A n -> A (P n)) -> + forall n : Z, A n. +Proof NZorder_induction'_0. + +Ltac Zinduct n := induction_maker n ltac:(apply Zorder_induction_0). + +(** Elimintation principle for < *) + +Theorem Zlt_ind : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall n : Z, A (S n) -> + (forall m : Z, n < m -> A m -> A (S m)) -> forall m : Z, n < m -> A m. +Proof NZlt_ind. + +(** Elimintation principle for <= *) + +Theorem Zle_ind : + forall A : Z -> Prop, predicate_wd Zeq A -> + forall n : Z, A n -> + (forall m : Z, n <= m -> A m -> A (S m)) -> forall m : Z, n <= m -> A m. +Proof NZle_ind. + +(** Well-founded relations *) + +Theorem Zlt_wf : forall z : Z, well_founded (fun n m : Z => z <= n /\ n < m). +Proof NZlt_wf. + +Theorem Zgt_wf : forall z : Z, well_founded (fun n m : Z => m < n /\ n <= z). +Proof NZgt_wf. + +(* Theorems that are either not valid on N or have different proofs on N and Z *) + +Theorem Zlt_pred_l : forall n : Z, P n < n. +Proof. +intro n; rewrite <- (Zsucc_pred n) at 2; apply Zlt_succ_diag_r. +Qed. + +Theorem Zle_pred_l : forall n : Z, P n <= n. +Proof. +intro; apply Zlt_le_incl; apply Zlt_pred_l. +Qed. + +Theorem Zlt_le_pred : forall n m : Z, n < m <-> n <= P m. +Proof. +intros n m; rewrite <- (Zsucc_pred m); rewrite Zpred_succ. apply Zlt_succ_r. +Qed. + +Theorem Znle_pred_r : forall n : Z, ~ n <= P n. +Proof. +intro; rewrite <- Zlt_le_pred; apply Zlt_irrefl. +Qed. + +Theorem Zlt_pred_le : forall n m : Z, P n < m <-> n <= m. +Proof. +intros n m; rewrite <- (Zsucc_pred n) at 2. +symmetry; apply Zle_succ_l. +Qed. + +Theorem Zlt_lt_pred : forall n m : Z, n < m -> P n < m. +Proof. +intros; apply <- Zlt_pred_le; now apply Zlt_le_incl. +Qed. + +Theorem Zle_le_pred : forall n m : Z, n <= m -> P n <= m. +Proof. +intros; apply Zlt_le_incl; now apply <- Zlt_pred_le. +Qed. + +Theorem Zlt_pred_lt : forall n m : Z, n < P m -> n < m. +Proof. +intros n m H; apply Zlt_trans with (P m); [assumption | apply Zlt_pred_l]. +Qed. + +Theorem Zle_pred_lt : forall n m : Z, n <= P m -> n <= m. +Proof. +intros; apply Zlt_le_incl; now apply <- Zlt_le_pred. +Qed. + +Theorem Zpred_lt_mono : forall n m : Z, n < m <-> P n < P m. +Proof. +intros; rewrite Zlt_le_pred; symmetry; apply Zlt_pred_le. +Qed. + +Theorem Zpred_le_mono : forall n m : Z, n <= m <-> P n <= P m. +Proof. +intros; rewrite <- Zlt_pred_le; now rewrite Zlt_le_pred. +Qed. + +Theorem Zlt_succ_lt_pred : forall n m : Z, S n < m <-> n < P m. +Proof. +intros n m; now rewrite (Zpred_lt_mono (S n) m), Zpred_succ. +Qed. + +Theorem Zle_succ_le_pred : forall n m : Z, S n <= m <-> n <= P m. +Proof. +intros n m; now rewrite (Zpred_le_mono (S n) m), Zpred_succ. +Qed. + +Theorem Zlt_pred_lt_succ : forall n m : Z, P n < m <-> n < S m. +Proof. +intros; rewrite Zlt_pred_le; symmetry; apply Zlt_succ_r. +Qed. + +Theorem Zle_pred_lt_succ : forall n m : Z, P n <= m <-> n <= S m. +Proof. +intros n m; now rewrite (Zpred_le_mono n (S m)), Zpred_succ. +Qed. + +Theorem Zneq_pred_l : forall n : Z, P n ~= n. +Proof. +intro; apply Zlt_neq; apply Zlt_pred_l. +Qed. + +Theorem Zlt_n1_r : forall n m : Z, n < m -> m < 0 -> n < -1. +Proof. +intros n m H1 H2. apply -> Zlt_le_pred in H2. +setoid_replace (P 0) with (-1) in H2. now apply NZlt_le_trans with m. +apply <- Zeq_opp_r. now rewrite Zopp_pred, Zopp_0. +Qed. + +End ZOrderPropFunct. + diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v new file mode 100644 index 00000000..c48d1b4c --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -0,0 +1,115 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export ZAdd. + +Module ZMulPropFunct (Import ZAxiomsMod : ZAxiomsSig). +Module Export ZAddPropMod := ZAddPropFunct ZAxiomsMod. +Open Local Scope IntScope. + +Theorem Zmul_wd : + forall n1 n2 : Z, n1 == n2 -> forall m1 m2 : Z, m1 == m2 -> n1 * m1 == n2 * m2. +Proof NZmul_wd. + +Theorem Zmul_0_l : forall n : Z, 0 * n == 0. +Proof NZmul_0_l. + +Theorem Zmul_succ_l : forall n m : Z, (S n) * m == n * m + m. +Proof NZmul_succ_l. + +(* Theorems that are valid for both natural numbers and integers *) + +Theorem Zmul_0_r : forall n : Z, n * 0 == 0. +Proof NZmul_0_r. + +Theorem Zmul_succ_r : forall n m : Z, n * (S m) == n * m + n. +Proof NZmul_succ_r. + +Theorem Zmul_comm : forall n m : Z, n * m == m * n. +Proof NZmul_comm. + +Theorem Zmul_add_distr_r : forall n m p : Z, (n + m) * p == n * p + m * p. +Proof NZmul_add_distr_r. + +Theorem Zmul_add_distr_l : forall n m p : Z, n * (m + p) == n * m + n * p. +Proof NZmul_add_distr_l. + +(* A note on naming: right (correspondingly, left) distributivity happens +when the sum is multiplied by a number on the right (left), not when the +sum itself is the right (left) factor in the product (see planetmath.org +and mathworld.wolfram.com). In the old library BinInt, distributivity over +subtraction was named correctly, but distributivity over addition was named +incorrectly. The names in Isabelle/HOL library are also incorrect. *) + +Theorem Zmul_assoc : forall n m p : Z, n * (m * p) == (n * m) * p. +Proof NZmul_assoc. + +Theorem Zmul_1_l : forall n : Z, 1 * n == n. +Proof NZmul_1_l. + +Theorem Zmul_1_r : forall n : Z, n * 1 == n. +Proof NZmul_1_r. + +(* The following two theorems are true in an ordered ring, +but since they don't mention order, we'll put them here *) + +Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0. +Proof NZeq_mul_0. + +Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Proof NZneq_mul_0. + +(* Theorems that are either not valid on N or have different proofs on N and Z *) + +Theorem Zmul_pred_r : forall n m : Z, n * (P m) == n * m - n. +Proof. +intros n m. +rewrite <- (Zsucc_pred m) at 2. +now rewrite Zmul_succ_r, <- Zadd_sub_assoc, Zsub_diag, Zadd_0_r. +Qed. + +Theorem Zmul_pred_l : forall n m : Z, (P n) * m == n * m - m. +Proof. +intros n m; rewrite (Zmul_comm (P n) m), (Zmul_comm n m). apply Zmul_pred_r. +Qed. + +Theorem Zmul_opp_l : forall n m : Z, (- n) * m == - (n * m). +Proof. +intros n m. apply -> Zadd_move_0_r. +now rewrite <- Zmul_add_distr_r, Zadd_opp_diag_l, Zmul_0_l. +Qed. + +Theorem Zmul_opp_r : forall n m : Z, n * (- m) == - (n * m). +Proof. +intros n m; rewrite (Zmul_comm n (- m)), (Zmul_comm n m); apply Zmul_opp_l. +Qed. + +Theorem Zmul_opp_opp : forall n m : Z, (- n) * (- m) == n * m. +Proof. +intros n m; now rewrite Zmul_opp_l, Zmul_opp_r, Zopp_involutive. +Qed. + +Theorem Zmul_sub_distr_l : forall n m p : Z, n * (m - p) == n * m - n * p. +Proof. +intros n m p. do 2 rewrite <- Zadd_opp_r. rewrite Zmul_add_distr_l. +now rewrite Zmul_opp_r. +Qed. + +Theorem Zmul_sub_distr_r : forall n m p : Z, (n - m) * p == n * p - m * p. +Proof. +intros n m p; rewrite (Zmul_comm (n - m) p), (Zmul_comm n p), (Zmul_comm m p); +now apply Zmul_sub_distr_l. +Qed. + +End ZMulPropFunct. + + diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v new file mode 100644 index 00000000..e3f1d9aa --- /dev/null +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -0,0 +1,343 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export ZAddOrder. + +Module ZMulOrderPropFunct (Import ZAxiomsMod : ZAxiomsSig). +Module Export ZAddOrderPropMod := ZAddOrderPropFunct ZAxiomsMod. +Open Local Scope IntScope. + +Theorem Zmul_lt_pred : + forall p q n m : Z, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). +Proof NZmul_lt_pred. + +Theorem Zmul_lt_mono_pos_l : forall p n m : Z, 0 < p -> (n < m <-> p * n < p * m). +Proof NZmul_lt_mono_pos_l. + +Theorem Zmul_lt_mono_pos_r : forall p n m : Z, 0 < p -> (n < m <-> n * p < m * p). +Proof NZmul_lt_mono_pos_r. + +Theorem Zmul_lt_mono_neg_l : forall p n m : Z, p < 0 -> (n < m <-> p * m < p * n). +Proof NZmul_lt_mono_neg_l. + +Theorem Zmul_lt_mono_neg_r : forall p n m : Z, p < 0 -> (n < m <-> m * p < n * p). +Proof NZmul_lt_mono_neg_r. + +Theorem Zmul_le_mono_nonneg_l : forall n m p : Z, 0 <= p -> n <= m -> p * n <= p * m. +Proof NZmul_le_mono_nonneg_l. + +Theorem Zmul_le_mono_nonpos_l : forall n m p : Z, p <= 0 -> n <= m -> p * m <= p * n. +Proof NZmul_le_mono_nonpos_l. + +Theorem Zmul_le_mono_nonneg_r : forall n m p : Z, 0 <= p -> n <= m -> n * p <= m * p. +Proof NZmul_le_mono_nonneg_r. + +Theorem Zmul_le_mono_nonpos_r : forall n m p : Z, p <= 0 -> n <= m -> m * p <= n * p. +Proof NZmul_le_mono_nonpos_r. + +Theorem Zmul_cancel_l : forall n m p : Z, p ~= 0 -> (p * n == p * m <-> n == m). +Proof NZmul_cancel_l. + +Theorem Zmul_cancel_r : forall n m p : Z, p ~= 0 -> (n * p == m * p <-> n == m). +Proof NZmul_cancel_r. + +Theorem Zmul_id_l : forall n m : Z, m ~= 0 -> (n * m == m <-> n == 1). +Proof NZmul_id_l. + +Theorem Zmul_id_r : forall n m : Z, n ~= 0 -> (n * m == n <-> m == 1). +Proof NZmul_id_r. + +Theorem Zmul_le_mono_pos_l : forall n m p : Z, 0 < p -> (n <= m <-> p * n <= p * m). +Proof NZmul_le_mono_pos_l. + +Theorem Zmul_le_mono_pos_r : forall n m p : Z, 0 < p -> (n <= m <-> n * p <= m * p). +Proof NZmul_le_mono_pos_r. + +Theorem Zmul_le_mono_neg_l : forall n m p : Z, p < 0 -> (n <= m <-> p * m <= p * n). +Proof NZmul_le_mono_neg_l. + +Theorem Zmul_le_mono_neg_r : forall n m p : Z, p < 0 -> (n <= m <-> m * p <= n * p). +Proof NZmul_le_mono_neg_r. + +Theorem Zmul_lt_mono_nonneg : + forall n m p q : Z, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. +Proof NZmul_lt_mono_nonneg. + +Theorem Zmul_lt_mono_nonpos : + forall n m p q : Z, m <= 0 -> n < m -> q <= 0 -> p < q -> m * q < n * p. +Proof. +intros n m p q H1 H2 H3 H4. +apply Zle_lt_trans with (m * p). +apply Zmul_le_mono_nonpos_l; [assumption | now apply Zlt_le_incl]. +apply -> Zmul_lt_mono_neg_r; [assumption | now apply Zlt_le_trans with q]. +Qed. + +Theorem Zmul_le_mono_nonneg : + forall n m p q : Z, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. +Proof NZmul_le_mono_nonneg. + +Theorem Zmul_le_mono_nonpos : + forall n m p q : Z, m <= 0 -> n <= m -> q <= 0 -> p <= q -> m * q <= n * p. +Proof. +intros n m p q H1 H2 H3 H4. +apply Zle_trans with (m * p). +now apply Zmul_le_mono_nonpos_l. +apply Zmul_le_mono_nonpos_r; [now apply Zle_trans with q | assumption]. +Qed. + +Theorem Zmul_pos_pos : forall n m : Z, 0 < n -> 0 < m -> 0 < n * m. +Proof NZmul_pos_pos. + +Theorem Zmul_neg_neg : forall n m : Z, n < 0 -> m < 0 -> 0 < n * m. +Proof NZmul_neg_neg. + +Theorem Zmul_pos_neg : forall n m : Z, 0 < n -> m < 0 -> n * m < 0. +Proof NZmul_pos_neg. + +Theorem Zmul_neg_pos : forall n m : Z, n < 0 -> 0 < m -> n * m < 0. +Proof NZmul_neg_pos. + +Theorem Zmul_nonneg_nonneg : forall n m : Z, 0 <= n -> 0 <= m -> 0 <= n * m. +Proof. +intros n m H1 H2. +rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonneg_r. +Qed. + +Theorem Zmul_nonpos_nonpos : forall n m : Z, n <= 0 -> m <= 0 -> 0 <= n * m. +Proof. +intros n m H1 H2. +rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r. +Qed. + +Theorem Zmul_nonneg_nonpos : forall n m : Z, 0 <= n -> m <= 0 -> n * m <= 0. +Proof. +intros n m H1 H2. +rewrite <- (Zmul_0_l m). now apply Zmul_le_mono_nonpos_r. +Qed. + +Theorem Zmul_nonpos_nonneg : forall n m : Z, n <= 0 -> 0 <= m -> n * m <= 0. +Proof. +intros; rewrite Zmul_comm; now apply Zmul_nonneg_nonpos. +Qed. + +Theorem Zlt_1_mul_pos : forall n m : Z, 1 < n -> 0 < m -> 1 < n * m. +Proof NZlt_1_mul_pos. + +Theorem Zeq_mul_0 : forall n m : Z, n * m == 0 <-> n == 0 \/ m == 0. +Proof NZeq_mul_0. + +Theorem Zneq_mul_0 : forall n m : Z, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Proof NZneq_mul_0. + +Theorem Zeq_square_0 : forall n : Z, n * n == 0 <-> n == 0. +Proof NZeq_square_0. + +Theorem Zeq_mul_0_l : forall n m : Z, n * m == 0 -> m ~= 0 -> n == 0. +Proof NZeq_mul_0_l. + +Theorem Zeq_mul_0_r : forall n m : Z, n * m == 0 -> n ~= 0 -> m == 0. +Proof NZeq_mul_0_r. + +Theorem Zlt_0_mul : forall n m : Z, 0 < n * m <-> 0 < n /\ 0 < m \/ m < 0 /\ n < 0. +Proof NZlt_0_mul. + +Notation Zmul_pos := Zlt_0_mul (only parsing). + +Theorem Zlt_mul_0 : + forall n m : Z, n * m < 0 <-> n < 0 /\ m > 0 \/ n > 0 /\ m < 0. +Proof. +intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. +destruct (Zlt_trichotomy n 0) as [H1 | [H1 | H1]]; +[| rewrite H1 in H; rewrite Zmul_0_l in H; false_hyp H Zlt_irrefl |]; +(destruct (Zlt_trichotomy m 0) as [H2 | [H2 | H2]]; +[| rewrite H2 in H; rewrite Zmul_0_r in H; false_hyp H Zlt_irrefl |]); +try (left; now split); try (right; now split). +assert (H3 : n * m > 0) by now apply Zmul_neg_neg. +elimtype False; now apply (Zlt_asymm (n * m) 0). +assert (H3 : n * m > 0) by now apply Zmul_pos_pos. +elimtype False; now apply (Zlt_asymm (n * m) 0). +now apply Zmul_neg_pos. now apply Zmul_pos_neg. +Qed. + +Notation Zmul_neg := Zlt_mul_0 (only parsing). + +Theorem Zle_0_mul : + forall n m : Z, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. +Proof. +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. +rewrite Zlt_0_mul, Zeq_mul_0. +pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. +Qed. + +Notation Zmul_nonneg := Zle_0_mul (only parsing). + +Theorem Zle_mul_0 : + forall n m : Z, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. +Proof. +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. +rewrite Zlt_mul_0, Zeq_mul_0. +pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. +Qed. + +Notation Zmul_nonpos := Zle_mul_0 (only parsing). + +Theorem Zle_0_square : forall n : Z, 0 <= n * n. +Proof. +intro n; destruct (Zneg_nonneg_cases n). +apply Zlt_le_incl; now apply Zmul_neg_neg. +now apply Zmul_nonneg_nonneg. +Qed. + +Notation Zsquare_nonneg := Zle_0_square (only parsing). + +Theorem Znlt_square_0 : forall n : Z, ~ n * n < 0. +Proof. +intros n H. apply -> Zlt_nge in H. apply H. apply Zsquare_nonneg. +Qed. + +Theorem Zsquare_lt_mono_nonneg : forall n m : Z, 0 <= n -> n < m -> n * n < m * m. +Proof NZsquare_lt_mono_nonneg. + +Theorem Zsquare_lt_mono_nonpos : forall n m : Z, n <= 0 -> m < n -> n * n < m * m. +Proof. +intros n m H1 H2. now apply Zmul_lt_mono_nonpos. +Qed. + +Theorem Zsquare_le_mono_nonneg : forall n m : Z, 0 <= n -> n <= m -> n * n <= m * m. +Proof NZsquare_le_mono_nonneg. + +Theorem Zsquare_le_mono_nonpos : forall n m : Z, n <= 0 -> m <= n -> n * n <= m * m. +Proof. +intros n m H1 H2. now apply Zmul_le_mono_nonpos. +Qed. + +Theorem Zsquare_lt_simpl_nonneg : forall n m : Z, 0 <= m -> n * n < m * m -> n < m. +Proof NZsquare_lt_simpl_nonneg. + +Theorem Zsquare_le_simpl_nonneg : forall n m : Z, 0 <= m -> n * n <= m * m -> n <= m. +Proof NZsquare_le_simpl_nonneg. + +Theorem Zsquare_lt_simpl_nonpos : forall n m : Z, m <= 0 -> n * n < m * m -> m < n. +Proof. +intros n m H1 H2. destruct (Zle_gt_cases n 0). +destruct (NZlt_ge_cases m n). +assumption. assert (F : m * m <= n * n) by now apply Zsquare_le_mono_nonpos. +apply -> NZle_ngt in F. false_hyp H2 F. +now apply Zle_lt_trans with 0. +Qed. + +Theorem Zsquare_le_simpl_nonpos : forall n m : NZ, m <= 0 -> n * n <= m * m -> m <= n. +Proof. +intros n m H1 H2. destruct (NZle_gt_cases n 0). +destruct (NZle_gt_cases m n). +assumption. assert (F : m * m < n * n) by now apply Zsquare_lt_mono_nonpos. +apply -> NZlt_nge in F. false_hyp H2 F. +apply Zlt_le_incl; now apply NZle_lt_trans with 0. +Qed. + +Theorem Zmul_2_mono_l : forall n m : Z, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. +Proof NZmul_2_mono_l. + +Theorem Zlt_1_mul_neg : forall n m : Z, n < -1 -> m < 0 -> 1 < n * m. +Proof. +intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1. +apply <- Zopp_pos_neg in H2. rewrite Zmul_opp_l, Zmul_1_l in H1. +now apply Zlt_1_l with (- m). +assumption. +Qed. + +Theorem Zlt_mul_n1_neg : forall n m : Z, 1 < n -> m < 0 -> n * m < -1. +Proof. +intros n m H1 H2. apply -> (NZmul_lt_mono_neg_r m) in H1. +rewrite Zmul_1_l in H1. now apply Zlt_n1_r with m. +assumption. +Qed. + +Theorem Zlt_mul_n1_pos : forall n m : Z, n < -1 -> 0 < m -> n * m < -1. +Proof. +intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1. +rewrite Zmul_opp_l, Zmul_1_l in H1. +apply <- Zopp_neg_pos in H2. now apply Zlt_n1_r with (- m). +assumption. +Qed. + +Theorem Zlt_1_mul_l : forall n m : Z, 1 < n -> n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Proof. +intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]]. +left. now apply Zlt_mul_n1_neg. +right; left; now rewrite H1, Zmul_0_r. +right; right; now apply Zlt_1_mul_pos. +Qed. + +Theorem Zlt_n1_mul_r : forall n m : Z, n < -1 -> n * m < -1 \/ n * m == 0 \/ 1 < n * m. +Proof. +intros n m H; destruct (Zlt_trichotomy m 0) as [H1 | [H1 | H1]]. +right; right. now apply Zlt_1_mul_neg. +right; left; now rewrite H1, Zmul_0_r. +left. now apply Zlt_mul_n1_pos. +Qed. + +Theorem Zeq_mul_1 : forall n m : Z, n * m == 1 -> n == 1 \/ n == -1. +Proof. +assert (F : ~ 1 < -1). +intro H. +assert (H1 : -1 < 0). apply <- Zopp_neg_pos. apply Zlt_succ_diag_r. +assert (H2 : 1 < 0) by now apply Zlt_trans with (-1). false_hyp H2 Znlt_succ_diag_l. +Z0_pos_neg n. +intros m H; rewrite Zmul_0_l in H; false_hyp H Zneq_succ_diag_r. +intros n H; split; apply <- Zle_succ_l in H; le_elim H. +intros m H1; apply (Zlt_1_mul_l n m) in H. +rewrite H1 in H; destruct H as [H | [H | H]]. +false_hyp H F. false_hyp H Zneq_succ_diag_l. false_hyp H Zlt_irrefl. +intros; now left. +intros m H1; apply (Zlt_1_mul_l n m) in H. rewrite Zmul_opp_l in H1; +apply -> Zeq_opp_l in H1. rewrite H1 in H; destruct H as [H | [H | H]]. +false_hyp H Zlt_irrefl. apply -> Zeq_opp_l in H. rewrite Zopp_0 in H. +false_hyp H Zneq_succ_diag_l. false_hyp H F. +intros; right; symmetry; now apply Zopp_wd. +Qed. + +Theorem Zlt_mul_diag_l : forall n m : Z, n < 0 -> (1 < m <-> n * m < n). +Proof. +intros n m H. stepr (n * m < n * 1) by now rewrite Zmul_1_r. +now apply Zmul_lt_mono_neg_l. +Qed. + +Theorem Zlt_mul_diag_r : forall n m : Z, 0 < n -> (1 < m <-> n < n * m). +Proof. +intros n m H. stepr (n * 1 < n * m) by now rewrite Zmul_1_r. +now apply Zmul_lt_mono_pos_l. +Qed. + +Theorem Zle_mul_diag_l : forall n m : Z, n < 0 -> (1 <= m <-> n * m <= n). +Proof. +intros n m H. stepr (n * m <= n * 1) by now rewrite Zmul_1_r. +now apply Zmul_le_mono_neg_l. +Qed. + +Theorem Zle_mul_diag_r : forall n m : Z, 0 < n -> (1 <= m <-> n <= n * m). +Proof. +intros n m H. stepr (n * 1 <= n * m) by now rewrite Zmul_1_r. +now apply Zmul_le_mono_pos_l. +Qed. + +Theorem Zlt_mul_r : forall n m p : Z, 0 < n -> 1 < p -> n < m -> n < m * p. +Proof. +intros. stepl (n * 1) by now rewrite Zmul_1_r. +apply Zmul_lt_mono_nonneg. +now apply Zlt_le_incl. assumption. apply Zle_0_1. assumption. +Qed. + +End ZMulOrderPropFunct. + diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v new file mode 100644 index 00000000..09abf424 --- /dev/null +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -0,0 +1,109 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: BigZ.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export BigN. +Require Import ZMulOrder. +Require Import ZSig. +Require Import ZSigZAxioms. +Require Import ZMake. + +Module BigZ <: ZType := ZMake.Make BigN. + +(** Module [BigZ] implements [ZAxiomsSig] *) + +Module Export BigZAxiomsMod := ZSig_ZAxioms BigZ. +Module Export BigZMulOrderPropMod := ZMulOrderPropFunct BigZAxiomsMod. + +(** Notations about [BigZ] *) + +Notation bigZ := BigZ.t. + +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_. + +Notation Local "0" := BigZ.zero : 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.compare : bigZ_scope. +Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope. +Infix "<" := BigZ.lt : bigZ_scope. +Infix "<=" := BigZ.le : bigZ_scope. +Notation "[ i ]" := (BigZ.to_Z i) : bigZ_scope. + +Open Scope bigZ_scope. + +(** Some additional results about [BigZ] *) + +Theorem spec_to_Z: forall n:bigZ, + BigN.to_Z (BigZ.to_N n) = ((Zsgn [n]) * [n])%Z. +Proof. +intros n; case n; simpl; intros p; + generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. +intros p1 H1; case H1; auto. +intros p1 H1; case H1; auto. +Qed. + +Theorem spec_to_N n: + ([n] = Zsgn [n] * (BigN.to_Z (BigZ.to_N n)))%Z. +Proof. +intros n; case n; simpl; intros p; + generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. +intros p1 H1; case H1; auto. +intros p1 H1; case H1; auto. +Qed. + +Theorem spec_to_Z_pos: forall n, (0 <= [n])%Z -> + BigN.to_Z (BigZ.to_N n) = [n]. +Proof. +intros n; case n; simpl; intros p; + generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. +intros p1 _ H1; case H1; auto. +intros p1 H1; case H1; auto. +Qed. + +Lemma sub_opp : forall x y : bigZ, x - y == x + (- y). +Proof. +red; intros; zsimpl; auto. +Qed. + +Lemma add_opp : forall x : bigZ, x + (- x) == 0. +Proof. +red; intros; zsimpl; auto with zarith. +Qed. + +(** [BigZ] is a ring *) + +Lemma BigZring : + ring_theory BigZ.zero BigZ.one BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq. +Proof. +constructor. +exact Zadd_0_l. +exact Zadd_comm. +exact Zadd_assoc. +exact Zmul_1_l. +exact Zmul_comm. +exact Zmul_assoc. +exact Zmul_add_distr_r. +exact sub_opp. +exact add_opp. +Qed. + +Add Ring BigZr : BigZring. + +(** Todo: tactic translating from [BigZ] to [Z] + omega *) + +(** Todo: micromega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v new file mode 100644 index 00000000..1f2b12bb --- /dev/null +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -0,0 +1,491 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZMake.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import NSig. +Require Import ZSig. + +Open Scope Z_scope. + +(** * ZMake + + A generic transformation from a structure of natural numbers + [NSig.NType] to a structure of integers [ZSig.ZType]. +*) + +Module Make (N:NType) <: ZType. + + Inductive t_ := + | Pos : N.t -> t_ + | Neg : N.t -> t_. + + Definition t := t_. + + Definition zero := Pos N.zero. + Definition one := Pos N.one. + Definition minus_one := Neg N.one. + + Definition of_Z x := + match x with + | Zpos x => Pos (N.of_N (Npos x)) + | Z0 => zero + | Zneg x => Neg (N.of_N (Npos x)) + end. + + Definition to_Z x := + match x with + | Pos nx => N.to_Z nx + | Neg nx => Zopp (N.to_Z nx) + end. + + Theorem spec_of_Z: forall x, to_Z (of_Z x) = x. + intros x; case x; unfold to_Z, of_Z, zero. + exact N.spec_0. + intros; rewrite N.spec_of_N; auto. + intros; rewrite N.spec_of_N; auto. + Qed. + + Definition eq x y := (to_Z x = to_Z y). + + Theorem spec_0: to_Z zero = 0. + exact N.spec_0. + Qed. + + Theorem spec_1: to_Z one = 1. + exact N.spec_1. + Qed. + + Theorem spec_m1: to_Z minus_one = -1. + simpl; rewrite N.spec_1; auto. + Qed. + + Definition compare x y := + match x, y with + | Pos nx, Pos ny => N.compare nx ny + | Pos nx, Neg ny => + match N.compare nx N.zero with + | Gt => Gt + | _ => N.compare ny N.zero + end + | Neg nx, Pos ny => + match N.compare N.zero nx with + | Lt => Lt + | _ => N.compare N.zero ny + end + | Neg nx, Neg ny => N.compare ny nx + end. + + Definition lt n m := compare n m = Lt. + Definition le n m := compare n m <> Gt. + 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. + + Theorem spec_compare: forall x y, + match compare x y with + Eq => to_Z x = to_Z y + | Lt => to_Z x < to_Z y + | Gt => to_Z x > to_Z y + end. + unfold compare, to_Z; intros x y; case x; case y; clear x y; + intros x y; auto; generalize (N.spec_pos x) (N.spec_pos y). + generalize (N.spec_compare y x); case N.compare; auto with zarith. + generalize (N.spec_compare y N.zero); case N.compare; + try rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare x N.zero); case N.compare; + rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare x N.zero); case N.compare; + rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare N.zero y); case N.compare; + try rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare N.zero x); case N.compare; + rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare N.zero x); case N.compare; + rewrite N.spec_0; auto with zarith. + generalize (N.spec_compare x y); case N.compare; auto with zarith. + Qed. + + Definition eq_bool x y := + match compare x y with + | Eq => true + | _ => false + end. + + Theorem spec_eq_bool: forall x y, + if eq_bool x y then to_Z x = to_Z y else to_Z x <> to_Z y. + intros x y; unfold eq_bool; + generalize (spec_compare x y); case compare; auto with zarith. + Qed. + + Definition cmp_sign x y := + match x, y with + | Pos nx, Neg ny => + if N.eq_bool ny N.zero then Eq else Gt + | Neg nx, Pos ny => + if N.eq_bool nx N.zero then Eq else Lt + | _, _ => Eq + end. + + Theorem spec_cmp_sign: forall x y, + match cmp_sign x y with + | Gt => 0 <= to_Z x /\ to_Z y < 0 + | Lt => to_Z x < 0 /\ 0 <= to_Z y + | Eq => True + end. + Proof. + intros [x | x] [y | y]; unfold cmp_sign; auto. + generalize (N.spec_eq_bool y N.zero); case N.eq_bool; auto. + rewrite N.spec_0; unfold to_Z. + generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. + generalize (N.spec_eq_bool x N.zero); case N.eq_bool; auto. + rewrite N.spec_0; unfold to_Z. + generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. + Qed. + + Definition to_N x := + match x with + | Pos nx => nx + | Neg nx => nx + end. + + Definition abs x := Pos (to_N x). + + Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x). + intros x; case x; clear x; intros x; assert (F:=N.spec_pos x). + simpl; rewrite Zabs_eq; auto. + simpl; rewrite Zabs_non_eq; simpl; auto with zarith. + Qed. + + Definition opp x := + match x with + | Pos nx => Neg nx + | Neg nx => Pos nx + end. + + Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. + intros x; case x; simpl; auto with zarith. + Qed. + + Definition succ x := + match x with + | Pos n => Pos (N.succ n) + | Neg n => + match N.compare N.zero n with + | Lt => Neg (N.pred n) + | _ => one + end + end. + + Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. + intros x; case x; clear x; intros x. + exact (N.spec_succ x). + simpl; generalize (N.spec_compare N.zero x); case N.compare; + rewrite N.spec_0; simpl. + intros HH; rewrite <- HH; rewrite N.spec_1; ring. + intros HH; rewrite N.spec_pred; auto with zarith. + generalize (N.spec_pos x); auto with zarith. + Qed. + + Definition add x y := + match x, y with + | Pos nx, Pos ny => Pos (N.add nx ny) + | Pos nx, Neg ny => + match N.compare nx ny with + | Gt => Pos (N.sub nx ny) + | Eq => zero + | Lt => Neg (N.sub ny nx) + end + | Neg nx, Pos ny => + match N.compare nx ny with + | Gt => Neg (N.sub nx ny) + | Eq => zero + | Lt => Pos (N.sub ny nx) + end + | Neg nx, Neg ny => Neg (N.add nx ny) + end. + + Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. + unfold add, to_Z; intros [x | x] [y | y]. + exact (N.spec_add x y). + unfold zero; generalize (N.spec_compare x y); case N.compare. + rewrite N.spec_0; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + unfold zero; generalize (N.spec_compare x y); case N.compare. + rewrite N.spec_0; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + intros; rewrite N.spec_add; try ring; auto with zarith. + Qed. + + Definition pred x := + match x with + | Pos nx => + match N.compare N.zero nx with + | Lt => Pos (N.pred nx) + | _ => minus_one + end + | Neg nx => Neg (N.succ nx) + end. + + Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. + unfold pred, to_Z, minus_one; intros [x | x]. + generalize (N.spec_compare N.zero x); case N.compare; + rewrite N.spec_0; try rewrite N.spec_1; auto with zarith. + intros H; exact (N.spec_pred _ H). + generalize (N.spec_pos x); auto with zarith. + rewrite N.spec_succ; ring. + Qed. + + Definition sub x y := + match x, y with + | Pos nx, Pos ny => + match N.compare nx ny with + | Gt => Pos (N.sub nx ny) + | Eq => zero + | Lt => Neg (N.sub ny nx) + end + | Pos nx, Neg ny => Pos (N.add nx ny) + | Neg nx, Pos ny => Neg (N.add nx ny) + | Neg nx, Neg ny => + match N.compare nx ny with + | Gt => Neg (N.sub nx ny) + | Eq => zero + | Lt => Pos (N.sub ny nx) + end + end. + + Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y. + unfold sub, to_Z; intros [x | x] [y | y]. + unfold zero; generalize (N.spec_compare x y); case N.compare. + rewrite N.spec_0; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + rewrite N.spec_add; ring. + rewrite N.spec_add; ring. + unfold zero; generalize (N.spec_compare x y); case N.compare. + rewrite N.spec_0; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + intros; rewrite N.spec_sub; try ring; auto with zarith. + Qed. + + Definition mul x y := + match x, y with + | Pos nx, Pos ny => Pos (N.mul nx ny) + | Pos nx, Neg ny => Neg (N.mul nx ny) + | Neg nx, Pos ny => Neg (N.mul nx ny) + | Neg nx, Neg ny => Pos (N.mul nx ny) + end. + + + Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. + unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring. + Qed. + + Definition square x := + match x with + | Pos nx => Pos (N.square nx) + | Neg nx => Pos (N.square nx) + end. + + Theorem spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. + unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring. + Qed. + + Definition power_pos x p := + match x with + | Pos nx => Pos (N.power_pos nx p) + | Neg nx => + match p with + | xH => x + | xO _ => Pos (N.power_pos nx p) + | xI _ => Neg (N.power_pos nx p) + end + end. + + Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. + 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. + assert (F: 0 <= 2 * Zpos p). + assert (0 <= Zpos p); auto with zarith. + rewrite Zpos_xI; repeat rewrite Zpower_exp; auto with zarith. + repeat rewrite Zpower_mult; auto with zarith. + rewrite F0; ring. + assert (F: 0 <= 2 * Zpos p). + assert (0 <= Zpos p); auto with zarith. + rewrite Zpos_xO; repeat rewrite Zpower_exp; auto with zarith. + repeat rewrite Zpower_mult; auto with zarith. + rewrite F0; ring. + Qed. + + Definition sqrt x := + match x with + | Pos nx => Pos (N.sqrt nx) + | 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. + 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. + Qed. + + Definition div_eucl x y := + match x, y with + | Pos nx, Pos ny => + let (q, r) := N.div_eucl nx ny in + (Pos q, Pos r) + | Pos nx, Neg ny => + let (q, r) := N.div_eucl nx ny in + match N.compare N.zero r with + | Eq => (Neg q, zero) + | _ => (Neg (N.succ q), Neg (N.sub ny r)) + end + | Neg nx, Pos ny => + let (q, r) := N.div_eucl nx ny in + match N.compare N.zero r with + | Eq => (Neg q, zero) + | _ => (Neg (N.succ q), Pos (N.sub ny r)) + end + | Neg nx, Neg ny => + let (q, r) := N.div_eucl nx ny in + (Pos q, Neg r) + end. + + + Theorem spec_div_eucl: forall x y, + to_Z y <> 0 -> + let (q,r) := div_eucl x y in + (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y). + unfold div_eucl, to_Z; intros [x | x] [y | y] H. + assert (H1: 0 < N.to_Z y). + generalize (N.spec_pos y); auto with zarith. + generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. + assert (HH: 0 < N.to_Z y). + generalize (N.spec_pos y); auto with zarith. + generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. + intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; + case_eq (N.to_Z x); case_eq (N.to_Z y); + try (intros; apply False_ind; auto with zarith; fail). + intros p He1 He2 _ _ H1; injection H1; intros H2 H3. + generalize (N.spec_compare N.zero r); case N.compare; + unfold zero; rewrite N.spec_0; try rewrite H3; auto. + rewrite H2; intros; apply False_ind; auto with zarith. + rewrite H2; intros; apply False_ind; auto with zarith. + intros p _ _ _ H1; discriminate H1. + intros p He p1 He1 H1 _. + generalize (N.spec_compare N.zero r); case N.compare. + change (- Zpos p) with (Zneg p). + unfold zero; lazy zeta. + rewrite N.spec_0; intros H2; rewrite <- H2. + intros H3; rewrite <- H3; auto. + rewrite N.spec_0; intros H2. + change (- Zpos p) with (Zneg p); lazy iota beta. + intros H3; rewrite <- H3; auto. + rewrite N.spec_succ; rewrite N.spec_sub. + generalize H2; case (N.to_Z r). + intros; apply False_ind; auto with zarith. + intros p2 _; rewrite He; auto with zarith. + change (Zneg p) with (- (Zpos p)); apply f_equal2 with (f := @pair Z Z); ring. + intros p2 H4; discriminate H4. + assert (N.to_Z r = (Zpos p1 mod (Zpos p))). + unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. + case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. + rewrite N.spec_0; intros H2; generalize (N.spec_pos r); + intros; apply False_ind; auto with zarith. + assert (HH: 0 < N.to_Z y). + generalize (N.spec_pos y); auto with zarith. + generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. + intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; + case_eq (N.to_Z x); case_eq (N.to_Z y); + try (intros; apply False_ind; auto with zarith; fail). + intros p He1 He2 _ _ H1; injection H1; intros H2 H3. + generalize (N.spec_compare N.zero r); case N.compare; + unfold zero; rewrite N.spec_0; try rewrite H3; auto. + rewrite H2; intros; apply False_ind; auto with zarith. + rewrite H2; intros; apply False_ind; auto with zarith. + intros p _ _ _ H1; discriminate H1. + intros p He p1 He1 H1 _. + generalize (N.spec_compare N.zero r); case N.compare. + change (- Zpos p1) with (Zneg p1). + unfold zero; lazy zeta. + rewrite N.spec_0; intros H2; rewrite <- H2. + intros H3; rewrite <- H3; auto. + rewrite N.spec_0; intros H2. + change (- Zpos p1) with (Zneg p1); lazy iota beta. + intros H3; rewrite <- H3; auto. + rewrite N.spec_succ; rewrite N.spec_sub. + generalize H2; case (N.to_Z r). + intros; apply False_ind; auto with zarith. + intros p2 _; rewrite He; auto with zarith. + intros p2 H4; discriminate H4. + assert (N.to_Z r = (Zpos p1 mod (Zpos p))). + unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. + case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. + rewrite N.spec_0; generalize (N.spec_pos r); intros; apply False_ind; auto with zarith. + assert (H1: 0 < N.to_Z y). + generalize (N.spec_pos y); auto with zarith. + generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. + intros q r; generalize (N.spec_pos x) H1; unfold Zdiv_eucl; + case_eq (N.to_Z x); case_eq (N.to_Z y); + try (intros; apply False_ind; auto with zarith; fail). + change (-0) with 0; lazy iota beta; auto. + intros p _ _ _ _ H2; injection H2. + intros H3 H4; rewrite H3; rewrite H4; auto. + intros p _ _ _ H2; discriminate H2. + intros p He p1 He1 _ _ H2. + change (- Zpos p1) with (Zneg p1); lazy iota beta. + change (- Zpos p) with (Zneg p); lazy iota beta. + rewrite <- H2; auto. + Qed. + + Definition div x y := fst (div_eucl x y). + + Definition spec_div: forall x y, + to_Z y <> 0 -> to_Z (div x y) = to_Z x / to_Z y. + intros x y H1; generalize (spec_div_eucl x y H1); unfold div, Zdiv. + case div_eucl; case Zdiv_eucl; simpl; auto. + intros q r q11 r1 H; injection H; auto. + Qed. + + Definition modulo x y := snd (div_eucl x y). + + Theorem spec_modulo: + forall x y, to_Z y <> 0 -> to_Z (modulo x y) = to_Z x mod to_Z y. + intros x y H1; generalize (spec_div_eucl x y H1); unfold modulo, Zmod. + case div_eucl; case Zdiv_eucl; simpl; auto. + intros q r q11 r1 H; injection H; auto. + Qed. + + Definition gcd x y := + match x, y with + | Pos nx, Pos ny => Pos (N.gcd nx ny) + | Pos nx, Neg ny => Pos (N.gcd nx ny) + | Neg nx, Pos ny => Pos (N.gcd nx ny) + | Neg nx, Neg ny => Pos (N.gcd nx ny) + end. + + Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b). + unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd; + auto; case N.to_Z; simpl; auto with zarith; + try rewrite Zabs_Zopp; auto; + case N.to_Z; simpl; auto with zarith. + Qed. + +End Make. diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v new file mode 100644 index 00000000..66d2a96a --- /dev/null +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -0,0 +1,249 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZBinary.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import ZMulOrder. +Require Import ZArith. + +Open Local Scope Z_scope. + +Module ZBinAxiomsMod <: ZAxiomsSig. +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ := Z. +Definition NZeq := (@eq Z). +Definition NZ0 := 0. +Definition NZsucc := Zsucc'. +Definition NZpred := Zpred'. +Definition NZadd := Zplus. +Definition NZsub := Zminus. +Definition NZmul := Zmult. + +Theorem NZeq_equiv : equiv Z NZeq. +Proof. +exact (@eq_equiv Z). +Qed. + +Add Relation Z NZeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Proof. +congruence. +Qed. + +Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Proof. +congruence. +Qed. + +Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Proof. +congruence. +Qed. + +Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. +Proof. +congruence. +Qed. + +Theorem NZpred_succ : forall n : Z, NZpred (NZsucc n) = n. +Proof. +exact Zpred'_succ'. +Qed. + +Theorem NZinduction : + forall A : Z -> Prop, predicate_wd NZeq A -> + A 0 -> (forall n : Z, A n <-> A (NZsucc n)) -> forall n : Z, A n. +Proof. +intros A A_wd A0 AS n; apply Zind; clear n. +assumption. +intros; now apply -> AS. +intros n H. rewrite <- (Zsucc'_pred' n) in H. now apply <- AS. +Qed. + +Theorem NZadd_0_l : forall n : Z, 0 + n = n. +Proof. +exact Zplus_0_l. +Qed. + +Theorem NZadd_succ_l : forall n m : Z, (NZsucc n) + m = NZsucc (n + m). +Proof. +intros; do 2 rewrite <- Zsucc_succ'; apply Zplus_succ_l. +Qed. + +Theorem NZsub_0_r : forall n : Z, n - 0 = n. +Proof. +exact Zminus_0_r. +Qed. + +Theorem NZsub_succ_r : forall n m : Z, n - (NZsucc m) = NZpred (n - m). +Proof. +intros; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'; +apply Zminus_succ_r. +Qed. + +Theorem NZmul_0_l : forall n : Z, 0 * n = 0. +Proof. +reflexivity. +Qed. + +Theorem NZmul_succ_l : forall n m : Z, (NZsucc n) * m = n * m + m. +Proof. +intros; rewrite <- Zsucc_succ'; apply Zmult_succ_l. +Qed. + +End NZAxiomsMod. + +Definition NZlt := Zlt. +Definition NZle := Zle. +Definition NZmin := Zmin. +Definition NZmax := Zmax. + +Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. +Proof. +unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. +Proof. +unfold NZeq. intros n1 n2 H1 m1 m2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. +Proof. +congruence. +Qed. + +Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n = m. +Proof. +intros n m; split. apply Zle_lt_or_eq. +intro H; destruct H as [H | H]. now apply Zlt_le_weak. rewrite H; apply Zle_refl. +Qed. + +Theorem NZlt_irrefl : forall n : Z, ~ n < n. +Proof. +exact Zlt_irrefl. +Qed. + +Theorem NZlt_succ_r : forall n m : Z, n < (NZsucc m) <-> n <= m. +Proof. +intros; unfold NZsucc; rewrite <- Zsucc_succ'; split; +[apply Zlt_succ_le | apply Zle_lt_succ]. +Qed. + +Theorem NZmin_l : forall n m : NZ, n <= m -> NZmin n m = n. +Proof. +unfold NZmin, Zmin, Zle; intros n m H. +destruct (n ?= m); try reflexivity. now elim H. +Qed. + +Theorem NZmin_r : forall n m : NZ, m <= n -> NZmin n m = m. +Proof. +unfold NZmin, Zmin, Zle; intros n m H. +case_eq (n ?= m); intro H1; try reflexivity. +now apply Zcompare_Eq_eq. +apply <- Zcompare_Gt_Lt_antisym in H1. now elim H. +Qed. + +Theorem NZmax_l : forall n m : NZ, m <= n -> NZmax n m = n. +Proof. +unfold NZmax, Zmax, Zle; intros n m H. +case_eq (n ?= m); intro H1; try reflexivity. +apply <- Zcompare_Gt_Lt_antisym in H1. now elim H. +Qed. + +Theorem NZmax_r : forall n m : NZ, n <= m -> NZmax n m = m. +Proof. +unfold NZmax, Zmax, Zle; intros n m H. +case_eq (n ?= m); intro H1. +now apply Zcompare_Eq_eq. reflexivity. now elim H. +Qed. + +End NZOrdAxiomsMod. + +Definition Zopp (x : Z) := +match x with +| Z0 => Z0 +| Zpos x => Zneg x +| Zneg x => Zpos x +end. + +Add Morphism Zopp with signature NZeq ==> NZeq as Zopp_wd. +Proof. +congruence. +Qed. + +Theorem Zsucc_pred : forall n : Z, NZsucc (NZpred n) = n. +Proof. +exact Zsucc'_pred'. +Qed. + +Theorem Zopp_0 : - 0 = 0. +Proof. +reflexivity. +Qed. + +Theorem Zopp_succ : forall n : Z, - (NZsucc n) = NZpred (- n). +Proof. +intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'. apply Zopp_succ. +Qed. + +End ZBinAxiomsMod. + +Module Export ZBinMulOrderPropMod := ZMulOrderPropFunct ZBinAxiomsMod. + +(** Z forms a ring *) + +(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Zopp NZeq. +Proof. +constructor. +exact Zadd_0_l. +exact Zadd_comm. +exact Zadd_assoc. +exact Zmul_1_l. +exact Zmul_comm. +exact Zmul_assoc. +exact Zmul_add_distr_r. +intros; now rewrite Zadd_opp_minus. +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 new file mode 100644 index 00000000..8b3d815d --- /dev/null +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -0,0 +1,422 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZNatPairs.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NSub. (* The most complete file for natural numbers *) +Require Export ZMulOrder. (* The most complete file for integers *) +Require Export Ring. + +Module ZPairsAxiomsMod (Import NAxiomsMod : NAxiomsSig) <: ZAxiomsSig. +Module Import NPropMod := NSubPropFunct NAxiomsMod. (* Get all properties of natural numbers *) + +(* We do not declare ring in Natural/Abstract for two reasons. First, some +of the properties proved in NAdd and NMul are used in the new BinNat, +and it is in turn used in Ring. Using ring in Natural/Abstract would be +circular. It is possible, however, not to make BinNat dependent on +Numbers/Natural and prove the properties necessary for ring from scratch +(this is, of course, how it used to be). In addition, if we define semiring +structures in the implementation subdirectories of Natural, we are able to +specify binary natural numbers as the type of coefficients. For these +reasons we define an abstract semiring here. *) + +Open Local Scope NatScope. + +Lemma Nsemi_ring : semi_ring_theory 0 1 add mul Neq. +Proof. +constructor. +exact add_0_l. +exact add_comm. +exact add_assoc. +exact mul_1_l. +exact mul_0_l. +exact mul_comm. +exact mul_assoc. +exact mul_add_distr_r. +Qed. + +Add Ring NSR : Nsemi_ring. + +(* The definitios of functions (NZadd, NZmul, etc.) will be unfolded by +the properties functor. Since we don't want Zadd_comm to refer to unfolded +definitions of equality: fun p1 p2 : NZ => (fst p1 + snd p2) = (fst p2 + snd p1), +we will provide an extra layer of definitions. *) + +Definition Z := (N * N)%type. +Definition Z0 : Z := (0, 0). +Definition Zeq (p1 p2 : Z) := ((fst p1) + (snd p2) == (fst p2) + (snd p1)). +Definition Zsucc (n : Z) : Z := (S (fst n), snd n). +Definition Zpred (n : Z) : Z := (fst n, S (snd n)). + +(* We do not have Zpred (Zsucc n) = n but only Zpred (Zsucc n) == n. It +could be possible to consider as canonical only pairs where one of the +elements is 0, and make all operations convert canonical values into other +canonical values. In that case, we could get rid of setoids and arrive at +integers as signed natural numbers. *) + +Definition Zadd (n m : Z) : Z := ((fst n) + (fst m), (snd n) + (snd m)). +Definition Zsub (n m : Z) : Z := ((fst n) + (snd m), (snd n) + (fst m)). + +(* Unfortunately, the elements of the pair keep increasing, even during +subtraction *) + +Definition Zmul (n m : Z) : Z := + ((fst n) * (fst m) + (snd n) * (snd m), (fst n) * (snd m) + (snd n) * (fst m)). +Definition Zlt (n m : Z) := (fst n) + (snd m) < (fst m) + (snd n). +Definition Zle (n m : Z) := (fst n) + (snd m) <= (fst m) + (snd n). +Definition Zmin (n m : Z) := (min ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)). +Definition Zmax (n m : Z) := (max ((fst n) + (snd m)) ((fst m) + (snd n)), (snd n) + (snd m)). + +Delimit Scope IntScope with Int. +Bind Scope IntScope with Z. +Notation "x == y" := (Zeq x y) (at level 70) : IntScope. +Notation "x ~= y" := (~ Zeq x y) (at level 70) : IntScope. +Notation "0" := Z0 : IntScope. +Notation "1" := (Zsucc Z0) : IntScope. +Notation "x + y" := (Zadd x y) : IntScope. +Notation "x - y" := (Zsub x y) : IntScope. +Notation "x * y" := (Zmul x y) : IntScope. +Notation "x < y" := (Zlt x y) : IntScope. +Notation "x <= y" := (Zle x y) : IntScope. +Notation "x > y" := (Zlt y x) (only parsing) : IntScope. +Notation "x >= y" := (Zle y x) (only parsing) : IntScope. + +Notation Local N := NZ. +(* To remember N without having to use a long qualifying name. since NZ will be redefined *) +Notation Local NE := NZeq (only parsing). +Notation Local add_wd := NZadd_wd (only parsing). + +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ : Type := Z. +Definition NZeq := Zeq. +Definition NZ0 := Z0. +Definition NZsucc := Zsucc. +Definition NZpred := Zpred. +Definition NZadd := Zadd. +Definition NZsub := Zsub. +Definition NZmul := Zmul. + +Theorem ZE_refl : reflexive Z Zeq. +Proof. +unfold reflexive, Zeq. reflexivity. +Qed. + +Theorem ZE_symm : symmetric Z Zeq. +Proof. +unfold symmetric, Zeq; now symmetry. +Qed. + +Theorem ZE_trans : transitive Z Zeq. +Proof. +unfold transitive, Zeq. intros n m p H1 H2. +assert (H3 : (fst n + snd m) + (fst m + snd p) == (fst m + snd n) + (fst p + snd m)) +by now apply add_wd. +stepl ((fst n + snd p) + (fst m + snd m)) in H3 by ring. +stepr ((fst p + snd n) + (fst m + snd m)) in H3 by ring. +now apply -> add_cancel_r in H3. +Qed. + +Theorem NZeq_equiv : equiv Z Zeq. +Proof. +unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_symm]. +Qed. + +Add Relation Z Zeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +Add Morphism (@pair N N) with signature NE ==> NE ==> Zeq as Zpair_wd. +Proof. +intros n1 n2 H1 m1 m2 H2; unfold Zeq; simpl; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZsucc with signature Zeq ==> Zeq as NZsucc_wd. +Proof. +unfold NZsucc, Zeq; intros n m H; simpl. +do 2 rewrite add_succ_l; now rewrite H. +Qed. + +Add Morphism NZpred with signature Zeq ==> Zeq as NZpred_wd. +Proof. +unfold NZpred, Zeq; intros n m H; simpl. +do 2 rewrite add_succ_r; now rewrite H. +Qed. + +Add Morphism NZadd with signature Zeq ==> Zeq ==> Zeq as NZadd_wd. +Proof. +unfold Zeq, NZadd; intros n1 m1 H1 n2 m2 H2; simpl. +assert (H3 : (fst n1 + snd m1) + (fst n2 + snd m2) == (fst m1 + snd n1) + (fst m2 + snd n2)) +by now apply add_wd. +stepl (fst n1 + snd m1 + (fst n2 + snd m2)) by ring. +now stepr (fst m1 + snd n1 + (fst m2 + snd n2)) by ring. +Qed. + +Add Morphism NZsub with signature Zeq ==> Zeq ==> Zeq as NZsub_wd. +Proof. +unfold Zeq, NZsub; intros n1 m1 H1 n2 m2 H2; simpl. +symmetry in H2. +assert (H3 : (fst n1 + snd m1) + (fst m2 + snd n2) == (fst m1 + snd n1) + (fst n2 + snd m2)) +by now apply add_wd. +stepl (fst n1 + snd m1 + (fst m2 + snd n2)) by ring. +now stepr (fst m1 + snd n1 + (fst n2 + snd m2)) by ring. +Qed. + +Add Morphism NZmul with signature Zeq ==> Zeq ==> Zeq as NZmul_wd. +Proof. +unfold NZmul, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. +stepl (fst n1 * fst n2 + (snd n1 * snd n2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. +stepr (fst n1 * snd n2 + (fst m1 * fst m2 + snd m1 * snd m2 + snd n1 * fst n2)) by ring. +apply add_mul_repl_pair with (n := fst m2) (m := snd m2); [| now idtac]. +stepl (snd n1 * snd n2 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. +stepr (snd n1 * fst n2 + (fst n1 * snd m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. +apply add_mul_repl_pair with (n := snd m2) (m := fst m2); +[| (stepl (fst n2 + snd m2) by ring); now stepr (fst m2 + snd n2) by ring]. +stepl (snd m2 * snd n1 + (fst n1 * fst m2 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. +stepr (snd m2 * fst n1 + (snd n1 * fst m2 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. +apply add_mul_repl_pair with (n := snd m1) (m := fst m1); +[ | (stepl (fst n1 + snd m1) by ring); now stepr (fst m1 + snd n1) by ring]. +stepl (fst m2 * fst n1 + (snd m2 * snd m1 + fst m1 * snd m2 + snd m1 * fst m2)) by ring. +stepr (fst m2 * snd n1 + (snd m2 * fst m1 + fst m1 * fst m2 + snd m1 * snd m2)) by ring. +apply add_mul_repl_pair with (n := fst m1) (m := snd m1); [| now idtac]. +ring. +Qed. + +Section Induction. +Open Scope NatScope. (* automatically closes at the end of the section *) +Variable A : Z -> Prop. +Hypothesis A_wd : predicate_wd Zeq A. + +Add Morphism A with signature Zeq ==> iff as A_morph. +Proof. +exact A_wd. +Qed. + +Theorem NZinduction : + A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n. (* 0 is interpreted as in Z due to "Bind" directive *) +Proof. +intros A0 AS n; unfold NZ0, Zsucc, predicate_wd, fun_wd, Zeq in *. +destruct n as [n m]. +cut (forall p : N, A (p, 0)); [intro H1 |]. +cut (forall p : N, A (0, p)); [intro H2 |]. +destruct (add_dichotomy n m) as [[p H] | [p H]]. +rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm). +apply H2. +rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1. +induct p. assumption. intros p IH. +apply -> (A_wd (0, p) (1, S p)) in IH; [| now rewrite add_0_l, add_1_l]. +now apply <- AS. +induct p. assumption. intros p IH. +replace 0 with (snd (p, 0)); [| reflexivity]. +replace (S p) with (S (fst (p, 0))); [| reflexivity]. now apply -> AS. +Qed. + +End Induction. + +(* Time to prove theorems in the language of Z *) + +Open Local Scope IntScope. + +Theorem NZpred_succ : forall n : Z, Zpred (Zsucc n) == n. +Proof. +unfold NZpred, NZsucc, Zeq; intro n; simpl. +rewrite add_succ_l; now rewrite add_succ_r. +Qed. + +Theorem NZadd_0_l : forall n : Z, 0 + n == n. +Proof. +intro n; unfold NZadd, Zeq; simpl. now do 2 rewrite add_0_l. +Qed. + +Theorem NZadd_succ_l : forall n m : Z, (Zsucc n) + m == Zsucc (n + m). +Proof. +intros n m; unfold NZadd, Zeq; simpl. now do 2 rewrite add_succ_l. +Qed. + +Theorem NZsub_0_r : forall n : Z, n - 0 == n. +Proof. +intro n; unfold NZsub, Zeq; simpl. now do 2 rewrite add_0_r. +Qed. + +Theorem NZsub_succ_r : forall n m : Z, n - (Zsucc m) == Zpred (n - m). +Proof. +intros n m; unfold NZsub, Zeq; simpl. symmetry; now rewrite add_succ_r. +Qed. + +Theorem NZmul_0_l : forall n : Z, 0 * n == 0. +Proof. +intro n; unfold NZmul, Zeq; simpl. +repeat rewrite mul_0_l. now rewrite add_assoc. +Qed. + +Theorem NZmul_succ_l : forall n m : Z, (Zsucc n) * m == n * m + m. +Proof. +intros n m; unfold NZmul, NZsucc, Zeq; simpl. +do 2 rewrite mul_succ_l. ring. +Qed. + +End NZAxiomsMod. + +Definition NZlt := Zlt. +Definition NZle := Zle. +Definition NZmin := Zmin. +Definition NZmax := Zmax. + +Add Morphism NZlt with signature Zeq ==> Zeq ==> iff as NZlt_wd. +Proof. +unfold NZlt, Zlt, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. split; intro H. +stepr (snd m1 + fst m2) by apply add_comm. +apply (add_lt_repl_pair (fst n1) (snd n1)); [| assumption]. +stepl (snd m2 + fst n1) by apply add_comm. +stepr (fst m2 + snd n1) by apply add_comm. +apply (add_lt_repl_pair (snd n2) (fst n2)). +now stepl (fst n1 + snd n2) by apply add_comm. +stepl (fst m2 + snd n2) by apply add_comm. now stepr (fst n2 + snd m2) by apply add_comm. +stepr (snd n1 + fst n2) by apply add_comm. +apply (add_lt_repl_pair (fst m1) (snd m1)); [| now symmetry]. +stepl (snd n2 + fst m1) by apply add_comm. +stepr (fst n2 + snd m1) by apply add_comm. +apply (add_lt_repl_pair (snd m2) (fst m2)). +now stepl (fst m1 + snd m2) by apply add_comm. +stepl (fst n2 + snd m2) by apply add_comm. now stepr (fst m2 + snd n2) by apply add_comm. +Qed. + +Add Morphism NZle with signature Zeq ==> Zeq ==> iff as NZle_wd. +Proof. +unfold NZle, Zle, Zeq; intros n1 m1 H1 n2 m2 H2; simpl. +do 2 rewrite lt_eq_cases. rewrite (NZlt_wd n1 m1 H1 n2 m2 H2). fold (m1 < m2)%Int. +fold (n1 == n2)%Int (m1 == m2)%Int; fold (n1 == m1)%Int in H1; fold (n2 == m2)%Int in H2. +now rewrite H1, H2. +Qed. + +Add Morphism NZmin with signature Zeq ==> Zeq ==> Zeq as NZmin_wd. +Proof. +intros n1 m1 H1 n2 m2 H2; unfold NZmin, Zeq; simpl. +destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H]. +rewrite (min_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. +rewrite (min_l (fst m1 + snd m2) (fst m2 + snd m1)) by +now apply -> (NZle_wd n1 m1 H1 n2 m2 H2). +stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring. +unfold Zeq in H1. rewrite H1. ring. +rewrite (min_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. +rewrite (min_r (fst m1 + snd m2) (fst m2 + snd m1)) by +now apply -> (NZle_wd n2 m2 H2 n1 m1 H1). +stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring. +unfold Zeq in H2. rewrite H2. ring. +Qed. + +Add Morphism NZmax with signature Zeq ==> Zeq ==> Zeq as NZmax_wd. +Proof. +intros n1 m1 H1 n2 m2 H2; unfold NZmax, Zeq; simpl. +destruct (le_ge_cases (fst n1 + snd n2) (fst n2 + snd n1)) as [H | H]. +rewrite (max_r (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. +rewrite (max_r (fst m1 + snd m2) (fst m2 + snd m1)) by +now apply -> (NZle_wd n1 m1 H1 n2 m2 H2). +stepl ((fst n2 + snd m2) + (snd n1 + snd m1)) by ring. +unfold Zeq in H2. rewrite H2. ring. +rewrite (max_l (fst n1 + snd n2) (fst n2 + snd n1)) by assumption. +rewrite (max_l (fst m1 + snd m2) (fst m2 + snd m1)) by +now apply -> (NZle_wd n2 m2 H2 n1 m1 H1). +stepl ((fst n1 + snd m1) + (snd n2 + snd m2)) by ring. +unfold Zeq in H1. rewrite H1. ring. +Qed. + +Open Local Scope IntScope. + +Theorem NZlt_eq_cases : forall n m : Z, n <= m <-> n < m \/ n == m. +Proof. +intros n m; unfold Zlt, Zle, Zeq; simpl. apply lt_eq_cases. +Qed. + +Theorem NZlt_irrefl : forall n : Z, ~ (n < n). +Proof. +intros n; unfold Zlt, Zeq; simpl. apply lt_irrefl. +Qed. + +Theorem NZlt_succ_r : forall n m : Z, n < (Zsucc m) <-> n <= m. +Proof. +intros n m; unfold Zlt, Zle, Zeq; simpl. rewrite add_succ_l; apply lt_succ_r. +Qed. + +Theorem NZmin_l : forall n m : Z, n <= m -> Zmin n m == n. +Proof. +unfold Zmin, Zle, Zeq; simpl; intros n m H. +rewrite min_l by assumption. ring. +Qed. + +Theorem NZmin_r : forall n m : Z, m <= n -> Zmin n m == m. +Proof. +unfold Zmin, Zle, Zeq; simpl; intros n m H. +rewrite min_r by assumption. ring. +Qed. + +Theorem NZmax_l : forall n m : Z, m <= n -> Zmax n m == n. +Proof. +unfold Zmax, Zle, Zeq; simpl; intros n m H. +rewrite max_l by assumption. ring. +Qed. + +Theorem NZmax_r : forall n m : Z, n <= m -> Zmax n m == m. +Proof. +unfold Zmax, Zle, Zeq; simpl; intros n m H. +rewrite max_r by assumption. ring. +Qed. + +End NZOrdAxiomsMod. + +Definition Zopp (n : Z) : Z := (snd n, fst n). + +Notation "- x" := (Zopp x) : IntScope. + +Add Morphism Zopp with signature Zeq ==> Zeq as Zopp_wd. +Proof. +unfold Zeq; intros n m H; simpl. symmetry. +stepl (fst n + snd m) by apply add_comm. +now stepr (fst m + snd n) by apply add_comm. +Qed. + +Open Local Scope IntScope. + +Theorem Zsucc_pred : forall n : Z, Zsucc (Zpred n) == n. +Proof. +intro n; unfold Zsucc, Zpred, Zeq; simpl. +rewrite add_succ_l; now rewrite add_succ_r. +Qed. + +Theorem Zopp_0 : - 0 == 0. +Proof. +unfold Zopp, Zeq; simpl. now rewrite add_0_l. +Qed. + +Theorem Zopp_succ : forall n, - (Zsucc n) == Zpred (- n). +Proof. +reflexivity. +Qed. + +End ZPairsAxiomsMod. + +(* For example, let's build integers out of pairs of Peano natural numbers +and get their properties *) + +(* The following lines increase the compilation time at least twice *) +(* +Require Import NPeano. + +Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod NPeanoAxiomsMod. +Module Export ZPairsMulOrderPropMod := ZMulOrderPropFunct ZPairsPeanoAxiomsMod. + +Open Local Scope IntScope. + +Eval compute in (3, 5) * (4, 6). +*) + diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v new file mode 100644 index 00000000..0af98c74 --- /dev/null +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -0,0 +1,117 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: ZSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import ZArith Znumtheory. + +Open Scope Z_scope. + +(** * ZSig *) + +(** Interface of a rich structure about integers. + Specifications are written via translation to Z. +*) + +Module Type ZType. + + Parameter t : Type. + + Parameter to_Z : t -> Z. + Notation "[ x ]" := (to_Z x). + + Definition eq x y := ([x] = [y]). + + Parameter of_Z : Z -> t. + Parameter spec_of_Z: forall x, to_Z (of_Z x) = x. + + Parameter zero : t. + Parameter one : t. + Parameter minus_one : t. + + Parameter spec_0: [zero] = 0. + Parameter spec_1: [one] = 1. + Parameter spec_m1: [minus_one] = -1. + + Parameter compare : t -> t -> comparison. + + Parameter spec_compare: forall x y, + match compare x y with + | Eq => [x] = [y] + | Lt => [x] < [y] + | Gt => [x] > [y] + end. + + Definition lt n m := compare n m = Lt. + Definition le n m := compare n m <> Gt. + 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. + + Parameter eq_bool : t -> t -> bool. + + Parameter spec_eq_bool: forall x y, + if eq_bool x y then [x] = [y] else [x] <> [y]. + + Parameter succ : t -> t. + + Parameter spec_succ: forall n, [succ n] = [n] + 1. + + Parameter add : t -> t -> t. + + Parameter spec_add: forall x y, [add x y] = [x] + [y]. + + Parameter pred : t -> t. + + Parameter spec_pred: forall x, [pred x] = [x] - 1. + + Parameter sub : t -> t -> t. + + Parameter spec_sub: forall x y, [sub x y] = [x] - [y]. + + Parameter opp : t -> t. + + Parameter spec_opp: forall x, [opp x] = - [x]. + + Parameter mul : t -> t -> t. + + Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. + + Parameter square : t -> t. + + Parameter spec_square: forall x, [square x] = [x] * [x]. + + Parameter power_pos : t -> positive -> t. + + Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + + Parameter sqrt : t -> t. + + Parameter spec_sqrt: forall x, 0 <= [x] -> + [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + + Parameter div_eucl : t -> t -> t * t. + + Parameter spec_div_eucl: forall x y, [y] <> 0 -> + let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + + Parameter div : t -> t -> t. + + Parameter spec_div: forall x y, [y] <> 0 -> [div x y] = [x] / [y]. + + Parameter modulo : t -> t -> t. + + Parameter spec_modulo: forall x y, [y] <> 0 -> + [modulo x y] = [x] mod [y]. + + Parameter gcd : t -> t -> t. + + Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b). + +End ZType. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v new file mode 100644 index 00000000..d7c56267 --- /dev/null +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -0,0 +1,306 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: ZSigZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import ZArith. +Require Import ZAxioms. +Require Import ZSig. + +(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *) + +Module ZSig_ZAxioms (Z:ZType) <: ZAxiomsSig. + +Delimit Scope IntScope with Int. +Bind Scope IntScope with Z.t. +Open Local Scope IntScope. +Notation "[ x ]" := (Z.to_Z x) : IntScope. +Infix "==" := Z.eq (at level 70) : IntScope. +Notation "0" := Z.zero : IntScope. +Infix "+" := Z.add : IntScope. +Infix "-" := Z.sub : IntScope. +Infix "*" := Z.mul : IntScope. +Notation "- x" := (Z.opp x) : IntScope. + +Hint Rewrite + Z.spec_0 Z.spec_1 Z.spec_add Z.spec_sub Z.spec_pred Z.spec_succ + Z.spec_mul Z.spec_opp Z.spec_of_Z : Zspec. + +Ltac zsimpl := unfold Z.eq in *; autorewrite with Zspec. + +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ := Z.t. +Definition NZeq := Z.eq. +Definition NZ0 := Z.zero. +Definition NZsucc := Z.succ. +Definition NZpred := Z.pred. +Definition NZadd := Z.add. +Definition NZsub := Z.sub. +Definition NZmul := Z.mul. + +Theorem NZeq_equiv : equiv Z.t Z.eq. +Proof. +repeat split; repeat red; intros; auto; congruence. +Qed. + +Add Relation Z.t Z.eq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) + as NZeq_rel. + +Add Morphism NZsucc with signature Z.eq ==> Z.eq as NZsucc_wd. +Proof. +intros; zsimpl; f_equal; assumption. +Qed. + +Add Morphism NZpred with signature Z.eq ==> Z.eq as NZpred_wd. +Proof. +intros; zsimpl; f_equal; assumption. +Qed. + +Add Morphism NZadd with signature Z.eq ==> Z.eq ==> Z.eq as NZadd_wd. +Proof. +intros; zsimpl; f_equal; assumption. +Qed. + +Add Morphism NZsub with signature Z.eq ==> Z.eq ==> Z.eq as NZsub_wd. +Proof. +intros; zsimpl; f_equal; assumption. +Qed. + +Add Morphism NZmul with signature Z.eq ==> Z.eq ==> Z.eq as NZmul_wd. +Proof. +intros; zsimpl; f_equal; assumption. +Qed. + +Theorem NZpred_succ : forall n, Z.pred (Z.succ n) == n. +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Section Induction. + +Variable A : Z.t -> Prop. +Hypothesis A_wd : predicate_wd Z.eq A. +Hypothesis A0 : A 0. +Hypothesis AS : forall n, A n <-> A (Z.succ n). + +Add Morphism A with signature Z.eq ==> iff as A_morph. +Proof. apply A_wd. Qed. + +Let B (z : Z) := A (Z.of_Z z). + +Lemma B0 : B 0. +Proof. +unfold B; simpl. +rewrite <- (A_wd 0); auto. +zsimpl; auto. +Qed. + +Lemma BS : forall z : Z, B z -> B (z + 1). +Proof. +intros z H. +unfold B in *. apply -> AS in H. +setoid_replace (Z.of_Z (z + 1)) with (Z.succ (Z.of_Z z)); auto. +zsimpl; auto. +Qed. + +Lemma BP : forall z : Z, B z -> B (z - 1). +Proof. +intros z H. +unfold B in *. rewrite AS. +setoid_replace (Z.succ (Z.of_Z (z - 1))) with (Z.of_Z z); auto. +zsimpl; auto with zarith. +Qed. + +Lemma B_holds : forall z : Z, B z. +Proof. +intros; destruct (Z_lt_le_dec 0 z). +apply natlike_ind; auto with zarith. +apply B0. +intros; apply BS; auto. +replace z with (-(-z))%Z in * by (auto with zarith). +remember (-z)%Z as z'. +pattern z'; apply natlike_ind. +apply B0. +intros; rewrite Zopp_succ; unfold Zpred; apply BP; auto. +subst z'; auto with zarith. +Qed. + +Theorem NZinduction : forall n, A n. +Proof. +intro n. setoid_replace n with (Z.of_Z (Z.to_Z n)). +apply B_holds. +zsimpl; auto. +Qed. + +End Induction. + +Theorem NZadd_0_l : forall n, 0 + n == n. +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem NZadd_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m). +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem NZsub_0_r : forall n, n - 0 == n. +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem NZsub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m). +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem NZmul_0_l : forall n, 0 * n == 0. +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem NZmul_succ_l : forall n m, (Z.succ n) * m == n * m + m. +Proof. +intros; zsimpl; ring. +Qed. + +End NZAxiomsMod. + +Definition NZlt := Z.lt. +Definition NZle := Z.le. +Definition NZmin := Z.min. +Definition NZmax := Z.max. + +Infix "<=" := Z.le : IntScope. +Infix "<" := Z.lt : IntScope. + +Lemma spec_compare_alt : forall x y, Z.compare x y = ([x] ?= [y])%Z. +Proof. + intros; generalize (Z.spec_compare x y). + destruct (Z.compare x y); auto. + intros H; rewrite H; symmetry; apply Zcompare_refl. +Qed. + +Lemma spec_lt : forall x y, (x<y) <-> ([x]<[y])%Z. +Proof. + intros; unfold Z.lt, Zlt; rewrite spec_compare_alt; intuition. +Qed. + +Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z. +Proof. + intros; unfold Z.le, Zle; rewrite spec_compare_alt; intuition. +Qed. + +Lemma spec_min : forall x y, [Z.min x y] = Zmin [x] [y]. +Proof. + intros; unfold Z.min, Zmin. + rewrite spec_compare_alt; destruct Zcompare; auto. +Qed. + +Lemma spec_max : forall x y, [Z.max x y] = Zmax [x] [y]. +Proof. + intros; unfold Z.max, Zmax. + rewrite spec_compare_alt; destruct Zcompare; auto. +Qed. + +Add Morphism Z.compare with signature Z.eq ==> Z.eq ==> (@eq comparison) as compare_wd. +Proof. +intros x x' Hx y y' Hy. +rewrite 2 spec_compare_alt; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism Z.lt with signature Z.eq ==> Z.eq ==> iff as NZlt_wd. +Proof. +intros x x' Hx y y' Hy; unfold Z.lt; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism Z.le with signature Z.eq ==> Z.eq ==> iff as NZle_wd. +Proof. +intros x x' Hx y y' Hy; unfold Z.le; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism Z.min with signature Z.eq ==> Z.eq ==> Z.eq as NZmin_wd. +Proof. +intros; red; rewrite 2 spec_min; congruence. +Qed. + +Add Morphism Z.max with signature Z.eq ==> Z.eq ==> Z.eq as NZmax_wd. +Proof. +intros; red; rewrite 2 spec_max; congruence. +Qed. + +Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +Proof. +intros. +unfold Z.eq; rewrite spec_lt, spec_le; omega. +Qed. + +Theorem NZlt_irrefl : forall n, ~ n < n. +Proof. +intros; rewrite spec_lt; auto with zarith. +Qed. + +Theorem NZlt_succ_r : forall n m, n < (Z.succ m) <-> n <= m. +Proof. +intros; rewrite spec_lt, spec_le, Z.spec_succ; omega. +Qed. + +Theorem NZmin_l : forall n m, n <= m -> Z.min n m == n. +Proof. +intros n m; unfold Z.eq; rewrite spec_le, spec_min. +generalize (Zmin_spec [n] [m]); omega. +Qed. + +Theorem NZmin_r : forall n m, m <= n -> Z.min n m == m. +Proof. +intros n m; unfold Z.eq; rewrite spec_le, spec_min. +generalize (Zmin_spec [n] [m]); omega. +Qed. + +Theorem NZmax_l : forall n m, m <= n -> Z.max n m == n. +Proof. +intros n m; unfold Z.eq; rewrite spec_le, spec_max. +generalize (Zmax_spec [n] [m]); omega. +Qed. + +Theorem NZmax_r : forall n m, n <= m -> Z.max n m == m. +Proof. +intros n m; unfold Z.eq; rewrite spec_le, spec_max. +generalize (Zmax_spec [n] [m]); omega. +Qed. + +End NZOrdAxiomsMod. + +Definition Zopp := Z.opp. + +Add Morphism Z.opp with signature Z.eq ==> Z.eq as Zopp_wd. +Proof. +intros; zsimpl; auto with zarith. +Qed. + +Theorem Zsucc_pred : forall n, Z.succ (Z.pred n) == n. +Proof. +red; intros; zsimpl; auto with zarith. +Qed. + +Theorem Zopp_0 : - 0 == 0. +Proof. +red; intros; zsimpl; auto with zarith. +Qed. + +Theorem Zopp_succ : forall n, - (Z.succ n) == Z.pred (- n). +Proof. +intros; zsimpl; auto with zarith. +Qed. + +End ZSig_ZAxioms. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v new file mode 100644 index 00000000..04a48d51 --- /dev/null +++ b/theories/Numbers/NaryFunctions.v @@ -0,0 +1,142 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *) +(************************************************************************) + +(*i $Id: NaryFunctions.v 10967 2008-05-22 12:59:38Z letouzey $ i*) + +Open Local Scope type_scope. + +Require Import List. + +(** * Generic dependently-typed operators about [n]-ary functions *) + +(** The type of [n]-ary function: [nfun A n B] is + [A -> ... -> A -> B] with [n] occurences of [A] in this type. *) + +Fixpoint nfun A n B := + match n with + | O => B + | S n => A -> (nfun A n B) + end. + +Notation " A ^^ n --> B " := (nfun A n B) + (at level 50, n at next level) : type_scope. + +(** [napply_cst _ _ a n f] iterates [n] times the application of a + particular constant [a] to the [n]-ary function [f]. *) + +Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := + match n return (A^^n-->B) -> B with + | O => fun x => x + | S n => fun x => napply_cst _ _ a n (x a) + end. + + +(** A generic transformation from an n-ary function to another one.*) + +Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : + (A^^n-->B) -> (A^^n-->C) := + match n return (A^^n-->B) -> (A^^n-->C) with + | O => f + | S n => fun g a => nfun_to_nfun _ _ _ f n (g a) + end. + +(** [napply_except_last _ _ n f] expects [n] arguments of type [A], + applies [n-1] of them to [f] and discard the last one. *) + +Definition napply_except_last (A B:Type) := + nfun_to_nfun A B (A->B) (fun b a => b). + +(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], + applies them to [f] and then apply [a] to the result. *) + +Definition napply_then_last (A B:Type)(a:A) := + nfun_to_nfun A (A->B) B (fun fab => fab a). + +(** [napply_discard _ b n] expects [n] arguments, discards then, + and returns [b]. *) + +Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B := + match n return A^^n-->B with + | O => b + | S n => fun _ => napply_discard _ _ b n + end. + +(** A fold function *) + +Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with + | O => b + | S n => fun a => (nfold _ _ f (f a b) n) + end. + + +(** [n]-ary products : [nprod A n] is [A*...*A*unit], + with [n] occurrences of [A] in this type. *) + +Fixpoint nprod A n : Type := match n with + | O => unit + | S n => (A * nprod A n)%type +end. + +Notation "A ^ n" := (nprod A n) : type_scope. + +(** [n]-ary curryfication / uncurryfication *) + +Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := + match n return (A^n -> B) -> (A^^n-->B) with + | O => fun x => x tt + | S n => fun f a => ncurry _ _ n (fun p => f (a,p)) + end. + +Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := + match n return (A^^n-->B) -> (A^n -> B) with + | O => fun x _ => x + | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p + end. + +(** Earlier functions can also be defined via [ncurry/nuncurry]. + For instance : *) + +Definition nfun_to_nfun_bis A B C (f:B->C) n : + (A^^n-->B) -> (A^^n-->C) := + fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)). + +(** We can also us it to obtain another [fold] function, + equivalent to the previous one, but with a nicer expansion + (see for instance Int31.iszero). *) + +Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with + | O => b + | S n => fun a => + nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n) + end. + +(** From [nprod] to [list] *) + +Fixpoint nprod_to_list (A:Type) n : A^n -> list A := + match n with + | O => fun _ => nil + | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p) + end. + +(** From [list] to [nprod] *) + +Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := + match l return A^(length l) with + | nil => tt + | x::l => (x, nprod_of_list _ l) + end. + +(** This gives an additional way to write the fold *) + +Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := + ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)). + diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v new file mode 100644 index 00000000..c9bb5c95 --- /dev/null +++ b/theories/Numbers/NatInt/NZAdd.v @@ -0,0 +1,91 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NZAxioms. +Require Import NZBase. + +Module NZAddPropFunct (Import NZAxiomsMod : NZAxiomsSig). +Module Export NZBasePropMod := NZBasePropFunct NZAxiomsMod. +Open Local Scope NatIntScope. + +Theorem NZadd_0_r : forall n : NZ, n + 0 == n. +Proof. +NZinduct n. now rewrite NZadd_0_l. +intro. rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZadd_succ_r : forall n m : NZ, n + S m == S (n + m). +Proof. +intros n m; NZinduct n. +now do 2 rewrite NZadd_0_l. +intro. repeat rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZadd_comm : forall n m : NZ, n + m == m + n. +Proof. +intros n m; NZinduct n. +rewrite NZadd_0_l; now rewrite NZadd_0_r. +intros n. rewrite NZadd_succ_l; rewrite NZadd_succ_r. now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZadd_1_l : forall n : NZ, 1 + n == S n. +Proof. +intro n; rewrite NZadd_succ_l; now rewrite NZadd_0_l. +Qed. + +Theorem NZadd_1_r : forall n : NZ, n + 1 == S n. +Proof. +intro n; rewrite NZadd_comm; apply NZadd_1_l. +Qed. + +Theorem NZadd_assoc : forall n m p : NZ, n + (m + p) == (n + m) + p. +Proof. +intros n m p; NZinduct n. +now do 2 rewrite NZadd_0_l. +intro. do 3 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZadd_shuffle1 : forall n m p q : NZ, (n + m) + (p + q) == (n + p) + (m + q). +Proof. +intros n m p q. +rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_comm m (p + q)). +rewrite <- (NZadd_assoc p q m). rewrite (NZadd_assoc n p (q + m)). +now rewrite (NZadd_comm q m). +Qed. + +Theorem NZadd_shuffle2 : forall n m p q : NZ, (n + m) + (p + q) == (n + q) + (m + p). +Proof. +intros n m p q. +rewrite <- (NZadd_assoc n m (p + q)). rewrite (NZadd_assoc m p q). +rewrite (NZadd_comm (m + p) q). now rewrite <- (NZadd_assoc n q (m + p)). +Qed. + +Theorem NZadd_cancel_l : forall n m p : NZ, p + n == p + m <-> n == m. +Proof. +intros n m p; NZinduct p. +now do 2 rewrite NZadd_0_l. +intro p. do 2 rewrite NZadd_succ_l. now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZadd_cancel_r : forall n m p : NZ, n + p == m + p <-> n == m. +Proof. +intros n m p. rewrite (NZadd_comm n p); rewrite (NZadd_comm m p). +apply NZadd_cancel_l. +Qed. + +Theorem NZsub_1_r : forall n : NZ, n - 1 == P n. +Proof. +intro n; rewrite NZsub_succ_r; now rewrite NZsub_0_r. +Qed. + +End NZAddPropFunct. + diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v new file mode 100644 index 00000000..50d1c42f --- /dev/null +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -0,0 +1,166 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NZAxioms. +Require Import NZOrder. + +Module NZAddOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). +Module Export NZOrderPropMod := NZOrderPropFunct NZOrdAxiomsMod. +Open Local Scope NatIntScope. + +Theorem NZadd_lt_mono_l : forall n m p : NZ, n < m <-> p + n < p + m. +Proof. +intros n m p; NZinduct p. +now do 2 rewrite NZadd_0_l. +intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_lt_mono. +Qed. + +Theorem NZadd_lt_mono_r : forall n m p : NZ, n < m <-> n + p < m + p. +Proof. +intros n m p. +rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_lt_mono_l. +Qed. + +Theorem NZadd_lt_mono : forall n m p q : NZ, n < m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply NZlt_trans with (m + p); +[now apply -> NZadd_lt_mono_r | now apply -> NZadd_lt_mono_l]. +Qed. + +Theorem NZadd_le_mono_l : forall n m p : NZ, n <= m <-> p + n <= p + m. +Proof. +intros n m p; NZinduct p. +now do 2 rewrite NZadd_0_l. +intro p. do 2 rewrite NZadd_succ_l. now rewrite <- NZsucc_le_mono. +Qed. + +Theorem NZadd_le_mono_r : forall n m p : NZ, n <= m <-> n + p <= m + p. +Proof. +intros n m p. +rewrite (NZadd_comm n p); rewrite (NZadd_comm m p); apply NZadd_le_mono_l. +Qed. + +Theorem NZadd_le_mono : forall n m p q : NZ, n <= m -> p <= q -> n + p <= m + q. +Proof. +intros n m p q H1 H2. +apply NZle_trans with (m + p); +[now apply -> NZadd_le_mono_r | now apply -> NZadd_le_mono_l]. +Qed. + +Theorem NZadd_lt_le_mono : forall n m p q : NZ, n < m -> p <= q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply NZlt_le_trans with (m + p); +[now apply -> NZadd_lt_mono_r | now apply -> NZadd_le_mono_l]. +Qed. + +Theorem NZadd_le_lt_mono : forall n m p q : NZ, n <= m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply NZle_lt_trans with (m + p); +[now apply -> NZadd_le_mono_r | now apply -> NZadd_lt_mono_l]. +Qed. + +Theorem NZadd_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_mono. +Qed. + +Theorem NZadd_pos_nonneg : forall n m : NZ, 0 < n -> 0 <= m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_lt_le_mono. +Qed. + +Theorem NZadd_nonneg_pos : forall n m : NZ, 0 <= n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_lt_mono. +Qed. + +Theorem NZadd_nonneg_nonneg : forall n m : NZ, 0 <= n -> 0 <= m -> 0 <= n + m. +Proof. +intros n m H1 H2. rewrite <- (NZadd_0_l 0). now apply NZadd_le_mono. +Qed. + +Theorem NZlt_add_pos_l : forall n m : NZ, 0 < n -> m < n + m. +Proof. +intros n m H. apply -> (NZadd_lt_mono_r 0 n m) in H. +now rewrite NZadd_0_l in H. +Qed. + +Theorem NZlt_add_pos_r : forall n m : NZ, 0 < n -> m < m + n. +Proof. +intros; rewrite NZadd_comm; now apply NZlt_add_pos_l. +Qed. + +Theorem NZle_lt_add_lt : forall n m p q : NZ, n <= m -> p + m < q + n -> p < q. +Proof. +intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption]. +pose proof (NZadd_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H2. +false_hyp H3 H2. +Qed. + +Theorem NZlt_le_add_lt : forall n m p q : NZ, n < m -> p + m <= q + n -> p < q. +Proof. +intros n m p q H1 H2. destruct (NZle_gt_cases q p); [| assumption]. +pose proof (NZadd_le_lt_mono q p n m H H1) as H3. apply <- NZnle_gt in H3. +false_hyp H2 H3. +Qed. + +Theorem NZle_le_add_le : forall n m p q : NZ, n <= m -> p + m <= q + n -> p <= q. +Proof. +intros n m p q H1 H2. destruct (NZle_gt_cases p q); [assumption |]. +pose proof (NZadd_lt_le_mono q p n m H H1) as H3. apply <- NZnle_gt in H3. +false_hyp H2 H3. +Qed. + +Theorem NZadd_lt_cases : forall n m p q : NZ, n + m < p + q -> n < p \/ m < q. +Proof. +intros n m p q H; +destruct (NZle_gt_cases p n) as [H1 | H1]. +destruct (NZle_gt_cases q m) as [H2 | H2]. +pose proof (NZadd_le_mono p n q m H1 H2) as H3. apply -> NZle_ngt in H3. +false_hyp H H3. +now right. now left. +Qed. + +Theorem NZadd_le_cases : forall n m p q : NZ, n + m <= p + q -> n <= p \/ m <= q. +Proof. +intros n m p q H. +destruct (NZle_gt_cases n p) as [H1 | H1]. now left. +destruct (NZle_gt_cases m q) as [H2 | H2]. now right. +assert (H3 : p + q < n + m) by now apply NZadd_lt_mono. +apply -> NZle_ngt in H. false_hyp H3 H. +Qed. + +Theorem NZadd_neg_cases : forall n m : NZ, n + m < 0 -> n < 0 \/ m < 0. +Proof. +intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l. +Qed. + +Theorem NZadd_pos_cases : forall n m : NZ, 0 < n + m -> 0 < n \/ 0 < m. +Proof. +intros n m H; apply NZadd_lt_cases; now rewrite NZadd_0_l. +Qed. + +Theorem NZadd_nonpos_cases : forall n m : NZ, n + m <= 0 -> n <= 0 \/ m <= 0. +Proof. +intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l. +Qed. + +Theorem NZadd_nonneg_cases : forall n m : NZ, 0 <= n + m -> 0 <= n \/ 0 <= m. +Proof. +intros n m H; apply NZadd_le_cases; now rewrite NZadd_0_l. +Qed. + +End NZAddOrderPropFunct. + diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v new file mode 100644 index 00000000..26933646 --- /dev/null +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -0,0 +1,99 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NumPrelude. + +Module Type NZAxiomsSig. + +Parameter Inline NZ : Type. +Parameter Inline NZeq : NZ -> NZ -> Prop. +Parameter Inline NZ0 : NZ. +Parameter Inline NZsucc : NZ -> NZ. +Parameter Inline NZpred : NZ -> NZ. +Parameter Inline NZadd : NZ -> NZ -> NZ. +Parameter Inline NZsub : NZ -> NZ -> NZ. +Parameter Inline NZmul : NZ -> NZ -> NZ. + +(* Unary subtraction (opp) is not defined on natural numbers, so we have + it for integers only *) + +Axiom NZeq_equiv : equiv NZ NZeq. +Add Relation NZ NZeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. + +Delimit Scope NatIntScope with NatInt. +Open Local Scope NatIntScope. +Notation "x == y" := (NZeq x y) (at level 70) : NatIntScope. +Notation "x ~= y" := (~ NZeq x y) (at level 70) : NatIntScope. +Notation "0" := NZ0 : NatIntScope. +Notation S := NZsucc. +Notation P := NZpred. +Notation "1" := (S 0) : NatIntScope. +Notation "x + y" := (NZadd x y) : NatIntScope. +Notation "x - y" := (NZsub x y) : NatIntScope. +Notation "x * y" := (NZmul x y) : NatIntScope. + +Axiom NZpred_succ : forall n : NZ, P (S n) == n. + +Axiom NZinduction : + forall A : NZ -> Prop, predicate_wd NZeq A -> + A 0 -> (forall n : NZ, A n <-> A (S n)) -> forall n : NZ, A n. + +Axiom NZadd_0_l : forall n : NZ, 0 + n == n. +Axiom NZadd_succ_l : forall n m : NZ, (S n) + m == S (n + m). + +Axiom NZsub_0_r : forall n : NZ, n - 0 == n. +Axiom NZsub_succ_r : forall n m : NZ, n - (S m) == P (n - m). + +Axiom NZmul_0_l : forall n : NZ, 0 * n == 0. +Axiom NZmul_succ_l : forall n m : NZ, S n * m == n * m + m. + +End NZAxiomsSig. + +Module Type NZOrdAxiomsSig. +Declare Module Export NZAxiomsMod : NZAxiomsSig. +Open Local Scope NatIntScope. + +Parameter Inline NZlt : NZ -> NZ -> Prop. +Parameter Inline NZle : NZ -> NZ -> Prop. +Parameter Inline NZmin : NZ -> NZ -> NZ. +Parameter Inline NZmax : NZ -> NZ -> NZ. + +Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. +Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. +Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. +Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. + +Notation "x < y" := (NZlt x y) : NatIntScope. +Notation "x <= y" := (NZle x y) : NatIntScope. +Notation "x > y" := (NZlt y x) (only parsing) : NatIntScope. +Notation "x >= y" := (NZle y x) (only parsing) : NatIntScope. + +Axiom NZlt_eq_cases : forall n m : NZ, n <= m <-> n < m \/ n == m. +Axiom NZlt_irrefl : forall n : NZ, ~ (n < n). +Axiom NZlt_succ_r : forall n m : NZ, n < S m <-> n <= m. + +Axiom NZmin_l : forall n m : NZ, n <= m -> NZmin n m == n. +Axiom NZmin_r : forall n m : NZ, m <= n -> NZmin n m == m. +Axiom NZmax_l : forall n m : NZ, m <= n -> NZmax n m == n. +Axiom NZmax_r : forall n m : NZ, n <= m -> NZmax n m == m. + +End NZOrdAxiomsSig. diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v new file mode 100644 index 00000000..8b01e353 --- /dev/null +++ b/theories/Numbers/NatInt/NZBase.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZBase.v 10934 2008-05-15 21:58:20Z letouzey $ i*) + +Require Import NZAxioms. + +Module NZBasePropFunct (Import NZAxiomsMod : NZAxiomsSig). +Open Local Scope NatIntScope. + +Theorem NZneq_symm : forall n m : NZ, n ~= m -> m ~= n. +Proof. +intros n m H1 H2; symmetry in H2; false_hyp H2 H1. +Qed. + +Theorem NZE_stepl : forall x y z : NZ, x == y -> x == z -> z == y. +Proof. +intros x y z H1 H2; now rewrite <- H1. +Qed. + +Declare Left Step NZE_stepl. +(* The right step lemma is just the transitivity of NZeq *) +Declare Right Step (proj1 (proj2 NZeq_equiv)). + +Theorem NZsucc_inj : forall n1 n2 : NZ, S n1 == S n2 -> n1 == n2. +Proof. +intros n1 n2 H. +apply NZpred_wd in H. now do 2 rewrite NZpred_succ in H. +Qed. + +(* The following theorem is useful as an equivalence for proving +bidirectional induction steps *) +Theorem NZsucc_inj_wd : forall n1 n2 : NZ, S n1 == S n2 <-> n1 == n2. +Proof. +intros; split. +apply NZsucc_inj. +apply NZsucc_wd. +Qed. + +Theorem NZsucc_inj_wd_neg : forall n m : NZ, S n ~= S m <-> n ~= m. +Proof. +intros; now rewrite NZsucc_inj_wd. +Qed. + +(* We cannot prove that the predecessor is injective, nor that it is +left-inverse to the successor at this point *) + +Section CentralInduction. + +Variable A : predicate NZ. + +Hypothesis A_wd : predicate_wd NZeq A. + +Add Morphism A with signature NZeq ==> iff as A_morph. +Proof. apply A_wd. Qed. + +Theorem NZcentral_induction : + forall z : NZ, A z -> + (forall n : NZ, A n <-> A (S n)) -> + forall n : NZ, A n. +Proof. +intros z Base Step; revert Base; pattern z; apply NZinduction. +solve_predicate_wd. +intro; now apply NZinduction. +intro; pose proof (Step n); tauto. +Qed. + +End CentralInduction. + +Tactic Notation "NZinduct" ident(n) := + induction_maker n ltac:(apply NZinduction). + +Tactic Notation "NZinduct" ident(n) constr(u) := + induction_maker n ltac:(apply NZcentral_induction with (z := u)). + +End NZBasePropFunct. + diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v new file mode 100644 index 00000000..fda8b7a3 --- /dev/null +++ b/theories/Numbers/NatInt/NZMul.v @@ -0,0 +1,80 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NZAxioms. +Require Import NZAdd. + +Module NZMulPropFunct (Import NZAxiomsMod : NZAxiomsSig). +Module Export NZAddPropMod := NZAddPropFunct NZAxiomsMod. +Open Local Scope NatIntScope. + +Theorem NZmul_0_r : forall n : NZ, n * 0 == 0. +Proof. +NZinduct n. +now rewrite NZmul_0_l. +intro. rewrite NZmul_succ_l. now rewrite NZadd_0_r. +Qed. + +Theorem NZmul_succ_r : forall n m : NZ, n * (S m) == n * m + n. +Proof. +intros n m; NZinduct n. +do 2 rewrite NZmul_0_l; now rewrite NZadd_0_l. +intro n. do 2 rewrite NZmul_succ_l. do 2 rewrite NZadd_succ_r. +rewrite NZsucc_inj_wd. rewrite <- (NZadd_assoc (n * m) m n). +rewrite (NZadd_comm m n). rewrite NZadd_assoc. +now rewrite NZadd_cancel_r. +Qed. + +Theorem NZmul_comm : forall n m : NZ, n * m == m * n. +Proof. +intros n m; NZinduct n. +rewrite NZmul_0_l; now rewrite NZmul_0_r. +intro. rewrite NZmul_succ_l; rewrite NZmul_succ_r. now rewrite NZadd_cancel_r. +Qed. + +Theorem NZmul_add_distr_r : forall n m p : NZ, (n + m) * p == n * p + m * p. +Proof. +intros n m p; NZinduct n. +rewrite NZmul_0_l. now do 2 rewrite NZadd_0_l. +intro n. rewrite NZadd_succ_l. do 2 rewrite NZmul_succ_l. +rewrite <- (NZadd_assoc (n * p) p (m * p)). +rewrite (NZadd_comm p (m * p)). rewrite (NZadd_assoc (n * p) (m * p) p). +now rewrite NZadd_cancel_r. +Qed. + +Theorem NZmul_add_distr_l : forall n m p : NZ, n * (m + p) == n * m + n * p. +Proof. +intros n m p. +rewrite (NZmul_comm n (m + p)). rewrite (NZmul_comm n m). +rewrite (NZmul_comm n p). apply NZmul_add_distr_r. +Qed. + +Theorem NZmul_assoc : forall n m p : NZ, n * (m * p) == (n * m) * p. +Proof. +intros n m p; NZinduct n. +now do 3 rewrite NZmul_0_l. +intro n. do 2 rewrite NZmul_succ_l. rewrite NZmul_add_distr_r. +now rewrite NZadd_cancel_r. +Qed. + +Theorem NZmul_1_l : forall n : NZ, 1 * n == n. +Proof. +intro n. rewrite NZmul_succ_l; rewrite NZmul_0_l. now rewrite NZadd_0_l. +Qed. + +Theorem NZmul_1_r : forall n : NZ, n * 1 == n. +Proof. +intro n; rewrite NZmul_comm; apply NZmul_1_l. +Qed. + +End NZMulPropFunct. + diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v new file mode 100644 index 00000000..c707bf73 --- /dev/null +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -0,0 +1,310 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NZAxioms. +Require Import NZAddOrder. + +Module NZMulOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). +Module Export NZAddOrderPropMod := NZAddOrderPropFunct NZOrdAxiomsMod. +Open Local Scope NatIntScope. + +Theorem NZmul_lt_pred : + forall p q n m : NZ, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). +Proof. +intros p q n m H. rewrite <- H. do 2 rewrite NZmul_succ_l. +rewrite <- (NZadd_assoc (p * n) n m). +rewrite <- (NZadd_assoc (p * m) m n). +rewrite (NZadd_comm n m). now rewrite <- NZadd_lt_mono_r. +Qed. + +Theorem NZmul_lt_mono_pos_l : forall p n m : NZ, 0 < p -> (n < m <-> p * n < p * m). +Proof. +NZord_induct p. +intros n m H; false_hyp H NZlt_irrefl. +intros p H IH n m H1. do 2 rewrite NZmul_succ_l. +le_elim H. assert (LR : forall n m : NZ, n < m -> p * n + n < p * m + m). +intros n1 m1 H2. apply NZadd_lt_mono; [now apply -> IH | assumption]. +split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3. +apply <- NZle_ngt in H3. le_elim H3. +apply NZlt_asymm in H2. apply H2. now apply LR. +rewrite H3 in H2; false_hyp H2 NZlt_irrefl. +rewrite <- H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l. +intros p H1 _ n m H2. apply NZlt_asymm in H1. false_hyp H2 H1. +Qed. + +Theorem NZmul_lt_mono_pos_r : forall p n m : NZ, 0 < p -> (n < m <-> n * p < m * p). +Proof. +intros p n m. +rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_pos_l. +Qed. + +Theorem NZmul_lt_mono_neg_l : forall p n m : NZ, p < 0 -> (n < m <-> p * m < p * n). +Proof. +NZord_induct p. +intros n m H; false_hyp H NZlt_irrefl. +intros p H1 _ n m H2. apply NZlt_succ_l in H2. apply <- NZnle_gt in H2. false_hyp H1 H2. +intros p H IH n m H1. apply <- NZle_succ_l in H. +le_elim H. assert (LR : forall n m : NZ, n < m -> p * m < p * n). +intros n1 m1 H2. apply (NZle_lt_add_lt n1 m1). +now apply NZlt_le_incl. do 2 rewrite <- NZmul_succ_l. now apply -> IH. +split; [apply LR |]. intro H2. apply -> NZlt_dne; intro H3. +apply <- NZle_ngt in H3. le_elim H3. +apply NZlt_asymm in H2. apply H2. now apply LR. +rewrite H3 in H2; false_hyp H2 NZlt_irrefl. +rewrite (NZmul_lt_pred p (S p)) by reflexivity. +rewrite H; do 2 rewrite NZmul_0_l; now do 2 rewrite NZadd_0_l. +Qed. + +Theorem NZmul_lt_mono_neg_r : forall p n m : NZ, p < 0 -> (n < m <-> m * p < n * p). +Proof. +intros p n m. +rewrite (NZmul_comm n p); rewrite (NZmul_comm m p). now apply NZmul_lt_mono_neg_l. +Qed. + +Theorem NZmul_le_mono_nonneg_l : forall n m p : NZ, 0 <= p -> n <= m -> p * n <= p * m. +Proof. +intros n m p H1 H2. le_elim H1. +le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_pos_l. +apply NZeq_le_incl; now rewrite H2. +apply NZeq_le_incl; rewrite <- H1; now do 2 rewrite NZmul_0_l. +Qed. + +Theorem NZmul_le_mono_nonpos_l : forall n m p : NZ, p <= 0 -> n <= m -> p * m <= p * n. +Proof. +intros n m p H1 H2. le_elim H1. +le_elim H2. apply NZlt_le_incl. now apply -> NZmul_lt_mono_neg_l. +apply NZeq_le_incl; now rewrite H2. +apply NZeq_le_incl; rewrite H1; now do 2 rewrite NZmul_0_l. +Qed. + +Theorem NZmul_le_mono_nonneg_r : forall n m p : NZ, 0 <= p -> n <= m -> n * p <= m * p. +Proof. +intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); +now apply NZmul_le_mono_nonneg_l. +Qed. + +Theorem NZmul_le_mono_nonpos_r : forall n m p : NZ, p <= 0 -> n <= m -> m * p <= n * p. +Proof. +intros n m p H1 H2; rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); +now apply NZmul_le_mono_nonpos_l. +Qed. + +Theorem NZmul_cancel_l : forall n m p : NZ, p ~= 0 -> (p * n == p * m <-> n == m). +Proof. +intros n m p H; split; intro H1. +destruct (NZlt_trichotomy p 0) as [H2 | [H2 | H2]]. +apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3]. +assert (H4 : p * m < p * n); [now apply -> NZmul_lt_mono_neg_l |]. +rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +assert (H4 : p * n < p * m); [now apply -> NZmul_lt_mono_neg_l |]. +rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +false_hyp H2 H. +apply -> NZeq_dne; intro H3. apply -> NZlt_gt_cases in H3. destruct H3 as [H3 | H3]. +assert (H4 : p * n < p * m) by (now apply -> NZmul_lt_mono_pos_l). +rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +assert (H4 : p * m < p * n) by (now apply -> NZmul_lt_mono_pos_l). +rewrite H1 in H4; false_hyp H4 NZlt_irrefl. +now rewrite H1. +Qed. + +Theorem NZmul_cancel_r : forall n m p : NZ, p ~= 0 -> (n * p == m * p <-> n == m). +Proof. +intros n m p. rewrite (NZmul_comm n p), (NZmul_comm m p); apply NZmul_cancel_l. +Qed. + +Theorem NZmul_id_l : forall n m : NZ, m ~= 0 -> (n * m == m <-> n == 1). +Proof. +intros n m H. +stepl (n * m == 1 * m) by now rewrite NZmul_1_l. now apply NZmul_cancel_r. +Qed. + +Theorem NZmul_id_r : forall n m : NZ, n ~= 0 -> (n * m == n <-> m == 1). +Proof. +intros n m; rewrite NZmul_comm; apply NZmul_id_l. +Qed. + +Theorem NZmul_le_mono_pos_l : forall n m p : NZ, 0 < p -> (n <= m <-> p * n <= p * m). +Proof. +intros n m p H; do 2 rewrite NZlt_eq_cases. +rewrite (NZmul_lt_mono_pos_l p n m) by assumption. +now rewrite -> (NZmul_cancel_l n m p) by +(intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl). +Qed. + +Theorem NZmul_le_mono_pos_r : forall n m p : NZ, 0 < p -> (n <= m <-> n * p <= m * p). +Proof. +intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); +apply NZmul_le_mono_pos_l. +Qed. + +Theorem NZmul_le_mono_neg_l : forall n m p : NZ, p < 0 -> (n <= m <-> p * m <= p * n). +Proof. +intros n m p H; do 2 rewrite NZlt_eq_cases. +rewrite (NZmul_lt_mono_neg_l p n m); [| assumption]. +rewrite -> (NZmul_cancel_l m n p) by (intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl). +now setoid_replace (n == m) with (m == n) using relation iff by (split; now intro). +Qed. + +Theorem NZmul_le_mono_neg_r : forall n m p : NZ, p < 0 -> (n <= m <-> m * p <= n * p). +Proof. +intros n m p. rewrite (NZmul_comm n p); rewrite (NZmul_comm m p); +apply NZmul_le_mono_neg_l. +Qed. + +Theorem NZmul_lt_mono_nonneg : + forall n m p q : NZ, 0 <= n -> n < m -> 0 <= p -> p < q -> n * p < m * q. +Proof. +intros n m p q H1 H2 H3 H4. +apply NZle_lt_trans with (m * p). +apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl]. +apply -> NZmul_lt_mono_pos_l; [assumption | now apply NZle_lt_trans with n]. +Qed. + +(* There are still many variants of the theorem above. One can assume 0 < n +or 0 < p or n <= m or p <= q. *) + +Theorem NZmul_le_mono_nonneg : + forall n m p q : NZ, 0 <= n -> n <= m -> 0 <= p -> p <= q -> n * p <= m * q. +Proof. +intros n m p q H1 H2 H3 H4. +le_elim H2; le_elim H4. +apply NZlt_le_incl; now apply NZmul_lt_mono_nonneg. +rewrite <- H4; apply NZmul_le_mono_nonneg_r; [assumption | now apply NZlt_le_incl]. +rewrite <- H2; apply NZmul_le_mono_nonneg_l; [assumption | now apply NZlt_le_incl]. +rewrite H2; rewrite H4; now apply NZeq_le_incl. +Qed. + +Theorem NZmul_pos_pos : forall n m : NZ, 0 < n -> 0 < m -> 0 < n * m. +Proof. +intros n m H1 H2. +rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_pos_r. +Qed. + +Theorem NZmul_neg_neg : forall n m : NZ, n < 0 -> m < 0 -> 0 < n * m. +Proof. +intros n m H1 H2. +rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r. +Qed. + +Theorem NZmul_pos_neg : forall n m : NZ, 0 < n -> m < 0 -> n * m < 0. +Proof. +intros n m H1 H2. +rewrite <- (NZmul_0_l m). now apply -> NZmul_lt_mono_neg_r. +Qed. + +Theorem NZmul_neg_pos : forall n m : NZ, n < 0 -> 0 < m -> n * m < 0. +Proof. +intros; rewrite NZmul_comm; now apply NZmul_pos_neg. +Qed. + +Theorem NZlt_1_mul_pos : forall n m : NZ, 1 < n -> 0 < m -> 1 < n * m. +Proof. +intros n m H1 H2. apply -> (NZmul_lt_mono_pos_r m) in H1. +rewrite NZmul_1_l in H1. now apply NZlt_1_l with m. +assumption. +Qed. + +Theorem NZeq_mul_0 : forall n m : NZ, n * m == 0 <-> n == 0 \/ m == 0. +Proof. +intros n m; split. +intro H; destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]]; +destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]]; +try (now right); try (now left). +elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_neg_neg |]. +elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_neg_pos |]. +elimtype False; now apply (NZlt_neq (n * m) 0); [apply NZmul_pos_neg |]. +elimtype False; now apply (NZlt_neq 0 (n * m)); [apply NZmul_pos_pos |]. +intros [H | H]. now rewrite H, NZmul_0_l. now rewrite H, NZmul_0_r. +Qed. + +Theorem NZneq_mul_0 : forall n m : NZ, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Proof. +intros n m; split; intro H. +intro H1; apply -> NZeq_mul_0 in H1. tauto. +split; intro H1; rewrite H1 in H; +(rewrite NZmul_0_l in H || rewrite NZmul_0_r in H); now apply H. +Qed. + +Theorem NZeq_square_0 : forall n : NZ, n * n == 0 <-> n == 0. +Proof. +intro n; rewrite NZeq_mul_0; tauto. +Qed. + +Theorem NZeq_mul_0_l : forall n m : NZ, n * m == 0 -> m ~= 0 -> n == 0. +Proof. +intros n m H1 H2. apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1]. +assumption. false_hyp H1 H2. +Qed. + +Theorem NZeq_mul_0_r : forall n m : NZ, n * m == 0 -> n ~= 0 -> m == 0. +Proof. +intros n m H1 H2; apply -> NZeq_mul_0 in H1. destruct H1 as [H1 | H1]. +false_hyp H1 H2. assumption. +Qed. + +Theorem NZlt_0_mul : forall n m : NZ, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0). +Proof. +intros n m; split; [intro H | intros [[H1 H2] | [H1 H2]]]. +destruct (NZlt_trichotomy n 0) as [H1 | [H1 | H1]]; +[| rewrite H1 in H; rewrite NZmul_0_l in H; false_hyp H NZlt_irrefl |]; +(destruct (NZlt_trichotomy m 0) as [H2 | [H2 | H2]]; +[| rewrite H2 in H; rewrite NZmul_0_r in H; false_hyp H NZlt_irrefl |]); +try (left; now split); try (right; now split). +assert (H3 : n * m < 0) by now apply NZmul_neg_pos. +elimtype False; now apply (NZlt_asymm (n * m) 0). +assert (H3 : n * m < 0) by now apply NZmul_pos_neg. +elimtype False; now apply (NZlt_asymm (n * m) 0). +now apply NZmul_pos_pos. now apply NZmul_neg_neg. +Qed. + +Theorem NZsquare_lt_mono_nonneg : forall n m : NZ, 0 <= n -> n < m -> n * n < m * m. +Proof. +intros n m H1 H2. now apply NZmul_lt_mono_nonneg. +Qed. + +Theorem NZsquare_le_mono_nonneg : forall n m : NZ, 0 <= n -> n <= m -> n * n <= m * m. +Proof. +intros n m H1 H2. now apply NZmul_le_mono_nonneg. +Qed. + +(* The converse theorems require nonnegativity (or nonpositivity) of the +other variable *) + +Theorem NZsquare_lt_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n < m * m -> n < m. +Proof. +intros n m H1 H2. destruct (NZlt_ge_cases n 0). +now apply NZlt_le_trans with 0. +destruct (NZlt_ge_cases n m). +assumption. assert (F : m * m <= n * n) by now apply NZsquare_le_mono_nonneg. +apply -> NZle_ngt in F. false_hyp H2 F. +Qed. + +Theorem NZsquare_le_simpl_nonneg : forall n m : NZ, 0 <= m -> n * n <= m * m -> n <= m. +Proof. +intros n m H1 H2. destruct (NZlt_ge_cases n 0). +apply NZlt_le_incl; now apply NZlt_le_trans with 0. +destruct (NZle_gt_cases n m). +assumption. assert (F : m * m < n * n) by now apply NZsquare_lt_mono_nonneg. +apply -> NZlt_nge in F. false_hyp H2 F. +Qed. + +Theorem NZmul_2_mono_l : forall n m : NZ, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. +Proof. +intros n m H. apply <- NZle_succ_l in H. +apply -> (NZmul_le_mono_pos_l (S n) m (1 + 1)) in H. +repeat rewrite NZmul_add_distr_r in *; repeat rewrite NZmul_1_l in *. +repeat rewrite NZadd_succ_r in *. repeat rewrite NZadd_succ_l in *. rewrite NZadd_0_l. +now apply -> NZle_succ_l. +apply NZadd_pos_pos; now apply NZlt_succ_diag_r. +Qed. + +End NZMulOrderPropFunct. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v new file mode 100644 index 00000000..15004824 --- /dev/null +++ b/theories/Numbers/NatInt/NZOrder.v @@ -0,0 +1,666 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NZOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import NZAxioms. +Require Import NZMul. +Require Import Decidable. + +Module NZOrderPropFunct (Import NZOrdAxiomsMod : NZOrdAxiomsSig). +Module Export NZMulPropMod := NZMulPropFunct NZAxiomsMod. +Open Local Scope NatIntScope. + +Ltac le_elim H := rewrite NZlt_eq_cases in H; destruct H as [H | H]. + +Theorem NZlt_le_incl : forall n m : NZ, n < m -> n <= m. +Proof. +intros; apply <- NZlt_eq_cases; now left. +Qed. + +Theorem NZeq_le_incl : forall n m : NZ, n == m -> n <= m. +Proof. +intros; apply <- NZlt_eq_cases; now right. +Qed. + +Lemma NZlt_stepl : forall x y z : NZ, x < y -> x == z -> z < y. +Proof. +intros x y z H1 H2; now rewrite <- H2. +Qed. + +Lemma NZlt_stepr : forall x y z : NZ, x < y -> y == z -> x < z. +Proof. +intros x y z H1 H2; now rewrite <- H2. +Qed. + +Lemma NZle_stepl : forall x y z : NZ, x <= y -> x == z -> z <= y. +Proof. +intros x y z H1 H2; now rewrite <- H2. +Qed. + +Lemma NZle_stepr : forall x y z : NZ, x <= y -> y == z -> x <= z. +Proof. +intros x y z H1 H2; now rewrite <- H2. +Qed. + +Declare Left Step NZlt_stepl. +Declare Right Step NZlt_stepr. +Declare Left Step NZle_stepl. +Declare Right Step NZle_stepr. + +Theorem NZlt_neq : forall n m : NZ, n < m -> n ~= m. +Proof. +intros n m H1 H2; rewrite H2 in H1; false_hyp H1 NZlt_irrefl. +Qed. + +Theorem NZle_neq : forall n m : NZ, n < m <-> n <= m /\ n ~= m. +Proof. +intros n m; split; [intro H | intros [H1 H2]]. +split. now apply NZlt_le_incl. now apply NZlt_neq. +le_elim H1. assumption. false_hyp H1 H2. +Qed. + +Theorem NZle_refl : forall n : NZ, n <= n. +Proof. +intro; now apply NZeq_le_incl. +Qed. + +Theorem NZlt_succ_diag_r : forall n : NZ, n < S n. +Proof. +intro n. rewrite NZlt_succ_r. now apply NZeq_le_incl. +Qed. + +Theorem NZle_succ_diag_r : forall n : NZ, n <= S n. +Proof. +intro; apply NZlt_le_incl; apply NZlt_succ_diag_r. +Qed. + +Theorem NZlt_0_1 : 0 < 1. +Proof. +apply NZlt_succ_diag_r. +Qed. + +Theorem NZle_0_1 : 0 <= 1. +Proof. +apply NZle_succ_diag_r. +Qed. + +Theorem NZlt_lt_succ_r : forall n m : NZ, n < m -> n < S m. +Proof. +intros. rewrite NZlt_succ_r. now apply NZlt_le_incl. +Qed. + +Theorem NZle_le_succ_r : forall n m : NZ, n <= m -> n <= S m. +Proof. +intros n m H. rewrite <- NZlt_succ_r in H. now apply NZlt_le_incl. +Qed. + +Theorem NZle_succ_r : forall n m : NZ, n <= S m <-> n <= m \/ n == S m. +Proof. +intros n m; rewrite NZlt_eq_cases. now rewrite NZlt_succ_r. +Qed. + +(* The following theorem is a special case of neq_succ_iter_l below, +but we prove it separately *) + +Theorem NZneq_succ_diag_l : forall n : NZ, S n ~= n. +Proof. +intros n H. pose proof (NZlt_succ_diag_r n) as H1. rewrite H in H1. +false_hyp H1 NZlt_irrefl. +Qed. + +Theorem NZneq_succ_diag_r : forall n : NZ, n ~= S n. +Proof. +intro n; apply NZneq_symm; apply NZneq_succ_diag_l. +Qed. + +Theorem NZnlt_succ_diag_l : forall n : NZ, ~ S n < n. +Proof. +intros n H; apply NZlt_lt_succ_r in H. false_hyp H NZlt_irrefl. +Qed. + +Theorem NZnle_succ_diag_l : forall n : NZ, ~ S n <= n. +Proof. +intros n H; le_elim H. +false_hyp H NZnlt_succ_diag_l. false_hyp H NZneq_succ_diag_l. +Qed. + +Theorem NZle_succ_l : forall n m : NZ, S n <= m <-> n < m. +Proof. +intro n; NZinduct m n. +setoid_replace (n < n) with False using relation iff by + (apply -> neg_false; apply NZlt_irrefl). +now setoid_replace (S n <= n) with False using relation iff by + (apply -> neg_false; apply NZnle_succ_diag_l). +intro m. rewrite NZlt_succ_r. rewrite NZle_succ_r. +rewrite NZsucc_inj_wd. +rewrite (NZlt_eq_cases n m). +rewrite or_cancel_r. +reflexivity. +intros H1 H2; rewrite H2 in H1; false_hyp H1 NZnle_succ_diag_l. +apply NZlt_neq. +Qed. + +Theorem NZlt_succ_l : forall n m : NZ, S n < m -> n < m. +Proof. +intros n m H; apply -> NZle_succ_l; now apply NZlt_le_incl. +Qed. + +Theorem NZsucc_lt_mono : forall n m : NZ, n < m <-> S n < S m. +Proof. +intros n m. rewrite <- NZle_succ_l. symmetry. apply NZlt_succ_r. +Qed. + +Theorem NZsucc_le_mono : forall n m : NZ, n <= m <-> S n <= S m. +Proof. +intros n m. do 2 rewrite NZlt_eq_cases. +rewrite <- NZsucc_lt_mono; now rewrite NZsucc_inj_wd. +Qed. + +Theorem NZlt_asymm : forall n m, n < m -> ~ m < n. +Proof. +intros n m; NZinduct n m. +intros H _; false_hyp H NZlt_irrefl. +intro n; split; intros H H1 H2. +apply NZlt_succ_l in H1. apply -> NZlt_succ_r in H2. le_elim H2. +now apply H. rewrite H2 in H1; false_hyp H1 NZlt_irrefl. +apply NZlt_lt_succ_r in H2. apply <- NZle_succ_l in H1. le_elim H1. +now apply H. rewrite H1 in H2; false_hyp H2 NZlt_irrefl. +Qed. + +Theorem NZlt_trans : forall n m p : NZ, n < m -> m < p -> n < p. +Proof. +intros n m p; NZinduct p m. +intros _ H; false_hyp H NZlt_irrefl. +intro p. do 2 rewrite NZlt_succ_r. +split; intros H H1 H2. +apply NZlt_le_incl; le_elim H2; [now apply H | now rewrite H2 in H1]. +assert (n <= p) as H3. apply H. assumption. now apply NZlt_le_incl. +le_elim H3. assumption. rewrite <- H3 in H2. +elimtype False; now apply (NZlt_asymm n m). +Qed. + +Theorem NZle_trans : forall n m p : NZ, n <= m -> m <= p -> n <= p. +Proof. +intros n m p H1 H2; le_elim H1. +le_elim H2. apply NZlt_le_incl; now apply NZlt_trans with (m := m). +apply NZlt_le_incl; now rewrite <- H2. now rewrite H1. +Qed. + +Theorem NZle_lt_trans : forall n m p : NZ, n <= m -> m < p -> n < p. +Proof. +intros n m p H1 H2; le_elim H1. +now apply NZlt_trans with (m := m). now rewrite H1. +Qed. + +Theorem NZlt_le_trans : forall n m p : NZ, n < m -> m <= p -> n < p. +Proof. +intros n m p H1 H2; le_elim H2. +now apply NZlt_trans with (m := m). now rewrite <- H2. +Qed. + +Theorem NZle_antisymm : forall n m : NZ, n <= m -> m <= n -> n == m. +Proof. +intros n m H1 H2; now (le_elim H1; le_elim H2); +[elimtype False; apply (NZlt_asymm n m) | | |]. +Qed. + +Theorem NZlt_1_l : forall n m : NZ, 0 < n -> n < m -> 1 < m. +Proof. +intros n m H1 H2. apply <- NZle_succ_l in H1. now apply NZle_lt_trans with n. +Qed. + +(** Trichotomy, decidability, and double negation elimination *) + +Theorem NZlt_trichotomy : forall n m : NZ, n < m \/ n == m \/ m < n. +Proof. +intros n m; NZinduct n m. +right; now left. +intro n; rewrite NZlt_succ_r. stepr ((S n < m \/ S n == m) \/ m <= n) by tauto. +rewrite <- (NZlt_eq_cases (S n) m). +setoid_replace (n == m) with (m == n) using relation iff by now split. +stepl (n < m \/ m < n \/ m == n) by tauto. rewrite <- NZlt_eq_cases. +apply or_iff_compat_r. symmetry; apply NZle_succ_l. +Qed. + +(* Decidability of equality, even though true in each finite ring, does not +have a uniform proof. Otherwise, the proof for two fixed numbers would +reduce to a normal form that will say if the numbers are equal or not, +which cannot be true in all finite rings. Therefore, we prove decidability +in the presence of order. *) + +Theorem NZeq_dec : forall n m : NZ, decidable (n == m). +Proof. +intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]]. +right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl. +now left. +right; intro H1; rewrite H1 in H; false_hyp H NZlt_irrefl. +Qed. + +(* DNE stands for double-negation elimination *) + +Theorem NZeq_dne : forall n m, ~ ~ n == m <-> n == m. +Proof. +intros n m; split; intro H. +destruct (NZeq_dec n m) as [H1 | H1]. +assumption. false_hyp H1 H. +intro H1; now apply H1. +Qed. + +Theorem NZlt_gt_cases : forall n m : NZ, n ~= m <-> n < m \/ n > m. +Proof. +intros n m; split. +pose proof (NZlt_trichotomy n m); tauto. +intros H H1; destruct H as [H | H]; rewrite H1 in H; false_hyp H NZlt_irrefl. +Qed. + +Theorem NZle_gt_cases : forall n m : NZ, n <= m \/ n > m. +Proof. +intros n m; destruct (NZlt_trichotomy n m) as [H | [H | H]]. +left; now apply NZlt_le_incl. left; now apply NZeq_le_incl. now right. +Qed. + +(* The following theorem is cleary redundant, but helps not to +remember whether one has to say le_gt_cases or lt_ge_cases *) + +Theorem NZlt_ge_cases : forall n m : NZ, n < m \/ n >= m. +Proof. +intros n m; destruct (NZle_gt_cases m n); try (now left); try (now right). +Qed. + +Theorem NZle_ge_cases : forall n m : NZ, n <= m \/ n >= m. +Proof. +intros n m; destruct (NZle_gt_cases n m) as [H | H]. +now left. right; now apply NZlt_le_incl. +Qed. + +Theorem NZle_ngt : forall n m : NZ, n <= m <-> ~ n > m. +Proof. +intros n m. split; intro H; [intro H1 |]. +eapply NZle_lt_trans in H; [| eassumption ..]. false_hyp H NZlt_irrefl. +destruct (NZle_gt_cases n m) as [H1 | H1]. +assumption. false_hyp H1 H. +Qed. + +(* Redundant but useful *) + +Theorem NZnlt_ge : forall n m : NZ, ~ n < m <-> n >= m. +Proof. +intros n m; symmetry; apply NZle_ngt. +Qed. + +Theorem NZlt_dec : forall n m : NZ, decidable (n < m). +Proof. +intros n m; destruct (NZle_gt_cases m n); +[right; now apply -> NZle_ngt | now left]. +Qed. + +Theorem NZlt_dne : forall n m, ~ ~ n < m <-> n < m. +Proof. +intros n m; split; intro H; +[destruct (NZlt_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] | +intro H1; false_hyp H H1]. +Qed. + +Theorem NZnle_gt : forall n m : NZ, ~ n <= m <-> n > m. +Proof. +intros n m. rewrite NZle_ngt. apply NZlt_dne. +Qed. + +(* Redundant but useful *) + +Theorem NZlt_nge : forall n m : NZ, n < m <-> ~ n >= m. +Proof. +intros n m; symmetry; apply NZnle_gt. +Qed. + +Theorem NZle_dec : forall n m : NZ, decidable (n <= m). +Proof. +intros n m; destruct (NZle_gt_cases n m); +[now left | right; now apply <- NZnle_gt]. +Qed. + +Theorem NZle_dne : forall n m : NZ, ~ ~ n <= m <-> n <= m. +Proof. +intros n m; split; intro H; +[destruct (NZle_dec n m) as [H1 | H1]; [assumption | false_hyp H1 H] | +intro H1; false_hyp H H1]. +Qed. + +Theorem NZnlt_succ_r : forall n m : NZ, ~ m < S n <-> n < m. +Proof. +intros n m; rewrite NZlt_succ_r; apply NZnle_gt. +Qed. + +(* The difference between integers and natural numbers is that for +every integer there is a predecessor, which is not true for natural +numbers. However, for both classes, every number that is bigger than +some other number has a predecessor. The proof of this fact by regular +induction does not go through, so we need to use strong +(course-of-value) induction. *) + +Lemma NZlt_exists_pred_strong : + forall z n m : NZ, z < m -> m <= n -> exists k : NZ, m == S k /\ z <= k. +Proof. +intro z; NZinduct n z. +intros m H1 H2; apply <- NZnle_gt in H1; false_hyp H2 H1. +intro n; split; intros IH m H1 H2. +apply -> NZle_succ_r in H2; destruct H2 as [H2 | H2]. +now apply IH. exists n. now split; [| rewrite <- NZlt_succ_r; rewrite <- H2]. +apply IH. assumption. now apply NZle_le_succ_r. +Qed. + +Theorem NZlt_exists_pred : + forall z n : NZ, z < n -> exists k : NZ, n == S k /\ z <= k. +Proof. +intros z n H; apply NZlt_exists_pred_strong with (z := z) (n := n). +assumption. apply NZle_refl. +Qed. + +(** A corollary of having an order is that NZ is infinite *) + +(* This section about infinity of NZ relies on the type nat and can be +safely removed *) + +Definition NZsucc_iter (n : nat) (m : NZ) := + nat_rect (fun _ => NZ) m (fun _ l => S l) n. + +Theorem NZlt_succ_iter_r : + forall (n : nat) (m : NZ), m < NZsucc_iter (Datatypes.S n) m. +Proof. +intros n m; induction n as [| n IH]; simpl in *. +apply NZlt_succ_diag_r. now apply NZlt_lt_succ_r. +Qed. + +Theorem NZneq_succ_iter_l : + forall (n : nat) (m : NZ), NZsucc_iter (Datatypes.S n) m ~= m. +Proof. +intros n m H. pose proof (NZlt_succ_iter_r n m) as H1. rewrite H in H1. +false_hyp H1 NZlt_irrefl. +Qed. + +(* End of the section about the infinity of NZ *) + +(** Stronger variant of induction with assumptions n >= 0 (n < 0) +in the induction step *) + +Section Induction. + +Variable A : NZ -> Prop. +Hypothesis A_wd : predicate_wd NZeq A. + +Add Morphism A with signature NZeq ==> iff as A_morph. +Proof. apply A_wd. Qed. + +Section Center. + +Variable z : NZ. (* A z is the basis of induction *) + +Section RightInduction. + +Let A' (n : NZ) := forall m : NZ, z <= m -> m < n -> A m. +Let right_step := forall n : NZ, z <= n -> A n -> A (S n). +Let right_step' := forall n : NZ, z <= n -> A' n -> A n. +Let right_step'' := forall n : NZ, A' n <-> A' (S n). + +Lemma NZrs_rs' : A z -> right_step -> right_step'. +Proof. +intros Az RS n H1 H2. +le_elim H1. apply NZlt_exists_pred in H1. destruct H1 as [k [H3 H4]]. +rewrite H3. apply RS; [assumption | apply H2; [assumption | rewrite H3; apply NZlt_succ_diag_r]]. +rewrite <- H1; apply Az. +Qed. + +Lemma NZrs'_rs'' : right_step' -> right_step''. +Proof. +intros RS' n; split; intros H1 m H2 H3. +apply -> NZlt_succ_r in H3; le_elim H3; +[now apply H1 | rewrite H3 in *; now apply RS']. +apply H1; [assumption | now apply NZlt_lt_succ_r]. +Qed. + +Lemma NZrbase : A' z. +Proof. +intros m H1 H2. apply -> NZle_ngt in H1. false_hyp H2 H1. +Qed. + +Lemma NZA'A_right : (forall n : NZ, A' n) -> forall n : NZ, z <= n -> A n. +Proof. +intros H1 n H2. apply H1 with (n := S n); [assumption | apply NZlt_succ_diag_r]. +Qed. + +Theorem NZstrong_right_induction: right_step' -> forall n : NZ, z <= n -> A n. +Proof. +intro RS'; apply NZA'A_right; unfold A'; NZinduct n z; +[apply NZrbase | apply NZrs'_rs''; apply RS']. +Qed. + +Theorem NZright_induction : A z -> right_step -> forall n : NZ, z <= n -> A n. +Proof. +intros Az RS; apply NZstrong_right_induction; now apply NZrs_rs'. +Qed. + +Theorem NZright_induction' : + (forall n : NZ, n <= z -> A n) -> right_step -> forall n : NZ, A n. +Proof. +intros L R n. +destruct (NZlt_trichotomy n z) as [H | [H | H]]. +apply L; now apply NZlt_le_incl. +apply L; now apply NZeq_le_incl. +apply NZright_induction. apply L; now apply NZeq_le_incl. assumption. now apply NZlt_le_incl. +Qed. + +Theorem NZstrong_right_induction' : + (forall n : NZ, n <= z -> A n) -> right_step' -> forall n : NZ, A n. +Proof. +intros L R n. +destruct (NZlt_trichotomy n z) as [H | [H | H]]. +apply L; now apply NZlt_le_incl. +apply L; now apply NZeq_le_incl. +apply NZstrong_right_induction. assumption. now apply NZlt_le_incl. +Qed. + +End RightInduction. + +Section LeftInduction. + +Let A' (n : NZ) := forall m : NZ, m <= z -> n <= m -> A m. +Let left_step := forall n : NZ, n < z -> A (S n) -> A n. +Let left_step' := forall n : NZ, n <= z -> A' (S n) -> A n. +Let left_step'' := forall n : NZ, A' n <-> A' (S n). + +Lemma NZls_ls' : A z -> left_step -> left_step'. +Proof. +intros Az LS n H1 H2. le_elim H1. +apply LS; [assumption | apply H2; [now apply <- NZle_succ_l | now apply NZeq_le_incl]]. +rewrite H1; apply Az. +Qed. + +Lemma NZls'_ls'' : left_step' -> left_step''. +Proof. +intros LS' n; split; intros H1 m H2 H3. +apply -> NZle_succ_l in H3. apply NZlt_le_incl in H3. now apply H1. +le_elim H3. +apply <- NZle_succ_l in H3. now apply H1. +rewrite <- H3 in *; now apply LS'. +Qed. + +Lemma NZlbase : A' (S z). +Proof. +intros m H1 H2. apply -> NZle_succ_l in H2. +apply -> NZle_ngt in H1. false_hyp H2 H1. +Qed. + +Lemma NZA'A_left : (forall n : NZ, A' n) -> forall n : NZ, n <= z -> A n. +Proof. +intros H1 n H2. apply H1 with (n := n); [assumption | now apply NZeq_le_incl]. +Qed. + +Theorem NZstrong_left_induction: left_step' -> forall n : NZ, n <= z -> A n. +Proof. +intro LS'; apply NZA'A_left; unfold A'; NZinduct n (S z); +[apply NZlbase | apply NZls'_ls''; apply LS']. +Qed. + +Theorem NZleft_induction : A z -> left_step -> forall n : NZ, n <= z -> A n. +Proof. +intros Az LS; apply NZstrong_left_induction; now apply NZls_ls'. +Qed. + +Theorem NZleft_induction' : + (forall n : NZ, z <= n -> A n) -> left_step -> forall n : NZ, A n. +Proof. +intros R L n. +destruct (NZlt_trichotomy n z) as [H | [H | H]]. +apply NZleft_induction. apply R. now apply NZeq_le_incl. assumption. now apply NZlt_le_incl. +rewrite H; apply R; now apply NZeq_le_incl. +apply R; now apply NZlt_le_incl. +Qed. + +Theorem NZstrong_left_induction' : + (forall n : NZ, z <= n -> A n) -> left_step' -> forall n : NZ, A n. +Proof. +intros R L n. +destruct (NZlt_trichotomy n z) as [H | [H | H]]. +apply NZstrong_left_induction; auto. now apply NZlt_le_incl. +rewrite H; apply R; now apply NZeq_le_incl. +apply R; now apply NZlt_le_incl. +Qed. + +End LeftInduction. + +Theorem NZorder_induction : + A z -> + (forall n : NZ, z <= n -> A n -> A (S n)) -> + (forall n : NZ, n < z -> A (S n) -> A n) -> + forall n : NZ, A n. +Proof. +intros Az RS LS n. +destruct (NZlt_trichotomy n z) as [H | [H | H]]. +now apply NZleft_induction; [| | apply NZlt_le_incl]. +now rewrite H. +now apply NZright_induction; [| | apply NZlt_le_incl]. +Qed. + +Theorem NZorder_induction' : + A z -> + (forall n : NZ, z <= n -> A n -> A (S n)) -> + (forall n : NZ, n <= z -> A n -> A (P n)) -> + forall n : NZ, A n. +Proof. +intros Az AS AP n; apply NZorder_induction; try assumption. +intros m H1 H2. apply AP in H2; [| now apply <- NZle_succ_l]. +unfold predicate_wd, fun_wd in A_wd; apply -> (A_wd (P (S m)) m); +[assumption | apply NZpred_succ]. +Qed. + +End Center. + +Theorem NZorder_induction_0 : + A 0 -> + (forall n : NZ, 0 <= n -> A n -> A (S n)) -> + (forall n : NZ, n < 0 -> A (S n) -> A n) -> + forall n : NZ, A n. +Proof (NZorder_induction 0). + +Theorem NZorder_induction'_0 : + A 0 -> + (forall n : NZ, 0 <= n -> A n -> A (S n)) -> + (forall n : NZ, n <= 0 -> A n -> A (P n)) -> + forall n : NZ, A n. +Proof (NZorder_induction' 0). + +(** Elimintation principle for < *) + +Theorem NZlt_ind : forall (n : NZ), + A (S n) -> + (forall m : NZ, n < m -> A m -> A (S m)) -> + forall m : NZ, n < m -> A m. +Proof. +intros n H1 H2 m H3. +apply NZright_induction with (S n); [assumption | | now apply <- NZle_succ_l]. +intros; apply H2; try assumption. now apply -> NZle_succ_l. +Qed. + +(** Elimintation principle for <= *) + +Theorem NZle_ind : forall (n : NZ), + A n -> + (forall m : NZ, n <= m -> A m -> A (S m)) -> + forall m : NZ, n <= m -> A m. +Proof. +intros n H1 H2 m H3. +now apply NZright_induction with n. +Qed. + +End Induction. + +Tactic Notation "NZord_induct" ident(n) := + induction_maker n ltac:(apply NZorder_induction_0). + +Tactic Notation "NZord_induct" ident(n) constr(z) := + induction_maker n ltac:(apply NZorder_induction with z). + +Section WF. + +Variable z : NZ. + +Let Rlt (n m : NZ) := z <= n /\ n < m. +Let Rgt (n m : NZ) := m < n /\ n <= z. + +Add Morphism Rlt with signature NZeq ==> NZeq ==> iff as Rlt_wd. +Proof. +intros x1 x2 H1 x3 x4 H2; unfold Rlt; rewrite H1; now rewrite H2. +Qed. + +Add Morphism Rgt with signature NZeq ==> NZeq ==> iff as Rgt_wd. +Proof. +intros x1 x2 H1 x3 x4 H2; unfold Rgt; rewrite H1; now rewrite H2. +Qed. + +Lemma NZAcc_lt_wd : predicate_wd NZeq (Acc Rlt). +Proof. +unfold predicate_wd, fun_wd. +intros x1 x2 H; split; intro H1; destruct H1 as [H2]; +constructor; intros; apply H2; now (rewrite H || rewrite <- H). +Qed. + +Lemma NZAcc_gt_wd : predicate_wd NZeq (Acc Rgt). +Proof. +unfold predicate_wd, fun_wd. +intros x1 x2 H; split; intro H1; destruct H1 as [H2]; +constructor; intros; apply H2; now (rewrite H || rewrite <- H). +Qed. + +Theorem NZlt_wf : well_founded Rlt. +Proof. +unfold well_founded. +apply NZstrong_right_induction' with (z := z). +apply NZAcc_lt_wd. +intros n H; constructor; intros y [H1 H2]. +apply <- NZnle_gt in H2. elim H2. now apply NZle_trans with z. +intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. +Qed. + +Theorem NZgt_wf : well_founded Rgt. +Proof. +unfold well_founded. +apply NZstrong_left_induction' with (z := z). +apply NZAcc_gt_wd. +intros n H; constructor; intros y [H1 H2]. +apply <- NZnle_gt in H2. elim H2. now apply NZle_lt_trans with n. +intros n H1 H2; constructor; intros m [H3 H4]. +apply H2. assumption. now apply <- NZle_succ_l. +Qed. + +End WF. + +End NZOrderPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v new file mode 100644 index 00000000..f58b87d8 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -0,0 +1,156 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NBase. + +Module NAddPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NBasePropMod := NBasePropFunct NAxiomsMod. + +Open Local Scope NatScope. + +Theorem add_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 + m1 == n2 + m2. +Proof NZadd_wd. + +Theorem add_0_l : forall n : N, 0 + n == n. +Proof NZadd_0_l. + +Theorem add_succ_l : forall n m : N, (S n) + m == S (n + m). +Proof NZadd_succ_l. + +(** Theorems that are valid for both natural numbers and integers *) + +Theorem add_0_r : forall n : N, n + 0 == n. +Proof NZadd_0_r. + +Theorem add_succ_r : forall n m : N, n + S m == S (n + m). +Proof NZadd_succ_r. + +Theorem add_comm : forall n m : N, n + m == m + n. +Proof NZadd_comm. + +Theorem add_assoc : forall n m p : N, n + (m + p) == (n + m) + p. +Proof NZadd_assoc. + +Theorem add_shuffle1 : forall n m p q : N, (n + m) + (p + q) == (n + p) + (m + q). +Proof NZadd_shuffle1. + +Theorem add_shuffle2 : forall n m p q : N, (n + m) + (p + q) == (n + q) + (m + p). +Proof NZadd_shuffle2. + +Theorem add_1_l : forall n : N, 1 + n == S n. +Proof NZadd_1_l. + +Theorem add_1_r : forall n : N, n + 1 == S n. +Proof NZadd_1_r. + +Theorem add_cancel_l : forall n m p : N, p + n == p + m <-> n == m. +Proof NZadd_cancel_l. + +Theorem add_cancel_r : forall n m p : N, n + p == m + p <-> n == m. +Proof NZadd_cancel_r. + +(* Theorems that are valid for natural numbers but cannot be proved for Z *) + +Theorem eq_add_0 : forall n m : N, n + m == 0 <-> n == 0 /\ m == 0. +Proof. +intros n m; induct n. +(* The next command does not work with the axiom add_0_l from NAddSig *) +rewrite add_0_l. intuition reflexivity. +intros n IH. rewrite add_succ_l. +setoid_replace (S (n + m) == 0) with False using relation iff by + (apply -> neg_false; apply neq_succ_0). +setoid_replace (S n == 0) with False using relation iff by + (apply -> neg_false; apply neq_succ_0). tauto. +Qed. + +Theorem eq_add_succ : + forall n m : N, (exists p : N, n + m == S p) <-> + (exists n' : N, n == S n') \/ (exists m' : N, m == S m'). +Proof. +intros n m; cases n. +split; intro H. +destruct H as [p H]. rewrite add_0_l in H; right; now exists p. +destruct H as [[n' H] | [m' H]]. +symmetry in H; false_hyp H neq_succ_0. +exists m'; now rewrite add_0_l. +intro n; split; intro H. +left; now exists n. +exists (n + m); now rewrite add_succ_l. +Qed. + +Theorem eq_add_1 : forall n m : N, + n + m == 1 -> n == 1 /\ m == 0 \/ n == 0 /\ m == 1. +Proof. +intros n m H. +assert (H1 : exists p : N, n + m == S p) by now exists 0. +apply -> eq_add_succ in H1. destruct H1 as [[n' H1] | [m' H1]]. +left. rewrite H1 in H; rewrite add_succ_l in H; apply succ_inj in H. +apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H2 in H1; now split. +right. rewrite H1 in H; rewrite add_succ_r in H; apply succ_inj in H. +apply -> eq_add_0 in H. destruct H as [H2 H3]; rewrite H3 in H1; now split. +Qed. + +Theorem succ_add_discr : forall n m : N, m ~= S (n + m). +Proof. +intro n; induct m. +apply neq_symm. apply neq_succ_0. +intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. +unfold not in IH; now apply IH. +Qed. + +Theorem add_pred_l : forall n m : N, n ~= 0 -> P n + m == P (n + m). +Proof. +intros n m; cases n. +intro H; now elim H. +intros n IH; rewrite add_succ_l; now do 2 rewrite pred_succ. +Qed. + +Theorem add_pred_r : forall n m : N, m ~= 0 -> n + P m == P (n + m). +Proof. +intros n m H; rewrite (add_comm n (P m)); +rewrite (add_comm n m); now apply add_pred_l. +Qed. + +(* One could define n <= m as exists p : N, p + n == m. Then we have +dichotomy: + +forall n m : N, n <= m \/ m <= n, + +i.e., + +forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n) (1) + +We will need (1) in the proof of induction principle for integers +constructed as pairs of natural numbers. The formula (1) can be proved +using properties of order and truncated subtraction. Thus, p would be +m - n or n - m and (1) would hold by theorem sub_add from Sub.v +depending on whether n <= m or m <= n. However, in proving induction +for integers constructed from natural numbers we do not need to +require implementations of order and sub; it is enough to prove (1) +here. *) + +Theorem add_dichotomy : + forall n m : N, (exists p : N, p + n == m) \/ (exists p : N, p + m == n). +Proof. +intros n m; induct n. +left; exists m; apply add_0_r. +intros n IH. +destruct IH as [[p H] | [p H]]. +destruct (zero_or_succ p) as [H1 | [p' H1]]; rewrite H1 in H. +rewrite add_0_l in H. right; exists (S 0); rewrite H; rewrite add_succ_l; now rewrite add_0_l. +left; exists p'; rewrite add_succ_r; now rewrite add_succ_l in H. +right; exists (S p). rewrite add_succ_l; now rewrite H. +Qed. + +End NAddPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v new file mode 100644 index 00000000..7024fd00 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -0,0 +1,114 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NAddOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NOrder. + +Module NAddOrderPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NOrderPropMod := NOrderPropFunct NAxiomsMod. +Open Local Scope NatScope. + +Theorem add_lt_mono_l : forall n m p : N, n < m <-> p + n < p + m. +Proof NZadd_lt_mono_l. + +Theorem add_lt_mono_r : forall n m p : N, n < m <-> n + p < m + p. +Proof NZadd_lt_mono_r. + +Theorem add_lt_mono : forall n m p q : N, n < m -> p < q -> n + p < m + q. +Proof NZadd_lt_mono. + +Theorem add_le_mono_l : forall n m p : N, n <= m <-> p + n <= p + m. +Proof NZadd_le_mono_l. + +Theorem add_le_mono_r : forall n m p : N, n <= m <-> n + p <= m + p. +Proof NZadd_le_mono_r. + +Theorem add_le_mono : forall n m p q : N, n <= m -> p <= q -> n + p <= m + q. +Proof NZadd_le_mono. + +Theorem add_lt_le_mono : forall n m p q : N, n < m -> p <= q -> n + p < m + q. +Proof NZadd_lt_le_mono. + +Theorem add_le_lt_mono : forall n m p q : N, n <= m -> p < q -> n + p < m + q. +Proof NZadd_le_lt_mono. + +Theorem add_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n + m. +Proof NZadd_pos_pos. + +Theorem lt_add_pos_l : forall n m : N, 0 < n -> m < n + m. +Proof NZlt_add_pos_l. + +Theorem lt_add_pos_r : forall n m : N, 0 < n -> m < m + n. +Proof NZlt_add_pos_r. + +Theorem le_lt_add_lt : forall n m p q : N, n <= m -> p + m < q + n -> p < q. +Proof NZle_lt_add_lt. + +Theorem lt_le_add_lt : forall n m p q : N, n < m -> p + m <= q + n -> p < q. +Proof NZlt_le_add_lt. + +Theorem le_le_add_le : forall n m p q : N, n <= m -> p + m <= q + n -> p <= q. +Proof NZle_le_add_le. + +Theorem add_lt_cases : forall n m p q : N, n + m < p + q -> n < p \/ m < q. +Proof NZadd_lt_cases. + +Theorem add_le_cases : forall n m p q : N, n + m <= p + q -> n <= p \/ m <= q. +Proof NZadd_le_cases. + +Theorem add_pos_cases : forall n m : N, 0 < n + m -> 0 < n \/ 0 < m. +Proof NZadd_pos_cases. + +(* Theorems true for natural numbers *) + +Theorem le_add_r : forall n m : N, n <= n + m. +Proof. +intro n; induct m. +rewrite add_0_r; now apply eq_le_incl. +intros m IH. rewrite add_succ_r; now apply le_le_succ_r. +Qed. + +Theorem lt_lt_add_r : forall n m p : N, n < m -> n < m + p. +Proof. +intros n m p H; rewrite <- (add_0_r n). +apply add_lt_le_mono; [assumption | apply le_0_l]. +Qed. + +Theorem lt_lt_add_l : forall n m p : N, n < m -> n < p + m. +Proof. +intros n m p; rewrite add_comm; apply lt_lt_add_r. +Qed. + +Theorem add_pos_l : forall n m : N, 0 < n -> 0 < n + m. +Proof. +intros; apply NZadd_pos_nonneg. assumption. apply le_0_l. +Qed. + +Theorem add_pos_r : forall n m : N, 0 < m -> 0 < n + m. +Proof. +intros; apply NZadd_nonneg_pos. apply le_0_l. assumption. +Qed. + +(* The following property is used to prove the correctness of the +definition of order on integers constructed from pairs of natural numbers *) + +Theorem add_lt_repl_pair : forall n m n' m' u v : N, + n + u < m + v -> n + m' == n' + m -> n' + u < m' + v. +Proof. +intros n m n' m' u v H1 H2. +symmetry in H2. assert (H3 : n' + m <= n + m') by now apply eq_le_incl. +pose proof (add_lt_le_mono _ _ _ _ H1 H3) as H4. +rewrite (add_shuffle2 n u), (add_shuffle1 m v), (add_comm m n) in H4. +do 2 rewrite <- add_assoc in H4. do 2 apply <- add_lt_mono_l in H4. +now rewrite (add_comm n' u), (add_comm m' v). +Qed. + +End NAddOrderPropFunct. diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v new file mode 100644 index 00000000..750cc977 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -0,0 +1,71 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NZAxioms. + +Set Implicit Arguments. + +Module Type NAxiomsSig. +Declare Module Export NZOrdAxiomsMod : NZOrdAxiomsSig. + +Delimit Scope NatScope with Nat. +Notation N := NZ. +Notation Neq := NZeq. +Notation N0 := NZ0. +Notation N1 := (NZsucc NZ0). +Notation S := NZsucc. +Notation P := NZpred. +Notation add := NZadd. +Notation mul := NZmul. +Notation sub := NZsub. +Notation lt := NZlt. +Notation le := NZle. +Notation min := NZmin. +Notation max := NZmax. +Notation "x == y" := (Neq x y) (at level 70) : NatScope. +Notation "x ~= y" := (~ Neq x y) (at level 70) : NatScope. +Notation "0" := NZ0 : NatScope. +Notation "1" := (NZsucc NZ0) : NatScope. +Notation "x + y" := (NZadd x y) : NatScope. +Notation "x - y" := (NZsub x y) : NatScope. +Notation "x * y" := (NZmul x y) : NatScope. +Notation "x < y" := (NZlt x y) : NatScope. +Notation "x <= y" := (NZle x y) : NatScope. +Notation "x > y" := (NZlt y x) (only parsing) : NatScope. +Notation "x >= y" := (NZle y x) (only parsing) : NatScope. + +Open Local Scope NatScope. + +Parameter Inline recursion : forall A : Type, A -> (N -> A -> A) -> N -> A. +Implicit Arguments recursion [A]. + +Axiom pred_0 : P 0 == 0. + +Axiom recursion_wd : forall (A : Type) (Aeq : relation A), + forall a a' : A, Aeq a a' -> + forall f f' : N -> A -> A, fun2_eq Neq Aeq Aeq f f' -> + forall x x' : N, x == x' -> + Aeq (recursion a f x) (recursion a' f' x'). + +Axiom recursion_0 : + forall (A : Type) (a : A) (f : N -> A -> A), recursion a f 0 = a. + +Axiom recursion_succ : + forall (A : Type) (Aeq : relation A) (a : A) (f : N -> A -> A), + Aeq a a -> fun2_wd Neq Aeq Aeq f -> + forall n : N, Aeq (recursion a f (S n)) (f n (recursion a f n)). + +(*Axiom dep_rec : + forall A : N -> Type, A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n.*) + +End NAxiomsSig. + diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v new file mode 100644 index 00000000..3e4032b5 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -0,0 +1,288 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export Decidable. +Require Export NAxioms. +Require Import NZMulOrder. (* The last property functor on NZ, which subsumes all others *) + +Module NBasePropFunct (Import NAxiomsMod : NAxiomsSig). + +Open Local Scope NatScope. + +(* We call the last property functor on NZ, which includes all the previous +ones, to get all properties of NZ at once. This way we will include them +only one time. *) + +Module Export NZMulOrderMod := NZMulOrderPropFunct NZOrdAxiomsMod. + +(* Here we probably need to re-prove all axioms declared in NAxioms.v to +make sure that the definitions like N, S and add are unfolded in them, +since unfolding is done only inside a functor. In fact, we'll do it in the +files that prove the corresponding properties. In those files, we will also +rename properties proved in NZ files by removing NZ from their names. In +this way, one only has to consult, for example, NAdd.v to see all +available properties for add, i.e., one does not have to go to NAxioms.v +for axioms and NZAdd.v for theorems. *) + +Theorem succ_wd : forall n1 n2 : N, n1 == n2 -> S n1 == S n2. +Proof NZsucc_wd. + +Theorem pred_wd : forall n1 n2 : N, n1 == n2 -> P n1 == P n2. +Proof NZpred_wd. + +Theorem pred_succ : forall n : N, P (S n) == n. +Proof NZpred_succ. + +Theorem pred_0 : P 0 == 0. +Proof pred_0. + +Theorem Neq_refl : forall n : N, n == n. +Proof (proj1 NZeq_equiv). + +Theorem Neq_symm : forall n m : N, n == m -> m == n. +Proof (proj2 (proj2 NZeq_equiv)). + +Theorem Neq_trans : forall n m p : N, n == m -> m == p -> n == p. +Proof (proj1 (proj2 NZeq_equiv)). + +Theorem neq_symm : forall n m : N, n ~= m -> m ~= n. +Proof NZneq_symm. + +Theorem succ_inj : forall n1 n2 : N, S n1 == S n2 -> n1 == n2. +Proof NZsucc_inj. + +Theorem succ_inj_wd : forall n1 n2 : N, S n1 == S n2 <-> n1 == n2. +Proof NZsucc_inj_wd. + +Theorem succ_inj_wd_neg : forall n m : N, S n ~= S m <-> n ~= m. +Proof NZsucc_inj_wd_neg. + +(* Decidability and stability of equality was proved only in NZOrder, but +since it does not mention order, we'll put it here *) + +Theorem eq_dec : forall n m : N, decidable (n == m). +Proof NZeq_dec. + +Theorem eq_dne : forall n m : N, ~ ~ n == m <-> n == m. +Proof NZeq_dne. + +(* Now 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 : Set) (a b : A) (n : N) : A := + recursion a (fun _ _ => b) n. + +Add Parametric Morphism (A : Set) : (if_zero A) with signature (@eq _ ==> @eq _ ==> Neq ==> @eq _) as if_zero_wd. +Proof. +intros; unfold if_zero. apply recursion_wd with (Aeq := (@eq A)). +reflexivity. unfold fun2_eq; now intros. assumption. +Qed. + +Theorem if_zero_0 : forall (A : Set) (a b : A), if_zero A a b 0 = a. +Proof. +unfold if_zero; intros; now rewrite recursion_0. +Qed. + +Theorem if_zero_succ : forall (A : Set) (a b : A) (n : N), if_zero A a b (S n) = b. +Proof. +intros; unfold if_zero. +now rewrite (@recursion_succ A (@eq A)); [| | unfold fun2_wd; now intros]. +Qed. + +Implicit Arguments if_zero [A]. + +Theorem neq_succ_0 : forall n : N, S n ~= 0. +Proof. +intros n H. +assert (true = false); [| discriminate]. +replace true with (if_zero false true (S n)) by apply if_zero_succ. +pattern false at 2; replace false with (if_zero false true 0) by apply if_zero_0. +now rewrite H. +Qed. + +Theorem neq_0_succ : forall n : N, 0 ~= S n. +Proof. +intro n; apply neq_symm; apply neq_succ_0. +Qed. + +(* Next, we show that all numbers are nonnegative and recover regular induction +from the bidirectional induction on NZ *) + +Theorem le_0_l : forall n : N, 0 <= n. +Proof. +NZinduct n. +now apply NZeq_le_incl. +intro n; split. +apply NZle_le_succ_r. +intro H; apply -> NZle_succ_r in H; destruct H as [H | H]. +assumption. +symmetry in H; false_hyp H neq_succ_0. +Qed. + +Theorem induction : + forall A : N -> Prop, predicate_wd Neq A -> + A 0 -> (forall n : N, A n -> A (S n)) -> forall n : N, A n. +Proof. +intros A A_wd A0 AS n; apply NZright_induction with 0; try assumption. +intros; auto; apply le_0_l. apply le_0_l. +Qed. + +(* The theorems NZinduction, NZcentral_induction and the tactic NZinduct +refer to bidirectional induction, which is not useful on natural +numbers. Therefore, we define a new induction tactic for natural numbers. +We do not have to call "Declare Left Step" and "Declare Right Step" +commands again, since the data for stepl and stepr tactics is inherited +from NZ. *) + +Ltac induct n := induction_maker n ltac:(apply induction). + +Theorem case_analysis : + forall A : N -> Prop, predicate_wd Neq A -> + A 0 -> (forall n : N, A (S n)) -> forall n : N, A n. +Proof. +intros; apply induction; auto. +Qed. + +Ltac cases n := induction_maker n ltac:(apply case_analysis). + +Theorem neq_0 : ~ forall n, n == 0. +Proof. +intro H; apply (neq_succ_0 0). apply H. +Qed. + +Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m. +Proof. +cases n. split; intro H; +[now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0]. +intro n; split; intro H; [now exists n | apply neq_succ_0]. +Qed. + +Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m. +Proof. +cases n. +now left. +intro n; right; now exists n. +Qed. + +Theorem eq_pred_0 : forall n : 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]. +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. +Qed. + +Theorem succ_pred : forall n : N, n ~= 0 -> S (P n) == n. +Proof. +cases n. +intro H; elimtype False; now apply H. +intros; now rewrite pred_succ. +Qed. + +Theorem pred_inj : forall n m : N, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. +Proof. +intros n m; cases n. +intros H; elimtype False; now apply H. +intros n _; cases m. +intros H; elimtype False; now apply H. +intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3. +Qed. + +(* The following induction principle is useful for reasoning about, e.g., +Fibonacci numbers *) + +Section PairInduction. + +Variable A : N -> Prop. +Hypothesis A_wd : predicate_wd Neq A. + +Add Morphism A with signature Neq ==> iff as A_morph. +Proof. +exact A_wd. +Qed. + +Theorem pair_induction : + A 0 -> A 1 -> + (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n. +Proof. +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. +Qed. + +End PairInduction. + +(*Ltac pair_induct n := induction_maker n ltac:(apply pair_induction).*) + +(* The following is useful for reasoning about, e.g., Ackermann function *) +Section TwoDimensionalInduction. + +Variable R : N -> N -> Prop. +Hypothesis R_wd : relation_wd Neq Neq R. + +Add Morphism R with signature Neq ==> Neq ==> iff as R_morph. +Proof. +exact R_wd. +Qed. + +Theorem two_dim_induction : + R 0 0 -> + (forall n m, R n m -> R n (S m)) -> + (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. +Proof. +intros H1 H2 H3. induct n. +induct m. +exact H1. exact (H2 0). +intros n IH. induct m. +now apply H3. exact (H2 (S n)). +Qed. + +End TwoDimensionalInduction. + +(*Ltac two_dim_induct n m := + try intros until n; + try intros until m; + pattern n, m; apply two_dim_induction; clear n m; + [solve_relation_wd | | | ].*) + +Section DoubleInduction. + +Variable R : N -> N -> Prop. +Hypothesis R_wd : relation_wd Neq Neq R. + +Add Morphism R with signature Neq ==> Neq ==> iff as R_morph1. +Proof. +exact R_wd. +Qed. + +Theorem double_induction : + (forall m : N, R 0 m) -> + (forall n : N, R (S n) 0) -> + (forall n m : N, R n m -> R (S n) (S m)) -> forall n m : N, R n m. +Proof. +intros H1 H2 H3; induct n; auto. +intros n H; cases m; auto. +Qed. + +End DoubleInduction. + +Ltac double_induct n m := + try intros until n; + try intros until m; + pattern n, m; apply double_induction; clear n m; + [solve_relation_wd | | | ]. + +End NBasePropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v new file mode 100644 index 00000000..e15e4672 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -0,0 +1,298 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NDefOps.v 11039 2008-06-02 23:26:13Z letouzey $ i*) + +Require Import Bool. (* To get the orb and negb function *) +Require Export NStrongRec. + +Module NdefOpsPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NStrongRecPropMod := NStrongRecPropFunct NAxiomsMod. +Open Local Scope NatScope. + +(*****************************************************) +(** Addition *) + +Definition def_add (x y : N) := recursion y (fun _ p => S p) x. + +Infix Local "++" := def_add (at level 50, left associativity). + +Add Morphism def_add with signature Neq ==> Neq ==> Neq as def_add_wd. +Proof. +unfold def_add. +intros x x' Exx' y y' Eyy'. +apply recursion_wd with (Aeq := Neq). +assumption. +unfold fun2_eq; intros _ _ _ p p' Epp'; now rewrite Epp'. +assumption. +Qed. + +Theorem def_add_0_l : forall y : N, 0 ++ y == y. +Proof. +intro y. unfold def_add. now rewrite recursion_0. +Qed. + +Theorem def_add_succ_l : forall x y : N, S x ++ y == S (x ++ y). +Proof. +intros x y; unfold def_add. +rewrite (@recursion_succ N Neq); try reflexivity. +unfold fun2_wd. intros _ _ _ m1 m2 H2. now rewrite H2. +Qed. + +Theorem def_add_add : forall n m : N, n ++ m == n + m. +Proof. +intros n m; induct n. +now rewrite def_add_0_l, add_0_l. +intros n H. now rewrite def_add_succ_l, add_succ_l, H. +Qed. + +(*****************************************************) +(** Multiplication *) + +Definition def_mul (x y : N) := recursion 0 (fun _ p => p ++ x) y. + +Infix Local "**" := def_mul (at level 40, left associativity). + +Lemma def_mul_step_wd : forall x : N, fun2_wd Neq Neq Neq (fun _ p => def_add p x). +Proof. +unfold fun2_wd. intros. now apply def_add_wd. +Qed. + +Lemma def_mul_step_equal : + forall x x' : N, x == x' -> + fun2_eq Neq Neq Neq (fun _ p => def_add p x) (fun x p => def_add p x'). +Proof. +unfold fun2_eq; intros; apply def_add_wd; assumption. +Qed. + +Add Morphism def_mul with signature Neq ==> Neq ==> Neq as def_mul_wd. +Proof. +unfold def_mul. +intros x x' Exx' y y' Eyy'. +apply recursion_wd with (Aeq := Neq). +reflexivity. apply def_mul_step_equal. assumption. assumption. +Qed. + +Theorem def_mul_0_r : forall x : N, x ** 0 == 0. +Proof. +intro. unfold def_mul. now rewrite recursion_0. +Qed. + +Theorem def_mul_succ_r : forall x y : N, x ** S y == x ** y ++ x. +Proof. +intros x y; unfold def_mul. +now rewrite (@recursion_succ N Neq); [| apply def_mul_step_wd |]. +Qed. + +Theorem def_mul_mul : forall n m : N, n ** m == n * m. +Proof. +intros n m; induct m. +now rewrite def_mul_0_r, mul_0_r. +intros m IH; now rewrite def_mul_succ_r, mul_succ_r, def_add_add, IH. +Qed. + +(*****************************************************) +(** Order *) + +Definition def_ltb (m : N) : N -> bool := +recursion + (if_zero false true) + (fun _ f => fun n => recursion false (fun n' _ => f n') n) + m. + +Infix Local "<<" := def_ltb (at level 70, no associativity). + +Lemma lt_base_wd : fun_wd Neq (@eq bool) (if_zero false true). +unfold fun_wd; intros; now apply if_zero_wd. +Qed. + +Lemma lt_step_wd : +fun2_wd Neq (fun_eq Neq (@eq bool)) (fun_eq Neq (@eq bool)) + (fun _ f => fun n => recursion false (fun n' _ => f n') n). +Proof. +unfold fun2_wd, fun_eq. +intros x x' Exx' f f' Eff' y y' Eyy'. +apply recursion_wd with (Aeq := @eq bool). +reflexivity. +unfold fun2_eq; intros; now apply Eff'. +assumption. +Qed. + +Lemma lt_curry_wd : + forall m m' : N, m == m' -> fun_eq Neq (@eq bool) (def_ltb m) (def_ltb m'). +Proof. +unfold def_ltb. +intros m m' Emm'. +apply recursion_wd with (Aeq := fun_eq Neq (@eq bool)). +apply lt_base_wd. +apply lt_step_wd. +assumption. +Qed. + +Add Morphism def_ltb with signature Neq ==> Neq ==> (@eq bool) as def_ltb_wd. +Proof. +intros; now apply lt_curry_wd. +Qed. + +Theorem def_ltb_base : forall n : N, 0 << n = if_zero false true n. +Proof. +intro n; unfold def_ltb; now rewrite recursion_0. +Qed. + +Theorem def_ltb_step : + forall m n : N, S m << n = recursion false (fun n' _ => m << n') n. +Proof. +intros m n; unfold def_ltb. +pose proof + (@recursion_succ + (N -> bool) + (fun_eq Neq (@eq bool)) + (if_zero false true) + (fun _ f => fun n => recursion false (fun n' _ => f n') n) + lt_base_wd + lt_step_wd + m n n) as H. +now rewrite H. +Qed. + +(* Above, we rewrite applications of function. Is it possible to rewrite +functions themselves, i.e., rewrite (recursion lt_base lt_step (S n)) to +lt_step n (recursion lt_base lt_step n)? *) + +Theorem def_ltb_0 : forall n : N, n << 0 = false. +Proof. +cases n. +rewrite def_ltb_base; now rewrite if_zero_0. +intro n; rewrite def_ltb_step. now rewrite recursion_0. +Qed. + +Theorem def_ltb_0_succ : forall n : N, 0 << S n = true. +Proof. +intro n; rewrite def_ltb_base; now rewrite if_zero_succ. +Qed. + +Theorem succ_def_ltb_mono : forall n m : N, (S n << S m) = (n << m). +Proof. +intros n m. +rewrite def_ltb_step. rewrite (@recursion_succ bool (@eq bool)); try reflexivity. +unfold fun2_wd; intros; now apply def_ltb_wd. +Qed. + +Theorem def_ltb_lt : forall n m : N, n << m = true <-> n < m. +Proof. +double_induct n m. +cases m. +rewrite def_ltb_0. split; intro H; [discriminate H | false_hyp H nlt_0_r]. +intro n. rewrite def_ltb_0_succ. split; intro; [apply lt_0_succ | reflexivity]. +intro n. rewrite def_ltb_0. split; intro H; [discriminate | false_hyp H nlt_0_r]. +intros n m. rewrite succ_def_ltb_mono. now rewrite <- succ_lt_mono. +Qed. + +(* +(*****************************************************) +(** Even *) + +Definition even (x : N) := recursion true (fun _ p => negb p) x. + +Lemma even_step_wd : fun2_wd Neq (@eq bool) (@eq bool) (fun x p => if p then false else true). +Proof. +unfold fun2_wd. +intros x x' Exx' b b' Ebb'. +unfold eq_bool; destruct b; destruct b'; now simpl. +Qed. + +Add Morphism even with signature Neq ==> (@eq bool) as even_wd. +Proof. +unfold even; intros. +apply recursion_wd with (A := bool) (Aeq := (@eq bool)). +now unfold eq_bool. +unfold fun2_eq. intros _ _ _ b b' Ebb'. unfold eq_bool; destruct b; destruct b'; now simpl. +assumption. +Qed. + +Theorem even_0 : even 0 = true. +Proof. +unfold even. +now rewrite recursion_0. +Qed. + +Theorem even_succ : forall x : N, even (S x) = negb (even x). +Proof. +unfold even. +intro x; rewrite (recursion_succ (@eq bool)); try reflexivity. +unfold fun2_wd. +intros _ _ _ b b' Ebb'. destruct b; destruct b'; now simpl. +Qed. + +(*****************************************************) +(** Division by 2 *) + +Definition half_aux (x : N) : N * N := + recursion (0, 0) (fun _ p => let (x1, x2) := p in ((S x2, x1))) x. + +Definition half (x : N) := snd (half_aux x). + +Definition E2 := prod_rel Neq Neq. + +Add Relation (prod N N) E2 +reflexivity proved by (prod_rel_refl N N Neq Neq E_equiv E_equiv) +symmetry proved by (prod_rel_symm N N Neq Neq E_equiv E_equiv) +transitivity proved by (prod_rel_trans N N Neq Neq E_equiv E_equiv) +as E2_rel. + +Lemma half_step_wd: fun2_wd Neq E2 E2 (fun _ p => let (x1, x2) := p in ((S x2, x1))). +Proof. +unfold fun2_wd, E2, prod_rel. +intros _ _ _ p1 p2 [H1 H2]. +destruct p1; destruct p2; simpl in *. +now split; [rewrite H2 |]. +Qed. + +Add Morphism half with signature Neq ==> Neq as half_wd. +Proof. +unfold half. +assert (H: forall x y, x == y -> E2 (half_aux x) (half_aux y)). +intros x y Exy; unfold half_aux; apply recursion_wd with (Aeq := E2); unfold E2. +unfold E2. +unfold prod_rel; simpl; now split. +unfold fun2_eq, prod_rel; simpl. +intros _ _ _ p1 p2; destruct p1; destruct p2; simpl. +intros [H1 H2]; split; [rewrite H2 | assumption]. reflexivity. assumption. +unfold E2, prod_rel in H. intros x y Exy; apply H in Exy. +exact (proj2 Exy). +Qed. + +(*****************************************************) +(** Logarithm for the base 2 *) + +Definition log (x : N) : N := +strong_rec 0 + (fun x g => + if (e x 0) then 0 + else if (e x 1) then 0 + else S (g (half x))) + x. + +Add Morphism log with signature Neq ==> Neq as log_wd. +Proof. +intros x x' Exx'. unfold log. +apply strong_rec_wd with (Aeq := Neq); try (reflexivity || assumption). +unfold fun2_eq. intros y y' Eyy' g g' Egg'. +assert (H : e y 0 = e y' 0); [now apply e_wd|]. +rewrite <- H; clear H. +assert (H : e y 1 = e y' 1); [now apply e_wd|]. +rewrite <- H; clear H. +assert (H : S (g (half y)) == S (g' (half y'))); +[apply succ_wd; apply Egg'; now apply half_wd|]. +now destruct (e y 0); destruct (e y 1). +Qed. +*) +End NdefOpsPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v new file mode 100644 index 00000000..f6ccf3db --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -0,0 +1,122 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NIso.v 10934 2008-05-15 21:58:20Z letouzey $ i*) + +Require Import NBase. + +Module Homomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). + +Module NBasePropMod2 := NBasePropFunct NAxiomsMod2. + +Notation Local N1 := NAxiomsMod1.N. +Notation Local N2 := NAxiomsMod2.N. +Notation Local Eq1 := NAxiomsMod1.Neq. +Notation Local Eq2 := NAxiomsMod2.Neq. +Notation Local O1 := NAxiomsMod1.N0. +Notation Local O2 := NAxiomsMod2.N0. +Notation Local S1 := NAxiomsMod1.S. +Notation Local S2 := NAxiomsMod2.S. +Notation Local "n == m" := (Eq2 n m) (at level 70, no associativity). + +Definition homomorphism (f : N1 -> N2) : Prop := + f O1 == O2 /\ forall n : N1, f (S1 n) == S2 (f n). + +Definition natural_isomorphism : N1 -> N2 := + NAxiomsMod1.recursion O2 (fun (n : N1) (p : N2) => S2 p). + +Add Morphism natural_isomorphism with signature Eq1 ==> Eq2 as natural_isomorphism_wd. +Proof. +unfold natural_isomorphism. +intros n m Eqxy. +apply NAxiomsMod1.recursion_wd with (Aeq := Eq2). +reflexivity. +unfold fun2_eq. intros _ _ _ y' y'' H. now apply NBasePropMod2.succ_wd. +assumption. +Qed. + +Theorem natural_isomorphism_0 : natural_isomorphism O1 == O2. +Proof. +unfold natural_isomorphism; now rewrite NAxiomsMod1.recursion_0. +Qed. + +Theorem natural_isomorphism_succ : + forall n : N1, natural_isomorphism (S1 n) == S2 (natural_isomorphism n). +Proof. +unfold natural_isomorphism. +intro n. now rewrite (@NAxiomsMod1.recursion_succ N2 NAxiomsMod2.Neq) ; +[ | | unfold fun2_wd; intros; apply NBasePropMod2.succ_wd]. +Qed. + +Theorem hom_nat_iso : homomorphism natural_isomorphism. +Proof. +unfold homomorphism, natural_isomorphism; split; +[exact natural_isomorphism_0 | exact natural_isomorphism_succ]. +Qed. + +End Homomorphism. + +Module Inverse (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). + +Module Import NBasePropMod1 := NBasePropFunct NAxiomsMod1. +(* This makes the tactic induct available. Since it is taken from +(NBasePropFunct NAxiomsMod1), it refers to induction on N1. *) + +Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2. +Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1. + +Notation Local N1 := NAxiomsMod1.N. +Notation Local N2 := NAxiomsMod2.N. +Notation Local h12 := Hom12.natural_isomorphism. +Notation Local h21 := Hom21.natural_isomorphism. + +Notation Local "n == m" := (NAxiomsMod1.Neq n m) (at level 70, no associativity). + +Lemma inverse_nat_iso : forall n : N1, h21 (h12 n) == n. +Proof. +induct n. +now rewrite Hom12.natural_isomorphism_0, Hom21.natural_isomorphism_0. +intros n IH. +now rewrite Hom12.natural_isomorphism_succ, Hom21.natural_isomorphism_succ, IH. +Qed. + +End Inverse. + +Module Isomorphism (NAxiomsMod1 NAxiomsMod2 : NAxiomsSig). + +Module Hom12 := Homomorphism NAxiomsMod1 NAxiomsMod2. +Module Hom21 := Homomorphism NAxiomsMod2 NAxiomsMod1. + +Module Inverse12 := Inverse NAxiomsMod1 NAxiomsMod2. +Module Inverse21 := Inverse NAxiomsMod2 NAxiomsMod1. + +Notation Local N1 := NAxiomsMod1.N. +Notation Local N2 := NAxiomsMod2.N. +Notation Local Eq1 := NAxiomsMod1.Neq. +Notation Local Eq2 := NAxiomsMod2.Neq. +Notation Local h12 := Hom12.natural_isomorphism. +Notation Local h21 := Hom21.natural_isomorphism. + +Definition isomorphism (f1 : N1 -> N2) (f2 : N2 -> N1) : Prop := + Hom12.homomorphism f1 /\ Hom21.homomorphism f2 /\ + forall n : N1, Eq1 (f2 (f1 n)) n /\ + forall n : N2, Eq2 (f1 (f2 n)) n. + +Theorem iso_nat_iso : isomorphism h12 h21. +Proof. +unfold isomorphism. +split. apply Hom12.hom_nat_iso. +split. apply Hom21.hom_nat_iso. +split. apply Inverse12.inverse_nat_iso. +apply Inverse21.inverse_nat_iso. +Qed. + +End Isomorphism. + diff --git a/theories/Numbers/Natural/Abstract/NMul.v b/theories/Numbers/Natural/Abstract/NMul.v new file mode 100644 index 00000000..0b00f689 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NMul.v @@ -0,0 +1,87 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NMul.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NAdd. + +Module NMulPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NAddPropMod := NAddPropFunct NAxiomsMod. +Open Local Scope NatScope. + +Theorem mul_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 * m1 == n2 * m2. +Proof NZmul_wd. + +Theorem mul_0_l : forall n : N, 0 * n == 0. +Proof NZmul_0_l. + +Theorem mul_succ_l : forall n m : N, (S n) * m == n * m + m. +Proof NZmul_succ_l. + +(** Theorems that are valid for both natural numbers and integers *) + +Theorem mul_0_r : forall n, n * 0 == 0. +Proof NZmul_0_r. + +Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. +Proof NZmul_succ_r. + +Theorem mul_comm : forall n m : N, n * m == m * n. +Proof NZmul_comm. + +Theorem mul_add_distr_r : forall n m p : N, (n + m) * p == n * p + m * p. +Proof NZmul_add_distr_r. + +Theorem mul_add_distr_l : forall n m p : N, n * (m + p) == n * m + n * p. +Proof NZmul_add_distr_l. + +Theorem mul_assoc : forall n m p : N, n * (m * p) == (n * m) * p. +Proof NZmul_assoc. + +Theorem mul_1_l : forall n : N, 1 * n == n. +Proof NZmul_1_l. + +Theorem mul_1_r : forall n : N, n * 1 == n. +Proof NZmul_1_r. + +(* Theorems that cannot be proved in NZMul *) + +(* In proving the correctness of the definition of multiplication on +integers constructed from pairs of natural numbers, we'll need the +following fact about natural numbers: + +a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u = a * m' + v + +Here n + m' == n' + m expresses equality of integers (n, m) and (n', m'), +since a pair (a, b) of natural numbers represents the integer a - b. On +integers, the formula above could be proved by moving a * m to the left, +factoring out a and replacing n - m by n' - m'. However, the formula is +required in the process of constructing integers, so it has to be proved +for natural numbers, where terms cannot be moved from one side of an +equation to the other. The proof uses the cancellation laws add_cancel_l +and add_cancel_r. *) + +Theorem add_mul_repl_pair : forall a n m n' m' u v : N, + a * n + u == a * m + v -> n + m' == n' + m -> a * n' + u == a * m' + v. +Proof. +intros a n m n' m' u v H1 H2. +apply (@NZmul_wd a a) in H2; [| reflexivity]. +do 2 rewrite mul_add_distr_l in H2. symmetry in H2. +pose proof (NZadd_wd _ _ H1 _ _ H2) as H3. +rewrite (add_shuffle1 (a * m)), (add_comm (a * m) (a * n)) in H3. +do 2 rewrite <- add_assoc in H3. apply -> add_cancel_l in H3. +rewrite (add_assoc u), (add_comm (a * m)) in H3. +apply -> add_cancel_r in H3. +now rewrite (add_comm (a * n') u), (add_comm (a * m') v). +Qed. + +End NMulPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v new file mode 100644 index 00000000..aa21fb50 --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -0,0 +1,131 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NAddOrder. + +Module NMulOrderPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NAddOrderPropMod := NAddOrderPropFunct NAxiomsMod. +Open Local Scope NatScope. + +Theorem mul_lt_pred : + forall p q n m : N, S p == q -> (p * n < p * m <-> q * n + m < q * m + n). +Proof NZmul_lt_pred. + +Theorem mul_lt_mono_pos_l : forall p n m : N, 0 < p -> (n < m <-> p * n < p * m). +Proof NZmul_lt_mono_pos_l. + +Theorem mul_lt_mono_pos_r : forall p n m : N, 0 < p -> (n < m <-> n * p < m * p). +Proof NZmul_lt_mono_pos_r. + +Theorem mul_cancel_l : forall n m p : N, p ~= 0 -> (p * n == p * m <-> n == m). +Proof NZmul_cancel_l. + +Theorem mul_cancel_r : forall n m p : N, p ~= 0 -> (n * p == m * p <-> n == m). +Proof NZmul_cancel_r. + +Theorem mul_id_l : forall n m : N, m ~= 0 -> (n * m == m <-> n == 1). +Proof NZmul_id_l. + +Theorem mul_id_r : forall n m : N, n ~= 0 -> (n * m == n <-> m == 1). +Proof NZmul_id_r. + +Theorem mul_le_mono_pos_l : forall n m p : N, 0 < p -> (n <= m <-> p * n <= p * m). +Proof NZmul_le_mono_pos_l. + +Theorem mul_le_mono_pos_r : forall n m p : N, 0 < p -> (n <= m <-> n * p <= m * p). +Proof NZmul_le_mono_pos_r. + +Theorem mul_pos_pos : forall n m : N, 0 < n -> 0 < m -> 0 < n * m. +Proof NZmul_pos_pos. + +Theorem lt_1_mul_pos : forall n m : N, 1 < n -> 0 < m -> 1 < n * m. +Proof NZlt_1_mul_pos. + +Theorem eq_mul_0 : forall n m : N, n * m == 0 <-> n == 0 \/ m == 0. +Proof NZeq_mul_0. + +Theorem neq_mul_0 : forall n m : N, n ~= 0 /\ m ~= 0 <-> n * m ~= 0. +Proof NZneq_mul_0. + +Theorem eq_square_0 : forall n : N, n * n == 0 <-> n == 0. +Proof NZeq_square_0. + +Theorem eq_mul_0_l : forall n m : N, n * m == 0 -> m ~= 0 -> n == 0. +Proof NZeq_mul_0_l. + +Theorem eq_mul_0_r : forall n m : N, n * m == 0 -> n ~= 0 -> m == 0. +Proof NZeq_mul_0_r. + +Theorem square_lt_mono : forall n m : N, n < m <-> n * n < m * m. +Proof. +intros n m; split; intro; +[apply NZsquare_lt_mono_nonneg | apply NZsquare_lt_simpl_nonneg]; +try assumption; apply le_0_l. +Qed. + +Theorem square_le_mono : forall n m : N, n <= m <-> n * n <= m * m. +Proof. +intros n m; split; intro; +[apply NZsquare_le_mono_nonneg | apply NZsquare_le_simpl_nonneg]; +try assumption; apply le_0_l. +Qed. + +Theorem mul_2_mono_l : forall n m : N, n < m -> 1 + (1 + 1) * n < (1 + 1) * m. +Proof NZmul_2_mono_l. + +(* Theorems that are either not valid on Z or have different proofs on N and Z *) + +Theorem mul_le_mono_l : forall n m p : N, n <= m -> p * n <= p * m. +Proof. +intros; apply NZmul_le_mono_nonneg_l. apply le_0_l. assumption. +Qed. + +Theorem mul_le_mono_r : forall n m p : N, n <= m -> n * p <= m * p. +Proof. +intros; apply NZmul_le_mono_nonneg_r. apply le_0_l. assumption. +Qed. + +Theorem mul_lt_mono : forall n m p q : N, n < m -> p < q -> n * p < m * q. +Proof. +intros; apply NZmul_lt_mono_nonneg; try assumption; apply le_0_l. +Qed. + +Theorem mul_le_mono : forall n m p q : N, n <= m -> p <= q -> n * p <= m * q. +Proof. +intros; apply NZmul_le_mono_nonneg; try assumption; apply le_0_l. +Qed. + +Theorem lt_0_mul : forall n m : N, n * m > 0 <-> n > 0 /\ m > 0. +Proof. +intros n m; split; [intro H | intros [H1 H2]]. +apply -> NZlt_0_mul in H. destruct H as [[H1 H2] | [H1 H2]]. now split. false_hyp H1 nlt_0_r. +now apply NZmul_pos_pos. +Qed. + +Notation mul_pos := lt_0_mul (only parsing). + +Theorem eq_mul_1 : forall n m : N, n * m == 1 <-> n == 1 /\ m == 1. +Proof. +intros n m. +split; [| intros [H1 H2]; now rewrite H1, H2, mul_1_l]. +intro H; destruct (NZlt_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. +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. +assert (H3 : 1 < n * m) by now apply (lt_1_l 0 m). +rewrite H in H3; false_hyp H3 lt_irrefl. +Qed. + +End NMulOrderPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v new file mode 100644 index 00000000..826ffa2c --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -0,0 +1,539 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NMul. + +Module NOrderPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NMulPropMod := NMulPropFunct NAxiomsMod. +Open Local Scope NatScope. + +(* The tactics le_less, le_equal and le_elim are inherited from NZOrder.v *) + +(* Axioms *) + +Theorem lt_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 < m1 <-> n2 < m2). +Proof NZlt_wd. + +Theorem le_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> (n1 <= m1 <-> n2 <= m2). +Proof NZle_wd. + +Theorem min_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> min n1 m1 == min n2 m2. +Proof NZmin_wd. + +Theorem max_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> max n1 m1 == max n2 m2. +Proof NZmax_wd. + +Theorem lt_eq_cases : forall n m : N, n <= m <-> n < m \/ n == m. +Proof NZlt_eq_cases. + +Theorem lt_irrefl : forall n : N, ~ n < n. +Proof NZlt_irrefl. + +Theorem lt_succ_r : forall n m : N, n < S m <-> n <= m. +Proof NZlt_succ_r. + +Theorem min_l : forall n m : N, n <= m -> min n m == n. +Proof NZmin_l. + +Theorem min_r : forall n m : N, m <= n -> min n m == m. +Proof NZmin_r. + +Theorem max_l : forall n m : N, m <= n -> max n m == n. +Proof NZmax_l. + +Theorem max_r : forall n m : N, n <= m -> max n m == m. +Proof NZmax_r. + +(* Renaming theorems from NZOrder.v *) + +Theorem lt_le_incl : forall n m : N, n < m -> n <= m. +Proof NZlt_le_incl. + +Theorem eq_le_incl : forall n m : N, n == m -> n <= m. +Proof NZeq_le_incl. + +Theorem lt_neq : forall n m : N, n < m -> n ~= m. +Proof NZlt_neq. + +Theorem le_neq : forall n m : N, n < m <-> n <= m /\ n ~= m. +Proof NZle_neq. + +Theorem le_refl : forall n : N, n <= n. +Proof NZle_refl. + +Theorem lt_succ_diag_r : forall n : N, n < S n. +Proof NZlt_succ_diag_r. + +Theorem le_succ_diag_r : forall n : N, n <= S n. +Proof NZle_succ_diag_r. + +Theorem lt_0_1 : 0 < 1. +Proof NZlt_0_1. + +Theorem le_0_1 : 0 <= 1. +Proof NZle_0_1. + +Theorem lt_lt_succ_r : forall n m : N, n < m -> n < S m. +Proof NZlt_lt_succ_r. + +Theorem le_le_succ_r : forall n m : N, n <= m -> n <= S m. +Proof NZle_le_succ_r. + +Theorem le_succ_r : forall n m : N, n <= S m <-> n <= m \/ n == S m. +Proof NZle_succ_r. + +Theorem neq_succ_diag_l : forall n : N, S n ~= n. +Proof NZneq_succ_diag_l. + +Theorem neq_succ_diag_r : forall n : N, n ~= S n. +Proof NZneq_succ_diag_r. + +Theorem nlt_succ_diag_l : forall n : N, ~ S n < n. +Proof NZnlt_succ_diag_l. + +Theorem nle_succ_diag_l : forall n : N, ~ S n <= n. +Proof NZnle_succ_diag_l. + +Theorem le_succ_l : forall n m : N, S n <= m <-> n < m. +Proof NZle_succ_l. + +Theorem lt_succ_l : forall n m : N, S n < m -> n < m. +Proof NZlt_succ_l. + +Theorem succ_lt_mono : forall n m : N, n < m <-> S n < S m. +Proof NZsucc_lt_mono. + +Theorem succ_le_mono : forall n m : N, n <= m <-> S n <= S m. +Proof NZsucc_le_mono. + +Theorem lt_asymm : forall n m : N, n < m -> ~ m < n. +Proof NZlt_asymm. + +Notation lt_ngt := lt_asymm (only parsing). + +Theorem lt_trans : forall n m p : N, n < m -> m < p -> n < p. +Proof NZlt_trans. + +Theorem le_trans : forall n m p : N, n <= m -> m <= p -> n <= p. +Proof NZle_trans. + +Theorem le_lt_trans : forall n m p : N, n <= m -> m < p -> n < p. +Proof NZle_lt_trans. + +Theorem lt_le_trans : forall n m p : N, n < m -> m <= p -> n < p. +Proof NZlt_le_trans. + +Theorem le_antisymm : forall n m : N, n <= m -> m <= n -> n == m. +Proof NZle_antisymm. + +(** Trichotomy, decidability, and double negation elimination *) + +Theorem lt_trichotomy : forall n m : N, n < m \/ n == m \/ m < n. +Proof NZlt_trichotomy. + +Notation lt_eq_gt_cases := lt_trichotomy (only parsing). + +Theorem lt_gt_cases : forall n m : N, n ~= m <-> n < m \/ n > m. +Proof NZlt_gt_cases. + +Theorem le_gt_cases : forall n m : N, n <= m \/ n > m. +Proof NZle_gt_cases. + +Theorem lt_ge_cases : forall n m : N, n < m \/ n >= m. +Proof NZlt_ge_cases. + +Theorem le_ge_cases : forall n m : N, n <= m \/ n >= m. +Proof NZle_ge_cases. + +Theorem le_ngt : forall n m : N, n <= m <-> ~ n > m. +Proof NZle_ngt. + +Theorem nlt_ge : forall n m : N, ~ n < m <-> n >= m. +Proof NZnlt_ge. + +Theorem lt_dec : forall n m : N, decidable (n < m). +Proof NZlt_dec. + +Theorem lt_dne : forall n m : N, ~ ~ n < m <-> n < m. +Proof NZlt_dne. + +Theorem nle_gt : forall n m : N, ~ n <= m <-> n > m. +Proof NZnle_gt. + +Theorem lt_nge : forall n m : N, n < m <-> ~ n >= m. +Proof NZlt_nge. + +Theorem le_dec : forall n m : N, decidable (n <= m). +Proof NZle_dec. + +Theorem le_dne : forall n m : N, ~ ~ n <= m <-> n <= m. +Proof NZle_dne. + +Theorem nlt_succ_r : forall n m : N, ~ m < S n <-> n < m. +Proof NZnlt_succ_r. + +Theorem lt_exists_pred : + forall z n : N, z < n -> exists k : N, n == S k /\ z <= k. +Proof NZlt_exists_pred. + +Theorem lt_succ_iter_r : + forall (n : nat) (m : N), m < NZsucc_iter (Datatypes.S n) m. +Proof NZlt_succ_iter_r. + +Theorem neq_succ_iter_l : + forall (n : nat) (m : N), NZsucc_iter (Datatypes.S n) m ~= m. +Proof NZneq_succ_iter_l. + +(** Stronger variant of induction with assumptions n >= 0 (n < 0) +in the induction step *) + +Theorem right_induction : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, A z -> + (forall n : N, z <= n -> A n -> A (S n)) -> + forall n : N, z <= n -> A n. +Proof NZright_induction. + +Theorem left_induction : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, A z -> + (forall n : N, n < z -> A (S n) -> A n) -> + forall n : N, n <= z -> A n. +Proof NZleft_induction. + +Theorem right_induction' : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, n <= z -> A n) -> + (forall n : N, z <= n -> A n -> A (S n)) -> + forall n : N, A n. +Proof NZright_induction'. + +Theorem left_induction' : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, z <= n -> A n) -> + (forall n : N, n < z -> A (S n) -> A n) -> + forall n : N, A n. +Proof NZleft_induction'. + +Theorem strong_right_induction : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) -> + forall n : N, z <= n -> A n. +Proof NZstrong_right_induction. + +Theorem strong_left_induction : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) -> + forall n : N, n <= z -> A n. +Proof NZstrong_left_induction. + +Theorem strong_right_induction' : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, n <= z -> A n) -> + (forall n : N, z <= n -> (forall m : N, z <= m -> m < n -> A m) -> A n) -> + forall n : N, A n. +Proof NZstrong_right_induction'. + +Theorem strong_left_induction' : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, + (forall n : N, z <= n -> A n) -> + (forall n : N, n <= z -> (forall m : N, m <= z -> S n <= m -> A m) -> A n) -> + forall n : N, A n. +Proof NZstrong_left_induction'. + +Theorem order_induction : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, A z -> + (forall n : N, z <= n -> A n -> A (S n)) -> + (forall n : N, n < z -> A (S n) -> A n) -> + forall n : N, A n. +Proof NZorder_induction. + +Theorem order_induction' : + forall A : N -> Prop, predicate_wd Neq A -> + forall z : N, A z -> + (forall n : N, z <= n -> A n -> A (S n)) -> + (forall n : N, n <= z -> A n -> A (P n)) -> + forall n : N, A n. +Proof NZorder_induction'. + +(* We don't need order_induction_0 and order_induction'_0 (see NZOrder and +ZOrder) since they boil down to regular induction *) + +(** Elimintation principle for < *) + +Theorem lt_ind : + forall A : N -> Prop, predicate_wd Neq A -> + forall n : N, + A (S n) -> + (forall m : N, n < m -> A m -> A (S m)) -> + forall m : N, n < m -> A m. +Proof NZlt_ind. + +(** Elimintation principle for <= *) + +Theorem le_ind : + forall A : N -> Prop, predicate_wd Neq A -> + forall n : N, + A n -> + (forall m : N, n <= m -> A m -> A (S m)) -> + forall m : N, n <= m -> A m. +Proof NZle_ind. + +(** Well-founded relations *) + +Theorem lt_wf : forall z : N, well_founded (fun n m : N => z <= n /\ n < m). +Proof NZlt_wf. + +Theorem gt_wf : forall z : N, well_founded (fun n m : N => m < n /\ n <= z). +Proof NZgt_wf. + +Theorem lt_wf_0 : well_founded lt. +Proof. +assert (H : relations_eq lt (fun n m : N => 0 <= n /\ n < m)). +intros x y; split. +intro H; split; [apply le_0_l | assumption]. now intros [_ H]. +rewrite H; apply lt_wf. +(* does not work: +setoid_replace lt with (fun n m : N => 0 <= n /\ n < m) using relation relations_eq.*) +Qed. + +(* Theorems that are true for natural numbers but not for integers *) + +(* "le_0_l : forall n : N, 0 <= n" was proved in NBase.v *) + +Theorem nlt_0_r : forall n : N, ~ n < 0. +Proof. +intro n; apply -> le_ngt. apply le_0_l. +Qed. + +Theorem nle_succ_0 : forall n : N, ~ (S n <= 0). +Proof. +intros n H; apply -> le_succ_l in H; false_hyp H nlt_0_r. +Qed. + +Theorem le_0_r : forall n : N, n <= 0 <-> n == 0. +Proof. +intros n; split; intro H. +le_elim H; [false_hyp H nlt_0_r | assumption]. +now apply eq_le_incl. +Qed. + +Theorem lt_0_succ : forall n : N, 0 < S n. +Proof. +induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. +Qed. + +Theorem neq_0_lt_0 : forall n : N, n ~= 0 <-> 0 < n. +Proof. +cases n. +split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. +intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. +Qed. + +Theorem eq_0_gt_0_cases : forall n : N, n == 0 \/ 0 < n. +Proof. +cases n. +now left. +intro; right; apply lt_0_succ. +Qed. + +Theorem zero_one : forall n : N, n == 0 \/ n == 1 \/ 1 < n. +Proof. +induct n. now left. +cases n. intros; right; now left. +intros n IH. destruct IH as [H | [H | H]]. +false_hyp H neq_succ_0. +right; right. rewrite H. apply lt_succ_diag_r. +right; right. now apply lt_lt_succ_r. +Qed. + +Theorem lt_1_r : forall n : N, n < 1 <-> n == 0. +Proof. +cases n. +split; intro; [reflexivity | apply lt_succ_diag_r]. +intros n. rewrite <- succ_lt_mono. +split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. +Qed. + +Theorem le_1_r : forall n : N, n <= 1 <-> n == 0 \/ n == 1. +Proof. +cases n. +split; intro; [now left | apply le_succ_diag_r]. +intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. +split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. +Qed. + +Theorem lt_lt_0 : forall n m : N, n < m -> 0 < m. +Proof. +intros n m; induct n. +trivial. +intros n IH H. apply IH; now apply lt_succ_l. +Qed. + +Theorem lt_1_l : forall n m p : N, n < m -> m < p -> 1 < p. +Proof. +intros n m p H1 H2. +apply le_lt_trans with m. apply <- le_succ_l. apply le_lt_trans with n. +apply le_0_l. assumption. assumption. +Qed. + +(** Elimination principlies for < and <= for relations *) + +Section RelElim. + +(* FIXME: Variable R : relation N. -- does not work *) + +Variable R : N -> N -> Prop. +Hypothesis R_wd : relation_wd Neq Neq R. + +Add Morphism R with signature Neq ==> Neq ==> iff as R_morph2. +Proof. apply R_wd. Qed. + +Theorem le_ind_rel : + (forall m : N, R 0 m) -> + (forall n m : N, n <= m -> R n m -> R (S n) (S m)) -> + forall n m : N, n <= m -> R n m. +Proof. +intros Base Step; induct n. +intros; apply Base. +intros n IH m H. elim H using le_ind. +solve_predicate_wd. +apply Step; [| apply IH]; now apply eq_le_incl. +intros k H1 H2. apply -> le_succ_l in H1. apply lt_le_incl in H1. auto. +Qed. + +Theorem lt_ind_rel : + (forall m : N, R 0 (S m)) -> + (forall n m : N, n < m -> R n m -> R (S n) (S m)) -> + forall n m : N, n < m -> R n m. +Proof. +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. +apply Step; [| apply IH]; now apply lt_succ_diag_r. +intros k H1 H2. apply lt_succ_l in H1. auto. +Qed. + +End RelElim. + +(** Predecessor and order *) + +Theorem succ_pred_pos : forall n : N, 0 < n -> S (P n) == n. +Proof. +intros n H; apply succ_pred; intro H1; rewrite H1 in H. +false_hyp H lt_irrefl. +Qed. + +Theorem le_pred_l : forall n : N, P n <= n. +Proof. +cases n. +rewrite pred_0; now apply eq_le_incl. +intros; rewrite pred_succ; apply le_succ_diag_r. +Qed. + +Theorem lt_pred_l : forall n : N, n ~= 0 -> P n < n. +Proof. +cases n. +intro H; elimtype False; now apply H. +intros; rewrite pred_succ; apply lt_succ_diag_r. +Qed. + +Theorem le_le_pred : forall n m : N, n <= m -> P n <= m. +Proof. +intros n m H; apply le_trans with n. apply le_pred_l. assumption. +Qed. + +Theorem lt_lt_pred : forall n m : N, n < m -> P n < m. +Proof. +intros n m H; apply le_lt_trans with n. apply le_pred_l. assumption. +Qed. + +Theorem lt_le_pred : forall n m : N, n < m -> n <= P m. (* Converse is false for n == m == 0 *) +Proof. +intro n; cases m. +intro H; false_hyp H nlt_0_r. +intros m IH. rewrite pred_succ; now apply -> lt_succ_r. +Qed. + +Theorem lt_pred_le : forall n m : N, P n < m -> n <= m. (* Converse is false for n == m == 0 *) +Proof. +intros n m; cases n. +rewrite pred_0; intro H; now apply lt_le_incl. +intros n IH. rewrite pred_succ in IH. now apply <- le_succ_l. +Qed. + +Theorem lt_pred_lt : forall n m : N, n < P m -> n < m. +Proof. +intros n m H; apply lt_le_trans with (P m); [assumption | apply le_pred_l]. +Qed. + +Theorem le_pred_le : forall n m : N, n <= P m -> n <= m. +Proof. +intros n m H; apply le_trans with (P m); [assumption | apply le_pred_l]. +Qed. + +Theorem pred_le_mono : forall n m : N, 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. +intro; rewrite pred_0; apply le_0_l. +intros p q H1 _; now do 2 rewrite pred_succ. +Qed. + +Theorem pred_lt_mono : forall n m : N, n ~= 0 -> (n < m <-> P n < P m). +Proof. +intros n m H1; split; intro H2. +assert (m ~= 0). apply <- neq_0_lt_0. now apply lt_lt_0 with n. +now rewrite <- (succ_pred n) in H2; rewrite <- (succ_pred m) in H2 ; +[apply <- succ_lt_mono | | |]. +assert (m ~= 0). apply <- neq_0_lt_0. apply lt_lt_0 with (P n). +apply lt_le_trans with (P m). assumption. apply le_pred_l. +apply -> succ_lt_mono in H2. now do 2 rewrite succ_pred in H2. +Qed. + +Theorem lt_succ_lt_pred : forall n m : N, S n < m <-> n < P m. +Proof. +intros n m. rewrite pred_lt_mono by apply neq_succ_0. now rewrite pred_succ. +Qed. + +Theorem le_succ_le_pred : forall n m : N, S n <= m -> n <= P m. (* Converse is false for n == m == 0 *) +Proof. +intros n m H. apply lt_le_pred. now apply -> le_succ_l. +Qed. + +Theorem lt_pred_lt_succ : forall n m : N, P n < m -> n < S m. (* Converse is false for n == m == 0 *) +Proof. +intros n m H. apply <- lt_succ_r. now apply lt_pred_le. +Qed. + +Theorem le_pred_le_succ : forall n m : N, P n <= m <-> n <= S m. +Proof. +intros n m; cases n. +rewrite pred_0. split; intro H; apply le_0_l. +intro n. rewrite pred_succ. apply succ_le_mono. +Qed. + +End NOrderPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v new file mode 100644 index 00000000..031dbdea --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -0,0 +1,133 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NStrongRec.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +(** This file defined the strong (course-of-value, well-founded) recursion +and proves its properties *) + +Require Export NSub. + +Module NStrongRecPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NSubPropMod := NSubPropFunct NAxiomsMod. +Open Local Scope NatScope. + +Section StrongRecursion. + +Variable A : Set. +Variable Aeq : relation A. + +Notation Local "x ==A y" := (Aeq x y) (at level 70, no associativity). + +Hypothesis Aeq_equiv : equiv A Aeq. + +Add Relation A Aeq + reflexivity proved by (proj1 Aeq_equiv) + symmetry proved by (proj2 (proj2 Aeq_equiv)) + transitivity proved by (proj1 (proj2 Aeq_equiv)) +as Aeq_rel. + +Definition strong_rec (a : A) (f : N -> (N -> A) -> A) (n : N) : A := +recursion + (fun _ : N => a) + (fun (m : N) (p : N -> A) (k : N) => f k p) + (S n) + n. + +Theorem strong_rec_wd : +forall a a' : A, a ==A a' -> + forall f f', fun2_eq Neq (fun_eq Neq Aeq) Aeq f f' -> + forall n n', n == n' -> + strong_rec a f n ==A strong_rec a' f' n'. +Proof. +intros a a' Eaa' f f' Eff' n n' Enn'. +(* First we prove that recursion (which is on type N -> A) returns +extensionally equal functions, and then we use the fact that n == n' *) +assert (H : fun_eq Neq Aeq + (recursion + (fun _ : N => a) + (fun (m : N) (p : N -> A) (k : N) => f k p) + (S n)) + (recursion + (fun _ : N => a') + (fun (m : N) (p : N -> A) (k : N) => f' k p) + (S n'))). +apply recursion_wd with (Aeq := fun_eq Neq Aeq). +unfold fun_eq; now intros. +unfold fun2_eq. intros y y' Eyy' p p' Epp'. unfold fun_eq. auto. +now rewrite Enn'. +unfold strong_rec. +now apply H. +Qed. + +(*Section FixPoint. + +Variable a : A. +Variable f : N -> (N -> A) -> A. + +Hypothesis f_wd : fun2_wd Neq (fun_eq Neq Aeq) Aeq f. + +Let g (n : N) : A := strong_rec a f n. + +Add Morphism g with signature Neq ==> Aeq as g_wd. +Proof. +intros n1 n2 H. unfold g. now apply strong_rec_wd. +Qed. + +Theorem NtoA_eq_symm : symmetric (N -> A) (fun_eq Neq Aeq). +Proof. +apply fun_eq_symm. +exact (proj2 (proj2 NZeq_equiv)). +exact (proj2 (proj2 Aeq_equiv)). +Qed. + +Theorem NtoA_eq_trans : transitive (N -> A) (fun_eq Neq Aeq). +Proof. +apply fun_eq_trans. +exact (proj1 NZeq_equiv). +exact (proj1 (proj2 NZeq_equiv)). +exact (proj1 (proj2 Aeq_equiv)). +Qed. + +Add Relation (N -> A) (fun_eq Neq Aeq) + symmetry proved by NtoA_eq_symm + transitivity proved by NtoA_eq_trans +as NtoA_eq_rel. + +Add Morphism f with signature Neq ==> (fun_eq Neq Aeq) ==> Aeq as f_morph. +Proof. +apply f_wd. +Qed. + +(* We need an assumption saying that for every n, the step function (f n h) +calls h only on the segment [0 ... n - 1]. This means that if h1 and h2 +coincide on values < n, then (f n h1) coincides with (f n h2) *) + +Hypothesis step_good : + forall (n : N) (h1 h2 : N -> A), + (forall m : N, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f n h1) (f n h2). + +(* Todo: +Theorem strong_rec_fixpoint : forall n : N, Aeq (g n) (f n g). +Proof. +apply induction. +unfold predicate_wd, fun_wd. +intros x y H. rewrite H. unfold fun_eq; apply g_wd. +reflexivity. +unfold g, strong_rec. +*) + +End FixPoint.*) +End StrongRecursion. + +Implicit Arguments strong_rec [A]. + +End NStrongRecPropFunct. + diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v new file mode 100644 index 00000000..f67689dd --- /dev/null +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -0,0 +1,180 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NSub.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Export NMulOrder. + +Module NSubPropFunct (Import NAxiomsMod : NAxiomsSig). +Module Export NMulOrderPropMod := NMulOrderPropFunct NAxiomsMod. +Open Local Scope NatScope. + +Theorem sub_wd : + forall n1 n2 : N, n1 == n2 -> forall m1 m2 : N, m1 == m2 -> n1 - m1 == n2 - m2. +Proof NZsub_wd. + +Theorem sub_0_r : forall n : N, n - 0 == n. +Proof NZsub_0_r. + +Theorem sub_succ_r : forall n m : N, n - (S m) == P (n - m). +Proof NZsub_succ_r. + +Theorem sub_1_r : forall n : N, n - 1 == P n. +Proof. +intro n; rewrite sub_succ_r; now rewrite sub_0_r. +Qed. + +Theorem sub_0_l : forall n : N, 0 - n == 0. +Proof. +induct n. +apply sub_0_r. +intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. +Qed. + +Theorem sub_succ : forall n m : N, S n - S m == n - m. +Proof. +intro n; induct m. +rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. +intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. +Qed. + +Theorem sub_diag : forall n : N, n - n == 0. +Proof. +induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. +Qed. + +Theorem sub_gt : forall n m : N, n > m -> n - m ~= 0. +Proof. +intros n m H; elim H using lt_ind_rel; clear n m H. +solve_relation_wd. +intro; rewrite sub_0_r; apply neq_succ_0. +intros; now rewrite sub_succ. +Qed. + +Theorem add_sub_assoc : forall n m p : N, p <= m -> n + (m - p) == (n + m) - p. +Proof. +intros n m p; induct p. +intro; now do 2 rewrite sub_0_r. +intros p IH H. do 2 rewrite sub_succ_r. +rewrite <- IH by (apply lt_le_incl; now apply -> le_succ_l). +rewrite add_pred_r by (apply sub_gt; now apply -> le_succ_l). +reflexivity. +Qed. + +Theorem sub_succ_l : forall n m : N, n <= m -> S m - n == S (m - n). +Proof. +intros n m H. rewrite <- (add_1_l m). rewrite <- (add_1_l (m - n)). +symmetry; now apply add_sub_assoc. +Qed. + +Theorem add_sub : forall n m : N, (n + m) - m == n. +Proof. +intros n m. rewrite <- add_sub_assoc by (apply le_refl). +rewrite sub_diag; now rewrite add_0_r. +Qed. + +Theorem sub_add : forall n m : N, n <= m -> (m - n) + n == m. +Proof. +intros n m H. rewrite add_comm. rewrite add_sub_assoc by assumption. +rewrite add_comm. apply add_sub. +Qed. + +Theorem add_sub_eq_l : forall n m p : N, m + p == n -> n - m == p. +Proof. +intros n m p H. symmetry. +assert (H1 : m + p - m == n - m) by now rewrite H. +rewrite add_comm in H1. now rewrite add_sub in H1. +Qed. + +Theorem add_sub_eq_r : forall n m p : N, m + p == n -> n - p == m. +Proof. +intros n m p H; rewrite add_comm in H; now apply add_sub_eq_l. +Qed. + +(* This could be proved by adding m to both sides. Then the proof would +use add_sub_assoc and sub_0_le, which is proven below. *) + +Theorem add_sub_eq_nz : forall n m p : N, p ~= 0 -> n - m == p -> m + p == n. +Proof. +intros n m p H; double_induct n m. +intros m H1; rewrite sub_0_l in H1. symmetry in H1; false_hyp H1 H. +intro n; rewrite sub_0_r; now rewrite add_0_l. +intros n m IH H1. rewrite sub_succ in H1. apply IH in H1. +rewrite add_succ_l; now rewrite H1. +Qed. + +Theorem sub_add_distr : forall n m p : N, n - (m + p) == (n - m) - p. +Proof. +intros n m; induct p. +rewrite add_0_r; now rewrite sub_0_r. +intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. +Qed. + +Theorem add_sub_swap : forall n m p : N, p <= n -> n + m - p == n - p + m. +Proof. +intros n m p H. +rewrite (add_comm n m). +rewrite <- add_sub_assoc by assumption. +now rewrite (add_comm m (n - p)). +Qed. + +(** Sub and order *) + +Theorem le_sub_l : forall n m : N, n - m <= n. +Proof. +intro n; induct m. +rewrite sub_0_r; now apply eq_le_incl. +intros m IH. rewrite sub_succ_r. +apply le_trans with (n - m); [apply le_pred_l | assumption]. +Qed. + +Theorem sub_0_le : forall n m : N, n - m == 0 <-> n <= m. +Proof. +double_induct n m. +intro m; split; intro; [apply le_0_l | apply sub_0_l]. +intro m; rewrite sub_0_r; split; intro H; +[false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. +intros n m H. rewrite <- succ_le_mono. now rewrite sub_succ. +Qed. + +(** Sub and mul *) + +Theorem mul_pred_r : forall n m : N, n * (P m) == n * m - n. +Proof. +intros n m; cases m. +now rewrite pred_0, mul_0_r, sub_0_l. +intro m; rewrite pred_succ, mul_succ_r, <- add_sub_assoc. +now rewrite sub_diag, add_0_r. +now apply eq_le_incl. +Qed. + +Theorem mul_sub_distr_r : forall n m p : N, (n - m) * p == n * p - m * p. +Proof. +intros n m p; induct n. +now rewrite sub_0_l, mul_0_l, sub_0_l. +intros n IH. destruct (le_gt_cases m n) as [H | H]. +rewrite sub_succ_l by assumption. do 2 rewrite mul_succ_l. +rewrite (add_comm ((n - m) * p) p), (add_comm (n * p) p). +rewrite <- (add_sub_assoc p (n * p) (m * p)) by now apply mul_le_mono_r. +now apply <- add_cancel_l. +assert (H1 : S n <= m); [now apply <- le_succ_l |]. +setoid_replace (S n - m) with 0 by now apply <- sub_0_le. +setoid_replace ((S n * p) - m * p) with 0 by (apply <- sub_0_le; now apply mul_le_mono_r). +apply mul_0_l. +Qed. + +Theorem mul_sub_distr_l : forall n m p : N, p * (n - m) == p * n - p * m. +Proof. +intros n m p; rewrite (mul_comm p (n - m)), (mul_comm p n), (mul_comm p m). +apply mul_sub_distr_r. +Qed. + +End NSubPropFunct. + diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v new file mode 100644 index 00000000..0574c09f --- /dev/null +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -0,0 +1,83 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: BigN.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +(** * Natural numbers in base 2^31 *) + +(** +Author: Arnaud Spiwack +*) + +Require Export Int31. +Require Import CyclicAxioms. +Require Import Cyclic31. +Require Import NSig. +Require Import NSigNAxioms. +Require Import NMake. +Require Import NSub. + +Module BigN <: NType := NMake.Make Int31Cyclic. + +(** Module [BigN] implements [NAxiomsSig] *) + +Module Export BigNAxiomsMod := NSig_NAxioms BigN. +Module Export BigNSubPropMod := NSubPropFunct BigNAxiomsMod. + +(** 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_. + +Notation Local "0" := BigN.zero : 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.compare : bigN_scope. +Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope. +Infix "<" := BigN.lt : bigN_scope. +Infix "<=" := BigN.le : bigN_scope. +Notation "[ i ]" := (BigN.to_Z i) : bigN_scope. + +Open Scope bigN_scope. + +(** Example of reasoning about [BigN] *) + +Theorem succ_pred: forall q:bigN, + 0 < q -> BigN.succ (BigN.pred q) == q. +Proof. +intros; apply succ_pred. +intro H'; rewrite H' in H; discriminate. +Qed. + +(** [BigN] is a semi-ring *) + +Lemma BigNring : + semi_ring_theory BigN.zero BigN.one BigN.add BigN.mul BigN.eq. +Proof. +constructor. +exact add_0_l. +exact add_comm. +exact add_assoc. +exact mul_1_l. +exact mul_0_l. +exact mul_comm. +exact mul_assoc. +exact mul_add_distr_r. +Qed. + +Add Ring BigNr : BigNring. + +(** Todo: tactic translating from [BigN] to [Z] + omega *) + +(** Todo: micromega *) diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml new file mode 100644 index 00000000..bd0fb5b1 --- /dev/null +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -0,0 +1,3166 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NMake_gen.ml 11136 2008-06-18 10:41:34Z herbelin $ i*) + +(*S NMake_gen.ml : this file generates NMake.v *) + + +(*s The two parameters 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) ^ ")" + +(* 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 *) + +(* 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 + + +(*s The actual printing *) + +let _ = + + pr "(************************************************************************)"; + pr "(* v * The Coq Proof Assistant / The Coq Development Team *)"; + pr "(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)"; + 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."; + pr "Require Import ZArith."; + pr "Require Import CyclicAxioms."; + pr "Require Import DoubleType."; + pr "Require Import DoubleMul."; + pr "Require Import DoubleDivn1."; + pr "Require Import DoubleCyclic."; + pr "Require Import Nbasic."; + pr "Require Import Wf_nat."; + pr "Require Import StreamMemo."; + pr "Require Import NSig."; + pr ""; + pr "Module Make (Import W0:CyclicType) <: NType."; + pr ""; + + pr " Definition w0 := W0.w."; + for i = 1 to size do + pr " Definition w%i := zn2z w%i." i (i-1) + done; + pr ""; + + 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 ""; + + pr " Section Make_op."; + pr " Variable mk : forall w', znz_op w' -> znz_op (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 " | O => w%i_op" (size+1); + pr " | S n1 =>"; + pr " match n1 return znz_op (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 " | O => w%i_op" (size+3); + pr " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))"; + pr " end"; + pr " end"; + pr " end."; + pr ""; + pr " End Make_op."; + pr ""; + pr " Definition omake_op := make_op_aux mk_zn2z_op_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 ""; + + 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 ""; + + for i = 0 to size do + pr " Definition one%i := w%i_op.(znz_1)." i i + done; + pr ""; + + + pr " Definition zero := %s0 w_0." c; + pr " Definition one := %s0 one0." c; + pr ""; + + pr " Definition to_Z x :="; + pr " match x with"; + for i = 0 to size do + pr " | %s%i wx => w%i_op.(znz_to_Z) wx" c i i + done; + pr " | %sn n wx => (make_op n).(znz_to_Z) wx" c; + pr " end."; + pr ""; + + pr " Open Scope Z_scope."; + pr " Notation \"[ x ]\" := (to_Z x)."; + pr ""; + + pr " Definition to_N x := Zabs_N (to_Z x)."; + 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 ""; + + + 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 ""; + + + 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 ""; + + 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 " Hint Rewrite spec_extendn_0: extr."; + 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 " Hint Rewrite spec_extendn_0: extr."; + 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 " Hint Rewrite spec_extend_tr: extr."; + 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 " Hint Rewrite spec_cast_l: extr."; + 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 " Hint Rewrite spec_cast_r: extr."; + 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 ""; + + + 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"; + 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); + 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 ""; + + 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 ""; + + 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."; + 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; + 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 ["; + 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"; + 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 " end."; + pr ""; + + pp " Ltac zg_tac := try"; + pp " (red; simpl Zcompare; auto;"; + pp " let t := fresh \"H\" in (intros t; discriminate t))."; + 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"; + 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); + done; + pr " | %sn m wy => fnm n m wx wy" c; + pr " end"; + 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 " (***************************************************************)"; + 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 " 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 " Hint Rewrite spec_w%i_add: addr." i; + 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."; + pp " Hint Rewrite spec_wn_add: addr."; + + 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: 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: 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 => opp_compare (comparen_%i (S n) y x))" i; + pr " (fun n => comparen_%i (S n))" i; + done; + pr " comparenm)."; + pr ""; + + pr " Definition lt n m := compare n m = Lt."; + pr " Definition le n m := compare n m <> Gt."; + pr " Definition min n m := match compare n m with Gt => m | _ => n end."; + pr " Definition max n m := match compare n m with Lt => m | _ => n end."; + 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 opp_compare c with Eq => v = u | Lt => v < u | Gt => v > u end."; + pp " Proof."; + pp " intros c u v; case c; unfold opp_compare; auto with zarith."; + pp " Qed."; + pp ""; + + + pr " Theorem spec_compare: 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 => opp_compare (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 " Definition eq_bool x y :="; + pr " match compare x y with"; + pr " | Eq => true"; + pr " | _ => false"; + pr " end."; + pr ""; + + + pr " Theorem spec_eq_bool: forall x y,"; + pr " if eq_bool x y then [x] = [y] else [x] <> [y]."; + pa " Admitted."; + pp " Proof."; + pp " intros x y; unfold eq_bool."; + pp " generalize (spec_compare x y); case compare; auto with zarith."; + 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 " 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 " (* Power *)"; + pr " (* *)"; + pr " (***************************************************************)"; + pr ""; + + pr " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=" t t; + pr " match p with"; + pr " | xH => x"; + pr " | xO p => square (power_pos x p)"; + pr " | xI p => mul (square (power_pos x p)) x"; + pr " end."; + pr ""; + + pr " Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n."; + pa " Admitted."; + pp " Proof."; + pp " intros x n; generalize x; elim n; clear n x; simpl power_pos."; + pp " intros; rewrite spec_mul; rewrite spec_square; rewrite H."; + pp " rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith."; + pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith."; + pp " rewrite Zpower_2; rewrite Zpower_1_r; auto."; + pp " intros; rewrite spec_square; rewrite H."; + pp " rewrite Zpos_xO; auto with zarith."; + pp " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith."; + pp " rewrite Zpower_2; auto."; + pp " intros; rewrite Zpower_1_r; auto."; + pp " Qed."; + pp ""; + 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 " Definition div_eucl x y :="; + pr " match compare x y with"; + pr " | Eq => (one, zero)"; + pr " | Lt => (zero, x)"; + pr " | Gt => div_gt x y"; + pr " end."; + pr ""; + + pr " Theorem spec_div_eucl: forall x y,"; + pr " 0 < [y] ->"; + pr " let (q,r) := div_eucl x y in"; + pr " ([q], [r]) = Zdiv_eucl [x] [y]."; + pa " Admitted."; + pp " Proof."; + pp " assert (F0: [zero] = 0)."; + pp " exact (spec_0 w0_spec)."; + pp " assert (F1: [one] = 1)."; + pp " exact (spec_1 w0_spec)."; + pp " intros x y H; generalize (spec_compare x y);"; + pp " unfold div_eucl; case compare; try rewrite F0;"; + pp " try rewrite F1; intros; auto with zarith."; + pp " rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))"; + pp " (Z_mod_same [y] (Zlt_gt _ _ H));"; + pp " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto."; + pp " assert (F2: 0 <= [x] < [y])."; + pp " generalize (spec_pos x); auto."; + pp " generalize (Zdiv_small _ _ F2)"; + pp " (Zmod_small _ _ F2);"; + pp " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto."; + pp " generalize (spec_div_gt _ _ H0 H); auto."; + pp " unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt."; + pp " intros a b c d (H1, H2); subst; auto."; + pp " Qed."; + pr ""; + + pr " Definition div x y := fst (div_eucl x y)."; + pr ""; + + pr " Theorem spec_div:"; + pr " forall x y, 0 < [y] -> [div x y] = [x] / [y]."; + pa " Admitted."; + pp " Proof."; + pp " intros x y H1; unfold div; generalize (spec_div_eucl x y H1);"; + pp " case div_eucl; simpl fst."; + pp " intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; "; + pp " injection H; 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 " Definition modulo x y := "; + pr " match compare x y with"; + pr " | Eq => zero"; + pr " | Lt => x"; + pr " | Gt => mod_gt x y"; + pr " end."; + pr ""; + + pr " Theorem spec_modulo:"; + pr " forall x y, 0 < [y] -> [modulo x y] = [x] mod [y]."; + pa " Admitted."; + pp " Proof."; + pp " assert (F0: [zero] = 0)."; + pp " exact (spec_0 w0_spec)."; + pp " assert (F1: [one] = 1)."; + pp " exact (spec_1 w0_spec)."; + pp " intros x y H; generalize (spec_compare x y);"; + pp " unfold modulo; case compare; try rewrite F0;"; + pp " try rewrite F1; intros; try split; auto with zarith."; + pp " rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith."; + pp " apply sym_equal; apply Zmod_small; auto with zarith."; + pp " generalize (spec_pos x); auto with zarith."; + pp " apply spec_mod_gt; auto."; + pp " Qed."; + pr ""; + + pr " (***************************************************************)"; + pr " (* *)"; + pr " (* Gcd *)"; + pr " (* *)"; + pr " (***************************************************************)"; + 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 " Definition gcd_gt_body a b cont :="; + pr " match compare b zero with"; + pr " | Gt =>"; + pr " let r := mod_gt a b in"; + pr " match compare r zero with"; + pr " | Gt => cont r (mod_gt b r)"; + pr " | _ => b"; + pr " end"; + pr " | _ => a"; + pr " end."; + pr ""; + + pp " Theorem Zspec_gcd_gt_body: forall a b cont p,"; + pp " [a] > [b] -> [a] < 2 ^ p ->"; + pp " (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] ->"; + pp " Zis_gcd [a1] [b1] [cont a1 b1]) -> "; + pp " Zis_gcd [a] [b] [gcd_gt_body a b cont]."; + pp " Proof."; + pp " assert (F1: [zero] = 0)."; + pp " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto."; + pp " intros a b cont p H2 H3 H4; unfold gcd_gt_body."; + pp " generalize (spec_compare b zero); case compare; try rewrite F1."; + pp " intros HH; rewrite HH; apply Zis_gcd_0."; + pp " intros HH; absurd (0 <= [b]); auto with zarith."; + pp " case (spec_digits b); auto with zarith."; + pp " intros H5; generalize (spec_compare (mod_gt a b) zero); "; + pp " case compare; try rewrite F1."; + pp " intros H6; rewrite <- (Zmult_1_r [b])."; + pp " rewrite (Z_div_mod_eq [a] [b]); auto with zarith."; + pp " rewrite <- spec_mod_gt; auto with zarith."; + pp " rewrite H6; rewrite Zplus_0_r."; + pp " apply Zis_gcd_mult; apply Zis_gcd_1."; + pp " intros; apply False_ind."; + pp " case (spec_digits (mod_gt a b)); auto with zarith."; + pp " intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith."; + pp " apply DoubleDiv.Zis_gcd_mod; auto with zarith."; + pp " rewrite <- spec_mod_gt; auto with zarith."; + pp " assert (F2: [b] > [mod_gt a b])."; + pp " case (Z_mod_lt [a] [b]); auto with zarith."; + pp " repeat rewrite <- spec_mod_gt; auto with zarith."; + pp " assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)])."; + pp " case (Z_mod_lt [b] [mod_gt a b]); auto with zarith."; + pp " rewrite <- spec_mod_gt; auto with zarith."; + pp " repeat rewrite <- spec_mod_gt; auto with zarith."; + pp " apply H4; auto with zarith."; + pp " apply Zmult_lt_reg_r with 2; auto with zarith."; + pp " apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith."; + pp " apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith."; + pp " apply Zplus_le_compat_r."; + pp " pattern [b] at 1; rewrite <- (Zmult_1_l [b])."; + pp " apply Zmult_le_compat_r; auto with zarith."; + pp " case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith."; + pp " intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;"; + pp " try rewrite <- HH in H2; auto with zarith."; + pp " case (Z_mod_lt [a] [b]); auto with zarith."; + pp " rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith."; + pp " rewrite <- Z_div_mod_eq; auto with zarith."; + pp " pattern 2 at 2; rewrite <- (Zpower_1_r 2)."; + pp " rewrite <- Zpower_exp; auto with zarith."; + pp " ring_simplify (p - 1 + 1); auto."; + pp " case (Zle_lt_or_eq 0 p); auto with zarith."; + pp " generalize H3; case p; simpl Zpower; auto with zarith."; + pp " intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith."; + pp " Qed."; + pp ""; + + pr " Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :="; + pr " gcd_gt_body a b"; + pr " (fun a b =>"; + pr " match p with"; + pr " | xH => cont a b"; + pr " | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b"; + pr " | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b"; + pr " end)."; + pr ""; + + pp " Theorem Zspec_gcd_gt_aux: forall p n a b cont,"; + pp " [a] > [b] -> [a] < 2 ^ (Zpos p + n) ->"; + pp " (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] ->"; + pp " Zis_gcd [a1] [b1] [cont a1 b1]) ->"; + pp " Zis_gcd [a] [b] [gcd_gt_aux p cont a b]."; + pp " intros p; elim p; clear p."; + pp " intros p Hrec n a b cont H2 H3 H4."; + pp " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto."; + pp " intros a1 b1 H6 H7."; + pp " apply Hrec with (Zpos p + n); auto."; + pp " replace (Zpos p + (Zpos p + n)) with"; + pp " (Zpos (xI p) + n - 1); auto."; + pp " rewrite Zpos_xI; ring."; + pp " intros a2 b2 H9 H10."; + pp " apply Hrec with n; auto."; + pp " intros p Hrec n a b cont H2 H3 H4."; + pp " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto."; + pp " intros a1 b1 H6 H7."; + pp " apply Hrec with (Zpos p + n - 1); auto."; + pp " replace (Zpos p + (Zpos p + n - 1)) with"; + pp " (Zpos (xO p) + n - 1); auto."; + pp " rewrite Zpos_xO; ring."; + pp " intros a2 b2 H9 H10."; + pp " apply Hrec with (n - 1); auto."; + pp " replace (Zpos p + (n - 1)) with"; + pp " (Zpos p + n - 1); auto with zarith."; + pp " intros a3 b3 H12 H13; apply H4; auto with zarith."; + pp " apply Zlt_le_trans with (1 := H12)."; + pp " case (Zle_or_lt 1 n); intros HH."; + pp " apply Zpower_le_monotone; auto with zarith."; + pp " apply Zle_trans with 0; auto with zarith."; + pp " assert (HH1: n - 1 < 0); auto with zarith."; + pp " generalize HH1; case (n - 1); auto with zarith."; + pp " intros p1 HH2; discriminate."; + pp " intros n a b cont H H2 H3."; + pp " simpl gcd_gt_aux."; + pp " apply Zspec_gcd_gt_body with (n + 1); auto with zarith."; + pp " rewrite Zplus_comm; auto."; + pp " intros a1 b1 H5 H6; apply H3; auto."; + pp " replace n with (n + 1 - 1); auto; try ring."; + pp " Qed."; + pp ""; + + pr " Definition gcd_cont a b :="; + pr " match compare one b with"; + pr " | Eq => one"; + pr " | _ => a"; + pr " end."; + pr ""; + + pr " Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b."; + pr ""; + + pr " Theorem spec_gcd_gt: forall a b,"; + pr " [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b]."; + pa " Admitted."; + pp " Proof."; + pp " intros a b H2."; + pp " case (spec_digits (gcd_gt a b)); intros H3 H4."; + pp " case (spec_digits a); intros H5 H6."; + pp " apply sym_equal; apply Zis_gcd_gcd; auto with zarith."; + pp " unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith."; + pp " intros a1 a2; rewrite Zpower_0_r."; + pp " case (spec_digits a2); intros H7 H8;"; + pp " intros; apply False_ind; auto with zarith."; + pp " Qed."; + pr ""; + + pr " Definition gcd a b :="; + pr " match compare a b with"; + pr " | Eq => a"; + pr " | Lt => gcd_gt b a"; + pr " | Gt => gcd_gt a b"; + pr " end."; + pr ""; + + pr " Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]."; + pa " Admitted."; + pp " Proof."; + pp " intros a b."; + pp " case (spec_digits a); intros H1 H2."; + pp " case (spec_digits b); intros H3 H4."; + pp " unfold gcd; generalize (spec_compare a b); case compare."; + pp " intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto."; + pp " apply Zis_gcd_refl."; + pp " intros; apply trans_equal with (Zgcd [b] [a])."; + pp " apply spec_gcd_gt; auto with zarith."; + pp " apply Zis_gcd_gcd; auto with zarith."; + pp " apply Zgcd_is_pos."; + pp " apply Zis_gcd_sym; apply Zgcd_is_gcd."; + pp " intros; apply spec_gcd_gt; auto."; + 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 " Definition of_N x :="; + pr " match x with"; + pr " | BinNat.N0 => zero"; + pr " | Npos p => of_pos p"; + pr " end."; + pr ""; + + pr " Theorem spec_of_N: forall x,"; + pr " [of_N x] = Z_of_N x."; + pa " Admitted."; + pp " Proof."; + pp " intros x; case x."; + pp " simpl of_N."; + pp " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto."; + pp " intros p; exact (spec_of_pos p)."; + 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 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 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 shiftr := Eval lazy beta delta [same_level] in "; + pr " same_level _ (fun n x => %s0 (shiftr0 n x))" c; + for i = 1 to size do + pr " (fun n x => reduce_%i (shiftr%i n x))" i i; + done; + pr " (fun n p x => reduce_n n (shiftrn n p x))."; + pr ""; + + + pr " Theorem spec_shiftr: forall n x,"; + pr " [n] <= [Ndigits x] -> [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 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 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 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 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 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 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 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 ""; + + pr " Definition safe_shiftr n x := "; + pr " match compare n (Ndigits x) with"; + pr " | Lt => shiftr n x "; + pr " | _ => %s0 w_0" c; + pr " end."; + pr ""; + + + pr " Theorem spec_safe_shiftr: forall n x,"; + pr " [safe_shiftr n x] = [x] / 2 ^ [n]."; + pa " Admitted."; + pp " Proof."; + pp " intros n x; unfold safe_shiftr;"; + pp " generalize (spec_compare n (Ndigits x)); case compare; intros H."; + pp " apply trans_equal with (1 := spec_0 w0_spec)."; + pp " apply sym_equal; apply Zdiv_small; rewrite H."; + pp " rewrite spec_Ndigits; exact (spec_digits x)."; + pp " rewrite <- spec_shiftr; auto with zarith."; + pp " apply trans_equal with (1 := spec_0 w0_spec)."; + pp " apply sym_equal; apply Zdiv_small."; + pp " rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2."; + pp " split; auto."; + pp " apply Zlt_le_trans with (1 := H2)."; + pp " apply Zpower_le_monotone; auto with zarith."; + pp " Qed."; + pr ""; + + pr ""; + + (* Shiftl *) + for i = 0 to size do + pr " Definition shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0)." i i i + done; + pr " Definition shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0)."; + pr " Definition shiftl := Eval lazy beta delta [same_level] in"; + pr " same_level _ (fun n x => %s0 (shiftl0 n x))" c; + for i = 1 to size do + pr " (fun n x => reduce_%i (shiftl%i n x))" i i; + done; + pr " (fun n p x => reduce_n n (shiftln n p x))."; + pr ""; + pr ""; + + + pr " Theorem spec_shiftl: forall n x,"; + pr " [n] <= [head0 x] -> [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 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 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 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 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 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 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 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 ""; + + + (* Safe shiftl *) + + pr " Definition safe_shiftl_aux_body cont n x :="; + pr " match compare n (head0 x) with"; + pr " Gt => cont n (double_size x)"; + pr " | _ => shiftl n x"; + pr " end."; + pr ""; + + pr " Theorem spec_safe_shift_aux_body: forall n p x cont,"; + pr " 2^ Zpos p <= [head0 x] ->"; + pr " (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->"; + pr " [cont n x] = [x] * 2 ^ [n]) ->"; + pr " [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n]."; + pa " Admitted."; + pp " Proof."; + pp " intros n p x cont H1 H2; unfold safe_shiftl_aux_body."; + pp " generalize (spec_compare n (head0 x)); case compare; intros H."; + pp " apply spec_shiftl; auto with zarith."; + pp " apply spec_shiftl; auto with zarith."; + pp " rewrite H2."; + pp " rewrite spec_double_size; auto."; + pp " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith."; + pp " apply Zle_trans with (2 := spec_double_size_head0 x)."; + pp " rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith."; + pp " Qed."; + pr ""; + + pr " Fixpoint safe_shiftl_aux p cont n x {struct p} :="; + pr " safe_shiftl_aux_body "; + pr " (fun n x => match p with"; + pr " | xH => cont n x"; + pr " | xO p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x"; + pr " | xI p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x"; + pr " end) n x."; + pr ""; + + pr " Theorem spec_safe_shift_aux: forall p q n x cont,"; + pr " 2 ^ (Zpos q) <= [head0 x] ->"; + pr " (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] ->"; + pr " [cont n x] = [x] * 2 ^ [n]) -> "; + pr " [safe_shiftl_aux p cont n x] = [x] * 2 ^ [n]."; + pa " Admitted."; + pp " Proof."; + pp " intros p; elim p; unfold safe_shiftl_aux; fold safe_shiftl_aux; clear p."; + pp " intros p Hrec q n x cont H1 H2."; + pp " apply spec_safe_shift_aux_body with (q); auto."; + pp " intros x1 H3; apply Hrec with (q + 1)%spositive; auto." "%"; + pp " intros x2 H4; apply Hrec with (p + q + 1)%spositive; auto." "%"; + pp " rewrite <- Pplus_assoc."; + pp " rewrite Zpos_plus_distr; auto."; + pp " intros x3 H5; apply H2."; + pp " rewrite Zpos_xI."; + pp " replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));"; + pp " auto."; + pp " repeat rewrite Zpos_plus_distr; ring."; + pp " intros p Hrec q n x cont H1 H2."; + pp " apply spec_safe_shift_aux_body with (q); auto."; + pp " intros x1 H3; apply Hrec with (q); auto."; + pp " apply Zle_trans with (2 := H3); auto with zarith."; + pp " apply Zpower_le_monotone; auto with zarith."; + pp " intros x2 H4; apply Hrec with (p + q)%spositive; auto." "%"; + pp " intros x3 H5; apply H2."; + pp " rewrite (Zpos_xO p)."; + pp " replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));"; + pp " auto."; + pp " repeat rewrite Zpos_plus_distr; ring."; + pp " intros q n x cont H1 H2."; + pp " apply spec_safe_shift_aux_body with (q); auto."; + pp " rewrite Zplus_comm; auto."; + pp " Qed."; + pr ""; + + + pr " Definition safe_shiftl n x :="; + pr " safe_shiftl_aux_body"; + pr " (safe_shiftl_aux_body"; + pr " (safe_shiftl_aux (digits n) shiftl)) n x."; + pr ""; + + pr " Theorem spec_safe_shift: forall n x,"; + pr " [safe_shiftl n x] = [x] * 2 ^ [n]."; + pa " Admitted."; + pp " Proof."; + pp " intros n x; unfold safe_shiftl, safe_shiftl_aux_body."; + pp " generalize (spec_compare n (head0 x)); case compare; intros H."; + pp " apply spec_shiftl; auto with zarith."; + pp " apply spec_shiftl; auto with zarith."; + pp " rewrite <- (spec_double_size x)."; + pp " generalize (spec_compare n (head0 (double_size x))); case compare; intros H1."; + pp " apply spec_shiftl; auto with zarith."; + pp " apply spec_shiftl; auto with zarith."; + pp " rewrite <- (spec_double_size (double_size x))."; + pp " apply spec_safe_shift_aux with 1%spositive." "%"; + pp " apply Zle_trans with (2 := spec_double_size_head0 (double_size x))."; + pp " replace (2 ^ 1) with (2 * 1)."; + pp " apply Zmult_le_compat_l; auto with zarith."; + pp " generalize (spec_double_size_head0_pos x); auto with zarith."; + pp " rewrite Zpower_1_r; ring."; + pp " intros x1 H2; apply spec_shiftl."; + pp " apply Zle_trans with (2 := H2)."; + pp " apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith."; + pp " case (spec_digits n); auto with zarith."; + pp " apply Zpower_le_monotone; 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 " Theorem spec_0: [zero] = 0."; + pa " Admitted."; + pp " Proof."; + pp " exact (spec_0 w0_spec)."; + pp " Qed."; + pr ""; + + pr " Theorem spec_1: [one] = 1."; + pa " Admitted."; + pp " Proof."; + pp " exact (spec_1 w0_spec)."; + pp " Qed."; + pr ""; + + pr "End Make."; + pr ""; + diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v new file mode 100644 index 00000000..ae2cfd30 --- /dev/null +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -0,0 +1,514 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: Nbasic.v 10964 2008-05-22 11:08:13Z letouzey $ i*) + +Require Import ZArith. +Require Import BigNumPrelude. +Require Import Max. +Require Import DoubleType. +Require Import DoubleBase. +Require Import CyclicAxioms. +Require Import DoubleCyclic. + +(* To compute the necessary height *) + +Fixpoint plength (p: positive) : positive := + match p with + xH => xH + | xO p1 => Psucc (plength p1) + | xI p1 => Psucc (plength p1) + end. + +Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z. +assert (F: (forall p, 2 ^ (Zpos (Psucc p)) = 2 * 2 ^ Zpos p)%Z). +intros p; replace (Zpos (Psucc p)) with (1 + Zpos p)%Z. +rewrite Zpower_exp; auto with zarith. +rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith. +intros p; elim p; simpl plength; auto. +intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI. +assert (tmp: (forall p, 2 * p = p + p)%Z); + try repeat rewrite tmp; auto with zarith. +intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1). +assert (tmp: (forall p, 2 * p = p + p)%Z); + try repeat rewrite tmp; auto with zarith. +rewrite Zpower_1_r; auto with zarith. +Qed. + +Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Ppred p)))%Z. +intros p; case (Psucc_pred p); intros H1. +subst; simpl plength. +rewrite Zpower_1_r; auto with zarith. +pattern p at 1; rewrite <- H1. +rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith. +generalize (plength_correct (Ppred p)); auto with zarith. +Qed. + +Definition Pdiv p q := + match Zdiv (Zpos p) (Zpos q) with + Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with + Z0 => q1 + | _ => (Psucc q1) + end + | _ => xH + end. + +Theorem Pdiv_le: forall p q, + Zpos p <= Zpos q * Zpos (Pdiv p q). +intros p q. +unfold Pdiv. +assert (H1: Zpos q > 0); auto with zarith. +assert (H1b: Zpos p >= 0); auto with zarith. +generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b). +generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Zdiv. + intros HH _; rewrite HH; rewrite Zmult_0_r; rewrite Zmult_1_r; simpl. +case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith. +intros q1 H2. +replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q). + 2: pattern (Zpos p) at 2; rewrite H2; auto with zarith. +generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; + case Zmod. + intros HH _; rewrite HH; auto with zarith. + intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism. + unfold Zsucc; rewrite Zmult_plus_distr_r; auto with zarith. + intros r1 _ (HH,_); case HH; auto. +intros q1 HH; rewrite HH. +unfold Zge; simpl Zcompare; intros HH1; case HH1; auto. +Qed. + +Definition is_one p := match p with xH => true | _ => false end. + +Theorem is_one_one: forall p, is_one p = true -> p = xH. +intros p; case p; auto; intros p1 H1; discriminate H1. +Qed. + +Definition get_height digits p := + let r := Pdiv p digits in + if is_one r then xH else Psucc (plength (Ppred r)). + +Theorem get_height_correct: + forall digits N, + Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)). +intros digits N. +unfold get_height. +assert (H1 := Pdiv_le N digits). +case_eq (is_one (Pdiv N digits)); intros H2. +rewrite (is_one_one _ H2) in H1. +rewrite Zmult_1_r in H1. +change (2^(1-1))%Z with 1; rewrite Zmult_1_r; auto. +clear H2. +apply Zle_trans with (1 := H1). +apply Zmult_le_compat_l; auto with zarith. +rewrite Zpos_succ_morphism; unfold Zsucc. +rewrite Zplus_comm; rewrite Zminus_plus. +apply plength_pred_correct. +Qed. + +Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. + fix zn2z_word_comm 2. + intros w n; case n. + reflexivity. + intros n0;simpl. + case (zn2z_word_comm w n0). + reflexivity. +Defined. + +Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) := + match n return forall w:Type, zn2z w -> word w (S n) with + | O => fun w x => x + | S m => + let aux := extend m in + fun w x => WW W0 (aux w x) + end. + +Section ExtendMax. + +Open Scope nat_scope. + +Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat := + match n return (n + S m = S (n + m))%nat with + | 0 => refl_equal (S m) + | S n1 => + let v := S (S n1 + m) in + eq_ind_r (fun n => S n = v) (refl_equal v) (plusnS n1 m) + end. + +Fixpoint plusn0 n : n + 0 = n := + match n return (n + 0 = n) with + | 0 => refl_equal 0 + | S n1 => + let v := S n1 in + eq_ind_r (fun n : nat => S n = v) (refl_equal v) (plusn0 n1) + end. + + Fixpoint diff (m n: nat) {struct m}: nat * nat := + match m, n with + O, n => (O, n) + | m, O => (m, O) + | S m1, S n1 => diff m1 n1 + end. + +Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n := + match m return fst (diff m n) + n = max m n with + | 0 => + match n return (n = max 0 n) with + | 0 => refl_equal _ + | S n0 => refl_equal _ + end + | S m1 => + match n return (fst (diff (S m1) n) + n = max (S m1) n) + with + | 0 => plusn0 _ + | S n1 => + let v := fst (diff m1 n1) + n1 in + let v1 := fst (diff m1 n1) + S n1 in + eq_ind v (fun n => v1 = S n) + (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _)) + _ (diff_l _ _) + end + end. + +Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n := + match m return (snd (diff m n) + m = max m n) with + | 0 => + match n return (snd (diff 0 n) + 0 = max 0 n) with + | 0 => refl_equal _ + | S _ => plusn0 _ + end + | S m => + match n return (snd (diff (S m) n) + S m = max (S m) n) with + | 0 => refl_equal (snd (diff (S m) 0) + S m) + | S n1 => + let v := S (max m n1) in + eq_ind_r (fun n => n = v) + (eq_ind_r (fun n => S n = v) + (refl_equal v) (diff_r _ _)) (plusnS _ _) + end + end. + + Variable w: Type. + + Definition castm (m n: nat) (H: m = n) (x: word w (S m)): + (word w (S n)) := + match H in (_ = y) return (word w (S y)) with + | refl_equal => x + end. + +Variable m: nat. +Variable v: (word w (S m)). + +Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) := + match n return (word w (S (n + m))) with + | O => v + | S n1 => WW W0 (extend_tr n1) + end. + +End ExtendMax. + +Implicit Arguments extend_tr[w m]. +Implicit Arguments castm[w m n]. + + + +Section Reduce. + + Variable w : Type. + Variable nT : Type. + Variable N0 : nT. + Variable eq0 : w -> bool. + Variable reduce_n : w -> nT. + Variable zn2z_to_Nt : zn2z w -> nT. + + Definition reduce_n1 (x:zn2z w) := + match x with + | W0 => N0 + | WW xh xl => + if eq0 xh then reduce_n xl + else zn2z_to_Nt x + end. + +End Reduce. + +Section ReduceRec. + + Variable w : Type. + Variable nT : Type. + Variable N0 : nT. + Variable reduce_1n : zn2z w -> nT. + Variable c : forall n, word w (S n) -> nT. + + Fixpoint reduce_n (n:nat) : word w (S n) -> nT := + match n return word w (S n) -> nT with + | O => reduce_1n + | S m => fun x => + match x with + | W0 => N0 + | WW xh xl => + match xh with + | W0 => @reduce_n m xl + | _ => @c (S m) x + end + end + end. + +End ReduceRec. + +Definition opp_compare cmp := + match cmp with + | Lt => Gt + | Eq => Eq + | Gt => Lt + end. + +Section CompareRec. + + Variable wm w : Type. + Variable w_0 : w. + Variable compare : w -> w -> comparison. + Variable compare0_m : wm -> comparison. + Variable compare_m : wm -> w -> comparison. + + Fixpoint compare0_mn (n:nat) : word wm n -> comparison := + match n return word wm n -> comparison with + | O => compare0_m + | S m => fun x => + match x with + | W0 => Eq + | WW xh xl => + match compare0_mn m xh with + | Eq => compare0_mn m xl + | r => Lt + end + end + end. + + Variable wm_base: positive. + Variable wm_to_Z: wm -> Z. + 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. + 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. + Let double_wB := double_wB wm_base. + + Lemma base_xO: forall n, base (xO n) = (base n)^2. + Proof. + intros n1; unfold base. + rewrite (Zpos_xO n1); rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith. + Qed. + + Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n := + (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos). + + + 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. + intros n; elim n; clear n; auto. + intros x; generalize (spec_compare0_m x); rewrite w_to_Z_0; auto. + intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto. + 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. + 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. + Qed. + + Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := + match n return word wm n -> w -> comparison with + | O => compare_m + | S m => fun x y => + match x with + | W0 => compare w_0 y + | WW xh xl => + match compare0_mn m xh with + | Eq => compare_mn_1 m xl y + | r => Gt + end + end + 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. + 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. + Variable wm_base_lt: forall x, + 0 <= w_to_Z x < base (wm_base). + + Let double_wB_lt: forall n x, + 0 <= w_to_Z x < (double_wB n). + Proof. + intros n x; elim n; simpl; auto; clear n. + 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)). + assert (0 < u). + unfold u, base; auto with zarith. + replace (u^2) with (u * u); simpl; auto with zarith. + apply Zle_trans with (1 * u); auto with zarith. + unfold Zpower_pos; simpl; ring. + Qed. + + + 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. + 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. + rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto. + apply Hrec. + 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. + Qed. + +End CompareRec. + + +Section AddS. + + Variable w wm : Type. + Variable incr : wm -> carry wm. + Variable addr : w -> wm -> carry wm. + Variable injr : w -> zn2z wm. + + Variable w_0 u: w. + Fixpoint injs (n:nat): word w (S n) := + match n return (word w (S n)) with + O => WW w_0 u + | S n1 => (WW W0 (injs n1)) + end. + + Definition adds x y := + match y with + W0 => C0 (injr x) + | WW hy ly => match addr x ly with + C0 z => C0 (WW hy z) + | C1 z => match incr hy with + C0 z1 => C0 (WW z1 z) + | C1 z1 => C1 (WW z1 z) + end + end + end. + +End AddS. + + + Lemma spec_opp: forall u x y, + match u with + | Eq => y = x + | Lt => y < x + | Gt => y > x + end -> + match opp_compare 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. + + Theorem length_pos_lt: forall x y, + (length_pos x < length_pos y)%nat -> Zpos x < Zpos y. + Proof. + intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac]; + intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; + try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1)); + try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1)); + try (inversion H; fail); + try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith); + assert (0 < Zpos y1); auto with zarith; red; auto. + Qed. + + Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x. + Proof. + intros A B f g x H; rewrite H; auto. + Qed. + + + Section SimplOp. + + Variable w: Type. + + Theorem digits_zop: forall w (x: znz_op w), + znz_digits (mk_zn2z_op x) = xO (znz_digits x). + 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). + intros ww x; auto. + Qed. + + Theorem make_zop: forall w (x: znz_op w), + znz_to_Z (mk_zn2z_op x) = + fun z => match z with + W0 => 0 + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + + znz_to_Z x xl + end. + intros ww x; auto. + Qed. + + Theorem make_kzop: forall w (x: znz_op w), + znz_to_Z (mk_zn2z_op_karatsuba x) = + fun z => match z with + W0 => 0 + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + + znz_to_Z x xl + end. + intros ww x; auto. + Qed. + + End SimplOp. diff --git a/theories/Numbers/Natural/Binary/NBinDefs.v b/theories/Numbers/Natural/Binary/NBinDefs.v new file mode 100644 index 00000000..fc2bd2df --- /dev/null +++ b/theories/Numbers/Natural/Binary/NBinDefs.v @@ -0,0 +1,267 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NBinDefs.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import BinPos. +Require Export BinNat. +Require Import NSub. + +Open Local Scope N_scope. + +(** Implementation of [NAxiomsSig] module type via [BinNat.N] *) + +Module NBinaryAxiomsMod <: NAxiomsSig. +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ := N. +Definition NZeq := @eq N. +Definition NZ0 := N0. +Definition NZsucc := Nsucc. +Definition NZpred := Npred. +Definition NZadd := Nplus. +Definition NZsub := Nminus. +Definition NZmul := Nmult. + +Theorem NZeq_equiv : equiv N NZeq. +Proof (eq_equiv N). + +Add Relation N NZeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Proof. +congruence. +Qed. + +Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Proof. +congruence. +Qed. + +Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Proof. +congruence. +Qed. + +Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. +Proof. +congruence. +Qed. + +Theorem NZinduction : + forall A : NZ -> Prop, predicate_wd NZeq A -> + A N0 -> (forall n, A n <-> A (NZsucc n)) -> forall n : NZ, A n. +Proof. +intros A A_wd A0 AS. apply Nrect. assumption. intros; now apply -> AS. +Qed. + +Theorem NZpred_succ : forall n : NZ, NZpred (NZsucc n) = n. +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. +Qed. + +Theorem NZadd_0_l : forall n : NZ, N0 + n = n. +Proof. +reflexivity. +Qed. + +Theorem NZadd_succ_l : forall n m : NZ, (NZsucc n) + m = NZsucc (n + m). +Proof. +destruct n; destruct m. +simpl in |- *; reflexivity. +unfold NZsucc, NZadd, Nsucc, Nplus. rewrite <- Pplus_one_succ_l; reflexivity. +simpl in |- *; reflexivity. +simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity. +Qed. + +Theorem NZsub_0_r : forall n : NZ, n - N0 = n. +Proof. +now destruct n. +Qed. + +Theorem NZsub_succ_r : forall n m : NZ, n - (NZsucc m) = NZpred (n - m). +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 |]. +Qed. + +Theorem NZmul_0_l : forall n : NZ, N0 * n = N0. +Proof. +destruct n; reflexivity. +Qed. + +Theorem NZmul_succ_l : forall n m : NZ, (NZsucc n) * m = n * m + m. +Proof. +destruct n as [| n]; destruct m as [| m]; simpl; try reflexivity. +now rewrite Pmult_Sn_m, Pplus_comm. +Qed. + +End NZAxiomsMod. + +Definition NZlt := Nlt. +Definition NZle := Nle. +Definition NZmin := Nmin. +Definition NZmax := Nmax. + +Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. +Proof. +unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. +Proof. +unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. +Proof. +congruence. +Qed. + +Theorem NZlt_eq_cases : forall n m : N, n <= m <-> n < m \/ n = m. +Proof. +intros n m. unfold Nle, Nlt. rewrite <- Ncompare_eq_correct. +destruct (n ?= m); split; intro H1; (try discriminate); try (now left); try now right. +now elim H1. destruct H1; discriminate. +Qed. + +Theorem NZlt_irrefl : forall n : NZ, ~ n < n. +Proof. +intro n; unfold Nlt; now rewrite Ncompare_refl. +Qed. + +Theorem NZlt_succ_r : forall n m : NZ, n < (NZsucc 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. elimtype False; 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. elimtype False; now apply H. +Qed. + +Theorem NZmin_l : forall n m : N, n <= m -> NZmin n m = n. +Proof. +unfold NZmin, Nmin, Nle; intros n m H. +destruct (n ?= m); try reflexivity. now elim H. +Qed. + +Theorem NZmin_r : forall n m : N, m <= n -> NZmin n m = m. +Proof. +unfold NZmin, 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 NZmax_l : forall n m : N, m <= n -> NZmax n m = n. +Proof. +unfold NZmax, 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 NZmax_r : forall n m : N, n <= m -> NZmax n m = m. +Proof. +unfold NZmax, Nmax, Nle; intros n m H. +destruct (n ?= m); try reflexivity. now elim H. +Qed. + +End NZOrdAxiomsMod. + +Definition recursion (A : Type) (a : A) (f : N -> A -> A) (n : N) := + Nrect (fun _ => A) a f n. +Implicit Arguments recursion [A]. + +Theorem pred_0 : Npred N0 = N0. +Proof. +reflexivity. +Qed. + +Theorem recursion_wd : +forall (A : Type) (Aeq : relation A), + forall a a' : A, Aeq a a' -> + forall f f' : N -> A -> A, fun2_eq NZeq Aeq Aeq f f' -> + forall x x' : N, x = x' -> + Aeq (recursion a f x) (recursion a' f' x'). +Proof. +unfold fun2_wd, NZeq, fun2_eq. +intros A Aeq 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 -> fun2_wd NZeq Aeq Aeq f -> + forall n : N, Aeq (recursion a f (Nsucc n)) (f n (recursion a f n)). +Proof. +unfold NZeq, recursion, fun2_wd; 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. + +End NBinaryAxiomsMod. + +Module Export NBinarySubPropMod := NSubPropFunct NBinaryAxiomsMod. + +(* Some fun comparing the efficiency of the generic log defined +by strong (course-of-value) recursion and the log defined by recursion +on notation *) +(* Time Eval compute in (log 100000). *) (* 98 sec *) + +(* +Fixpoint binposlog (p : positive) : N := +match p with +| xH => 0 +| xO p' => Nsucc (binposlog p') +| xI p' => Nsucc (binposlog p') +end. + +Definition binlog (n : N) : N := +match n with +| 0 => 0 +| Npos p => binposlog p +end. +*) +(* Eval compute in (binlog 1000000000000000000). *) (* Works very fast *) + diff --git a/theories/IntMap/Allmaps.v b/theories/Numbers/Natural/Binary/NBinary.v index d5af8f80..2c99128d 100644 --- a/theories/IntMap/Allmaps.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -5,17 +5,11 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Allmaps.v 8733 2006-04-25 22:52:18Z letouzey $ i*) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NBinary.v 10934 2008-05-15 21:58:20Z letouzey $ i*) + +Require Export NBinDefs. +Require Export NArithRing. -Require Export Map. -Require Export Fset. -Require Export Mapaxioms. -Require Export Mapiter. -Require Export Mapsubset. -Require Export Lsort. -Require Export Mapfold. -Require Export Mapcard. -Require Export Mapcanon. -Require Export Mapc. -Require Export Maplists. -Require Export Adalloc.
\ No newline at end of file diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v new file mode 100644 index 00000000..1c83da45 --- /dev/null +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -0,0 +1,220 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NPeano.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import Arith. +Require Import Min. +Require Import Max. +Require Import NSub. + +Module NPeanoAxiomsMod <: NAxiomsSig. +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ := nat. +Definition NZeq := (@eq nat). +Definition NZ0 := 0. +Definition NZsucc := S. +Definition NZpred := pred. +Definition NZadd := plus. +Definition NZsub := minus. +Definition NZmul := mult. + +Theorem NZeq_equiv : equiv nat NZeq. +Proof (eq_equiv nat). + +Add Relation nat NZeq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) +as NZeq_rel. + +(* If we say "Add Relation nat (@eq nat)" instead of "Add Relation nat NZeq" +then the theorem generated for succ_wd below is forall x, succ x = succ x, +which does not match the axioms in NAxiomsSig *) + +Add Morphism NZsucc with signature NZeq ==> NZeq as NZsucc_wd. +Proof. +congruence. +Qed. + +Add Morphism NZpred with signature NZeq ==> NZeq as NZpred_wd. +Proof. +congruence. +Qed. + +Add Morphism NZadd with signature NZeq ==> NZeq ==> NZeq as NZadd_wd. +Proof. +congruence. +Qed. + +Add Morphism NZsub with signature NZeq ==> NZeq ==> NZeq as NZsub_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmul with signature NZeq ==> NZeq ==> NZeq as NZmul_wd. +Proof. +congruence. +Qed. + +Theorem NZinduction : + forall A : nat -> Prop, predicate_wd (@eq nat) A -> + A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n. +Proof. +intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS. +Qed. + +Theorem NZpred_succ : forall n : nat, pred (S n) = n. +Proof. +reflexivity. +Qed. + +Theorem NZadd_0_l : forall n : nat, 0 + n = n. +Proof. +reflexivity. +Qed. + +Theorem NZadd_succ_l : forall n m : nat, (S n) + m = S (n + m). +Proof. +reflexivity. +Qed. + +Theorem NZsub_0_r : forall n : nat, n - 0 = n. +Proof. +intro n; now destruct n. +Qed. + +Theorem NZsub_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 NZsub_0_r. +Qed. + +Theorem NZmul_0_l : forall n : nat, 0 * n = 0. +Proof. +reflexivity. +Qed. + +Theorem NZmul_succ_l : forall n m : nat, S n * m = n * m + m. +Proof. +intros n m; now rewrite plus_comm. +Qed. + +End NZAxiomsMod. + +Definition NZlt := lt. +Definition NZle := le. +Definition NZmin := min. +Definition NZmax := max. + +Add Morphism NZlt with signature NZeq ==> NZeq ==> iff as NZlt_wd. +Proof. +unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZle with signature NZeq ==> NZeq ==> iff as NZle_wd. +Proof. +unfold NZeq; intros x1 x2 H1 y1 y2 H2; rewrite H1; now rewrite H2. +Qed. + +Add Morphism NZmin with signature NZeq ==> NZeq ==> NZeq as NZmin_wd. +Proof. +congruence. +Qed. + +Add Morphism NZmax with signature NZeq ==> NZeq ==> NZeq as NZmax_wd. +Proof. +congruence. +Qed. + +Theorem NZlt_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 NZlt_irrefl : forall n : nat, ~ (n < n). +Proof. +exact lt_irrefl. +Qed. + +Theorem NZlt_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]. +Qed. + +Theorem NZmin_l : forall n m : nat, n <= m -> NZmin n m = n. +Proof. +exact min_l. +Qed. + +Theorem NZmin_r : forall n m : nat, m <= n -> NZmin n m = m. +Proof. +exact min_r. +Qed. + +Theorem NZmax_l : forall n m : nat, m <= n -> NZmax n m = n. +Proof. +exact max_l. +Qed. + +Theorem NZmax_r : forall n m : nat, n <= m -> NZmax n m = m. +Proof. +exact max_r. +Qed. + +End NZOrdAxiomsMod. + +Definition recursion : forall A : Type, A -> (nat -> A -> A) -> nat -> A := + fun A : Type => nat_rect (fun _ => A). +Implicit Arguments recursion [A]. + +Theorem succ_neq_0 : forall n : nat, S n <> 0. +Proof. +intros; discriminate. +Qed. + +Theorem pred_0 : pred 0 = 0. +Proof. +reflexivity. +Qed. + +Theorem recursion_wd : forall (A : Type) (Aeq : relation A), + forall a a' : A, Aeq a a' -> + forall f f' : nat -> A -> A, fun2_eq (@eq nat) Aeq Aeq f f' -> + forall n n' : nat, n = n' -> + Aeq (recursion a f n) (recursion a' f' n'). +Proof. +unfold fun2_eq; induction n; intros n' Enn'; rewrite <- Enn' in *; simpl; auto. +Qed. + +Theorem recursion_0 : + forall (A : Type) (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), + Aeq a a -> fun2_wd (@eq nat) Aeq Aeq f -> + forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). +Proof. +induction n; simpl; auto. +Qed. + +End NPeanoAxiomsMod. + +(* Now we apply the largest property functor *) + +Module Export NPeanoSubPropMod := NSubPropFunct NPeanoAxiomsMod. + diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v new file mode 100644 index 00000000..0275d1e1 --- /dev/null +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -0,0 +1,115 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NSig.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import ZArith Znumtheory. + +Open Scope Z_scope. + +(** * NSig *) + +(** Interface of a rich structure about natural numbers. + Specifications are written via translation to Z. +*) + +Module Type NType. + + Parameter t : Type. + + Parameter to_Z : t -> Z. + Notation "[ x ]" := (to_Z x). + 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). + + Definition eq n m := ([n] = [m]). + + Parameter zero : t. + Parameter one : t. + + Parameter spec_0: [zero] = 0. + Parameter spec_1: [one] = 1. + + Parameter compare : t -> t -> comparison. + + Parameter spec_compare: forall x y, + match compare x y with + | Eq => [x] = [y] + | Lt => [x] < [y] + | Gt => [x] > [y] + end. + + Definition lt n m := compare n m = Lt. + Definition le n m := compare n m <> Gt. + 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. + + Parameter eq_bool : t -> t -> bool. + + Parameter spec_eq_bool: forall x y, + if eq_bool x y then [x] = [y] else [x] <> [y]. + + Parameter succ : t -> t. + + Parameter spec_succ: forall n, [succ n] = [n] + 1. + + Parameter add : t -> t -> t. + + Parameter spec_add: forall x y, [add x y] = [x] + [y]. + + Parameter pred : t -> t. + + Parameter spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1. + Parameter spec_pred0: forall x, [x] = 0 -> [pred x] = 0. + + Parameter sub : t -> t -> t. + + Parameter spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. + Parameter spec_sub0: forall x y, [x] < [y]-> [sub x y] = 0. + + Parameter mul : t -> t -> t. + + Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. + + Parameter square : t -> t. + + Parameter spec_square: forall x, [square x] = [x] * [x]. + + Parameter power_pos : t -> positive -> t. + + Parameter spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. + + Parameter sqrt : t -> t. + + Parameter spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. + + Parameter div_eucl : t -> t -> t * t. + + Parameter spec_div_eucl: forall x y, + 0 < [y] -> + let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. + + Parameter div : t -> t -> t. + + Parameter spec_div: forall x y, 0 < [y] -> [div x y] = [x] / [y]. + + Parameter modulo : t -> t -> t. + + Parameter spec_modulo: + forall x y, 0 < [y] -> [modulo x y] = [x] mod [y]. + + Parameter gcd : t -> t -> t. + + Parameter spec_gcd: forall a b, [gcd a b] = Zgcd (to_Z a) (to_Z b). + +End NType. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v new file mode 100644 index 00000000..fe068437 --- /dev/null +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -0,0 +1,356 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: NSigNAxioms.v 11040 2008-06-03 00:04:16Z letouzey $ i*) + +Require Import ZArith. +Require Import Nnat. +Require Import NAxioms. +Require Import NSig. + +(** * The interface [NSig.NType] implies the interface [NAxiomsSig] *) + +Module NSig_NAxioms (N:NType) <: NAxiomsSig. + +Delimit Scope IntScope with Int. +Bind Scope IntScope with N.t. +Open Local Scope IntScope. +Notation "[ x ]" := (N.to_Z x) : IntScope. +Infix "==" := N.eq (at level 70) : IntScope. +Notation "0" := N.zero : IntScope. +Infix "+" := N.add : IntScope. +Infix "-" := N.sub : IntScope. +Infix "*" := N.mul : IntScope. + +Module Export NZOrdAxiomsMod <: NZOrdAxiomsSig. +Module Export NZAxiomsMod <: NZAxiomsSig. + +Definition NZ := N.t. +Definition NZeq := N.eq. +Definition NZ0 := N.zero. +Definition NZsucc := N.succ. +Definition NZpred := N.pred. +Definition NZadd := N.add. +Definition NZsub := N.sub. +Definition NZmul := N.mul. + +Theorem NZeq_equiv : equiv N.t N.eq. +Proof. +repeat split; repeat red; intros; auto; congruence. +Qed. + +Add Relation N.t N.eq + reflexivity proved by (proj1 NZeq_equiv) + symmetry proved by (proj2 (proj2 NZeq_equiv)) + transitivity proved by (proj1 (proj2 NZeq_equiv)) + as NZeq_rel. + +Add Morphism NZsucc with signature N.eq ==> N.eq as NZsucc_wd. +Proof. +unfold N.eq; intros; rewrite 2 N.spec_succ; f_equal; auto. +Qed. + +Add Morphism NZpred with signature N.eq ==> N.eq as NZpred_wd. +Proof. +unfold N.eq; intros. +generalize (N.spec_pos y) (N.spec_pos x) (N.spec_eq_bool x 0). +destruct N.eq_bool; rewrite N.spec_0; intros. +rewrite 2 N.spec_pred0; congruence. +rewrite 2 N.spec_pred; f_equal; auto; try omega. +Qed. + +Add Morphism NZadd with signature N.eq ==> N.eq ==> N.eq as NZadd_wd. +Proof. +unfold N.eq; intros; rewrite 2 N.spec_add; f_equal; auto. +Qed. + +Add Morphism NZsub with signature N.eq ==> N.eq ==> N.eq as NZsub_wd. +Proof. +unfold N.eq; intros x x' Hx y y' Hy. +destruct (Z_lt_le_dec [x] [y]). +rewrite 2 N.spec_sub0; f_equal; congruence. +rewrite 2 N.spec_sub; f_equal; congruence. +Qed. + +Add Morphism NZmul with signature N.eq ==> N.eq ==> N.eq as NZmul_wd. +Proof. +unfold N.eq; intros; rewrite 2 N.spec_mul; f_equal; auto. +Qed. + +Theorem NZpred_succ : forall n, N.pred (N.succ n) == n. +Proof. +unfold N.eq; intros. +rewrite N.spec_pred; rewrite N.spec_succ. +omega. +generalize (N.spec_pos n); omega. +Qed. + +Definition N_of_Z z := N.of_N (Zabs_N z). + +Section Induction. + +Variable A : N.t -> Prop. +Hypothesis A_wd : predicate_wd N.eq A. +Hypothesis A0 : A 0. +Hypothesis AS : forall n, A n <-> A (N.succ n). + +Add Morphism A with signature N.eq ==> iff as A_morph. +Proof. apply A_wd. Qed. + +Let B (z : Z) := A (N_of_Z z). + +Lemma B0 : B 0. +Proof. +unfold B, N_of_Z; simpl. +rewrite <- (A_wd 0); auto. +red; rewrite N.spec_0, N.spec_of_N; auto. +Qed. + +Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1). +Proof. +intros z H1 H2. +unfold B in *. apply -> AS in H2. +setoid_replace (N_of_Z (z + 1)) with (N.succ (N_of_Z z)); auto. +unfold N.eq. rewrite N.spec_succ. +unfold N_of_Z. +rewrite 2 N.spec_of_N, 2 Z_of_N_abs, 2 Zabs_eq; auto with zarith. +Qed. + +Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z. +Proof. +exact (natlike_ind B B0 BS). +Qed. + +Theorem NZinduction : forall n, A n. +Proof. +intro n. setoid_replace n with (N_of_Z (N.to_Z n)). +apply B_holds. apply N.spec_pos. +red; unfold N_of_Z. +rewrite N.spec_of_N, Z_of_N_abs, Zabs_eq; auto. +apply N.spec_pos. +Qed. + +End Induction. + +Theorem NZadd_0_l : forall n, 0 + n == n. +Proof. +intros; red; rewrite N.spec_add, N.spec_0; auto with zarith. +Qed. + +Theorem NZadd_succ_l : forall n m, (N.succ n) + m == N.succ (n + m). +Proof. +intros; red; rewrite N.spec_add, 2 N.spec_succ, N.spec_add; auto with zarith. +Qed. + +Theorem NZsub_0_r : forall n, n - 0 == n. +Proof. +intros; red; rewrite N.spec_sub; rewrite N.spec_0; auto with zarith. +apply N.spec_pos. +Qed. + +Theorem NZsub_succ_r : forall n m, n - (N.succ m) == N.pred (n - m). +Proof. +intros; red. +destruct (Z_lt_le_dec [n] [N.succ m]) as [H|H]. +rewrite N.spec_sub0; auto. +rewrite N.spec_succ in H. +rewrite N.spec_pred0; auto. +destruct (Z_eq_dec [n] [m]). +rewrite N.spec_sub; auto with zarith. +rewrite N.spec_sub0; auto with zarith. + +rewrite N.spec_sub, N.spec_succ in *; auto. +rewrite N.spec_pred, N.spec_sub; auto with zarith. +rewrite N.spec_sub; auto with zarith. +Qed. + +Theorem NZmul_0_l : forall n, 0 * n == 0. +Proof. +intros; red. +rewrite N.spec_mul, N.spec_0; auto with zarith. +Qed. + +Theorem NZmul_succ_l : forall n m, (N.succ n) * m == n * m + m. +Proof. +intros; red. +rewrite N.spec_add, 2 N.spec_mul, N.spec_succ; ring. +Qed. + +End NZAxiomsMod. + +Definition NZlt := N.lt. +Definition NZle := N.le. +Definition NZmin := N.min. +Definition NZmax := N.max. + +Infix "<=" := N.le : IntScope. +Infix "<" := N.lt : IntScope. + +Lemma spec_compare_alt : forall x y, N.compare x y = ([x] ?= [y])%Z. +Proof. + intros; generalize (N.spec_compare x y). + destruct (N.compare x y); auto. + intros H; rewrite H; symmetry; apply Zcompare_refl. +Qed. + +Lemma spec_lt : forall x y, (x<y) <-> ([x]<[y])%Z. +Proof. + intros; unfold N.lt, Zlt; rewrite spec_compare_alt; intuition. +Qed. + +Lemma spec_le : forall x y, (x<=y) <-> ([x]<=[y])%Z. +Proof. + intros; unfold N.le, Zle; rewrite spec_compare_alt; intuition. +Qed. + +Lemma spec_min : forall x y, [N.min x y] = Zmin [x] [y]. +Proof. + intros; unfold N.min, Zmin. + rewrite spec_compare_alt; destruct Zcompare; auto. +Qed. + +Lemma spec_max : forall x y, [N.max x y] = Zmax [x] [y]. +Proof. + intros; unfold N.max, Zmax. + rewrite spec_compare_alt; destruct Zcompare; auto. +Qed. + +Add Morphism N.compare with signature N.eq ==> N.eq ==> (@eq comparison) as compare_wd. +Proof. +intros x x' Hx y y' Hy. +rewrite 2 spec_compare_alt; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism N.lt with signature N.eq ==> N.eq ==> iff as NZlt_wd. +Proof. +intros x x' Hx y y' Hy; unfold N.lt; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism N.le with signature N.eq ==> N.eq ==> iff as NZle_wd. +Proof. +intros x x' Hx y y' Hy; unfold N.le; rewrite Hx, Hy; intuition. +Qed. + +Add Morphism N.min with signature N.eq ==> N.eq ==> N.eq as NZmin_wd. +Proof. +intros; red; rewrite 2 spec_min; congruence. +Qed. + +Add Morphism N.max with signature N.eq ==> N.eq ==> N.eq as NZmax_wd. +Proof. +intros; red; rewrite 2 spec_max; congruence. +Qed. + +Theorem NZlt_eq_cases : forall n m, n <= m <-> n < m \/ n == m. +Proof. +intros. +unfold N.eq; rewrite spec_lt, spec_le; omega. +Qed. + +Theorem NZlt_irrefl : forall n, ~ n < n. +Proof. +intros; rewrite spec_lt; auto with zarith. +Qed. + +Theorem NZlt_succ_r : forall n m, n < (N.succ m) <-> n <= m. +Proof. +intros; rewrite spec_lt, spec_le, N.spec_succ; omega. +Qed. + +Theorem NZmin_l : forall n m, n <= m -> N.min n m == n. +Proof. +intros n m; unfold N.eq; rewrite spec_le, spec_min. +generalize (Zmin_spec [n] [m]); omega. +Qed. + +Theorem NZmin_r : forall n m, m <= n -> N.min n m == m. +Proof. +intros n m; unfold N.eq; rewrite spec_le, spec_min. +generalize (Zmin_spec [n] [m]); omega. +Qed. + +Theorem NZmax_l : forall n m, m <= n -> N.max n m == n. +Proof. +intros n m; unfold N.eq; rewrite spec_le, spec_max. +generalize (Zmax_spec [n] [m]); omega. +Qed. + +Theorem NZmax_r : forall n m, n <= m -> N.max n m == m. +Proof. +intros n m; unfold N.eq; rewrite spec_le, spec_max. +generalize (Zmax_spec [n] [m]); omega. +Qed. + +End NZOrdAxiomsMod. + +Theorem pred_0 : N.pred 0 == 0. +Proof. +red; rewrite N.spec_pred0; rewrite N.spec_0; auto. +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]. + +Theorem recursion_wd : +forall (A : Type) (Aeq : relation A), + forall a a' : A, Aeq a a' -> + forall f f' : N.t -> A -> A, fun2_eq N.eq Aeq Aeq f f' -> + forall x x' : N.t, x == x' -> + Aeq (recursion a f x) (recursion a' f' x'). +Proof. +unfold fun2_wd, N.eq, fun2_eq. +intros A Aeq a a' Eaa' f f' Eff' x x' Exx'. +unfold recursion. +unfold N.to_N. +rewrite <- Exx'; clear x' Exx'. +replace (Zabs_N [x]) with (N_of_nat (Zabs_nat [x])). +induction (Zabs_nat [x]). +simpl; auto. +rewrite N_of_S, 2 Nrect_step; 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. +Qed. + +Theorem recursion_0 : + forall (A : Type) (a : A) (f : N.t -> A -> A), recursion a f 0 = a. +Proof. +intros A a f; unfold recursion, N.to_N; rewrite N.spec_0; simpl; auto. +Qed. + +Theorem recursion_succ : + forall (A : Type) (Aeq : relation A) (a : A) (f : N.t -> A -> A), + Aeq a a -> fun2_wd N.eq Aeq Aeq f -> + forall n, Aeq (recursion a f (N.succ n)) (f n (recursion a f n)). +Proof. +unfold N.eq, recursion, fun2_wd; intros A Aeq a f EAaa f_wd n. +replace (N.to_N (N.succ n)) with (Nsucc (N.to_N n)). +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. +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 (N.spec_pos n); auto with zarith. +apply N.spec_pos; auto. +Qed. + +End NSig_NAxioms. diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v new file mode 100644 index 00000000..fdccf214 --- /dev/null +++ b/theories/Numbers/NumPrelude.v @@ -0,0 +1,267 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Evgeny Makarov, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: NumPrelude.v 10943 2008-05-19 08:45:13Z letouzey $ i*) + +Require Export Setoid. + +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]. + +(** Extentional properties of predicates, relations and functions *) + +Definition predicate (A : Type) := A -> Prop. + +Section ExtensionalProperties. + +Variables A B C : Type. +Variable Aeq : relation A. +Variable Beq : relation B. +Variable Ceq : relation C. + +(* "wd" stands for "well-defined" *) + +Definition fun_wd (f : A -> B) := forall x y : A, Aeq x y -> Beq (f x) (f y). + +Definition fun2_wd (f : A -> B -> C) := + forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f x' y'). + +Definition fun_eq : relation (A -> B) := + fun f f' => forall x x' : A, Aeq x x' -> Beq (f x) (f' x'). + +(* Note that reflexivity of fun_eq means that every function +is well-defined w.r.t. Aeq and Beq, i.e., +forall x x' : A, Aeq x x' -> Beq (f x) (f x') *) + +Definition fun2_eq (f f' : A -> B -> C) := + forall x x' : A, Aeq x x' -> forall y y' : B, Beq y y' -> Ceq (f x y) (f' x' y'). + +End ExtensionalProperties. + +(* The following definitions instantiate Beq or Ceq to iff; therefore, they +have to be outside the ExtensionalProperties section *) + +Definition predicate_wd (A : Type) (Aeq : relation A) := fun_wd Aeq iff. + +Definition relation_wd (A B : Type) (Aeq : relation A) (Beq : relation B) := + fun2_wd Aeq Beq iff. + +Definition relations_eq (A B : Type) (R1 R2 : A -> B -> Prop) := + forall (x : A) (y : B), R1 x y <-> R2 x y. + +Theorem relations_eq_equiv : + forall (A B : Type), equiv (A -> B -> Prop) (@relations_eq A B). +Proof. +intros A B; unfold equiv. split; [| split]; +unfold reflexive, symmetric, transitive, relations_eq. +reflexivity. +intros R1 R2 R3 H1 H2 x y; rewrite H1; apply H2. +now symmetry. +Qed. + +Add Parametric Relation (A B : Type) : (A -> B -> Prop) (@relations_eq A B) + reflexivity proved by (proj1 (relations_eq_equiv A B)) + symmetry proved by (proj2 (proj2 (relations_eq_equiv A B))) + transitivity proved by (proj1 (proj2 (relations_eq_equiv A B))) +as relations_eq_rel. + +Add Parametric Morphism (A : Type) : (@well_founded A) with signature (@relations_eq A A) ==> iff as well_founded_wd. +Proof. +unfold relations_eq, well_founded; intros R1 R2 H; +split; intros H1 a; induction (H1 a) as [x H2 H3]; constructor; +intros y H4; apply H3; [now apply <- H | now apply -> H]. +Qed. + +(* solve_predicate_wd solves the goal [predicate_wd P] for P consisting of +morhisms and quatifiers *) + +Ltac solve_predicate_wd := +unfold 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 [relation_wd R] for R consisting of +morhisms and quatifiers *) + +Ltac solve_relation_wd := +unfold relation_wd, fun2_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. +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 | ..]. + +(** Relations on cartesian product. Used in MiscFunct for defining +functions whose domain is a product of sets by primitive recursion *) + +Section RelationOnProduct. + +Variables A B : Set. +Variable Aeq : relation A. +Variable Beq : relation B. + +Hypothesis EA_equiv : equiv A Aeq. +Hypothesis EB_equiv : equiv B Beq. + +Definition prod_rel : relation (A * B) := + fun p1 p2 => Aeq (fst p1) (fst p2) /\ Beq (snd p1) (snd p2). + +Lemma prod_rel_refl : reflexive (A * B) prod_rel. +Proof. +unfold reflexive, prod_rel. +destruct x; split; [apply (proj1 EA_equiv) | apply (proj1 EB_equiv)]; simpl. +Qed. + +Lemma prod_rel_symm : symmetric (A * B) prod_rel. +Proof. +unfold symmetric, prod_rel. +destruct x; destruct y; +split; [apply (proj2 (proj2 EA_equiv)) | apply (proj2 (proj2 EB_equiv))]; simpl in *; tauto. +Qed. + +Lemma prod_rel_trans : transitive (A * B) prod_rel. +Proof. +unfold transitive, prod_rel. +destruct x; destruct y; destruct z; simpl. +intros; split; [apply (proj1 (proj2 EA_equiv)) with (y := a0) | +apply (proj1 (proj2 EB_equiv)) with (y := b0)]; tauto. +Qed. + +Theorem prod_rel_equiv : equiv (A * B) prod_rel. +Proof. +unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_symm]]. +Qed. + +End RelationOnProduct. + +Implicit Arguments prod_rel [A B]. +Implicit Arguments prod_rel_equiv [A B]. + +(** Miscellaneous *) + +(*Definition comp_bool (x y : comparison) : bool := +match x, y with +| Lt, Lt => true +| Eq, Eq => true +| Gt, Gt => true +| _, _ => false +end. + +Theorem comp_bool_correct : forall x y : comparison, + comp_bool x y <-> x = y. +Proof. +destruct x; destruct y; simpl; split; now intro. +Qed.*) + +Lemma eq_equiv : forall A : Set, equiv A (@eq A). +Proof. +intro A; unfold equiv, reflexive, symmetric, transitive. +repeat split; [exact (@trans_eq A) | exact (@sym_eq A)]. +(* It is interesting how the tactic split proves reflexivity *) +Qed. + +(*Add Relation (fun A : Set => A) LE_Set + reflexivity proved by (fun A : Set => (proj1 (eq_equiv A))) + symmetry proved by (fun A : Set => (proj2 (proj2 (eq_equiv A)))) + transitivity proved by (fun A : Set => (proj1 (proj2 (eq_equiv A)))) +as EA_rel.*) diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v new file mode 100644 index 00000000..39e120f7 --- /dev/null +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -0,0 +1,35 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: BigQ.v 11028 2008-06-01 17:34:19Z letouzey $ i*) + +Require Export QMake_base. +Require Import QpMake. +Require Import QvMake. +Require Import Q0Make. +Require Import QifMake. +Require Import QbiMake. + +(* We choose for Q the implemention with + multiple representation of 0: 0, 1/0, 2/0 etc *) + +Module BigQ <: QSig.QType := Q0. + +Notation bigQ := BigQ.t. + +Delimit Scope bigQ_scope with bigQ. +Bind Scope bigQ_scope with bigQ. +Bind Scope bigQ_scope with BigQ.t. + +Notation " i + j " := (BigQ.add i j) : bigQ_scope. +Notation " i - j " := (BigQ.sub i j) : bigQ_scope. +Notation " i * j " := (BigQ.mul i j) : bigQ_scope. +Notation " i / j " := (BigQ.div i j) : bigQ_scope. +Notation " i ?= j " := (BigQ.compare i j) : bigQ_scope. diff --git a/theories/Numbers/Rational/BigQ/Q0Make.v b/theories/Numbers/Rational/BigQ/Q0Make.v new file mode 100644 index 00000000..93f52c03 --- /dev/null +++ b/theories/Numbers/Rational/BigQ/Q0Make.v @@ -0,0 +1,1412 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: Q0Make.v 11028 2008-06-01 17:34:19Z letouzey $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import Arith. +Require Export BigN. +Require Export BigZ. +Require Import QArith. +Require Import Qcanon. +Require Import Qpower. +Require Import QSig. +Require Import QMake_base. + +Module Q0 <: QType. + + Import BinInt Zorder. + + (** The notation of a rational number is either an integer x, + interpreted as itself or a pair (x,y) of an integer x and a natural + number y interpreted as x/y. The pairs (x,0) and (0,y) are all + interpreted as 0. *) + + Definition t := q_type. + + (** Specification with respect to [QArith] *) + + Open Local Scope Q_scope. + + Definition of_Z x: t := Qz (BigZ.of_Z x). + + Definition of_Q q: t := + match q with x # y => + Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) + end. + + Definition to_Q (q: t) := + match q with + Qz x => BigZ.to_Z x # 1 + |Qq x y => if BigN.eq_bool y BigN.zero then 0 + else BigZ.to_Z x # Z2P (BigN.to_Z y) + end. + + Notation "[ x ]" := (to_Q x). + + Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q. + Proof. + intros (x,y); simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigN.spec_of_pos; intros HH; discriminate HH. + rewrite BigZ.spec_of_Z; simpl. + rewrite (BigN.spec_of_pos); auto. + Qed. + + Theorem spec_of_Q: forall q: Q, [of_Q q] == q. + Proof. + intros; rewrite strong_spec_of_Q; red; auto. + Qed. + + Definition eq x y := [x] == [y]. + + Definition zero: t := Qz BigZ.zero. + Definition one: t := Qz BigZ.one. + Definition minus_one: t := Qz BigZ.minus_one. + + Lemma spec_0: [zero] == 0. + Proof. + reflexivity. + Qed. + + Lemma spec_1: [one] == 1. + Proof. + reflexivity. + Qed. + + Lemma spec_m1: [minus_one] == -(1). + Proof. + reflexivity. + Qed. + + Definition opp (x: t): t := + match x with + | Qz zx => Qz (BigZ.opp zx) + | Qq nx dx => Qq (BigZ.opp nx) dx + end. + + Theorem strong_spec_opp: forall q, [opp q] = -[q]. + Proof. + intros [z | x y]; simpl. + rewrite BigZ.spec_opp; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigZ.spec_opp; auto. + Qed. + + Theorem spec_opp : forall q, [opp q] == -[q]. + Proof. + intros; rewrite strong_spec_opp; red; auto. + Qed. + + Definition compare (x y: t) := + match x, y with + | Qz zx, Qz zy => BigZ.compare zx zy + | Qz zx, Qq ny dy => + if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero + else BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny + | Qq nx dx, Qz zy => + if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy + else BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) + | Qq nx dx, Qq ny dy => + match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with + | true, true => Eq + | true, false => BigZ.compare BigZ.zero ny + | false, true => BigZ.compare nx BigZ.zero + | false, false => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) + end + end. + + Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). + Proof. + intros [z1 | x1 y1] [z2 | x2 y2]; + unfold Qcompare, compare, to_Q, Qnum, Qden. + repeat rewrite Zmult_1_r. + generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + rewrite Zmult_1_r. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero z2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y1); auto with zarith. + rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zcompare_refl; auto. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero x2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; + auto; rewrite BigZ.spec_0. + intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + repeat rewrite Z2P_correct. + 2: generalize (BigN.spec_pos y1); auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) + (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + Qed. + + Definition lt n m := compare n m = Lt. + Definition le n m := compare n m <> Gt. + 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. + +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d: t := + let gcd := BigN.gcd (BigZ.to_N n) d in + match BigN.compare BigN.one gcd with + | Lt => + let n := BigZ.div n (BigZ.Pos gcd) in + let d := BigN.div d gcd in + match BigN.compare d BigN.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end. + + Theorem spec_norm: forall n q, [norm n q] == [Qq n q]. + Proof. + intros p q; unfold norm. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. + apply Qeq_refl. + generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl; + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + auto with zarith. + generalize H2; rewrite H3; + rewrite Zdiv_0_l; auto with zarith. + generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. + rewrite spec_to_N. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl. + case H3. + generalize H1 H2 H3 HH; clear H1 H2 H3 HH. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 HH. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. + case (Zle_lt_or_eq _ _ HH); auto with zarith. + intros HH1; rewrite <- HH1; ring. + generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H3. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H4. + case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. + simpl. + assert (FF := BigN.spec_pos q). + rewrite Z2P_correct; auto with zarith. + rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. + simpl; rewrite BigZ.spec_div; simpl. + rewrite BigN.spec_gcd; auto with zarith. + generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4 HH FF. + rewrite spec_to_N; fold a. + rewrite Zgcd_div_swap; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); + rewrite BigN.spec_gcd; auto with zarith. + intros; apply False_ind; auto with zarith. + intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2; simpl. + rewrite spec_to_N. + rewrite FF2; ring. + Qed. + + + Definition add (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + Qq n d + end + end. + + Theorem spec_add : forall x y, [add x y] == [x] + [y]. + Proof. + intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. + rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + assert (F1:= BigN.spec_pos dy). + rewrite Zmult_1_r; red; simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + rewrite Zmult_1_r; rewrite Pmult_1_r. + apply Qeq_refl. + assert (F1:= BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + case HH2; auto. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH2; auto. + case HH1; auto. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH; auto. + rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. + apply Qeq_refl. + simpl. + generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_mul; + rewrite BigN.spec_0; intros HH2. + (case (Zmult_integral _ _ HH2); intros HH3); + [case HH| case HH1]; auto. + rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. + assert (Fx: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (Fy: (0 < BigN.to_Z dy)%Z). + generalize (BigN.spec_pos dy); auto with zarith. + red; simpl; rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + apply Zmult_lt_0_compat; auto. + Qed. + + Definition add_norm (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + norm n d + end + end. + + Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y]. + Proof. + intros x y; rewrite <- spec_add; auto. + case x; case y; clear x y; unfold add_norm, add. + intros; apply Qeq_refl. + intros p1 n p2. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + simpl. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + apply Qeq_refl. + intros p1 p2 n. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + apply Qeq_refl. + intros p1 q1 p2 q2. + generalize (BigN.spec_eq_bool q2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + generalize (BigN.spec_eq_bool q1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + apply Qeq_refl. + Qed. + + Definition sub x y := add x (opp y). + + Theorem spec_sub : forall x y, [sub x y] == [x] - [y]. + Proof. + intros x y; unfold sub; rewrite spec_add; auto. + rewrite spec_opp; ring. + Qed. + + Definition sub_norm x y := add_norm x (opp y). + + Theorem spec_sub_norm : forall x y, [sub_norm x y] == [x] - [y]. + Proof. + intros x y; unfold sub_norm; rewrite spec_add_norm; auto. + rewrite spec_opp; ring. + Qed. + + Definition mul (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + Theorem spec_mul : forall x y, [mul x y] == [x] * [y]. + Proof. + intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. + rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; rewrite Pmult_1_r. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; + intros HH1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + red; simpl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + red; simpl; ring. + case (Zmult_integral _ _ HH1); intros HH. + case HH2; auto. + case HH3; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + case HH1; rewrite HH2; ring. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + case HH1; rewrite HH3; ring. + rewrite BigZ.spec_mul. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + apply Qeq_refl. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dy); auto with zarith. + Qed. + +Definition mul_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => + if BigZ.eq_bool zx BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N zx) dy in + match BigN.compare gcd BigN.one with + Gt => + let zx := BigZ.div zx (BigZ.Pos gcd) in + let d := BigN.div dy gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) + else Qq (BigZ.mul zx ny) d + | _ => Qq (BigZ.mul zx ny) dy + end + | Qq nx dx, Qz zy => + if BigZ.eq_bool zy BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N zy) dx in + match BigN.compare gcd BigN.one with + Gt => + let zy := BigZ.div zy (BigZ.Pos gcd) in + let d := BigN.div dx gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) + else Qq (BigZ.mul zy nx) d + | _ => Qq (BigZ.mul zy nx) dx + end + | Qq nx dx, Qq ny dy => + let (nx, dy) := + let gcd := BigN.gcd (BigZ.to_N nx) dy in + match BigN.compare gcd BigN.one with + Gt => (BigZ.div nx (BigZ.Pos gcd), BigN.div dy gcd) + | _ => (nx, dy) + end in + let (ny, dx) := + let gcd := BigN.gcd (BigZ.to_N ny) dx in + match BigN.compare gcd BigN.one with + Gt => (BigZ.div ny (BigZ.Pos gcd), BigN.div dx gcd) + | _ => (ny, dx) + end in + let d := (BigN.mul dx dy) in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul ny nx) + else Qq (BigZ.mul ny nx) d + end. + + Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y]. + Proof. + intros x y; rewrite <- spec_mul; auto. + unfold mul_norm, mul; case x; case y; clear x y. + intros; apply Qeq_refl. + intros p1 n p2. + set (a := BigN.to_Z (BigZ.to_N p2)). + set (b := BigN.to_Z n). + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + case BigN.eq_bool; try apply Qeq_refl. + rewrite BigZ.spec_mul; rewrite H. + red; simpl; ring. + assert (F: (0 < a)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; + fold a b; intros H1. + apply Qeq_refl. + apply Qeq_refl. + assert (F0 : (0 < (Zgcd a b))%Z). + apply Zlt_trans with 1%Z. + red; auto. + apply Zgt_lt; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; + fold a b; intros H2. + assert (F1: b = Zgcd a b). + pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); + auto with zarith. + rewrite H2; ring. + assert (FF := Zgcd_is_gcd a b); inversion FF; auto. + assert (F2: (0 < b)%Z). + rewrite F1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros H3. + rewrite H3 in F2; discriminate F2. + rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite BigZ.spec_mul. + red; simpl; rewrite Z2P_correct; auto. + rewrite Zmult_1_r; rewrite spec_to_N; fold a b. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; fold a b; auto; intros H3. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + apply Qeq_refl. + case H4; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite H3; ring. + assert (FF := Zgcd_is_gcd a b); inversion FF; auto. + simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros H4. + case H3; rewrite H4; rewrite Zdiv_0_l; auto. + rewrite BigZ.spec_mul; rewrite BigZ.spec_div; simpl; + rewrite BigN.spec_gcd; fold a b; auto with zarith. + assert (F1: (0 < b)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos n)); fold b; auto with zarith. + red; simpl. + rewrite BigZ.spec_mul. + repeat rewrite Z2P_correct; auto. + rewrite spec_to_N; fold a. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + ring. + apply Zgcd_div_pos; auto. + intros p1 p2 n. + set (a := BigN.to_Z (BigZ.to_N p1)). + set (b := BigN.to_Z n). + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + case BigN.eq_bool; try apply Qeq_refl. + rewrite BigZ.spec_mul; rewrite H. + red; simpl; ring. + assert (F: (0 < a)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; + fold a b; intros H1. + repeat rewrite BigZ.spec_mul; rewrite Zmult_comm. + apply Qeq_refl. + repeat rewrite BigZ.spec_mul; rewrite Zmult_comm. + apply Qeq_refl. + assert (F0 : (0 < (Zgcd a b))%Z). + apply Zlt_trans with 1%Z. + red; auto. + apply Zgt_lt; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; + fold a b; intros H2. + assert (F1: b = Zgcd a b). + pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); + auto with zarith. + rewrite H2; ring. + assert (FF := Zgcd_is_gcd a b); inversion FF; auto. + assert (F2: (0 < b)%Z). + rewrite F1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros H3. + rewrite H3 in F2; discriminate F2. + rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite BigZ.spec_mul. + red; simpl; rewrite Z2P_correct; auto. + rewrite Zmult_1_r; rewrite spec_to_N; fold a b. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; fold a b; auto; intros H3. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + apply Qeq_refl. + case H4; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite H3; ring. + assert (FF := Zgcd_is_gcd a b); inversion FF; auto. + simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros H4. + case H3; rewrite H4; rewrite Zdiv_0_l; auto. + rewrite BigZ.spec_mul; rewrite BigZ.spec_div; simpl; + rewrite BigN.spec_gcd; fold a b; auto with zarith. + assert (F1: (0 < b)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos n)); fold b; auto with zarith. + red; simpl. + rewrite BigZ.spec_mul. + repeat rewrite Z2P_correct; auto. + rewrite spec_to_N; fold a. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + ring. + apply Zgcd_div_pos; auto. + set (f := fun p t => + match (BigN.gcd (BigZ.to_N p) t ?= BigN.one)%bigN with + | Eq => (p, t) + | Lt => (p, t) + | Gt => + ((p / BigZ.Pos (BigN.gcd (BigZ.to_N p) t))%bigZ, + (t / BigN.gcd (BigZ.to_N p) t)%bigN) + end). + assert (F: forall p t, + let (n, d) := f p t in [Qq p t] == [Qq n d]). + intros p t1; unfold f. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. + apply Qeq_refl. + apply Qeq_refl. + set (a := BigN.to_Z (BigZ.to_N p)). + set (b := BigN.to_Z t1). + fold a b in H1. + assert (F0 : (0 < (Zgcd a b))%Z). + apply Zlt_trans with 1%Z. + red; auto. + apply Zgt_lt; auto. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros HH1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; fold b; intros HH2. + simpl; ring. + case HH2. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; auto. + rewrite HH1; rewrite Zdiv_0_l; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; + rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; auto; + intros HH2. + case HH1. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite HH2; ring. + assert (FF := Zgcd_is_gcd a b); inversion FF; auto. + simpl. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; fold a b; auto with zarith. + assert (F1: (0 < b)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos t1)); fold b; auto with zarith. + intros HH; case HH1; auto. + repeat rewrite Z2P_correct; auto. + rewrite spec_to_N; fold a. + rewrite Zgcd_div_swap; auto. + apply Zgcd_div_pos; auto. + intros HH; rewrite HH in F0; discriminate F0. + intros p1 n1 p2 n2. + change ([let (nx , dy) := f p2 n1 in + let (ny, dx) := f p1 n2 in + if BigN.eq_bool (dx * dy)%bigN BigN.one + then Qz (ny * nx) + else Qq (ny * nx) (dx * dy)] == [Qq (p2 * p1) (n2 * n1)]). + generalize (F p2 n1) (F p1 n2). + case f; case f. + intros u1 u2 v1 v2 Hu1 Hv1. + apply Qeq_trans with [mul (Qq p2 n1) (Qq p1 n2)]. + rewrite spec_mul; rewrite Hu1; rewrite Hv1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; rewrite BigN.spec_mul; intros HH1. + assert (F1: BigN.to_Z u2 = 1%Z). + case (Zmult_1_inversion_l _ _ HH1); auto. + generalize (BigN.spec_pos u2); auto with zarith. + assert (F2: BigN.to_Z v2 = 1%Z). + rewrite Zmult_comm in HH1. + case (Zmult_1_inversion_l _ _ HH1); auto. + generalize (BigN.spec_pos v2); auto with zarith. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + rewrite H1 in F2; discriminate F2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2. + rewrite H2 in F1; discriminate F1. + simpl; rewrite BigZ.spec_mul. + rewrite F1; rewrite F2; simpl; ring. + rewrite Qmult_comm; rewrite <- spec_mul. + apply Qeq_refl. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; + rewrite Zmult_comm; intros H1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; intros H2; auto. + case H2; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; intros H2; auto. + case H1; auto. + Qed. + + +Definition inv (x: t): t := + match x with + | Qz (BigZ.Pos n) => Qq BigZ.one n + | Qz (BigZ.Neg n) => Qq BigZ.minus_one n + | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n + | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n + end. + + Theorem spec_inv : forall x, [inv x] == /[x]. + Proof. + intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + Qed. + +Definition inv_norm (x: t): t := + match x with + | Qz (BigZ.Pos n) => + match BigN.compare n BigN.one with + Gt => Qq BigZ.one n + | _ => x + end + | Qz (BigZ.Neg n) => + match BigN.compare n BigN.one with + Gt => Qq BigZ.minus_one n + | _ => x + end + | Qq (BigZ.Pos n) d => + match BigN.compare n BigN.one with + Gt => Qq (BigZ.Pos d) n + | Eq => Qz (BigZ.Pos d) + | Lt => Qz (BigZ.zero) + end + | Qq (BigZ.Neg n) d => + match BigN.compare n BigN.one with + Gt => Qq (BigZ.Neg d) n + | Eq => Qz (BigZ.Neg d) + | Lt => Qz (BigZ.zero) + end + end. + + Theorem spec_inv_norm : forall x, [inv_norm x] == /[x]. + Proof. + intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, Qinv. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H. + simpl; rewrite H; apply Qeq_refl. + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. + generalize H; case BigN.to_Z. + intros _ HH; discriminate HH. + intros p; case p; auto. + intros p1 HH; discriminate HH. + intros p1 HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; discriminate HH. + intros HH; rewrite <- HH. + apply Qeq_refl. + generalize H; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + rewrite H1; intros HH; discriminate. + generalize H; case BigN.to_Z. + intros HH; discriminate HH. + intros; red; simpl; auto. + intros p HH; discriminate HH. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H. + simpl; rewrite H; apply Qeq_refl. + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. + generalize H; case BigN.to_Z. + intros _ HH; discriminate HH. + intros p; case p; auto. + intros p1 HH; discriminate HH. + intros p1 HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; discriminate HH. + intros HH; rewrite <- HH. + apply Qeq_refl. + generalize H; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + rewrite H1; intros HH; discriminate. + generalize H; case BigN.to_Z. + intros HH; discriminate HH. + intros; red; simpl; auto. + intros p HH; discriminate HH. + simpl Qnum. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; simpl. + case BigN.compare; red; simpl; auto. + rewrite H1; auto. + case BigN.eq_bool; auto. + simpl; rewrite H1; auto. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H2. + rewrite H2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + red; simpl. + rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). + intros; apply Qeq_refl. + intros p; case p; clear p. + intros p HH; discriminate HH. + intros p HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + simpl; generalize H2; case (BigN.to_Z nx). + intros HH; discriminate HH. + intros p Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + rewrite H4 in H2; discriminate H2. + red; simpl. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + intros p HH; discriminate HH. + simpl Qnum. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; simpl. + case BigN.compare; red; simpl; auto. + rewrite H1; auto. + case BigN.eq_bool; auto. + simpl; rewrite H1; auto. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H2. + rewrite H2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). + intros; apply Qeq_refl. + intros p; case p; clear p. + intros p HH; discriminate HH. + intros p HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + simpl; generalize H2; case (BigN.to_Z nx). + intros HH; discriminate HH. + intros p Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + rewrite H4 in H2; discriminate H2. + red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p HH; discriminate HH. + Qed. + + Definition div x y := mul x (inv y). + + Theorem spec_div x y: [div x y] == [x] / [y]. + Proof. + intros x y; unfold div; rewrite spec_mul; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Definition div_norm x y := mul_norm x (inv y). + + Theorem spec_div_norm x y: [div_norm x y] == [x] / [y]. + Proof. + intros x y; unfold div_norm; rewrite spec_mul_norm; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Definition square (x: t): t := + match x with + | Qz zx => Qz (BigZ.square zx) + | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) + end. + + Theorem spec_square : forall x, [square x] == [x] ^ 2. + Proof. + intros [ x | nx dx]; unfold square. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + simpl Qpower. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H1; rewrite H; auto. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H; case (Zmult_integral _ _ H1); auto. + simpl. + rewrite BigZ.spec_square. + rewrite Zpos_mult_morphism. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dx); auto with zarith. + Qed. + + Definition power_pos (x: t) p: t := + match x with + | Qz zx => Qz (BigZ.power_pos zx p) + | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) + end. + + Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. + Proof. + intros [x | nx dx] p; unfold power_pos. + unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z x) 1). + unfold Qeq; simpl. + rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Zmult_1_r. + intros H; rewrite H. + rewrite BigZ.spec_power_pos; simpl; ring. + simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_power_pos; intros H1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2. + elim p; simpl. + intros; red; simpl; auto. + intros p1 Hp1; rewrite <- Hp1; red; simpl; auto. + apply Qeq_refl. + case H2; generalize H1. + elim p; simpl. + intros p1 Hrec. + change (xI p1) with (1 + (xO p1))%positive. + rewrite Zpower_pos_is_exp; rewrite Zpower_pos_1_r. + intros HH; case (Zmult_integral _ _ HH); auto. + rewrite <- Pplus_diag. + rewrite Zpower_pos_is_exp. + intros HH1; case (Zmult_integral _ _ HH1); auto. + intros p1 Hrec. + rewrite <- Pplus_diag. + rewrite Zpower_pos_is_exp. + intros HH1; case (Zmult_integral _ _ HH1); auto. + rewrite Zpower_pos_1_r; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2. + case H1; rewrite H2; auto. + simpl; rewrite Zpower_pos_0_l; auto. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). + unfold Zpower; apply Zpower_pos_pos; auto. + unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z nx) + (Z2P (BigN.to_Z dx))). + unfold Qeq; simpl. + repeat rewrite Z2P_correct; auto. + unfold Qeq; simpl; intros HH. + rewrite HH. + rewrite BigZ.spec_power_pos; simpl; ring. + Qed. + + (** Interaction with [Qcanon.Qc] *) + + Open Scope Qc_scope. + + Definition of_Qc q := of_Q (this q). + + Definition to_Qc q := !!(to_Q q). + + Notation "[[ x ]]" := (to_Qc x). + + Theorem spec_of_Qc: forall q, [[of_Qc q]] = q. + Proof. + intros (x, Hx); unfold of_Qc, to_Qc; simpl. + apply Qc_decomp; simpl. + intros. + rewrite <- H0 at 2; apply Qred_complete. + apply spec_of_Q. + Qed. + + Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. + Proof. + intros q; unfold Qcopp, to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + rewrite spec_opp. + rewrite <- Qred_opp. + rewrite Qred_correct; red; auto. + Qed. + + Theorem spec_comparec: forall q1 q2, + compare q1 q2 = ([[q1]] ?= [[q2]]). + Proof. + unfold Qccompare, to_Qc. + intros q1 q2; rewrite spec_compare; simpl; auto. + apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_addc x y: + [[add x y]] = [[x]] + [[y]]. + Proof. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_add_normc x y: + [[add_norm x y]] = [[x]] + [[y]]. + Proof. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add_norm; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. + Proof. + intros x y; unfold sub; rewrite spec_addc; auto. + rewrite spec_oppc; ring. + Qed. + + Theorem spec_sub_normc x y: + [[sub_norm x y]] = [[x]] - [[y]]. + intros x y; unfold sub_norm; rewrite spec_add_normc; auto. + rewrite spec_oppc; ring. + Qed. + + Theorem spec_mulc x y: + [[mul x y]] = [[x]] * [[y]]. + Proof. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_mul_normc x y: + [[mul_norm x y]] = [[x]] * [[y]]. + Proof. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul_norm; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_invc x: + [[inv x]] = /[[x]]. + Proof. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_inv_normc x: + [[inv_norm x]] = /[[x]]. + Proof. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv_norm; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. + Proof. + intros x y; unfold div; rewrite spec_mulc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. + Proof. + intros x y; unfold div_norm; rewrite spec_mul_normc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + Theorem spec_squarec x: [[square x]] = [[x]]^2. + Proof. + intros x; unfold to_Qc. + apply trans_equal with (!! ([x]^2)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_square; auto. + simpl Qcpower. + replace (!! [x] * 1) with (!![x]); try ring. + simpl. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Theorem spec_power_posc x p: + [[power_pos x p]] = [[x]] ^ nat_of_P p. + Proof. + intros x p; unfold to_Qc. + apply trans_equal with (!! ([x]^Zpos p)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_power_pos; auto. + pattern p; apply Pind; clear p. + simpl; ring. + intros p Hrec. + rewrite nat_of_P_succ_morphism; simpl Qcpower. + rewrite <- Hrec. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; + unfold this. + apply Qred_complete. + assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). + simpl; case x; simpl; clear x Hrec. + intros x; simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + intros nx dx. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + unfold Qpower_positive. + assert (tmp: forall p, pow_pos Qmult 0%Q p = 0%Q). + intros p1; elim p1; simpl; auto; clear p1. + intros p1 Hp1; rewrite Hp1; auto. + intros p1 Hp1; rewrite Hp1; auto. + repeat rewrite tmp; intros; red; simpl; auto. + intros H1. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + repeat rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto. + 2: apply Zpower_pos_pos; auto. + 2: apply Zpower_pos_pos; auto. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + rewrite F. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + +End Q0. diff --git a/theories/Numbers/Rational/BigQ/QMake_base.v b/theories/Numbers/Rational/BigQ/QMake_base.v new file mode 100644 index 00000000..547e74b7 --- /dev/null +++ b/theories/Numbers/Rational/BigQ/QMake_base.v @@ -0,0 +1,34 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(* $Id: QMake_base.v 10964 2008-05-22 11:08:13Z letouzey $ *) + +(** * An implementation of rational numbers based on big integers *) + +Require Export BigN. +Require Export BigZ. + +(* Basic type for Q: a Z or a pair of a Z and an N *) + +Inductive q_type := + | Qz : BigZ.t -> q_type + | Qq : BigZ.t -> BigN.t -> q_type. + +Definition print_type x := + match x with + | Qz _ => Z + | _ => (Z*Z)%type + end. + +Definition print x := + match x return print_type x with + | Qz zx => BigZ.to_Z zx + | Qq nx dx => (BigZ.to_Z nx, BigN.to_Z dx) + end. diff --git a/theories/Numbers/Rational/BigQ/QbiMake.v b/theories/Numbers/Rational/BigQ/QbiMake.v new file mode 100644 index 00000000..699f383e --- /dev/null +++ b/theories/Numbers/Rational/BigQ/QbiMake.v @@ -0,0 +1,1066 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: QbiMake.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import Arith. +Require Export BigN. +Require Export BigZ. +Require Import QArith. +Require Import Qcanon. +Require Import Qpower. +Require Import QMake_base. + +Module Qbi. + + Import BinInt Zorder. + Open Local Scope Q_scope. + Open Local Scope Qc_scope. + + (** The notation of a rational number is either an integer x, + interpreted as itself or a pair (x,y) of an integer x and a naturel + number y interpreted as x/y. The pairs (x,0) and (0,y) are all + interpreted as 0. *) + + Definition t := q_type. + + Definition zero: t := Qz BigZ.zero. + Definition one: t := Qz BigZ.one. + Definition minus_one: t := Qz BigZ.minus_one. + + Definition of_Z x: t := Qz (BigZ.of_Z x). + + + Definition of_Q q: t := + match q with x # y => + Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) + end. + + Definition of_Qc q := of_Q (this q). + + Definition to_Q (q: t) := + match q with + Qz x => BigZ.to_Z x # 1 + |Qq x y => if BigN.eq_bool y BigN.zero then 0%Q + else BigZ.to_Z x # Z2P (BigN.to_Z y) + end. + + Definition to_Qc q := !!(to_Q q). + + Notation "[[ x ]]" := (to_Qc x). + + Notation "[ x ]" := (to_Q x). + + Theorem spec_to_Q: forall q: Q, [of_Q q] = q. + intros (x,y); simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigN.spec_of_pos; intros HH; discriminate HH. + rewrite BigZ.spec_of_Z; simpl. + rewrite (BigN.spec_of_pos); auto. + Qed. + + Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. + intros (x, Hx); unfold of_Qc, to_Qc; simpl. + apply Qc_decomp; simpl. + intros; rewrite spec_to_Q; auto. + Qed. + + Definition opp (x: t): t := + match x with + | Qz zx => Qz (BigZ.opp zx) + | Qq nx dx => Qq (BigZ.opp nx) dx + end. + + Theorem spec_opp: forall q, ([opp q] = -[q])%Q. + intros [z | x y]; simpl. + rewrite BigZ.spec_opp; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigZ.spec_opp; auto. + Qed. + + Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. + intros q; unfold Qcopp, to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + rewrite spec_opp. + rewrite <- Qred_opp. + rewrite Qred_involutive; auto. + Qed. + + + Definition compare (x y: t) := + match x, y with + | Qz zx, Qz zy => BigZ.compare zx zy + | Qz zx, Qq ny dy => + if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero + else + match BigZ.cmp_sign zx ny with + | Lt => Lt + | Gt => Gt + | Eq => BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny + end + | Qq nx dx, Qz zy => + if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy + else + match BigZ.cmp_sign nx zy with + | Lt => Lt + | Gt => Gt + | Eq => BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) + end + | Qq nx dx, Qq ny dy => + match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with + | true, true => Eq + | true, false => BigZ.compare BigZ.zero ny + | false, true => BigZ.compare nx BigZ.zero + | false, false => + match BigZ.cmp_sign nx ny with + | Lt => Lt + | Gt => Gt + | Eq => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) + end + end + end. + + Theorem spec_compare: forall q1 q2, + compare q1 q2 = ([q1] ?= [q2])%Q. + intros [z1 | x1 y1] [z2 | x2 y2]; + unfold Qcompare, compare, to_Q, Qnum, Qden. + repeat rewrite Zmult_1_r. + generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + rewrite Zmult_1_r. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. + set (a := BigZ.to_Z z1); set (b := BigZ.to_Z x2); + set (c := BigN.to_Z y2); fold c in HH. + assert (F: (0 < c)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos y2)); fold c; auto. + intros H1; case HH; rewrite <- H1; auto. + rewrite Z2P_correct; auto with zarith. + generalize (BigZ.spec_cmp_sign z1 x2); case BigZ.cmp_sign; fold a b c. + intros _; generalize (BigZ.spec_compare (z1 * BigZ.Pos y2)%bigZ x2); + case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c; auto. + intros H1; rewrite H1; rewrite Zcompare_refl; auto. + intros (H1, H2); apply sym_equal; change (a * c < b)%Z. + apply Zlt_le_trans with (2 := H2). + change 0%Z with (0 * c)%Z. + apply Zmult_lt_compat_r; auto with zarith. + intros (H1, H2); apply sym_equal; change (a * c > b)%Z. + apply Zlt_gt. + apply Zlt_le_trans with (1 := H2). + change 0%Z with (0 * c)%Z. + apply Zmult_le_compat_r; auto with zarith. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero z2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. + set (a := BigZ.to_Z z2); set (b := BigZ.to_Z x1); + set (c := BigN.to_Z y1); fold c in HH. + assert (F: (0 < c)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos y1)); fold c; auto. + intros H1; case HH; rewrite <- H1; auto. + rewrite Zmult_1_r; rewrite Z2P_correct; auto with zarith. + generalize (BigZ.spec_cmp_sign x1 z2); case BigZ.cmp_sign; fold a b c. + intros _; generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1)%bigZ); + case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c; auto. + intros H1; rewrite H1; rewrite Zcompare_refl; auto. + intros (H1, H2); apply sym_equal; change (b < a * c)%Z. + apply Zlt_le_trans with (1 := H1). + change 0%Z with (0 * c)%Z. + apply Zmult_le_compat_r; auto with zarith. + intros (H1, H2); apply sym_equal; change (b > a * c)%Z. + apply Zlt_gt. + apply Zlt_le_trans with (2 := H1). + change 0%Z with (0 * c)%Z. + apply Zmult_lt_compat_r; auto with zarith. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zcompare_refl; auto. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero x2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; + auto; rewrite BigZ.spec_0. + intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + set (a := BigZ.to_Z x1); set (b := BigZ.to_Z x2); + set (c1 := BigN.to_Z y1); set (c2 := BigN.to_Z y2). + fold c1 in HH; fold c2 in HH1. + assert (F1: (0 < c1)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos y1)); fold c1; auto. + intros H1; case HH; rewrite <- H1; auto. + assert (F2: (0 < c2)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos y2)); fold c2; auto. + intros H1; case HH1; rewrite <- H1; auto. + repeat rewrite Z2P_correct; auto. + generalize (BigZ.spec_cmp_sign x1 x2); case BigZ.cmp_sign. + intros _; generalize (BigZ.spec_compare (x1 * BigZ.Pos y2)%bigZ + (x2 * BigZ.Pos y1)%bigZ); + case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c1 c2; auto. + rewrite BigZ.spec_mul; simpl; fold a b c1; intros HH2; rewrite HH2; + rewrite Zcompare_refl; auto. + rewrite BigZ.spec_mul; simpl; auto. + rewrite BigZ.spec_mul; simpl; auto. + fold a b; intros (H1, H2); apply sym_equal; change (a * c2 < b * c1)%Z. + apply Zlt_le_trans with 0%Z. + change 0%Z with (0 * c2)%Z. + apply Zmult_lt_compat_r; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + fold a b; intros (H1, H2); apply sym_equal; change (a * c2 > b * c1)%Z. + apply Zlt_gt; apply Zlt_le_trans with 0%Z. + change 0%Z with (0 * c1)%Z. + apply Zmult_lt_compat_r; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + Qed. + + + Definition do_norm_n n := + match n with + | BigN.N0 _ => false + | BigN.N1 _ => false + | BigN.N2 _ => false + | BigN.N3 _ => false + | BigN.N4 _ => false + | BigN.N5 _ => false + | BigN.N6 _ => false + | _ => true + end. + + Definition do_norm_z z := + match z with + | BigZ.Pos n => do_norm_n n + | BigZ.Neg n => do_norm_n n + end. + +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d: t := + if andb (do_norm_z n) (do_norm_n d) then + let gcd := BigN.gcd (BigZ.to_N n) d in + match BigN.compare BigN.one gcd with + | Lt => + let n := BigZ.div n (BigZ.Pos gcd) in + let d := BigN.div d gcd in + match BigN.compare d BigN.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end + else Qq n d. + + Theorem spec_norm: forall n q, + ([norm n q] == [Qq n q])%Q. + intros p q; unfold norm. + case do_norm_z; simpl andb. + 2: apply Qeq_refl. + case do_norm_n. + 2: apply Qeq_refl. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. + apply Qeq_refl. + generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl; + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + auto with zarith. + generalize H2; rewrite H3; + rewrite Zdiv_0_l; auto with zarith. + generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. + rewrite spec_to_N. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl. + case H3. + generalize H1 H2 H3 HH; clear H1 H2 H3 HH. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 HH. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. + case (Zle_lt_or_eq _ _ HH); auto with zarith. + intros HH1; rewrite <- HH1; ring. + generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H3. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H4. + case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. + simpl. + assert (FF := BigN.spec_pos q). + rewrite Z2P_correct; auto with zarith. + rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. + simpl; rewrite BigZ.spec_div; simpl. + rewrite BigN.spec_gcd; auto with zarith. + generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4 HH FF. + rewrite spec_to_N; fold a. + rewrite Zgcd_div_swap; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); + rewrite BigN.spec_gcd; auto with zarith. + intros; apply False_ind; auto with zarith. + intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2; simpl. + rewrite spec_to_N. + rewrite FF2; ring. + Qed. + + Definition add (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + if BigN.eq_bool dx dy then + let n := BigZ.add nx ny in + Qq n dx + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + Qq n d + end + end. + + + + Theorem spec_add x y: + ([add x y] == [x] + [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. + rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + assert (F1:= BigN.spec_pos dy). + rewrite Zmult_1_r; red; simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + rewrite Zmult_1_r; rewrite Pmult_1_r. + apply Qeq_refl. + assert (F1:= BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + case HH2; auto. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH2; auto. + case HH1; auto. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH; auto. + rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. + apply Qeq_refl. + simpl. + generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_mul; + rewrite BigN.spec_0; intros HH2. + (case (Zmult_integral _ _ HH2); intros HH3); + [case HH| case HH1]; auto. + generalize (BigN.spec_eq_bool dx dy); + case BigN.eq_bool; intros HH3. + rewrite <- HH3. + assert (Fx: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + red; simpl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH4. + case HH; auto. + simpl; rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. + ring. + assert (Fx: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (Fy: (0 < BigN.to_Z dy)%Z). + generalize (BigN.spec_pos dy); auto with zarith. + red; simpl; rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_mul; + rewrite BigN.spec_0; intros H3; simpl. + absurd (0 < 0)%Z; auto with zarith. + rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. + repeat rewrite Z2P_correct; auto with zarith. + apply Zmult_lt_0_compat; auto. + Qed. + + Theorem spec_addc x y: + [[add x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition add_norm (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + if BigN.eq_bool dx dy then + let n := BigZ.add nx ny in + norm n dx + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + norm n d + end + end. + + Theorem spec_add_norm x y: + ([add_norm x y] == [x] + [y])%Q. + intros x y; rewrite <- spec_add; auto. + case x; case y; clear x y; unfold add_norm, add. + intros; apply Qeq_refl. + intros p1 n p2. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + simpl. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + apply Qeq_refl. + intros p1 p2 n. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + apply Qeq_refl. + intros p1 q1 p2 q2. + generalize (BigN.spec_eq_bool q2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + generalize (BigN.spec_eq_bool q1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; intros HH3; + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; apply Qeq_refl. + Qed. + + Theorem spec_add_normc x y: + [[add_norm x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add_norm; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition sub x y := add x (opp y). + + Theorem spec_sub x y: + ([sub x y] == [x] - [y])%Q. + intros x y; unfold sub; rewrite spec_add; auto. + rewrite spec_opp; ring. + Qed. + + Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. + intros x y; unfold sub; rewrite spec_addc; auto. + rewrite spec_oppc; ring. + Qed. + + Definition sub_norm x y := add_norm x (opp y). + + Theorem spec_sub_norm x y: + ([sub_norm x y] == [x] - [y])%Q. + intros x y; unfold sub_norm; rewrite spec_add_norm; auto. + rewrite spec_opp; ring. + Qed. + + Theorem spec_sub_normc x y: + [[sub_norm x y]] = [[x]] - [[y]]. + intros x y; unfold sub_norm; rewrite spec_add_normc; auto. + rewrite spec_oppc; ring. + Qed. + + Definition mul (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. + rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; rewrite Pmult_1_r. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; + intros HH1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + red; simpl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + red; simpl; ring. + case (Zmult_integral _ _ HH1); intros HH. + case HH2; auto. + case HH3; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + case HH1; rewrite HH2; ring. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + case HH1; rewrite HH3; ring. + rewrite BigZ.spec_mul. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + apply Qeq_refl. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dy); auto with zarith. + Qed. + + Theorem spec_mulc x y: + [[mul x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition mul_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => mul (Qz ny) (norm zx dy) + | Qq nx dx, Qz zy => mul (Qz nx) (norm zy dx) + | Qq nx dx, Qq ny dy => mul (norm nx dy) (norm ny dx) + end. + + Theorem spec_mul_norm x y: + ([mul_norm x y] == [x] * [y])%Q. + intros x y; rewrite <- spec_mul; auto. + unfold mul_norm; case x; case y; clear x y. + intros; apply Qeq_refl. + intros p1 n p2. + repeat rewrite spec_mul. + match goal with |- ?Z == _ => + match Z with context id [norm ?X ?Y] => + let y := context id [Qq X Y] in + apply Qeq_trans with y; [repeat apply Qmult_comp; + repeat apply Qplus_comp; repeat apply Qeq_refl; + apply spec_norm | idtac] + end + end. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH; simpl; ring. + intros p1 p2 n. + repeat rewrite spec_mul. + match goal with |- ?Z == _ => + match Z with context id [norm ?X ?Y] => + let y := context id [Qq X Y] in + apply Qeq_trans with y; [repeat apply Qmult_comp; + repeat apply Qplus_comp; repeat apply Qeq_refl; + apply spec_norm | idtac] + end + end. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH; simpl; try ring. + rewrite Pmult_1_r; auto. + intros p1 n1 p2 n2. + repeat rewrite spec_mul. + repeat match goal with |- ?Z == _ => + match Z with context id [norm ?X ?Y] => + let y := context id [Qq X Y] in + apply Qeq_trans with y; [repeat apply Qmult_comp; + repeat apply Qplus_comp; repeat apply Qeq_refl; + apply spec_norm | idtac] + end + end. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; try ring. + repeat rewrite Zpos_mult_morphism; ring. + Qed. + + Theorem spec_mul_normc x y: + [[mul_norm x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul_norm; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition inv (x: t): t := + match x with + | Qz (BigZ.Pos n) => Qq BigZ.one n + | Qz (BigZ.Neg n) => Qq BigZ.minus_one n + | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n + | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n + end. + + + Theorem spec_inv x: + ([inv x] == /[x])%Q. + intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + Qed. + + Theorem spec_invc x: + [[inv x]] = /[[x]]. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition inv_norm (x: t): t := + match x with + | Qz (BigZ.Pos n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one n + | Qz (BigZ.Neg n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one n + | Qq (BigZ.Pos n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos d) n + | Qq (BigZ.Neg n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg d) n + end. + + Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. + intros x; rewrite <- spec_inv; generalize x; clear x. + intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, inv; + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; try apply Qeq_refl; + red; simpl; + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; auto; + case H2; auto. + Qed. + + Theorem spec_inv_normc x: + [[inv_norm x]] = /[[x]]. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv_norm; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + Definition div x y := mul x (inv y). + + Theorem spec_div x y: ([div x y] == [x] / [y])%Q. + intros x y; unfold div; rewrite spec_mul; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. + intros x y; unfold div; rewrite spec_mulc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + Definition div_norm x y := mul_norm x (inv y). + + Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. + intros x y; unfold div_norm; rewrite spec_mul_norm; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. + intros x y; unfold div_norm; rewrite spec_mul_normc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + + Definition square (x: t): t := + match x with + | Qz zx => Qz (BigZ.square zx) + | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) + end. + + + Theorem spec_square x: ([square x] == [x] ^ 2)%Q. + intros [ x | nx dx]; unfold square. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + simpl Qpower. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H1; rewrite H; auto. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H; case (Zmult_integral _ _ H1); auto. + simpl. + rewrite BigZ.spec_square. + rewrite Zpos_mult_morphism. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dx); auto with zarith. + Qed. + + Theorem spec_squarec x: [[square x]] = [[x]]^2. + intros x; unfold to_Qc. + apply trans_equal with (!! ([x]^2)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_square; auto. + simpl Qcpower. + replace (!! [x] * 1) with (!![x]); try ring. + simpl. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition power_pos (x: t) p: t := + match x with + | Qz zx => Qz (BigZ.power_pos zx p) + | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) + end. + + Theorem spec_power_pos x p: ([power_pos x p] == [x] ^ Zpos p)%Q. + Proof. + intros [x | nx dx] p; unfold power_pos. + unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z x) 1). + unfold Qeq; simpl. + rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Zmult_1_r. + intros H; rewrite H. + rewrite BigZ.spec_power_pos; simpl; ring. + simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_power_pos; intros H1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2. + elim p; simpl. + intros; red; simpl; auto. + intros p1 Hp1; rewrite <- Hp1; red; simpl; auto. + apply Qeq_refl. + case H2; generalize H1. + elim p; simpl. + intros p1 Hrec. + change (xI p1) with (1 + (xO p1))%positive. + rewrite Zpower_pos_is_exp; rewrite Zpower_pos_1_r. + intros HH; case (Zmult_integral _ _ HH); auto. + rewrite <- Pplus_diag. + rewrite Zpower_pos_is_exp. + intros HH1; case (Zmult_integral _ _ HH1); auto. + intros p1 Hrec. + rewrite <- Pplus_diag. + rewrite Zpower_pos_is_exp. + intros HH1; case (Zmult_integral _ _ HH1); auto. + rewrite Zpower_pos_1_r; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2. + case H1; rewrite H2; auto. + simpl; rewrite Zpower_pos_0_l; auto. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). + unfold Zpower; apply Zpower_pos_pos; auto. + unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z nx) + (Z2P (BigN.to_Z dx))). + unfold Qeq; simpl. + repeat rewrite Z2P_correct; auto. + unfold Qeq; simpl; intros HH. + rewrite HH. + rewrite BigZ.spec_power_pos; simpl; ring. + Qed. + + Theorem spec_power_posc x p: + [[power_pos x p]] = [[x]] ^ nat_of_P p. + intros x p; unfold to_Qc. + apply trans_equal with (!! ([x]^Zpos p)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_power_pos; auto. + pattern p; apply Pind; clear p. + simpl; ring. + intros p Hrec. + rewrite nat_of_P_succ_morphism; simpl Qcpower. + rewrite <- Hrec. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; + unfold this. + apply Qred_complete. + assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). + simpl; case x; simpl; clear x Hrec. + intros x; simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + intros nx dx. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + unfold Qpower_positive. + assert (tmp: forall p, pow_pos Qmult 0%Q p = 0%Q). + intros p1; elim p1; simpl; auto; clear p1. + intros p1 Hp1; rewrite Hp1; auto. + intros p1 Hp1; rewrite Hp1; auto. + repeat rewrite tmp; intros; red; simpl; auto. + intros H1. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + repeat rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto. + 2: apply Zpower_pos_pos; auto. + 2: apply Zpower_pos_pos; auto. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + rewrite F. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + +End Qbi. diff --git a/theories/Numbers/Rational/BigQ/QifMake.v b/theories/Numbers/Rational/BigQ/QifMake.v new file mode 100644 index 00000000..1d8ecc94 --- /dev/null +++ b/theories/Numbers/Rational/BigQ/QifMake.v @@ -0,0 +1,979 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: QifMake.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import Arith. +Require Export BigN. +Require Export BigZ. +Require Import QArith. +Require Import Qcanon. +Require Import Qpower. +Require Import QMake_base. + +Module Qif. + + Import BinInt. + Open Local Scope Q_scope. + Open Local Scope Qc_scope. + + (** The notation of a rational number is either an integer x, + interpreted as itself or a pair (x,y) of an integer x and a naturel + number y interpreted as x/y. The pairs (x,0) and (0,y) are all + interpreted as 0. *) + + Definition t := q_type. + + Definition zero: t := Qz BigZ.zero. + Definition one: t := Qz BigZ.one. + Definition minus_one: t := Qz BigZ.minus_one. + + Definition of_Z x: t := Qz (BigZ.of_Z x). + + Definition of_Q q: t := + match q with x # y => + Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) + end. + + Definition of_Qc q := of_Q (this q). + + Definition to_Q (q: t) := + match q with + Qz x => BigZ.to_Z x # 1 + |Qq x y => if BigN.eq_bool y BigN.zero then 0%Q + else BigZ.to_Z x # Z2P (BigN.to_Z y) + end. + + Definition to_Qc q := !!(to_Q q). + + Notation "[[ x ]]" := (to_Qc x). + + Notation "[ x ]" := (to_Q x). + + Theorem spec_to_Q: forall q: Q, [of_Q q] = q. + intros (x,y); simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigN.spec_of_pos; intros HH; discriminate HH. + rewrite BigZ.spec_of_Z; simpl. + rewrite (BigN.spec_of_pos); auto. + Qed. + + Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. + intros (x, Hx); unfold of_Qc, to_Qc; simpl. + apply Qc_decomp; simpl. + intros; rewrite spec_to_Q; auto. + Qed. + + Definition opp (x: t): t := + match x with + | Qz zx => Qz (BigZ.opp zx) + | Qq nx dx => Qq (BigZ.opp nx) dx + end. + + Theorem spec_opp: forall q, ([opp q] = -[q])%Q. + intros [z | x y]; simpl. + rewrite BigZ.spec_opp; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigZ.spec_opp; auto. + Qed. + + Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. + intros q; unfold Qcopp, to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + rewrite spec_opp. + rewrite <- Qred_opp. + rewrite Qred_involutive; auto. + Qed. + + Definition compare (x y: t) := + match x, y with + | Qz zx, Qz zy => BigZ.compare zx zy + | Qz zx, Qq ny dy => + if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero + else BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny + | Qq nx dx, Qz zy => + if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy + else BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) + | Qq nx dx, Qq ny dy => + match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with + | true, true => Eq + | true, false => BigZ.compare BigZ.zero ny + | false, true => BigZ.compare nx BigZ.zero + | false, false => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) + end + end. + + Theorem spec_compare: forall q1 q2, + compare q1 q2 = ([q1] ?= [q2])%Q. + intros [z1 | x1 y1] [z2 | x2 y2]; + unfold Qcompare, compare, to_Q, Qnum, Qden. + repeat rewrite Zmult_1_r. + generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + rewrite Zmult_1_r. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero z2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y1); auto with zarith. + rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zcompare_refl; auto. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare BigZ.zero x2); + case BigZ.compare; auto. + rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + rewrite Zmult_0_l; rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; + auto; rewrite BigZ.spec_0. + intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. + repeat rewrite Z2P_correct. + 2: generalize (BigN.spec_pos y1); auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) + (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + Qed. + + Definition do_norm_n n := + match n with + | BigN.N0 _ => false + | BigN.N1 _ => false + | BigN.N2 _ => false + | BigN.N3 _ => false + | BigN.N4 _ => false + | BigN.N5 _ => false + | BigN.N6 _ => false + | _ => true + end. + + Definition do_norm_z z := + match z with + | BigZ.Pos n => do_norm_n n + | BigZ.Neg n => do_norm_n n + end. + +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d: t := + if andb (do_norm_z n) (do_norm_n d) then + let gcd := BigN.gcd (BigZ.to_N n) d in + match BigN.compare BigN.one gcd with + | Lt => + let n := BigZ.div n (BigZ.Pos gcd) in + let d := BigN.div d gcd in + match BigN.compare d BigN.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end + else Qq n d. + + Theorem spec_norm: forall n q, + ([norm n q] == [Qq n q])%Q. + intros p q; unfold norm. + case do_norm_z; simpl andb. + 2: apply Qeq_refl. + case do_norm_n. + 2: apply Qeq_refl. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. + apply Qeq_refl. + generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl; + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + auto with zarith. + generalize H2; rewrite H3; + rewrite Zdiv_0_l; auto with zarith. + generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. + rewrite spec_to_N. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H3; simpl. + case H3. + generalize H1 H2 H3 HH; clear H1 H2 H3 HH. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 HH. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. + case (Zle_lt_or_eq _ _ HH); auto with zarith. + intros HH1; rewrite <- HH1; ring. + generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith; intros H3. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H4. + case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. + simpl. + assert (FF := BigN.spec_pos q). + rewrite Z2P_correct; auto with zarith. + rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. + simpl; rewrite BigZ.spec_div; simpl. + rewrite BigN.spec_gcd; auto with zarith. + generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. + set (a := (BigN.to_Z (BigZ.to_N p))). + set (b := (BigN.to_Z q)). + intros H1 H2 H3 H4 HH FF. + rewrite spec_to_N; fold a. + rewrite Zgcd_div_swap; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_div; + rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_gcd; auto with zarith. + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); + rewrite BigN.spec_gcd; auto with zarith. + intros; apply False_ind; auto with zarith. + intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). + red; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H2; simpl. + rewrite spec_to_N. + rewrite FF2; ring. + Qed. + + + Definition add (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + Qq n d + end + end. + + + Theorem spec_add x y: + ([add x y] == [x] + [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. + rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + assert (F1:= BigN.spec_pos dy). + rewrite Zmult_1_r; red; simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH; simpl; try ring. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; + rewrite BigN.spec_0; intros HH1; simpl; try ring. + case HH; auto. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. + rewrite Zmult_1_r; rewrite Pmult_1_r. + apply Qeq_refl. + assert (F1:= BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + case HH2; auto. + simpl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH2; auto. + case HH1; auto. + rewrite Zmult_1_r; apply Qeq_refl. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + simpl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + case HH; auto. + rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. + apply Qeq_refl. + simpl. + generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_mul; + rewrite BigN.spec_0; intros HH2. + (case (Zmult_integral _ _ HH2); intros HH3); + [case HH| case HH1]; auto. + rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. + assert (Fx: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (Fy: (0 < BigN.to_Z dy)%Z). + generalize (BigN.spec_pos dy); auto with zarith. + red; simpl; rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + apply Zmult_lt_0_compat; auto. + Qed. + + Theorem spec_addc x y: + [[add x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition add_norm (x y: t): t := + match x with + | Qz zx => + match y with + | Qz zy => Qz (BigZ.add zx zy) + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + end + | Qq nx dx => + if BigN.eq_bool dx BigN.zero then y + else match y with + | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq ny dy => + if BigN.eq_bool dy BigN.zero then x + else + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + norm n d + end + end. + + Theorem spec_add_norm x y: + ([add_norm x y] == [x] + [y])%Q. + intros x y; rewrite <- spec_add; auto. + case x; case y; clear x y; unfold add_norm, add. + intros; apply Qeq_refl. + intros p1 n p2. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + simpl. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + apply Qeq_refl. + intros p1 p2 n. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + apply Qeq_refl. + intros p1 q1 p2 q2. + generalize (BigN.spec_eq_bool q2 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. + apply Qeq_refl. + generalize (BigN.spec_eq_bool q1 BigN.zero); + case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. + apply Qeq_refl. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + apply Qeq_refl. + Qed. + + Theorem spec_add_normc x y: + [[add_norm x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add_norm; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition sub x y := add x (opp y). + + + Theorem spec_sub x y: + ([sub x y] == [x] - [y])%Q. + intros x y; unfold sub; rewrite spec_add; auto. + rewrite spec_opp; ring. + Qed. + + Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. + intros x y; unfold sub; rewrite spec_addc; auto. + rewrite spec_oppc; ring. + Qed. + + Definition sub_norm x y := add_norm x (opp y). + + Theorem spec_sub_norm x y: + ([sub_norm x y] == [x] - [y])%Q. + intros x y; unfold sub_norm; rewrite spec_add_norm; auto. + rewrite spec_opp; ring. + Qed. + + Theorem spec_sub_normc x y: + [[sub_norm x y]] = [[x]] - [[y]]. + intros x y; unfold sub_norm; rewrite spec_add_normc; auto. + rewrite spec_oppc; ring. + Qed. + + Definition mul (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + + Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. + rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH1. + red; simpl; ring. + rewrite BigZ.spec_mul; rewrite Pmult_1_r. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; rewrite BigN.spec_mul; + intros HH1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + red; simpl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + red; simpl; ring. + case (Zmult_integral _ _ HH1); intros HH. + case HH2; auto. + case HH3; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH2. + case HH1; rewrite HH2; ring. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros HH3. + case HH1; rewrite HH3; ring. + rewrite BigZ.spec_mul. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + apply Qeq_refl. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dy); auto with zarith. + Qed. + + Theorem spec_mulc x y: + [[mul x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + Definition mul_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => norm (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => norm (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => norm (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + Theorem spec_mul_norm x y: + ([mul_norm x y] == [x] * [y])%Q. + intros x y; rewrite <- spec_mul; auto. + unfold mul_norm, mul; case x; case y; clear x y. + intros; apply Qeq_refl. + intros p1 n p2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; apply Qeq_refl. + intros p1 p2 n. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; apply Qeq_refl. + intros p1 n1 p2 n2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; apply Qeq_refl. + Qed. + + Theorem spec_mul_normc x y: + [[mul_norm x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul_norm; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + + Definition inv (x: t): t := + match x with + | Qz (BigZ.Pos n) => Qq BigZ.one n + | Qz (BigZ.Neg n) => Qq BigZ.minus_one n + | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n + | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n + end. + + Theorem spec_inv x: + ([inv x] == /[x])%Q. + intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + rewrite H1; apply Qeq_refl. + generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl; auto. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + apply Qeq_refl. + rewrite H1; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H2; simpl; auto. + rewrite H2; red; simpl; auto. + generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; + auto. + intros HH; case HH; auto. + intros; red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p _ HH; case HH; auto. + Qed. + + Theorem spec_invc x: + [[inv x]] = /[[x]]. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + +Definition inv_norm (x: t): t := + match x with + | Qz (BigZ.Pos n) => + match BigN.compare n BigN.one with + Gt => Qq BigZ.one n + | _ => x + end + | Qz (BigZ.Neg n) => + match BigN.compare n BigN.one with + Gt => Qq BigZ.minus_one n + | _ => x + end + | Qq (BigZ.Pos n) d => + match BigN.compare n BigN.one with + Gt => Qq (BigZ.Pos d) n + | Eq => Qz (BigZ.Pos d) + | Lt => Qz (BigZ.zero) + end + | Qq (BigZ.Neg n) d => + match BigN.compare n BigN.one with + Gt => Qq (BigZ.Neg d) n + | Eq => Qz (BigZ.Neg d) + | Lt => Qz (BigZ.zero) + end + end. + + Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. + intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, Qinv. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H. + simpl; rewrite H; apply Qeq_refl. + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. + generalize H; case BigN.to_Z. + intros _ HH; discriminate HH. + intros p; case p; auto. + intros p1 HH; discriminate HH. + intros p1 HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; discriminate HH. + intros HH; rewrite <- HH. + apply Qeq_refl. + generalize H; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + rewrite H1; intros HH; discriminate. + generalize H; case BigN.to_Z. + intros HH; discriminate HH. + intros; red; simpl; auto. + intros p HH; discriminate HH. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H. + simpl; rewrite H; apply Qeq_refl. + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. + generalize H; case BigN.to_Z. + intros _ HH; discriminate HH. + intros p; case p; auto. + intros p1 HH; discriminate HH. + intros p1 HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; discriminate HH. + intros HH; rewrite <- HH. + apply Qeq_refl. + generalize H; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + rewrite H1; intros HH; discriminate. + generalize H; case BigN.to_Z. + intros HH; discriminate HH. + intros; red; simpl; auto. + intros p HH; discriminate HH. + simpl Qnum. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; simpl. + case BigN.compare; red; simpl; auto. + rewrite H1; auto. + case BigN.eq_bool; auto. + simpl; rewrite H1; auto. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H2. + rewrite H2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + red; simpl. + rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). + intros; apply Qeq_refl. + intros p; case p; clear p. + intros p HH; discriminate HH. + intros p HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + simpl; generalize H2; case (BigN.to_Z nx). + intros HH; discriminate HH. + intros p Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + rewrite H4 in H2; discriminate H2. + red; simpl. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + intros p HH; discriminate HH. + simpl Qnum. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1; simpl. + case BigN.compare; red; simpl; auto. + rewrite H1; auto. + case BigN.eq_bool; auto. + simpl; rewrite H1; auto. + match goal with |- context[BigN.compare ?X ?Y] => + generalize (BigN.spec_compare X Y); case BigN.compare + end; rewrite BigN.spec_1; intros H2. + rewrite H2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. + generalize (BigN.spec_pos dx); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). + intros; apply Qeq_refl. + intros p; case p; clear p. + intros p HH; discriminate HH. + intros p HH; discriminate HH. + intros HH; discriminate HH. + intros p _ HH; case HH; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H3. + case H1; auto. + simpl; generalize H2; case (BigN.to_Z nx). + intros HH; discriminate HH. + intros p Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H4. + rewrite H4 in H2; discriminate H2. + red; simpl. + assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. + rewrite tmp. + rewrite Zpos_mult_morphism. + rewrite Z2P_correct; auto. + ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p HH; discriminate HH. + Qed. + + Theorem spec_inv_normc x: + [[inv_norm x]] = /[[x]]. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv_norm; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + Definition div x y := mul x (inv y). + + Theorem spec_div x y: ([div x y] == [x] / [y])%Q. + intros x y; unfold div; rewrite spec_mul; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. + intros x y; unfold div; rewrite spec_mulc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + Definition div_norm x y := mul_norm x (inv y). + + Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. + intros x y; unfold div_norm; rewrite spec_mul_norm; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. + intros x y; unfold div_norm; rewrite spec_mul_normc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + + Definition square (x: t): t := + match x with + | Qz zx => Qz (BigZ.square zx) + | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) + end. + + Theorem spec_square x: ([square x] == [x] ^ 2)%Q. + intros [ x | nx dx]; unfold square. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + simpl Qpower. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; intros H. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H1; rewrite H; auto. + red; simpl. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; + intros H1. + case H; case (Zmult_integral _ _ H1); auto. + simpl. + rewrite BigZ.spec_square. + rewrite Zpos_mult_morphism. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dx); auto with zarith. + Qed. + + Theorem spec_squarec x: [[square x]] = [[x]]^2. + intros x; unfold to_Qc. + apply trans_equal with (!! ([x]^2)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_square; auto. + simpl Qcpower. + replace (!! [x] * 1) with (!![x]); try ring. + simpl. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + +End Qif. diff --git a/theories/Numbers/Rational/BigQ/QpMake.v b/theories/Numbers/Rational/BigQ/QpMake.v new file mode 100644 index 00000000..ac3ca47a --- /dev/null +++ b/theories/Numbers/Rational/BigQ/QpMake.v @@ -0,0 +1,901 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: QpMake.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import Arith. +Require Export BigN. +Require Export BigZ. +Require Import QArith. +Require Import Qcanon. +Require Import Qpower. +Require Import QMake_base. + +Notation Nspec_lt := BigNAxiomsMod.NZOrdAxiomsMod.spec_lt. +Notation Nspec_le := BigNAxiomsMod.NZOrdAxiomsMod.spec_le. + +Module Qp. + + (** The notation of a rational number is either an integer x, + interpreted as itself or a pair (x,y) of an integer x and a naturel + number y interpreted as x/(y+1). *) + + Definition t := q_type. + + Definition zero: t := Qz BigZ.zero. + Definition one: t := Qz BigZ.one. + Definition minus_one: t := Qz BigZ.minus_one. + + Definition of_Z x: t := Qz (BigZ.of_Z x). + + Definition d_to_Z d := BigZ.Pos (BigN.succ d). + + Definition of_Q q: t := + match q with x # y => + Qq (BigZ.of_Z x) (BigN.pred (BigN.of_N (Npos y))) + end. + + Definition of_Qc q := of_Q (this q). + + Definition to_Q (q: t) := + match q with + Qz x => BigZ.to_Z x # 1 + |Qq x y => BigZ.to_Z x # Z2P (BigN.to_Z (BigN.succ y)) + end. + + Definition to_Qc q := !!(to_Q q). + + Notation "[[ x ]]" := (to_Qc x). + + Notation "[ x ]" := (to_Q x). + + Theorem spec_to_Q: forall q: Q, [of_Q q] = q. + intros (x,y); simpl. + rewrite BigZ.spec_of_Z; auto. + rewrite BigN.spec_succ; simpl. simpl. + rewrite BigN.spec_pred; rewrite (BigN.spec_of_pos). + replace (Zpos y - 1 + 1)%Z with (Zpos y); auto; ring. + red; auto. + Qed. + + Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. + intros (x, Hx); unfold of_Qc, to_Qc; simpl. + apply Qc_decomp; simpl. + intros; rewrite spec_to_Q; auto. + Qed. + + Definition opp (x: t): t := + match x with + | Qz zx => Qz (BigZ.opp zx) + | Qq nx dx => Qq (BigZ.opp nx) dx + end. + + + Theorem spec_opp: forall q, ([opp q] = -[q])%Q. + intros [z | x y]; simpl. + rewrite BigZ.spec_opp; auto. + rewrite BigZ.spec_opp; auto. + Qed. + + + Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. + intros q; unfold Qcopp, to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + rewrite spec_opp. + rewrite <- Qred_opp. + rewrite Qred_involutive; auto. + Qed. + + Definition compare (x y: t) := + match x, y with + | Qz zx, Qz zy => BigZ.compare zx zy + | Qz zx, Qq ny dy => BigZ.compare (BigZ.mul zx (d_to_Z dy)) ny + | Qq nx dy, Qz zy => BigZ.compare nx (BigZ.mul zy (d_to_Z dy)) + | Qq nx dx, Qq ny dy => + BigZ.compare (BigZ.mul nx (d_to_Z dy)) (BigZ.mul ny (d_to_Z dx)) + end. + + Theorem spec_compare: forall q1 q2, + compare q1 q2 = ([q1] ?= [q2])%Q. + intros [z1 | x1 y1] [z2 | x2 y2]; unfold Qcompare; simpl. + repeat rewrite Zmult_1_r. + generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + rewrite Zmult_1_r. + rewrite BigN.spec_succ. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (z1 * d_to_Z y2) x2)%bigZ; case BigZ.compare; + intros H; rewrite <- H. + rewrite BigZ.spec_mul; unfold d_to_Z; simpl. + rewrite BigN.spec_succ. + rewrite Zcompare_refl; auto. + rewrite BigZ.spec_mul; unfold d_to_Z; simpl. + rewrite BigN.spec_succ; auto. + rewrite BigZ.spec_mul; unfold d_to_Z; simpl. + rewrite BigN.spec_succ; auto. + rewrite Zmult_1_r. + rewrite BigN.spec_succ. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y1); auto with zarith. + generalize (BigZ.spec_compare x1 (z2 * d_to_Z y1))%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; unfold d_to_Z; simpl; + rewrite BigN.spec_succ; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + repeat rewrite BigN.spec_succ; auto. + repeat rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y1); auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (x1 * d_to_Z y2) + (x2 * d_to_Z y1))%bigZ; case BigZ.compare; + repeat rewrite BigZ.spec_mul; unfold d_to_Z; simpl; + repeat rewrite BigN.spec_succ; intros H; auto. + rewrite H; auto. + rewrite Zcompare_refl; auto. + Qed. + + + Theorem spec_comparec: forall q1 q2, + compare q1 q2 = ([[q1]] ?= [[q2]]). + unfold Qccompare, to_Qc. + intros q1 q2; rewrite spec_compare; simpl. + apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. + Qed. + +(* Inv d > 0, Pour la forme normal unique on veut d > 1 *) + Definition norm n d: t := + if BigZ.eq_bool n BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N n) d in + if BigN.eq_bool gcd BigN.one then Qq n (BigN.pred d) + else + let n := BigZ.div n (BigZ.Pos gcd) in + let d := BigN.div d gcd in + if BigN.eq_bool d BigN.one then Qz n + else Qq n (BigN.pred d). + + Theorem spec_norm: forall n q, + ((0 < BigN.to_Z q)%Z -> [norm n q] == [Qq n (BigN.pred q)])%Q. + intros p q; unfold norm; intros Hq. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto; rewrite BigZ.spec_0; intros H1. + red; simpl; rewrite H1; ring. + case (Zle_lt_or_eq _ _ Hp); clear Hp; intros Hp. + case (Zle_lt_or_eq _ _ + (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p)) (BigN.to_Z q))); intros H4. + 2: generalize Hq; rewrite (Zgcd_inv_0_r _ _ (sym_equal H4)); auto with zarith. + 2: red; simpl; auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1; intros H2. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1. + red; simpl. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Zmult_1_r. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N; intros; rewrite Zgcd_div_swap; auto. + rewrite H; ring. + intros H3. + red; simpl. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + assert (F: (0 < BigN.to_Z (q / BigN.gcd (BigZ.to_N p) q)%bigN)%Z). + rewrite BigN.spec_div; auto with zarith. + rewrite BigN.spec_gcd. + apply Zgcd_div_pos; auto. + rewrite BigN.spec_gcd; auto. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite Z2P_correct; auto. + rewrite Z2P_correct; auto. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite spec_to_N; apply Zgcd_div_swap; auto. + case H1; rewrite spec_to_N; rewrite <- Hp; ring. + Qed. + + Theorem spec_normc: forall n q, + (0 < BigN.to_Z q)%Z -> [[norm n q]] = [[Qq n (BigN.pred q)]]. + intros n q H; unfold to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_norm; auto. + Qed. + + Definition add (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.add zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.add (BigZ.mul zx (d_to_Z dy)) ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.add nx (BigZ.mul zy (d_to_Z dx))) dx + | Qq nx dx, Qq ny dy => + let dx' := BigN.succ dx in + let dy' := BigN.succ dy in + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy')) (BigZ.mul ny (BigZ.Pos dx')) in + let d := BigN.pred (BigN.mul dx' dy') in + Qq n d + end. + + Theorem spec_d_to_Z: forall dy, + (BigZ.to_Z (d_to_Z dy) = BigN.to_Z dy + 1)%Z. + intros dy; unfold d_to_Z; simpl. + rewrite BigN.spec_succ; auto. + Qed. + + Theorem spec_succ_pos: forall p, + (0 < BigN.to_Z (BigN.succ p))%Z. + intros p; rewrite BigN.spec_succ; + generalize (BigN.spec_pos p); auto with zarith. + Qed. + + Theorem spec_add x y: ([add x y] == [x] + [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. + rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. + apply Qeq_refl; auto. + assert (F1:= BigN.spec_pos dy). + rewrite Zmult_1_r. + simpl; rewrite Z2P_correct; rewrite BigN.spec_succ; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul. + rewrite spec_d_to_Z; apply Qeq_refl. + assert (F1:= BigN.spec_pos dx). + rewrite Zmult_1_r; rewrite Pmult_1_r. + simpl; rewrite Z2P_correct; rewrite BigN.spec_succ; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul. + rewrite spec_d_to_Z; apply Qeq_refl. + repeat rewrite BigN.spec_succ. + assert (Fx: (0 < BigN.to_Z dx + 1)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (Fy: (0 < BigN.to_Z dy + 1)%Z). + generalize (BigN.spec_pos dy); auto with zarith. + repeat rewrite BigN.spec_pred. + rewrite BigZ.spec_add; repeat rewrite BigN.spec_mul; + repeat rewrite BigN.spec_succ. + assert (tmp: forall x, (x-1+1 = x)%Z); [intros; ring | rewrite tmp; clear tmp]. + repeat rewrite Z2P_correct; auto. + repeat rewrite BigZ.spec_mul; simpl. + repeat rewrite BigN.spec_succ. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto; apply Qeq_refl. + rewrite BigN.spec_mul; repeat rewrite BigN.spec_succ; auto with zarith. + apply Zmult_lt_0_compat; auto. + Qed. + + Theorem spec_addc x y: [[add x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition add_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.add zx zy) + | Qz zx, Qq ny dy => + let d := BigN.succ dy in + norm (BigZ.add (BigZ.mul zx (BigZ.Pos d)) ny) d + | Qq nx dx, Qz zy => + let d := BigN.succ dx in + norm (BigZ.add (BigZ.mul zy (BigZ.Pos d)) nx) d + | Qq nx dx, Qq ny dy => + let dx' := BigN.succ dx in + let dy' := BigN.succ dy in + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy')) (BigZ.mul ny (BigZ.Pos dx')) in + let d := BigN.mul dx' dy' in + norm n d + end. + + Theorem spec_add_norm x y: ([add_norm x y] == [x] + [y])%Q. + intros x y; rewrite <- spec_add. + unfold add_norm, add; case x; case y. + intros; apply Qeq_refl. + intros p1 n p2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X (BigN.pred Y)]); + [apply spec_norm | idtac] + end. + rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. + simpl. + repeat rewrite BigZ.spec_add. + repeat rewrite BigZ.spec_mul; simpl. + rewrite BigN.succ_pred; try apply Qeq_refl; apply lt_0_succ. + intros p1 n p2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X (BigN.pred Y)]); + [apply spec_norm | idtac] + end. + rewrite BigN.spec_succ; generalize (BigN.spec_pos p2); auto with zarith. + simpl. + repeat rewrite BigZ.spec_add. + repeat rewrite BigZ.spec_mul; simpl. + rewrite BinInt.Zplus_comm. + rewrite BigN.succ_pred; try apply Qeq_refl; apply lt_0_succ. + intros p1 q1 p2 q2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X (BigN.pred Y)]); + [apply spec_norm | idtac] + end; try apply Qeq_refl. + rewrite BigN.spec_mul. + apply Zmult_lt_0_compat; apply spec_succ_pos. + Qed. + + Theorem spec_add_normc x y: [[add_norm x y]] = [[x]] + [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add_norm. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition sub (x y: t): t := add x (opp y). + + Theorem spec_sub x y: ([sub x y] == [x] - [y])%Q. + intros x y; unfold sub; rewrite spec_add. + rewrite spec_opp; ring. + Qed. + + Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. + intros x y; unfold sub; rewrite spec_addc. + rewrite spec_oppc; ring. + Qed. + + Definition sub_norm x y := add_norm x (opp y). + + Theorem spec_sub_norm x y: ([sub_norm x y] == [x] - [y])%Q. + intros x y; unfold sub_norm; rewrite spec_add_norm. + rewrite spec_opp; ring. + Qed. + + Theorem spec_sub_normc x y: [[sub_norm x y]] = [[x]] - [[y]]. + intros x y; unfold sub_norm; rewrite spec_add_normc. + rewrite spec_oppc; ring. + Qed. + + + Definition mul (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => + Qq (BigZ.mul nx ny) (BigN.pred (BigN.mul (BigN.succ dx) (BigN.succ dy))) + end. + + Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. + rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. + apply Qeq_refl; auto. + rewrite BigZ.spec_mul; apply Qeq_refl. + rewrite BigZ.spec_mul; rewrite Pmult_1_r; auto. + apply Qeq_refl; auto. + assert (F1:= spec_succ_pos dx). + assert (F2:= spec_succ_pos dy). + rewrite BigN.succ_pred. + rewrite BigN.spec_mul; rewrite BigZ.spec_mul. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto; apply Qeq_refl. + rewrite Nspec_lt, BigN.spec_0, BigN.spec_mul; auto. + apply Zmult_lt_0_compat; apply spec_succ_pos. + Qed. + + Theorem spec_mulc x y: [[mul x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition mul_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => + if BigZ.eq_bool zx BigZ.zero then zero + else + let d := BigN.succ dy in + let gcd := BigN.gcd (BigZ.to_N zx) d in + if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zx ny) dy + else + let zx := BigZ.div zx (BigZ.Pos gcd) in + let d := BigN.div d gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) + else Qq (BigZ.mul zx ny) (BigN.pred d) + | Qq nx dx, Qz zy => + if BigZ.eq_bool zy BigZ.zero then zero + else + let d := BigN.succ dx in + let gcd := BigN.gcd (BigZ.to_N zy) d in + if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zy nx) dx + else + let zy := BigZ.div zy (BigZ.Pos gcd) in + let d := BigN.div d gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) + else Qq (BigZ.mul zy nx) (BigN.pred d) + | Qq nx dx, Qq ny dy => + norm (BigZ.mul nx ny) (BigN.mul (BigN.succ dx) (BigN.succ dy)) + end. + + Theorem spec_mul_norm x y: ([mul_norm x y] == [x] * [y])%Q. + intros x y; rewrite <- spec_mul. + unfold mul_norm, mul; case x; case y. + intros; apply Qeq_refl. + intros p1 n p2. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + rewrite BigZ.spec_mul; rewrite H; red; auto. + assert (F: (0 < BigN.to_Z (BigZ.to_N p2))%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + assert (F1: (0 < BigN.to_Z (BigN.succ n))%Z). + rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. + assert (F2: (0 < Zgcd (BigN.to_Z (BigZ.to_N p2)) (BigN.to_Z (BigN.succ n)))%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p2)) + (BigN.to_Z (BigN.succ n)))); intros H3; auto. + generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + intros; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith. + intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N. + rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite (spec_to_N p2). + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (BigN.succ n / + BigN.gcd (BigZ.to_N p2) + (BigN.succ n)))%bigN); intros F3. + rewrite BigN.succ_pred; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto; try ring. + rewrite Nspec_lt, BigN.spec_0; auto. + apply False_ind; generalize F1. + rewrite (Zdivide_Zdiv_eq + (Zgcd (BigN.to_Z (BigZ.to_N p2)) (BigN.to_Z (BigN.succ n))) + (BigN.to_Z (BigN.succ n))); auto. + generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith. + intros HH; rewrite <- HH; auto with zarith. + assert (FF:= Zgcd_is_gcd (BigN.to_Z (BigZ.to_N p2)) + (BigN.to_Z (BigN.succ n))); inversion FF; auto. + intros p1 p2 n. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + rewrite BigZ.spec_mul; rewrite H; red; simpl; ring. + assert (F: (0 < BigN.to_Z (BigZ.to_N p1))%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + assert (F1: (0 < BigN.to_Z (BigN.succ n))%Z). + rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. + assert (F2: (0 < Zgcd (BigN.to_Z (BigZ.to_N p1)) (BigN.to_Z (BigN.succ n)))%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p1)) + (BigN.to_Z (BigN.succ n)))); intros H3; auto. + generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + intros; repeat rewrite BigZ.spec_mul; rewrite Zmult_comm; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith. + intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N. + rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite (spec_to_N p1). + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (BigN.succ n / + BigN.gcd (BigZ.to_N p1) + (BigN.succ n)))%bigN); intros F3. + rewrite BigN.succ_pred; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto; try ring. + rewrite Nspec_lt, BigN.spec_0; auto. + apply False_ind; generalize F1. + rewrite (Zdivide_Zdiv_eq + (Zgcd (BigN.to_Z (BigZ.to_N p1)) (BigN.to_Z (BigN.succ n))) + (BigN.to_Z (BigN.succ n))); auto. + generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith. + intros HH; rewrite <- HH; auto with zarith. + assert (FF:= Zgcd_is_gcd (BigN.to_Z (BigZ.to_N p1)) + (BigN.to_Z (BigN.succ n))); inversion FF; auto. + intros p1 n1 p2 n2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X (BigN.pred Y)]); + [apply spec_norm | idtac] + end; try apply Qeq_refl. + rewrite BigN.spec_mul. + apply Zmult_lt_0_compat; rewrite BigN.spec_succ; + generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. + Qed. + + Theorem spec_mul_normc x y: [[mul_norm x y]] = [[x]] * [[y]]. + intros x y; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul_norm. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition inv (x: t): t := + match x with + | Qz (BigZ.Pos n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one (BigN.pred n) + | Qz (BigZ.Neg n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one (BigN.pred n) + | Qq (BigZ.Pos n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos (BigN.succ d)) (BigN.pred n) + | Qq (BigZ.Neg n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg (BigN.succ d)) (BigN.pred n) + end. + + Theorem spec_inv x: ([inv x] == /[x])%Q. + intros [ [x | x] | [nx | nx] dx]; unfold inv. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + unfold to_Q; rewrite BigZ.spec_1. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + red; unfold Qinv; simpl. + generalize F; case BigN.to_Z; auto with zarith. + intros p Hp; discriminate Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + red; unfold Qinv; simpl. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + generalize F; case BigN.to_Z; simpl; auto with zarith. + intros p Hp; discriminate Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z nx)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. + red; unfold Qinv; simpl. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite BigN.spec_succ; rewrite Z2P_correct; auto with zarith. + generalize F; case BigN.to_Z; auto with zarith. + intros p Hp; discriminate Hp. + generalize (BigN.spec_pos dx); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z nx)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. + red; unfold Qinv; simpl. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite BigN.spec_succ; rewrite Z2P_correct; auto with zarith. + generalize F; case BigN.to_Z; auto with zarith. + simpl; intros. + match goal with |- (?X = Zneg ?Y)%Z => + replace (Zneg Y) with (-(Zpos Y))%Z; + try rewrite Z2P_correct; auto with zarith + end. + rewrite Zpos_mult_morphism; + rewrite Z2P_correct; auto with zarith; try ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p Hp; discriminate Hp. + generalize (BigN.spec_pos dx); auto with zarith. + Qed. + + Theorem spec_invc x: [[inv x]] = /[[x]]. + intros x; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + +Definition inv_norm x := + match x with + | Qz (BigZ.Pos n) => + if BigN.eq_bool n BigN.zero then zero else + if BigN.eq_bool n BigN.one then x else Qq BigZ.one (BigN.pred n) + | Qz (BigZ.Neg n) => + if BigN.eq_bool n BigN.zero then zero else + if BigN.eq_bool n BigN.one then x else Qq BigZ.minus_one (BigN.pred n) + | Qq (BigZ.Pos n) d => let d := BigN.succ d in + if BigN.eq_bool n BigN.zero then zero else + if BigN.eq_bool n BigN.one then Qz (BigZ.Pos d) + else Qq (BigZ.Pos d) (BigN.pred n) + | Qq (BigZ.Neg n) d => let d := BigN.succ d in + if BigN.eq_bool n BigN.zero then zero else + if BigN.eq_bool n BigN.one then Qz (BigZ.Neg d) + else Qq (BigZ.Neg d) (BigN.pred n) + end. + + Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. + intros x; rewrite <- spec_inv. + (case x; clear x); [intros [x | x] | intros nx dx]; + unfold inv_norm, inv. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + red; simpl. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite Z2P_correct; try rewrite H1; auto with zarith. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + red; simpl. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite Z2P_correct; try rewrite H1; auto with zarith. + apply Qeq_refl. + case nx; clear nx; intros nx. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + red; simpl. + rewrite BigN.succ_pred; try rewrite H1; auto with zarith. + rewrite Nspec_lt, BigN.spec_0, H1; auto with zarith. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; intros H1. + red; simpl. + rewrite BigN.succ_pred; try rewrite H1; auto with zarith. + rewrite Nspec_lt, BigN.spec_0, H1; auto with zarith. + apply Qeq_refl. + Qed. + + + Definition div x y := mul x (inv y). + + Theorem spec_div x y: ([div x y] == [x] / [y])%Q. + intros x y; unfold div; rewrite spec_mul; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. + intros x y; unfold div; rewrite spec_mulc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + Definition div_norm x y := mul_norm x (inv y). + + Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. + intros x y; unfold div_norm; rewrite spec_mul_norm; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + Qed. + + Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. + intros x y; unfold div_norm; rewrite spec_mul_normc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + Qed. + + + Definition square (x: t): t := + match x with + | Qz zx => Qz (BigZ.square zx) + | Qq nx dx => Qq (BigZ.square nx) (BigN.pred (BigN.square (BigN.succ dx))) + end. + + Theorem spec_square x: ([square x] == [x] ^ 2)%Q. + intros [ x | nx dx]; unfold square. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + assert (F: (0 < BigN.to_Z (BigN.succ dx))%Z). + rewrite BigN.spec_succ; + case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. + assert (F1 : (0 < BigN.to_Z (BigN.square (BigN.succ dx)))%Z). + rewrite BigN.spec_square; apply Zmult_lt_0_compat; + auto with zarith. + rewrite BigN.succ_pred by (rewrite Nspec_lt, BigN.spec_0; auto). + rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + repeat rewrite BigN.spec_succ; auto with zarith. + rewrite BigN.spec_square; auto with zarith. + repeat rewrite BigN.spec_succ; auto with zarith. + Qed. + + Theorem spec_squarec x: [[square x]] = [[x]]^2. + intros x; unfold to_Qc. + apply trans_equal with (!! ([x]^2)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_square. + simpl Qcpower. + replace (!! [x] * 1) with (!![x]); try ring. + simpl. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition power_pos (x: t) p: t := + match x with + | Qz zx => Qz (BigZ.power_pos zx p) + | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.pred (BigN.power_pos (BigN.succ dx) p)) + end. + + + Theorem spec_power_pos x p: ([power_pos x p] == [x] ^ Zpos p)%Q. + Proof. + intros [x | nx dx] p; unfold power_pos. + unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z x) 1). + unfold Qeq; simpl. + rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Zmult_1_r. + intros H; rewrite H. + rewrite BigZ.spec_power_pos; simpl; ring. + assert (F1: (0 < BigN.to_Z (BigN.succ dx))%Z). + rewrite BigN.spec_succ; + generalize (BigN.spec_pos dx); auto with zarith. + assert (F2: (0 < BigN.to_Z (BigN.succ dx) ^ ' p)%Z). + unfold Zpower; apply Zpower_pos_pos; auto. + unfold power_pos; red; simpl. + rewrite BigN.succ_pred, BigN.spec_power_pos. + rewrite Z2P_correct; auto. + generalize (Qpower_decomp p (BigZ.to_Z nx) + (Z2P (BigN.to_Z (BigN.succ dx)))). + unfold Qeq; simpl. + repeat rewrite Z2P_correct; auto. + unfold Qeq; simpl; intros HH. + rewrite HH. + rewrite BigZ.spec_power_pos; simpl; ring. + rewrite Nspec_lt, BigN.spec_0, BigN.spec_power_pos; auto. + Qed. + + Theorem spec_power_posc x p: [[power_pos x p]] = [[x]] ^ nat_of_P p. + intros x p; unfold to_Qc. + apply trans_equal with (!! ([x]^Zpos p)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_power_pos. + pattern p; apply Pind; clear p. + simpl; ring. + intros p Hrec. + rewrite nat_of_P_succ_morphism; simpl Qcpower. + rewrite <- Hrec. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; + unfold this. + apply Qred_complete. + assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). + simpl; case x; simpl; clear x Hrec. + intros x; simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + intros nx dx; simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + assert (F1: (0 < BigN.to_Z (BigN.succ dx))%Z). + rewrite BigN.spec_succ; generalize (BigN.spec_pos dx); + auto with zarith. + repeat rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto. + 2: apply Zpower_pos_pos; auto. + 2: apply Zpower_pos_pos; auto. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + rewrite F. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + +End Qp. diff --git a/theories/Numbers/Rational/BigQ/QvMake.v b/theories/Numbers/Rational/BigQ/QvMake.v new file mode 100644 index 00000000..4523e241 --- /dev/null +++ b/theories/Numbers/Rational/BigQ/QvMake.v @@ -0,0 +1,1151 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) +(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) +(************************************************************************) + +(*i $Id: QvMake.v 11027 2008-06-01 13:28:59Z letouzey $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Znumtheory. +Require Import BigNumPrelude. +Require Import Arith. +Require Export BigN. +Require Export BigZ. +Require Import QArith. +Require Import Qcanon. +Require Import Qpower. +Require Import QMake_base. + +Module Qv. + + Import BinInt Zorder. + Open Local Scope Q_scope. + Open Local Scope Qc_scope. + + (** The notation of a rational number is either an integer x, + interpreted as itself or a pair (x,y) of an integer x and a naturel + number y interpreted as x/y. All functions maintain the invariant + that y is never zero. *) + + Definition t := q_type. + + Definition zero: t := Qz BigZ.zero. + Definition one: t := Qz BigZ.one. + Definition minus_one: t := Qz BigZ.minus_one. + + Definition of_Z x: t := Qz (BigZ.of_Z x). + + Definition wf x := + match x with + | Qz _ => True + | Qq n d => if BigN.eq_bool d BigN.zero then False else True + end. + + Definition of_Q q: t := + match q with x # y => + Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) + end. + + Definition of_Qc q := of_Q (this q). + + Definition to_Q (q: t) := + match q with + Qz x => BigZ.to_Z x # 1 + |Qq x y => BigZ.to_Z x # Z2P (BigN.to_Z y) + end. + + Definition to_Qc q := !!(to_Q q). + + Notation "[[ x ]]" := (to_Qc x). + + Notation "[ x ]" := (to_Q x). + + Theorem spec_to_Q: forall q: Q, [of_Q q] = q. + intros (x,y); simpl. + rewrite BigZ.spec_of_Z; simpl. + rewrite (BigN.spec_of_pos); auto. + Qed. + + Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. + intros (x, Hx); unfold of_Qc, to_Qc; simpl. + apply Qc_decomp; simpl. + intros; rewrite spec_to_Q; auto. + Qed. + + Definition opp (x: t): t := + match x with + | Qz zx => Qz (BigZ.opp zx) + | Qq nx dx => Qq (BigZ.opp nx) dx + end. + + Theorem wf_opp: forall x, wf x -> wf (opp x). + intros [zx | nx dx]; unfold opp, wf; auto. + Qed. + + Theorem spec_opp: forall q, ([opp q] = -[q])%Q. + intros [z | x y]; simpl. + rewrite BigZ.spec_opp; auto. + rewrite BigZ.spec_opp; auto. + Qed. + + Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. + intros q; unfold Qcopp, to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + rewrite spec_opp. + rewrite <- Qred_opp. + rewrite Qred_involutive; auto. + Qed. + + (* Les fonctions doivent assurer que si leur arguments sont valides alors + le resultat est correct et valide (si c'est un Q) + *) + + Definition compare (x y: t) := + match x, y with + | Qz zx, Qz zy => BigZ.compare zx zy + | Qz zx, Qq ny dy => BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny + | Qq nx dx, Qz zy => BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) + | Qq nx dx, Qq ny dy => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) + end. + + Theorem spec_compare: forall q1 q2, wf q1 -> wf q2 -> + compare q1 q2 = ([q1] ?= [q2])%Q. + intros [z1 | x1 y1] [z2 | x2 y2]; + unfold Qcompare, compare, to_Q, Qnum, Qden, wf. + repeat rewrite Zmult_1_r. + generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. + rewrite H; rewrite Zcompare_refl; auto. + rewrite Zmult_1_r. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool. + intros _ _ HH; case HH. + rewrite BigN.spec_0; intros HH _ _. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH _ _. + rewrite Z2P_correct; auto with zarith. + 2: generalize (BigN.spec_pos y1); auto with zarith. + rewrite Zmult_1_r. + generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + generalize (BigN.spec_eq_bool y1 BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH1. + generalize (BigN.spec_eq_bool y2 BigN.zero); + case BigN.eq_bool. + intros _ _ HH; case HH. + rewrite BigN.spec_0; intros HH2 _ _. + repeat rewrite Z2P_correct. + 2: generalize (BigN.spec_pos y1); auto with zarith. + 2: generalize (BigN.spec_pos y2); auto with zarith. + generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) + (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; + repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. + rewrite H; rewrite Zcompare_refl; auto. + Qed. + + Theorem spec_comparec: forall q1 q2, wf q1 -> wf q2 -> + compare q1 q2 = ([[q1]] ?= [[q2]]). + unfold Qccompare, to_Qc. + intros q1 q2 Hq1 Hq2; rewrite spec_compare; simpl; auto. + apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition norm n d: t := + if BigZ.eq_bool n BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N n) d in + if BigN.eq_bool gcd BigN.one then Qq n d + else + let n := BigZ.div n (BigZ.Pos gcd) in + let d := BigN.div d gcd in + if BigN.eq_bool d BigN.one then Qz n + else Qq n d. + + Theorem wf_norm: forall n q, + (BigN.to_Z q <> 0)%Z -> wf (norm n q). + intros p q; unfold norm, wf; intros Hq. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto; rewrite BigZ.spec_0; intros H1. + simpl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + set (a := BigN.to_Z (BigZ.to_N p)). + set (b := (BigN.to_Z q)). + assert (F: (0 < Zgcd a b)%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. + intros HH1; case Hq; apply (Zgcd_inv_0_r _ _ (sym_equal HH1)). + rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto; fold a; fold b. + intros H; case Hq; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite H; auto with zarith. + assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. + Qed. + + Theorem spec_norm: forall n q, + ((0 < BigN.to_Z q)%Z -> [norm n q] == [Qq n q])%Q. + intros p q; unfold norm; intros Hq. + assert (Hp := BigN.spec_pos (BigZ.to_N p)). + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto; rewrite BigZ.spec_0; intros H1. + red; simpl; rewrite H1; ring. + case (Zle_lt_or_eq _ _ Hp); clear Hp; intros Hp. + case (Zle_lt_or_eq _ _ + (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p)) (BigN.to_Z q))); intros H4. + 2: generalize Hq; rewrite (Zgcd_inv_0_r _ _ (sym_equal H4)); auto with zarith. + 2: red; simpl; auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1; intros H2. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_1. + red; simpl. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite Zmult_1_r. + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N; intros; rewrite Zgcd_div_swap; auto. + rewrite H; ring. + intros H3. + red; simpl. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + assert (F: (0 < BigN.to_Z (q / BigN.gcd (BigZ.to_N p) q)%bigN)%Z). + rewrite BigN.spec_div; auto with zarith. + rewrite BigN.spec_gcd. + apply Zgcd_div_pos; auto. + rewrite BigN.spec_gcd; auto. + rewrite Z2P_correct; auto. + rewrite Z2P_correct; auto. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. + rewrite spec_to_N; apply Zgcd_div_swap; auto. + case H1; rewrite spec_to_N; rewrite <- Hp; ring. + Qed. + + Theorem spec_normc: forall n q, + (0 < BigN.to_Z q)%Z -> [[norm n q]] = [[Qq n q]]. + intros n q H; unfold to_Qc, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_norm; auto. + Qed. + + Definition add (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.add zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx + | Qq nx dx, Qq ny dy => + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + Qq n d + end. + + Theorem wf_add: forall x y, wf x -> wf y -> wf (add x y). + intros [zx | nx dx] [zy | ny dy]; unfold add, wf; auto. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. + intros H1 H2 H3. + case (Zmult_integral _ _ H1); auto with zarith. + Qed. + + Theorem spec_add x y: wf x -> wf y -> + ([add x y] == [x] + [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. + rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + assert (F1:= BigN.spec_pos dy). + rewrite Zmult_1_r. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool. + intros _ _ HH; case HH. + rewrite BigN.spec_0; intros HH _ _. + rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul. + simpl; apply Qeq_refl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH _ _. + assert (F1:= BigN.spec_pos dx). + rewrite Zmult_1_r; rewrite Pmult_1_r. + simpl; rewrite Z2P_correct; auto with zarith. + rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl. + apply Qeq_refl. + generalize (BigN.spec_eq_bool dx BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH1. + generalize (BigN.spec_eq_bool dy BigN.zero); + case BigN.eq_bool. + intros _ _ HH; case HH. + rewrite BigN.spec_0; intros HH2 _ _. + assert (Fx: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (Fy: (0 < BigN.to_Z dy)%Z). + generalize (BigN.spec_pos dy); auto with zarith. + rewrite BigZ.spec_add; repeat rewrite BigN.spec_mul. + red; simpl. + rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto. + repeat rewrite BigZ.spec_mul; simpl; auto. + apply Zmult_lt_0_compat; auto. + Qed. + + Theorem spec_addc x y: wf x -> wf y -> + [[add x y]] = [[x]] + [[y]]. + intros x y H1 H2; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition add_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.add zx zy) + | Qz zx, Qq ny dy => + norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy + | Qq nx dx, Qz zy => + norm (BigZ.add (BigZ.mul zy (BigZ.Pos dx)) nx) dx + | Qq nx dx, Qq ny dy => + let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in + let d := BigN.mul dx dy in + norm n d + end. + + Theorem wf_add_norm: forall x y, wf x -> wf y -> wf (add_norm x y). + intros [zx | nx dx] [zy | ny dy]; unfold add_norm; auto. + intros HH1 HH2; apply wf_norm. + generalize HH2; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros HH1 HH2; apply wf_norm. + generalize HH1; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros HH1 HH2; apply wf_norm. + rewrite BigN.spec_mul; intros HH3. + case (Zmult_integral _ _ HH3). + generalize HH1; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + generalize HH2; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + Qed. + + Theorem spec_add_norm x y: wf x -> wf y -> + ([add_norm x y] == [x] + [y])%Q. + intros x y H1 H2; rewrite <- spec_add; auto. + generalize H1 H2; unfold add_norm, add, wf; case x; case y; clear H1 H2. + intros; apply Qeq_refl. + intros p1 n p2 _. + generalize (BigN.spec_eq_bool n BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH _. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + generalize (BigN.spec_pos n); auto with zarith. + simpl. + repeat rewrite BigZ.spec_add. + repeat rewrite BigZ.spec_mul; simpl. + apply Qeq_refl. + intros p1 n p2. + generalize (BigN.spec_eq_bool p2 BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH _ _. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end. + generalize (BigN.spec_pos p2); auto with zarith. + simpl. + repeat rewrite BigZ.spec_add. + repeat rewrite BigZ.spec_mul; simpl. + rewrite Zplus_comm. + apply Qeq_refl. + intros p1 q1 p2 q2. + generalize (BigN.spec_eq_bool q2 BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH1 _. + generalize (BigN.spec_eq_bool q1 BigN.zero); + case BigN.eq_bool. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH2 _. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; try apply Qeq_refl. + rewrite BigN.spec_mul. + apply Zmult_lt_0_compat. + generalize (BigN.spec_pos q2); auto with zarith. + generalize (BigN.spec_pos q1); auto with zarith. + Qed. + + Theorem spec_add_normc x y: wf x -> wf y -> + [[add_norm x y]] = [[x]] + [[y]]. + intros x y Hx Hy; unfold to_Qc. + apply trans_equal with (!! ([x] + [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_add_norm; auto. + unfold Qcplus, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qplus_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition sub x y := add x (opp y). + + Theorem wf_sub x y: wf x -> wf y -> wf (sub x y). + intros x y Hx Hy; unfold sub; apply wf_add; auto. + apply wf_opp; auto. + Qed. + + Theorem spec_sub x y: wf x -> wf y -> + ([sub x y] == [x] - [y])%Q. + intros x y Hx Hy; unfold sub; rewrite spec_add; auto. + rewrite spec_opp; ring. + apply wf_opp; auto. + Qed. + + Theorem spec_subc x y: wf x -> wf y -> + [[sub x y]] = [[x]] - [[y]]. + intros x y Hx Hy; unfold sub; rewrite spec_addc; auto. + rewrite spec_oppc; ring. + apply wf_opp; auto. + Qed. + + Definition sub_norm x y := add_norm x (opp y). + + Theorem wf_sub_norm x y: wf x -> wf y -> wf (sub_norm x y). + intros x y Hx Hy; unfold sub_norm; apply wf_add_norm; auto. + apply wf_opp; auto. + Qed. + + Theorem spec_sub_norm x y: wf x -> wf y -> + ([sub_norm x y] == [x] - [y])%Q. + intros x y Hx Hy; unfold sub_norm; rewrite spec_add_norm; auto. + rewrite spec_opp; ring. + apply wf_opp; auto. + Qed. + + Theorem spec_sub_normc x y: wf x -> wf y -> + [[sub_norm x y]] = [[x]] - [[y]]. + intros x y Hx Hy; unfold sub_norm; rewrite spec_add_normc; auto. + rewrite spec_oppc; ring. + apply wf_opp; auto. + Qed. + + Definition mul (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx + | Qq nx dx, Qq ny dy => + Qq (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + Theorem wf_mul: forall x y, wf x -> wf y -> wf (mul x y). + intros [zx | nx dx] [zy | ny dy]; unfold mul, wf; auto. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. + intros H1 H2 H3. + case (Zmult_integral _ _ H1); auto with zarith. + Qed. + + Theorem spec_mul x y: wf x -> wf y -> ([mul x y] == [x] * [y])%Q. + intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. + rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. + intros; apply Qeq_refl; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros _ _ HH; case HH. + rewrite BigN.spec_0; intros HH1 _ _. + rewrite BigZ.spec_mul; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros _ HH; case HH. + rewrite BigN.spec_0; intros HH1 _ _. + rewrite BigZ.spec_mul; rewrite Pmult_1_r. + apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros _ HH; case HH. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros _ _ _ HH; case HH. + rewrite BigN.spec_0; intros H1 H2 _ _. + rewrite BigZ.spec_mul; rewrite BigN.spec_mul. + assert (tmp: + (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). + intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. + rewrite tmp; auto. + apply Qeq_refl. + generalize (BigN.spec_pos dx); auto with zarith. + generalize (BigN.spec_pos dy); auto with zarith. + Qed. + + Theorem spec_mulc x y: wf x -> wf y -> + [[mul x y]] = [[x]] * [[y]]. + intros x y Hx Hy; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition mul_norm (x y: t): t := + match x, y with + | Qz zx, Qz zy => Qz (BigZ.mul zx zy) + | Qz zx, Qq ny dy => + if BigZ.eq_bool zx BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N zx) dy in + if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zx ny) dy + else + let zx := BigZ.div zx (BigZ.Pos gcd) in + let d := BigN.div dy gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) + else Qq (BigZ.mul zx ny) d + | Qq nx dx, Qz zy => + if BigZ.eq_bool zy BigZ.zero then zero + else + let gcd := BigN.gcd (BigZ.to_N zy) dx in + if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zy nx) dx + else + let zy := BigZ.div zy (BigZ.Pos gcd) in + let d := BigN.div dx gcd in + if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) + else Qq (BigZ.mul zy nx) d + | Qq nx dx, Qq ny dy => norm (BigZ.mul nx ny) (BigN.mul dx dy) + end. + + Theorem wf_mul_norm: forall x y, wf x -> wf y -> wf (mul_norm x y). + intros [zx | nx dx] [zy | ny dy]; unfold mul_norm; auto. + intros HH1 HH2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_1; rewrite BigZ.spec_0. + intros H1 H2; unfold wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_0. + set (a := BigN.to_Z (BigZ.to_N zx)). + set (b := (BigN.to_Z dy)). + assert (F: (0 < Zgcd a b)%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. + intros HH3; case H2; rewrite spec_to_N; fold a. + rewrite (Zgcd_inv_0_l _ _ (sym_equal HH3)); try ring. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. + intros H. + generalize HH2; simpl wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_0; intros HH; case HH; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite H; auto with zarith. + assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_1; rewrite BigN.spec_gcd. + intros HH1 H1 H2. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto. + rewrite BigN.spec_1; rewrite BigN.spec_gcd. + intros HH1 H1 H2. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; auto. + rewrite BigZ.spec_0. + intros HH2. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + set (a := BigN.to_Z (BigZ.to_N zy)). + set (b := (BigN.to_Z dx)). + assert (F: (0 < Zgcd a b)%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. + intros HH3; case HH2; rewrite spec_to_N; fold a. + rewrite (Zgcd_inv_0_l _ _ (sym_equal HH3)); try ring. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. + intros H; unfold wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_0. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. + intros HH; generalize H1; simpl wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + rewrite BigN.spec_0. + intros HH3; case HH3; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite HH; auto with zarith. + assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. + intros HH1 HH2; apply wf_norm. + rewrite BigN.spec_mul; intros HH3. + case (Zmult_integral _ _ HH3). + generalize HH1; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + generalize HH2; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + Qed. + + Theorem spec_mul_norm x y: wf x -> wf y -> + ([mul_norm x y] == [x] * [y])%Q. + intros x y Hx Hy; rewrite <- spec_mul; auto. + unfold mul_norm, mul; generalize Hx Hy; case x; case y; clear Hx Hy. + intros; apply Qeq_refl. + intros p1 n p2 Hx Hy. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + rewrite BigZ.spec_mul; rewrite H; red; auto. + assert (F: (0 < BigN.to_Z (BigZ.to_N p2))%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + assert (F1: (0 < BigN.to_Z n)%Z). + generalize Hy; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto. + intros _ HH; case HH. + rewrite BigN.spec_0; generalize (BigN.spec_pos n); auto with zarith. + set (a := BigN.to_Z (BigZ.to_N p2)). + set (b := BigN.to_Z n). + assert (F2: (0 < Zgcd a b )%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); intros H3; auto. + generalize F; fold a; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; try rewrite BigN.spec_gcd; + fold a b; intros H1. + intros; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith; fold a b; intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N; fold a; fold b. + rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + intros H2; red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite Z2P_correct; auto with zarith. + rewrite (spec_to_N p2); fold a b. + rewrite Z2P_correct; auto with zarith. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p1)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto; try ring. + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (n / + BigN.gcd (BigZ.to_N p2) + n))%bigN); + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + intros H3. + apply False_ind; generalize F1. + generalize Hy; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; auto with zarith. + intros HH; case HH; fold b. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + rewrite <- H3; ring. + assert (FF:= Zgcd_is_gcd a b); inversion FF; auto. + intros p1 p2 n Hx Hy. + match goal with |- context[BigZ.eq_bool ?X ?Y] => + generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool + end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. + rewrite BigZ.spec_mul; rewrite H; red; simpl; ring. + set (a := BigN.to_Z (BigZ.to_N p1)). + set (b := BigN.to_Z n). + assert (F: (0 < a)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. + intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. + assert (F1: (0 < b)%Z). + generalize Hx; unfold wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; auto with zarith. + generalize (BigN.spec_pos n); fold b; auto with zarith. + assert (F2: (0 < Zgcd a b)%Z). + case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); intros H3; auto. + generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; fold a b; intros H1. + intros; repeat rewrite BigZ.spec_mul; rewrite Zmult_comm; apply Qeq_refl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_1. + rewrite BigN.spec_div; rewrite BigN.spec_gcd; + auto with zarith. + fold a b; intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite spec_to_N; fold a b. + rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto with zarith. + rewrite H2; ring. + intros H2. + red; simpl. + repeat rewrite BigZ.spec_mul. + rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + rewrite Z2P_correct; auto with zarith. + rewrite (spec_to_N p1); fold a b. + case (Zle_lt_or_eq _ _ + (BigN.spec_pos (n / BigN.gcd (BigZ.to_N p1) n))%bigN); intros F3. + rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; + fold a b; auto with zarith. + repeat rewrite <- Zmult_assoc. + rewrite (Zmult_comm (BigZ.to_Z p2)). + repeat rewrite Zmult_assoc. + rewrite Zgcd_div_swap; auto; try ring. + apply False_ind; generalize F1. + rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. + generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; + auto with zarith. + intros HH; rewrite <- HH; auto with zarith. + assert (FF:= Zgcd_is_gcd a b); inversion FF; auto. + intros p1 n1 p2 n2 Hn1 Hn2. + match goal with |- [norm ?X ?Y] == _ => + apply Qeq_trans with ([Qq X Y]); + [apply spec_norm | idtac] + end; try apply Qeq_refl. + rewrite BigN.spec_mul. + apply Zmult_lt_0_compat. + generalize Hn1; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; auto with zarith. + generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. + generalize Hn2; simpl. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; auto with zarith. + generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. + Qed. + + Theorem spec_mul_normc x y: wf x -> wf y -> + [[mul_norm x y]] = [[x]] * [[y]]. + intros x y Hx Hy; unfold to_Qc. + apply trans_equal with (!! ([x] * [y])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_mul_norm; auto. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + Definition inv (x: t): t := + match x with + | Qz (BigZ.Pos n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one n + | Qz (BigZ.Neg n) => + if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one n + | Qq (BigZ.Pos n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos d) n + | Qq (BigZ.Neg n) d => + if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg d) n + end. + + + Theorem wf_inv: forall x, wf x -> wf (inv x). + intros [ zx | nx dx]; unfold inv, wf; auto. + case zx; clear zx. + intros nx. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. + intros nx. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + intros _ HH; case HH. + intros H1 _. + case nx; clear nx. + intros nx. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; simpl; auto. + intros nx. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; simpl; auto. + Qed. + + Theorem spec_inv x: wf x -> + ([inv x] == /[x])%Q. + intros [ [x | x] _ | [nx | nx] dx]; unfold inv. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + unfold to_Q; rewrite BigZ.spec_1. + red; unfold Qinv; simpl. + generalize F; case BigN.to_Z; auto with zarith. + intros p Hp; discriminate Hp. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z x)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. + red; unfold Qinv; simpl. + generalize F; case BigN.to_Z; simpl; auto with zarith. + intros p Hp; discriminate Hp. + simpl wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + intros HH; case HH. + intros _. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z nx)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. + red; unfold Qinv; simpl. + rewrite Z2P_correct; auto with zarith. + generalize F; case BigN.to_Z; auto with zarith. + intros p Hp; discriminate Hp. + generalize (BigN.spec_pos dx); auto with zarith. + simpl wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H1. + intros HH; case HH. + intros _. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; rewrite BigN.spec_0; intros H. + unfold zero, to_Q; rewrite BigZ.spec_0. + unfold BigZ.to_Z; rewrite H; apply Qeq_refl. + assert (F: (0 < BigN.to_Z nx)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. + red; unfold Qinv; simpl. + rewrite Z2P_correct; auto with zarith. + generalize F; case BigN.to_Z; auto with zarith. + simpl; intros. + match goal with |- (?X = Zneg ?Y)%Z => + replace (Zneg Y) with (Zopp (Zpos Y)); + try rewrite Z2P_correct; auto with zarith + end. + rewrite Zpos_mult_morphism; + rewrite Z2P_correct; auto with zarith; try ring. + generalize (BigN.spec_pos dx); auto with zarith. + intros p Hp; discriminate Hp. + generalize (BigN.spec_pos dx); auto with zarith. + Qed. + + Theorem spec_invc x: wf x -> + [[inv x]] = /[[x]]. + intros x Hx; unfold to_Qc. + apply trans_equal with (!! (/[x])). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_inv; auto. + unfold Qcinv, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qinv_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + Definition div x y := mul x (inv y). + + Theorem wf_div x y: wf x -> wf y -> wf (div x y). + intros x y Hx Hy; unfold div; apply wf_mul; auto. + apply wf_inv; auto. + Qed. + + Theorem spec_div x y: wf x -> wf y -> + ([div x y] == [x] / [y])%Q. + intros x y Hx Hy; unfold div; rewrite spec_mul; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + apply wf_inv; auto. + Qed. + + Theorem spec_divc x y: wf x -> wf y -> + [[div x y]] = [[x]] / [[y]]. + intros x y Hx Hy; unfold div; rewrite spec_mulc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + apply wf_inv; auto. + Qed. + + Definition div_norm x y := mul_norm x (inv y). + + Theorem wf_div_norm x y: wf x -> wf y -> wf (div_norm x y). + intros x y Hx Hy; unfold div_norm; apply wf_mul_norm; auto. + apply wf_inv; auto. + Qed. + + Theorem spec_div_norm x y: wf x -> wf y -> + ([div_norm x y] == [x] / [y])%Q. + intros x y Hx Hy; unfold div_norm; rewrite spec_mul_norm; auto. + unfold Qdiv; apply Qmult_comp. + apply Qeq_refl. + apply spec_inv; auto. + apply wf_inv; auto. + Qed. + + Theorem spec_div_normc x y: wf x -> wf y -> + [[div_norm x y]] = [[x]] / [[y]]. + intros x y Hx Hy; unfold div_norm; rewrite spec_mul_normc; auto. + unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. + apply spec_invc; auto. + apply wf_inv; auto. + Qed. + + Definition square (x: t): t := + match x with + | Qz zx => Qz (BigZ.square zx) + | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) + end. + + Theorem wf_square: forall x, wf x -> wf (square x). + intros [ zx | nx dx]; unfold square, wf; auto. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigN.spec_square; intros H1 H2; case H2. + case (Zmult_integral _ _ H1); auto. + Qed. + + Theorem spec_square x: wf x -> ([square x] == [x] ^ 2)%Q. + intros [ x | nx dx]; unfold square. + intros _. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + unfold wf. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + intros _ HH; case HH. + intros H1 _. + red; simpl; rewrite BigZ.spec_square; auto with zarith. + assert (F: (0 < BigN.to_Z dx)%Z). + case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. + assert (F1 : (0 < BigN.to_Z (BigN.square dx))%Z). + rewrite BigN.spec_square; apply Zmult_lt_0_compat; + auto with zarith. + rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto with zarith. + rewrite BigN.spec_square; auto with zarith. + Qed. + + Theorem spec_squarec x: wf x -> [[square x]] = [[x]]^2. + intros x Hx; unfold to_Qc. + apply trans_equal with (!! ([x]^2)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_square; auto. + simpl Qcpower. + replace (!! [x] * 1) with (!![x]); try ring. + simpl. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + + + Definition power_pos (x: t) p: t := + match x with + | Qz zx => Qz (BigZ.power_pos zx p) + | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) + end. + + Theorem wf_power_pos: forall x p, wf x -> wf (power_pos x p). + intros [ zx | nx dx] p; unfold power_pos, wf; auto. + repeat match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + rewrite BigN.spec_power_pos; simpl. + intros H1 H2 _. + case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. + intros H3; generalize (Zpower_pos_pos _ p H3); auto with zarith. + Qed. + + Theorem spec_power_pos x p: wf x -> ([power_pos x p] == [x] ^ Zpos p)%Q. + Proof. + intros [x | nx dx] p; unfold power_pos. + intros _; unfold power_pos; red; simpl. + generalize (Qpower_decomp p (BigZ.to_Z x) 1). + unfold Qeq; simpl. + rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Zmult_1_r. + intros H; rewrite H. + rewrite BigZ.spec_power_pos; simpl; ring. + unfold wf. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + intros _ HH; case HH. + intros H1 _. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). + unfold Zpower; apply Zpower_pos_pos; auto. + unfold power_pos; red; simpl. + rewrite Z2P_correct; rewrite BigN.spec_power_pos; auto. + generalize (Qpower_decomp p (BigZ.to_Z nx) + (Z2P (BigN.to_Z dx))). + unfold Qeq; simpl. + repeat rewrite Z2P_correct; auto. + unfold Qeq; simpl; intros HH. + rewrite HH. + rewrite BigZ.spec_power_pos; simpl; ring. + Qed. + + Theorem spec_power_posc x p: wf x -> + [[power_pos x p]] = [[x]] ^ nat_of_P p. + intros x p Hx; unfold to_Qc. + apply trans_equal with (!! ([x]^Zpos p)). + unfold Q2Qc. + apply Qc_decomp; intros _ _; unfold this. + apply Qred_complete; apply spec_power_pos; auto. + pattern p; apply Pind; clear p. + simpl; ring. + intros p Hrec. + rewrite nat_of_P_succ_morphism; simpl Qcpower. + rewrite <- Hrec. + unfold Qcmult, Q2Qc. + apply Qc_decomp; intros _ _; + unfold this. + apply Qred_complete. + assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). + simpl; generalize Hx; case x; simpl; clear x Hx Hrec. + intros x _; simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + intros nx dx. + match goal with |- context[BigN.eq_bool ?X ?Y] => + generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool + end; auto; rewrite BigN.spec_0. + intros _ HH; case HH. + intros H1 _. + assert (F1: (0 < BigN.to_Z dx)%Z). + generalize (BigN.spec_pos dx); auto with zarith. + simpl; repeat rewrite Qpower_decomp; simpl. + red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. + rewrite Pplus_one_succ_l. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + repeat rewrite Zpos_mult_morphism. + repeat rewrite Z2P_correct; auto. + 2: apply Zpower_pos_pos; auto. + 2: apply Zpower_pos_pos; auto. + rewrite Zpower_pos_is_exp. + rewrite Zpower_pos_1_r; auto. + rewrite F. + apply Qmult_comp; apply Qeq_sym; apply Qred_correct. + Qed. + +End Qv. + diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v new file mode 100644 index 00000000..a488c7c6 --- /dev/null +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: QSig.v 11028 2008-06-01 17:34:19Z letouzey $ i*) + +Require Import QArith Qpower. + +Open Scope Q_scope. + +(** * QSig *) + +(** Interface of a rich structure about rational numbers. + Specifications are written via translation to Q. +*) + +Module Type QType. + + Parameter t : Type. + + Parameter to_Q : t -> Q. + Notation "[ x ]" := (to_Q x). + + Definition eq x y := [x] == [y]. + + Parameter of_Q : Q -> t. + Parameter spec_of_Q: forall x, to_Q (of_Q x) == x. + + Parameter zero : t. + Parameter one : t. + Parameter minus_one : t. + + Parameter spec_0: [zero] == 0. + Parameter spec_1: [one] == 1. + Parameter spec_m1: [minus_one] == -(1). + + Parameter compare : t -> t -> comparison. + + Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). + + Definition lt n m := compare n m = Lt. + Definition le n m := compare n m <> Gt. + 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. + + Parameter add : t -> t -> t. + + Parameter spec_add: forall x y, [add x y] == [x] + [y]. + + Parameter sub : t -> t -> t. + + Parameter spec_sub: forall x y, [sub x y] == [x] - [y]. + + Parameter opp : t -> t. + + Parameter spec_opp: forall x, [opp x] == - [x]. + + Parameter mul : t -> t -> t. + + Parameter spec_mul: forall x y, [mul x y] == [x] * [y]. + + Parameter square : t -> t. + + Parameter spec_square: forall x, [square x] == [x] ^ 2. + + Parameter inv : t -> t. + + Parameter spec_inv : forall x, [inv x] == / [x]. + + Parameter div : t -> t -> t. + + Parameter spec_div: forall x y, [div x y] == [x] / [y]. + + Parameter power_pos : t -> positive -> t. + + Parameter spec_power_pos: forall x n, [power_pos x n] == [x] ^ Zpos n. + +End QType. + +(* TODO: add norm function and variants, add eq_bool, what about Qc ? *)
\ No newline at end of file diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v new file mode 100644 index 00000000..a1a78acc --- /dev/null +++ b/theories/Program/Basics.v @@ -0,0 +1,57 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Standard functions and combinators. + * Proofs about them require functional extensionality and can be found in [Combinators]. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(* $Id: Basics.v 11046 2008-06-03 22:48:06Z msozeau $ *) + +(** The polymorphic identity function. *) + +Definition id {A} := fun x : A => x. + +(** Function composition. *) + +Definition compose {A B C} (g : B -> C) (f : A -> B) := + fun x : A => g (f x). + +Hint Unfold compose. + +Notation " g ∘ f " := (compose g f) + (at level 40, left associativity) : program_scope. + +Open Local Scope program_scope. + +(** The non-dependent function space between [A] and [B]. *) + +Definition arrow (A B : Type) := A -> B. + +(** Logical implication. *) + +Definition impl (A B : Prop) : Prop := A -> B. + +(** The constant function [const a] always returns [a]. *) + +Definition const {A B} (a : A) := fun _ : B => a. + +(** The [flip] combinator reverses the first two arguments of a function. *) + +Definition flip {A B C} (f : A -> B -> C) x y := f y x. + +(** Application as a combinator. *) + +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]]. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v new file mode 100644 index 00000000..e267fbbe --- /dev/null +++ b/theories/Program/Combinators.v @@ -0,0 +1,71 @@ +(************************************************************************) +(* 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 about standard combinators, exports functional extensionality. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +Require Import Coq.Program.Basics. +Require Export Coq.Program.FunctionalExtensionality. + +Open Scope program_scope. + +(** Composition has [id] for neutral element and is associative. *) + +Lemma compose_id_left : forall A B (f : A -> B), id ∘ f = f. +Proof. + intros. + unfold id, compose. + symmetry. apply eta_expansion. +Qed. + +Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f. +Proof. + intros. + unfold id, compose. + symmetry ; apply eta_expansion. +Qed. + +Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), + h ∘ g ∘ f = h ∘ (g ∘ f). +Proof. + intros. + reflexivity. +Qed. + +Hint Rewrite @compose_id_left @compose_id_right @compose_assoc : core. + +(** [flip] is involutive. *) + +Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id. +Proof. + unfold flip, compose. + intros. + extensionality x ; extensionality y ; extensionality z. + reflexivity. +Qed. + +(** [prod_curry] and [prod_uncurry] are each others inverses. *) + +Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id. +Proof. + simpl ; intros. + unfold prod_uncurry, prod_curry, compose. + extensionality x ; extensionality y ; extensionality z. + reflexivity. +Qed. + +Lemma prod_curry_uncurry : forall A B C, @prod_curry A B C ∘ prod_uncurry = id. +Proof. + simpl ; intros. + unfold prod_uncurry, prod_curry, compose. + extensionality x ; extensionality p. + destruct p ; simpl ; reflexivity. +Qed. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v new file mode 100644 index 00000000..d19f29c3 --- /dev/null +++ b/theories/Program/Equality.v @@ -0,0 +1,264 @@ +(* -*- coq-prog-args: ("-emacs-U") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Equality.v 11023 2008-05-30 11:08:39Z msozeau $ i*) + +(** Tactics related to (dependent) equality and proof irrelevance. *) + +Require Export ProofIrrelevance. +Require Export JMeq. + +Require Import Coq.Program.Tactics. + +(** Notation for heterogenous equality. *) + +Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level). + +(** Do something on an heterogeneous equality appearing in the context. *) + +Ltac on_JMeq tac := + match goal with + | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H + end. + +(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) + +Ltac simpl_one_JMeq := + on_JMeq ltac:(fun H => replace_hyp H (JMeq_eq H)). + +(** Repeat it for every possible hypothesis. *) + +Ltac simpl_JMeq := repeat simpl_one_JMeq. + +(** Just simplify an h.eq. without clearing it. *) + +Ltac simpl_one_dep_JMeq := + on_JMeq + ltac:(fun H => let H' := fresh "H" in + assert (H' := JMeq_eq H)). + +Require Import Eqdep. + +(** Simplify dependent equality using sigmas to equality of the second projections if possible. + Uses UIP. *) + +Ltac simpl_existT := + match goal with + [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => + let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H + end. + +Ltac simpl_existTs := repeat simpl_existT. + +(** Tries to eliminate a call to [eq_rect] (the substitution principle) by any means available. *) + +Ltac elim_eq_rect := + match goal with + | [ |- ?t ] => + match t with + | context [ @eq_rect _ _ _ _ _ ?p ] => + let P := fresh "P" in + set (P := p); simpl in P ; + ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + | context [ @eq_rect _ _ _ _ _ ?p _ ] => + let P := fresh "P" in + set (P := p); simpl in P ; + ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + end + end. + +(** Rewrite using uniqueness of indentity proofs [H = refl_equal X]. *) + +Ltac simpl_uip := + match goal with + [ H : ?X = ?X |- _ ] => rewrite (UIP_refl _ _ H) in *; clear H + end. + +(** Simplify equalities appearing in the context and goal. *) + +Ltac simpl_eq := simpl ; repeat (elim_eq_rect ; simpl) ; repeat (simpl_uip ; simpl). + +(** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *) + +Ltac abstract_eq_hyp H' p := + let ty := type of p in + let tyred := eval simpl in ty in + match tyred with + ?X = ?Y => + match goal with + | [ H : X = Y |- _ ] => fail 1 + | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H' + end + end. + +(** Apply the tactic tac to proofs of equality appearing as coercion arguments. + Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. + *) + +Ltac on_coerce_proof tac T := + match T with + | context [ eq_rect _ _ _ _ ?p ] => tac p + end. + +Ltac on_coerce_proof_gl tac := + match goal with + [ |- ?T ] => on_coerce_proof tac T + end. + +(** Abstract proofs of equalities of coercions. *) + +Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p). + +Ltac abstract_eq_proofs := repeat abstract_eq_proof. + +(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality + in the goal become convertible. *) + +Ltac pi_eq_proof_hyp p := + let ty := type of p in + let tyred := eval simpl in ty in + match tyred with + ?X = ?Y => + match goal with + | [ H : X = Y |- _ ] => + match p with + | H => fail 2 + | _ => rewrite (proof_irrelevance (X = Y) p H) + end + | _ => fail " No hypothesis with same type " + end + end. + +(** Factorize proofs of equality appearing as coercion arguments. *) + +Ltac pi_eq_proof := on_coerce_proof_gl pi_eq_proof_hyp. + +Ltac pi_eq_proofs := repeat pi_eq_proof. + +(** The two preceding tactics in sequence. *) + +Ltac clear_eq_proofs := + abstract_eq_proofs ; pi_eq_proofs. + +Hint Rewrite <- eq_rect_eq : refl_id. + +(** The refl_id database should be populated with lemmas of the form + [coerce_* t (refl_equal _) = t]. *) + +Ltac rewrite_refl_id := autorewrite with refl_id. + +(** Clear the context and goal of equality proofs. *) + +Ltac clear_eq_ctx := + rewrite_refl_id ; clear_eq_proofs. + +(** Reapeated elimination of [eq_rect] applications. + Abstracting equalities makes it run much faster than an naive implementation. *) + +Ltac simpl_eqs := + repeat (elim_eq_rect ; simpl ; clear_eq_ctx). + +(** Clear unused reflexivity proofs. *) + +Ltac clear_refl_eq := + match goal with [ H : ?X = ?X |- _ ] => clear H end. +Ltac clear_refl_eqs := repeat clear_refl_eq. + +(** Clear unused equality proofs. *) + +Ltac clear_eq := + match goal with [ H : _ = _ |- _ ] => clear H end. +Ltac clear_eqs := repeat clear_eq. + +(** Combine all the tactics to simplify goals containing coercions. *) + +Ltac simplify_eqs := + simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; + try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id. + +(** A tactic that tries to remove trivial equality guards in induction hypotheses coming + from [dependent induction]/[generalize_eqs] invocations. *) + + +Ltac simpl_IH_eq H := + match type of H with + | @JMeq _ ?x _ _ -> _ => + refine_hyp (H (JMeq_refl x)) + | _ -> @JMeq _ ?x _ _ -> _ => + refine_hyp (H _ (JMeq_refl x)) + | _ -> _ -> @JMeq _ ?x _ _ -> _ => + refine_hyp (H _ _ (JMeq_refl x)) + | _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => + refine_hyp (H _ _ _ (JMeq_refl x)) + | _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => + refine_hyp (H _ _ _ _ (JMeq_refl x)) + | _ -> _ -> _ -> _ -> _ -> @JMeq _ ?x _ _ -> _ => + refine_hyp (H _ _ _ _ _ (JMeq_refl x)) + | ?x = _ -> _ => + refine_hyp (H (refl_equal x)) + | _ -> ?x = _ -> _ => + refine_hyp (H _ (refl_equal x)) + | _ -> _ -> ?x = _ -> _ => + refine_hyp (H _ _ (refl_equal x)) + | _ -> _ -> _ -> ?x = _ -> _ => + refine_hyp (H _ _ _ (refl_equal x)) + | _ -> _ -> _ -> _ -> ?x = _ -> _ => + refine_hyp (H _ _ _ _ (refl_equal x)) + | _ -> _ -> _ -> _ -> _ -> ?x = _ -> _ => + refine_hyp (H _ _ _ _ _ (refl_equal x)) + end. + +Ltac simpl_IH_eqs H := repeat simpl_IH_eq H. + +Ltac do_simpl_IHs_eqs := + match goal with + | [ H : context [ @JMeq _ _ _ _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) + | [ H : context [ _ = _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) + end. + +Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs. + +Ltac simpl_depind := subst* ; autoinjections ; try discriminates ; + simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + +(** The following tactics allow to do induction on an already instantiated inductive predicate + by first generalizing it and adding the proper equalities to the context, in a maner similar to + the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) + +(** The [do_depind] higher-order tactic takes an induction tactic as argument and an hypothesis + and starts a dependent induction using this tactic. *) + +Ltac do_depind tac H := + generalize_eqs H ; tac H ; repeat progress simpl_depind. + +(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. *) + +Tactic Notation "dependent" "destruction" ident(H) := + do_depind ltac:(fun H => destruct H ; intros) H ; subst*. + +Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := + do_depind ltac:(fun H => destruct H using c ; intros) H. + +(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by + writting another wrapper calling do_depind. *) + +Tactic Notation "dependent" "induction" ident(H) := + do_depind ltac:(fun H => induction H ; intros) H. + +Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := + do_depind ltac:(fun H => induction H using c ; intros) H. + +(** 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_depind ltac:(fun H => generalize l ; clear l ; induction H ; intros) H. + +Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := + do_depind ltac:(fun H => generalize l ; clear l ; induction H using c ; intros) H. + diff --git a/theories/Program/FunctionalExtensionality.v b/theories/Program/FunctionalExtensionality.v new file mode 100644 index 00000000..b5ad5b4d --- /dev/null +++ b/theories/Program/FunctionalExtensionality.v @@ -0,0 +1,109 @@ +(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: FunctionalExtensionality.v 10739 2008-04-01 14:45:20Z 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. + + It also defines two lemmas for expansion of fixpoint defs using extensionnality and proof-irrelevance + to avoid a side condition on the functionals. *) + +Require Import Coq.Program.Utils. +Require Import Coq.Program.Wf. +Require Import Coq.Program.Equality. + +Set Implicit Arguments. +Unset Strict Implicit. + +(** The converse of functional equality. *) + +Lemma equal_f : forall A B : Type, forall (f g : A -> B), + f = g -> forall x, f x = g x. +Proof. + intros. + rewrite H. + auto. +Qed. + +(** Statements of functional equality for simple and dependent functions. *) + +Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), + forall (f g : forall x : A, B x), + (forall x, f x = g x) -> f = g. + +Lemma fun_extensionality : forall A B (f g : A -> B), + (forall x, f x = g x) -> f = g. +Proof. + intros ; apply fun_extensionality_dep. + assumption. +Qed. + +Hint Resolve fun_extensionality fun_extensionality_dep : program. + +(** Apply [fun_extensionality], introducing variable x. *) + +Tactic Notation "extensionality" ident(x) := + match goal with + [ |- ?X = ?Y ] => apply (@fun_extensionality _ _ X Y) || apply (@fun_extensionality_dep _ _ X Y) ; intro x + end. + +(** Eta expansion follows from extensionality. *) + +Lemma eta_expansion_dep : forall A (B : A -> Type) (f : forall x : A, B x), + f = fun x => f x. +Proof. + intros. + extensionality x. + reflexivity. +Qed. + +Lemma eta_expansion : forall A B (f : A -> B), + f = fun x => f x. +Proof. + intros ; apply eta_expansion_dep. +Qed. + +(** The two following lemmas allow to unfold a well-founded fixpoint definition without + restriction using the functional extensionality axiom. *) + +(** For a function defined with Program using a well-founded order. *) + +Program Lemma fix_sub_eq_ext : + forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) + (P : A -> Set) + (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), + forall x : A, + Fix_sub A R Rwf P F_sub x = + F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y). +Proof. + intros ; apply Fix_eq ; auto. + intros. + assert(f = g). + extensionality y ; apply H. + rewrite H0 ; auto. +Qed. + +(** For a function defined with Program using a measure. *) + +Program Lemma fix_sub_measure_eq_ext : + forall (A : Type) (f : A -> nat) (P : A -> Type) + (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), + forall x : A, + Fix_measure_sub A f P F_sub x = + F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). +Proof. + intros ; apply Fix_measure_eq ; auto. + intros. + assert(f0 = g). + extensionality y ; apply H. + rewrite H0 ; auto. +Qed. + + diff --git a/theories/Program/Program.v b/theories/Program/Program.v new file mode 100644 index 00000000..b6c3031e --- /dev/null +++ b/theories/Program/Program.v @@ -0,0 +1,7 @@ +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 diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v new file mode 100644 index 00000000..d021326a --- /dev/null +++ b/theories/Program/Subset.v @@ -0,0 +1,116 @@ +(************************************************************************) +(* 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 Import Coq.Program.Utils. +Require Import Coq.Program.Equality. + +Open Local Scope program_scope. + +(** Tactics related to subsets and proof irrelevance. *) + +(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to + factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *) + +Ltac on_subset_proof_aux tac T := + match T with + | context [ exist ?P _ ?p ] => try on_subset_proof_aux tac P ; tac p + end. + +Ltac on_subset_proof tac := + match goal with + [ |- ?T ] => on_subset_proof_aux tac T + end. + +Ltac abstract_any_hyp H' p := + match type of p with + ?X => + match goal with + | [ H : X |- _ ] => fail 1 + | _ => set (H':=p) ; try (change p with H') ; clearbody H' + end + end. + +Ltac abstract_subset_proof := + on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H). + +Ltac abstract_subset_proofs := repeat abstract_subset_proof. + +Ltac pi_subset_proof_hyp p := + match type of p with + ?X => + match goal with + | [ H : X |- _ ] => + match p with + | H => fail 2 + | _ => rewrite (proof_irrelevance X p H) + end + | _ => fail " No hypothesis with same type " + end + end. + +Ltac pi_subset_proof := on_subset_proof pi_subset_proof_hyp. + +Ltac pi_subset_proofs := repeat pi_subset_proof. + +(** The two preceding tactics in sequence. *) + +Ltac clear_subset_proofs := + abstract_subset_proofs ; simpl in * |- ; pi_subset_proofs ; clear_dups. + +Ltac pi := repeat progress f_equal ; apply proof_irrelevance. + +Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. +Proof. + induction n. + induction m. + simpl. + split ; intros ; subst. + + inversion H. + reflexivity. + + pi. +Qed. + +(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] + in tactics. *) + +Definition match_eq (A B : Type) (x : A) (fn : forall (y : A | y = x), B) : B := + fn (exist _ x (refl_equal x)). + +(* This is what we want to be able to do: replace the originaly matched object by a new, + propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) + +Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) + (y : A | y = x), + match_eq A B x fn = fn y. +Proof. + intros. + unfold match_eq. + f_equal. + destruct y. + (* uses proof-irrelevance *) + apply <- subset_eq. + symmetry. assumption. +Qed. + +(** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary + equality [t = u], and [u] is now the subject of the [match]. *) + +Ltac rewrite_match_eq H := + match goal with + [ |- ?T ] => + match T with + context [ match_eq ?A ?B ?t ?f ] => + rewrite (match_eq_rewrite A B t f (exist _ _ (sym_eq H))) + end + end. + +(** Otherwise we can simply unfold [match_eq] and the term trivially reduces to the original definition. *) + +Ltac simpl_match_eq := unfold match_eq ; simpl. diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v new file mode 100644 index 00000000..6cd75257 --- /dev/null +++ b/theories/Program/Syntax.v @@ -0,0 +1,59 @@ +(* -*- coq-prog-args: ("-emacs-U") -*- *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* Custom notations and implicits for Coq prelude definitions. + * + * Author: Matthieu Sozeau + * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud + * 91405 Orsay, France *) + +(** Notations for the unit type and value. *) + +Notation " () " := Datatypes.unit : type_scope. +Notation " () " := tt. + +(** Set maximally inserted implicit arguments for standard definitions. *) + +Implicit Arguments eq [[A]]. + +Implicit Arguments Some [[A]]. +Implicit Arguments None [[A]]. + +Implicit Arguments inl [[A] [B]]. +Implicit Arguments inr [[A] [B]]. + +Implicit Arguments left [[A] [B]]. +Implicit Arguments right [[A] [B]]. + +Require Import Coq.Lists.List. + +Implicit Arguments nil [[A]]. +Implicit Arguments cons [[A]]. + +(** Standard notations for lists. *) + +Notation " [ ] " := nil : list_scope. +Notation " [ x ] " := (cons x nil) : list_scope. +Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. + +(** 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 "exist" constr(x) := exists x. +Tactic Notation "exist" constr(x) constr(y) := exists x ; exists y. +Tactic Notation "exist" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. +Tactic Notation "exist" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v new file mode 100644 index 00000000..41b170c9 --- /dev/null +++ b/theories/Program/Tactics.v @@ -0,0 +1,234 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Tactics.v 11122 2008-06-13 14:18:44Z msozeau $ i*) + +(** This module implements various tactics used to simplify the goals produced by Program, + which are also generally useful. *) + +(** Destructs one pair, without care regarding naming. *) + +Ltac destruct_one_pair := + match goal with + | [H : (_ /\ _) |- _] => destruct H + | [H : prod _ _ |- _] => destruct H + end. + +(** Repeateadly destruct pairs. *) + +Ltac destruct_pairs := repeat (destruct_one_pair). + +(** Destruct one existential package, keeping the name of the hypothesis for the first component. *) + +Ltac destruct_one_ex := + let tac H := let ph := fresh "H" in (destruct H as [H ph]) in + let tacT H := let ph := fresh "X" in (destruct H as [H ph]) in + match goal with + | [H : (ex _) |- _] => tac H + | [H : (sig ?P) |- _ ] => tac H + | [H : (sigT ?P) |- _ ] => tacT H + | [H : (ex2 _) |- _] => tac H + end. + +(** Repeateadly destruct existentials. *) + +Ltac destruct_exists := repeat (destruct_one_ex). + +(** Repeateadly destruct conjunctions and existentials. *) + +Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). + +(** Destruct an existential hypothesis [t] keeping its name for the first component + and using [Ht] for the second *) + +Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. + +(** Destruct a disjunction keeping its name in both subgoals. *) + +Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H]. + +(** Discriminate that also work on a [x <> x] hypothesis. *) + +Ltac discriminates := + match goal with + | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity + | _ => discriminate + end. + +(** Revert the last hypothesis. *) + +Ltac revert_last := + match goal with + [ H : _ |- _ ] => revert H + end. + +(** Reapeateadly reverse the last hypothesis, putting everything in the goal. *) + +Ltac reverse := repeat revert_last. + +(** Clear duplicated hypotheses *) + +Ltac clear_dup := + match goal with + | [ H : ?X |- _ ] => + match goal with + | [ H' : X |- _ ] => + match H' with + | H => fail 2 + | _ => clear H' || clear H + end + end + end. + +Ltac clear_dups := repeat clear_dup. + +(** A non-failing subst that substitutes as much as possible. *) + +Ltac subst_no_fail := + repeat (match goal with + [ H : ?X = ?Y |- _ ] => subst X || subst Y + end). + +Tactic Notation "subst" "*" := subst_no_fail. + +Ltac on_application f tac T := + match T with + | context [f ?x ?y ?z ?w ?v ?u ?a ?b ?c] => tac (f x y z w v u a b c) + | context [f ?x ?y ?z ?w ?v ?u ?a ?b] => tac (f x y z w v u a b) + | context [f ?x ?y ?z ?w ?v ?u ?a] => tac (f x y z w v u a) + | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) + | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) + | context [f ?x ?y ?z ?w] => tac (f x y z w) + | context [f ?x ?y ?z] => tac (f x y z) + | context [f ?x ?y] => tac (f x y) + | context [f ?x] => tac (f x) + end. + +(** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) + +Ltac on_call f tac := + match goal with + | |- ?T => on_application f tac T + | H : ?T |- _ => on_application f tac T + end. + +(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object. *) + +Ltac destruct_call f := + let tac t := (destruct t) in on_call f tac. + +Ltac destruct_calls f := repeat destruct_call f. + +Ltac destruct_call_in f H := + let tac t := (destruct t) in + let T := type of H in + on_application f tac T. + +Ltac destruct_call_as f l := + let tac t := (destruct t as l) in on_call f tac. + +Ltac destruct_call_as_in f l H := + let tac t := (destruct t as l) in + let T := type of H in + on_application f tac T. + +Tactic Notation "destruct_call" constr(f) := destruct_call f. + +(** Permit to name the results of destructing the call to [f]. *) + +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := + destruct_call_as f l. + +(** Specify the hypothesis in which the call occurs as well. *) + +Tactic Notation "destruct_call" constr(f) "in" hyp(id) := + destruct_call_in f id. + +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := + destruct_call_as_in f l id. + +(** Try to inject any potential constructor equality hypothesis. *) + +Ltac autoinjection := + let tac H := progress (inversion H ; subst ; clear_dups) ; clear H in + match goal with + | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H + | [ H : ?f ?a ?b = ?f' ?a' ?b' |- _ ] => tac H + | [ H : ?f ?a ?b ?c = ?f' ?a' ?b' ?c' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g= ?f' ?a' ?b' ?c' ?d' ?e' ?g' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h= ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i ?j = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' ?j' |- _ ] => tac H + end. + +Ltac autoinjections := repeat autoinjection. + +(** Destruct an hypothesis by first copying it to avoid dependencies. *) + +Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. + +(** If bang appears in the goal, it means that we have a proof of False and the goal is solved. *) + +Ltac bang := + match goal with + | |- ?x => + match x with + | context [False_rect _ ?p] => elim p + end + end. + +(** A tactic to show contradiction by first asserting an automatically provable hypothesis. *) +Tactic Notation "contradiction" "by" constr(t) := + let H := fresh in assert t as H by auto with * ; contradiction. + +(** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal. + Useful to do saturation using tactics. *) + +Ltac add_hypothesis H' p := + match type of p with + ?X => + match goal with + | [ H : X |- _ ] => fail 1 + | _ => set (H':=p) ; try (change p with H') ; clearbody H' + end + end. + +(** A tactic to replace an hypothesis by another term. *) + +Ltac replace_hyp H c := + let H' := fresh "H" in + assert(H' := c) ; clear H ; rename H' into H. + +(** A tactic to refine an hypothesis by supplying some of its arguments. *) + +Ltac refine_hyp c := + let tac H := replace_hyp H c in + match c with + | ?H _ => tac H + | ?H _ _ => tac H + | ?H _ _ _ => tac H + | ?H _ _ _ _ => tac H + | ?H _ _ _ _ _ => tac H + | ?H _ _ _ _ _ _ => tac H + | ?H _ _ _ _ _ _ _ => tac H + | ?H _ _ _ _ _ _ _ _ => tac H + end. + +(** The default simplification tactic used by Program is defined by [program_simpl], sometimes [auto] + is not enough, better rebind using [Obligations Tactic := tac] in this case, + possibly using [program_simplify] to use standard goal-cleaning tactics. *) + +Ltac program_simplify := + simpl ; intros ; destruct_conjs ; simpl proj1_sig in * ; subst* ; autoinjections ; try discriminates ; + try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). + +Ltac program_simpl := program_simplify ; auto. + +Ltac obligations_tactic := program_simpl. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v new file mode 100644 index 00000000..21eee0ca --- /dev/null +++ b/theories/Program/Utils.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Utils.v 10919 2008-05-11 22:04:26Z msozeau $ i*) + +Require Export Coq.Program.Tactics. + +Set Implicit Arguments. + +(** A simpler notation for subsets defined on a cartesian product. *) + +Notation "{ ( x , y ) : A | P }" := + (sig (fun anonymous : A => let (x,y) := anonymous in P)) + (x ident, y ident, at level 10) : type_scope. + +(** Generates an obligation to prove False. *) + +Notation " ! " := (False_rect _ _) : program_scope. + +Delimit Scope program_scope with prg. + +(** Abbreviation for first projection and hiding of proofs of subset objects. *) + +Notation " ` t " := (proj1_sig t) (at level 10, t at next level) : program_scope. + +(** Coerces objects to their support before comparing them. *) + +Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70) : program_scope. + +Require Import Coq.Bool.Sumbool. + +(** Construct a dependent disjunction from a boolean. *) + +Notation dec := sumbool_of_bool. + +(** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *) + +(** Hide proofs and generates obligations when put in a term. *) + +Notation "'in_left'" := (@left _ _ _) : program_scope. +Notation "'in_right'" := (@right _ _ _) : program_scope. + +(** Extraction directives *) +(* +Extraction Inline proj1_sig. +Extract Inductive unit => "unit" [ "()" ]. +Extract Inductive bool => "bool" [ "true" "false" ]. +Extract Inductive sumbool => "bool" [ "true" "false" ]. +(* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *) +(* Extract Inductive sigT => "prod" [ "" ]. *) +*)
\ No newline at end of file diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v new file mode 100644 index 00000000..b6ba5d44 --- /dev/null +++ b/theories/Program/Wf.v @@ -0,0 +1,148 @@ +Require Import Coq.Init.Wf. +Require Import Coq.Program.Utils. +Require Import ProofIrrelevance. + +Open Local Scope program_scope. + +Implicit Arguments Acc_inv [A R x y]. + +(** Reformulation of the Wellfounded module using subsets where possible. *) + +Section Well_founded. + Variable A : Type. + Variable R : A -> A -> Prop. + Hypothesis Rwf : well_founded R. + + Section Acc. + + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := + F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) + (Acc_inv r (proj2_sig y))). + + Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + End Acc. + + Section FixPoint. + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) + + Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). + + Hypothesis + F_ext : + forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), + (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g. + + Lemma Fix_F_eq : + forall (x:A) (r:Acc R x), + F_sub x (fun (y:A|R y x) => Fix_F (`y) (Acc_inv r (proj2_sig y))) = Fix_F x r. + Proof. + destruct r using Acc_inv_dep; auto. + Qed. + + Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s. + Proof. + intro x; induction (Rwf x); intros. + rewrite (proof_irrelevance (Acc R x) r s) ; auto. + Qed. + + Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:A|R y x) => Fix (proj1_sig y)). + Proof. + intro x; unfold Fix in |- *. + rewrite <- (Fix_F_eq ). + apply F_ext; intros. + apply Fix_F_inv. + Qed. + + Lemma fix_sub_eq : + forall x : A, + Fix_sub P F_sub x = + let f_sub := F_sub in + f_sub x (fun (y : A | R y x) => Fix (`y)). + exact Fix_eq. + Qed. + + End FixPoint. + +End Well_founded. + +Extraction Inline Fix_F_sub Fix_sub. + +Require Import Wf_nat. +Require Import Lt. + +Section Well_founded_measure. + Variable A : Type. + Variable m : A -> nat. + + Section Acc. + + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. + + Program Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x := + F_sub x (fun (y : A | m y < m x) => Fix_measure_F_sub y + (@Acc_inv _ _ _ r (m y) (proj2_sig y))). + + Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)). + + End Acc. + + Section FixPoint. + Variable P : A -> Type. + + Program Variable F_sub : forall x:A, (forall (y : A | m y < m x), P y) -> P x. + + Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *) + + Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)). + + Hypothesis + F_ext : + forall (x:A) (f g:forall y : { y : A | m y < m x}, P (`y)), + (forall y : { y : A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g. + + Program Lemma Fix_measure_F_eq : + forall (x:A) (r:Acc lt (m x)), + F_sub x (fun (y:A | m y < m x) => Fix_F y (Acc_inv r (proj2_sig y))) = Fix_F x r. + Proof. + intros x. + set (y := m x). + unfold Fix_measure_F_sub. + intros r ; case r ; auto. + Qed. + + Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s. + Proof. + intros x r s. + rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto. + Qed. + + Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)). + Proof. + intro x; unfold Fix_measure in |- *. + rewrite <- (Fix_measure_F_eq ). + apply F_ext; intros. + apply Fix_measure_F_inv. + Qed. + + Lemma fix_measure_sub_eq : forall x : A, + Fix_measure_sub P F_sub x = + let f_sub := F_sub in + f_sub x (fun (y : A | m y < m x) => Fix_measure (`y)). + exact Fix_measure_eq. + Qed. + + End FixPoint. + +End Well_founded_measure. + +Extraction Inline Fix_measure_F_sub Fix_measure_sub. diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index 03935e2b..2af65320 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith.v 8883 2006-05-31 21:56:37Z letouzey $ i*) +(*i $Id: QArith.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Export QArith_base. Require Export Qring. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index fc92c678..304fbf77 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith_base.v 9932 2007-07-02 14:31:33Z notin $ i*) +(*i $Id: QArith_base.v 10765 2008-04-08 16:15:23Z msozeau $ i*) Require Export ZArith. Require Export ZArithRing. @@ -79,9 +79,9 @@ Qed. Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). Proof. unfold Qle, Qcompare, Zle. -split; intros; swap H. +split; intros; contradict H. rewrite Zcompare_Gt_Lt_antisym; auto. -rewrite Zcompare_Gt_Lt_antisym in H0; auto. +rewrite Zcompare_Gt_Lt_antisym in H; auto. Qed. Hint Unfold Qeq Qlt Qle: qarith. @@ -121,7 +121,7 @@ Defined. Definition Q_Setoid : Setoid_Theory Q Qeq. Proof. - split; unfold Qeq in |- *; auto; apply Qeq_trans. + split; red; unfold Qeq in |- *; auto; apply Qeq_trans. Qed. Add Setoid Q Qeq Q_Setoid as Qsetoid. @@ -130,6 +130,12 @@ Hint Resolve (Seq_refl Q Qeq Q_Setoid): qarith. Hint Resolve (Seq_sym Q Qeq Q_Setoid): qarith. Hint Resolve (Seq_trans Q Qeq Q_Setoid): qarith. +Theorem Qnot_eq_sym : forall x y, ~x == y -> ~y == x. +Proof. + auto with qarith. +Qed. + +Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) @@ -165,6 +171,13 @@ Infix "/" := Qdiv : Q_scope. Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope. +Lemma Qmake_Qdiv : forall a b, a#b==inject_Z a/inject_Z ('b). +Proof. +intros a b. +unfold Qeq. +simpl. +ring. +Qed. (** * Setoid compatibility results *) @@ -187,7 +200,7 @@ Proof. unfold Qeq, Qopp; simpl. Open Scope Z_scope. intros. - replace (- Qnum x1 * ' Qden x2) with (- (Qnum x1 * ' Qden x2)) by ring. + replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring. rewrite H in |- *; ring. Close Scope Z_scope. Qed. @@ -416,6 +429,11 @@ Qed. (** * Inverse and division. *) +Lemma Qinv_involutive : forall q, (/ / q) == q. +Proof. +intros [[|n|n] d]; red; simpl; reflexivity. +Qed. + Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1. Proof. intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl; @@ -474,6 +492,8 @@ Proof. Close Scope Z_scope. Qed. +Hint Resolve Qle_trans : qarith. + Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y. Proof. unfold Qlt, Qeq; auto with zarith. @@ -552,6 +572,9 @@ Proof. unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto. Qed. +Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le + Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qartih. + (** Some decidability results about orders. *) Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}. @@ -574,6 +597,8 @@ Proof. do 2 rewrite <- Zopp_mult_distr_l; omega. Qed. +Hint Resolve Qopp_le_compat : qarith. + Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qle; simpl. @@ -641,50 +666,136 @@ Proof. Close Scope Z_scope. Qed. -(** * Rational to the n-th power *) +Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b. +Proof. +intros a b Ha Hb. +unfold Qle in *. +simpl in *. +auto with *. +Qed. -Fixpoint Qpower (q:Q)(n:nat) { struct n } : Q := - match n with - | O => 1 - | S n => q * (Qpower q n) - end. +Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a. +Proof. +intros [[|n|n] d] Ha; assumption. +Qed. -Notation " q ^ n " := (Qpower q n) : Q_scope. +Lemma Qle_shift_div_l : forall a b c, + 0 < c -> a*c <= b -> a <= b/c. +Proof. +intros a b c Hc H. +apply Qmult_lt_0_le_reg_r with (c). + assumption. +setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm. +rewrite Qmult_div_r; try assumption. +auto with *. +Qed. -Lemma Qpower_1 : forall n, 1^n == 1. +Lemma Qle_shift_inv_l : forall a c, + 0 < c -> a*c <= 1 -> a <= /c. Proof. - induction n; simpl; auto with qarith. - rewrite IHn; auto with qarith. +intros a c Hc H. +setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). +change (a <= 1/c). +apply Qle_shift_div_l; assumption. Qed. -Lemma Qpower_0 : forall n, n<>O -> 0^n == 0. +Lemma Qle_shift_div_r : forall a b c, + 0 < b -> a <= c*b -> a/b <= c. Proof. - destruct n; simpl. - destruct 1; auto. - intros. - compute; auto. +intros a b c Hc H. +apply Qmult_lt_0_le_reg_r with b. + assumption. +setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm. +rewrite Qmult_div_r; try assumption. +auto with *. Qed. -Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n. +Lemma Qle_shift_inv_r : forall b c, + 0 < b -> 1 <= c*b -> /b <= c. Proof. - induction n; simpl; auto with qarith. - intros; compute; intro; discriminate. - intros. - apply Qle_trans with (0*(p^n)). - compute; intro; discriminate. - apply Qmult_le_compat_r; auto. +intros b c Hc H. +setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). +change (1/b <= c). +apply Qle_shift_div_r; assumption. Qed. -Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n. +Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a. Proof. - induction n. - compute; auto. - simpl. - intros; rewrite IHn; clear IHn. - unfold Qdiv; rewrite Qinv_mult_distr. - setoid_replace (1#p) with (/ inject_Z ('p)). - apply Qeq_refl. - compute; auto. +intros [[|n|n] d] Ha; assumption. +Qed. + +Lemma Qlt_shift_div_l : forall a b c, + 0 < c -> a*c < b -> a < b/c. +Proof. +intros a b c Hc H. +apply Qnot_le_lt. +intros H0. +apply (Qlt_not_le _ _ H). +apply Qmult_lt_0_le_reg_r with (/c). + apply Qinv_lt_0_compat. + assumption. +setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *). +assumption. +Qed. + +Lemma Qlt_shift_inv_l : forall a c, + 0 < c -> a*c < 1 -> a < /c. +Proof. +intros a c Hc H. +setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l). +change (a < 1/c). +apply Qlt_shift_div_l; assumption. +Qed. + +Lemma Qlt_shift_div_r : forall a b c, + 0 < b -> a < c*b -> a/b < c. +Proof. +intros a b c Hc H. +apply Qnot_le_lt. +intros H0. +apply (Qlt_not_le _ _ H). +apply Qmult_lt_0_le_reg_r with (/b). + apply Qinv_lt_0_compat. + assumption. +setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *). +assumption. +Qed. + +Lemma Qlt_shift_inv_r : forall b c, + 0 < b -> 1 < c*b -> /b < c. +Proof. +intros b c Hc H. +setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l). +change (1/b < c). +apply Qlt_shift_div_r; assumption. Qed. +(** * Rational to the n-th power *) + +Definition Qpower_positive (q:Q)(p:positive) : Q := + pow_pos Qmult q p. +Add Morphism Qpower_positive with signature Qeq ==> @eq _ ==> Qeq as Qpower_positive_comp. +Proof. +intros x1 x2 Hx y. +unfold Qpower_positive. +induction y; simpl; +try rewrite IHy; +try rewrite Hx; +reflexivity. +Qed. + +Definition Qpower (q:Q) (z:Z) := + match z with + | Zpos p => Qpower_positive q p + | Z0 => 1 + | Zneg p => /Qpower_positive q p + end. + +Notation " q ^ z " := (Qpower q z) : Q_scope. + +Add Morphism Qpower with signature Qeq ==> @eq _ ==> Qeq as Qpower_comp. +Proof. +intros x1 x2 Hx [|y|y]; try reflexivity; +simpl; rewrite Hx; reflexivity. +Qed. diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v new file mode 100644 index 00000000..e672016e --- /dev/null +++ b/theories/QArith/Qabs.v @@ -0,0 +1,124 @@ +(************************************************************************) +(* 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 Export QArith. +Require Export Qreduction. + +Hint Resolve Qlt_le_weak : qarith. + +Definition Qabs (x:Q) := let (n,d):=x in (Zabs n#d). + +Lemma Qabs_case : forall (x:Q) (P : Q -> Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x). +Proof. +intros x P H1 H2. +destruct x as [[|xn|xn] xd]; +[apply H1|apply H1|apply H2]; +abstract (compute; discriminate). +Defined. + +Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_wd. +intros [xn xd] [yn yd] H. +simpl. +unfold Qeq in *. +simpl in *. +change (' yd)%Z with (Zabs (' yd)). +change (' xd)%Z with (Zabs (' xd)). +repeat rewrite <- Zabs_Zmult. +congruence. +Qed. + +Lemma Qabs_pos : forall x, 0 <= x -> Qabs x == x. +Proof. +intros x H. +apply Qabs_case. +reflexivity. +intros H0. +setoid_replace x with 0. +reflexivity. +apply Qle_antisym; assumption. +Qed. + +Lemma Qabs_neg : forall x, x <= 0 -> Qabs x == - x. +Proof. +intros x H. +apply Qabs_case. +intros H0. +setoid_replace x with 0. +reflexivity. +apply Qle_antisym; assumption. +reflexivity. +Qed. + +Lemma Qabs_nonneg : forall x, 0 <= (Qabs x). +intros x. +apply Qabs_case. +auto. +apply (Qopp_le_compat x 0). +Qed. + +Lemma Zabs_Qabs : forall n d, (Zabs n#d)==Qabs (n#d). +Proof. +intros [|n|n]; reflexivity. +Qed. + +Lemma Qabs_opp : forall x, Qabs (-x) == Qabs x. +Proof. +intros x. +do 2 apply Qabs_case; try (intros; ring); +(intros H0 H1; +setoid_replace x with 0;[reflexivity|]; +apply Qle_antisym);try assumption; +rewrite Qle_minus_iff in *; +ring_simplify; +ring_simplify in H1; +assumption. +Qed. + +Lemma Qabs_triangle : forall x y, Qabs (x+y) <= Qabs x + Qabs y. +Proof. +intros [xn xd] [yn yd]. +unfold Qplus. +unfold Qle. +simpl. +apply Zmult_le_compat_r;auto with *. +change (' yd)%Z with (Zabs (' yd)). +change (' xd)%Z with (Zabs (' xd)). +repeat rewrite <- Zabs_Zmult. +apply Zabs_triangle. +Qed. + +Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b). +Proof. +intros [an ad] [bn bd]. +simpl. +rewrite Zabs_Zmult. +reflexivity. +Qed. + +Lemma Qle_Qabs : forall a, a <= Qabs a. +Proof. +intros a. +apply Qabs_case; auto with *. +intros H. +apply Qle_trans with 0; try assumption. +change 0 with (-0). +apply Qopp_le_compat. +assumption. +Qed. + +Lemma Qabs_triangle_reverse : forall x y, Qabs x - Qabs y <= Qabs (x - y). +Proof. +intros x y. +rewrite Qle_minus_iff. +setoid_replace (Qabs (x - y) + - (Qabs x - Qabs y)) with ((Qabs (x - y) + Qabs y) + - Qabs x) by ring. +rewrite <- Qle_minus_iff. +setoid_replace (Qabs x) with (Qabs (x-y+y)). +apply Qabs_triangle. +apply Qabs_wd. +ring. +Qed. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 98c5ff9e..42522468 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qcanon.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Qcanon.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Import Field. Require Import QArith. @@ -101,6 +101,7 @@ Infix "<=" := Qcle : Qc_scope. Infix ">" := Qcgt : Qc_scope. Infix ">=" := Qcge : Qc_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. +Notation "x < y < z" := (x<y/\y<z) : Qc_scope. Definition Qccompare (p q : Qc) := (Qcompare p q). Notation "p ?= q" := (Qccompare p q) : Qc_scope. @@ -139,7 +140,7 @@ Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}. Proof. intros. destruct (Qeq_dec x y) as [H|H]; auto. - right; swap H; subst; auto with qarith. + right; contradict H; subst; auto with qarith. Defined. (** The addition, multiplication and opposite are defined @@ -347,7 +348,7 @@ Proof. unfold Qcle, Qclt; intros; eapply Qlt_le_trans; eauto. Qed. -Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z. +Lemma Qclt_trans : forall x y z, x<y -> y<z -> x<z. Proof. unfold Qclt; intros; eapply Qlt_trans; eauto. Qed. @@ -472,7 +473,7 @@ Proof. compute; auto. Qed. -Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n. +Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. Proof. induction n; simpl; auto with qarith. intros; compute; intro; discriminate. @@ -495,23 +496,6 @@ Proof. intros _ H; inversion H. Qed. -(* -Definition Qcrt : Ring_Theory Qcplus Qcmult 1 0 Qcopp Qc_eq_bool. -Proof. -constructor. -exact Qcplus_comm. -exact Qcplus_assoc. -exact Qcmult_comm. -exact Qcmult_assoc. -exact Qcplus_0_l. -exact Qcmult_1_l. -exact Qcplus_opp_r. -exact Qcmult_plus_distr_l. -unfold Is_true; intros x y; generalize (Qc_eq_bool_correct x y); - case (Qc_eq_bool x y); auto. -Qed. -Add Ring Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcrt [ Qcmake ]. -*) Definition Qcrt : ring_theory 0 1 Qcplus Qcmult Qcminus Qcopp (eq(A:=Qc)). Proof. constructor. @@ -547,4 +531,14 @@ auto. Qed. - +Theorem Qc_decomp: forall x y: Qc, + (Qred x = x -> Qred y = y -> (x:Q) = y)-> x = y. +Proof. + intros (q, Hq) (q', Hq'); simpl; intros H. + assert (H1 := H Hq Hq'). + subst q'. + assert (Hq = Hq'). + apply Eqdep_dec.eq_proofs_unicity; auto; intros. + repeat decide equality. + congruence. +Qed. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v new file mode 100644 index 00000000..5d548aea --- /dev/null +++ b/theories/QArith/Qfield.v @@ -0,0 +1,153 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Qfield.v 10739 2008-04-01 14:45:20Z herbelin $ i*) + +Require Export Field. +Require Export QArith_base. +Require Import NArithRing. + +(** * field and ring tactics for rational numbers *) + +Definition Qeq_bool (x y : Q) := + if Qeq_dec x y then true else false. + +Lemma Qeq_bool_correct : forall x y : Q, Qeq_bool x y = true -> x==y. +Proof. + intros x y; unfold Qeq_bool in |- *; case (Qeq_dec x y); simpl in |- *; auto. + intros _ H; inversion H. +Qed. + +Lemma Qeq_bool_complete : forall x y : Q, x==y -> Qeq_bool x y = true. +Proof. + intros x y; unfold Qeq_bool in |- *; case (Qeq_dec x y); simpl in |- *; auto. +Qed. + +Definition Qsft : field_theory 0 1 Qplus Qmult Qminus Qopp Qdiv Qinv Qeq. +Proof. + constructor. + constructor. + exact Qplus_0_l. + exact Qplus_comm. + exact Qplus_assoc. + exact Qmult_1_l. + exact Qmult_comm. + exact Qmult_assoc. + exact Qmult_plus_distr_l. + reflexivity. + exact Qplus_opp_r. + discriminate. + reflexivity. + intros p Hp. + rewrite Qmult_comm. + apply Qmult_inv_r. + exact Hp. +Qed. + +Lemma Qpower_theory : power_theory 1 Qmult Qeq Z_of_N Qpower. +Proof. +constructor. +intros r [|n]; +reflexivity. +Qed. + +Ltac isQcst t := + match t with + | inject_Z ?z => isZcst z + | Qmake ?n ?d => + match isZcst n with + true => isPcst d + | _ => false + end + | _ => false + end. + +Ltac Qcst t := + match isQcst t with + true => t + | _ => NotConstant + end. + +Ltac Qpow_tac t := + match t with + | Z0 => N0 + | Zpos ?n => Ncst (Npos n) + | Z_of_N ?n => Ncst n + | NtoZ ?n => Ncst n + | _ => NotConstant + end. + +Add Field Qfield : Qsft + (decidable Qeq_bool_correct, + completeness Qeq_bool_complete, + constants [Qcst], + power_tac Qpower_theory [Qpow_tac]). + +(** Exemple of use: *) + +Section Examples. + +Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). + intros. + ring. +Qed. + +Let ex2 : forall x y : Q, x+y == y+x. + intros. + ring. +Qed. + +Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). + intros. + ring. +Qed. + +Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). + ring. +Qed. + +Let ex5 : 1+1 == 2#1. + ring. +Qed. + +Let ex6 : (1#1)+(1#1) == 2#1. + ring. +Qed. + +Let ex7 : forall x : Q, x-x== 0. + intro. + ring. +Qed. + +Let ex8 : forall x : Q, x^1 == x. + intro. + ring. +Qed. + +Let ex9 : forall x : Q, x^0 == 1. + intro. + ring. +Qed. + +Let ex10 : forall x y : Q, ~(y==0) -> (x/y)*y == x. +intros. +field. +auto. +Qed. + +End Examples. + +Lemma Qopp_plus : forall a b, -(a+b) == -a + -b. +Proof. + intros; ring. +Qed. + +Lemma Qopp_opp : forall q, - -q==q. +Proof. + intros; ring. +Qed. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v new file mode 100644 index 00000000..8672592d --- /dev/null +++ b/theories/QArith/Qpower.v @@ -0,0 +1,239 @@ +(************************************************************************) +(* 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 Import Zpow_facts Qfield Qreduction. + +Lemma Qpower_positive_1 : forall n, Qpower_positive 1 n == 1. +Proof. +induction n; +simpl; try rewrite IHn; reflexivity. +Qed. + +Lemma Qpower_1 : forall n, 1^n == 1. +Proof. + intros [|n|n]; simpl; try rewrite Qpower_positive_1; reflexivity. +Qed. + +Lemma Qpower_positive_0 : forall n, Qpower_positive 0 n == 0. +Proof. +induction n; +simpl; try rewrite IHn; reflexivity. +Qed. + +Lemma Qpower_0 : forall n, (n<>0)%Z -> 0^n == 0. +Proof. + intros [|n|n] Hn; try (elim Hn; reflexivity); simpl; + rewrite Qpower_positive_0; reflexivity. +Qed. + +Lemma Qpower_not_0_positive : forall a n, ~a==0 -> ~Qpower_positive a n == 0. +Proof. +intros a n X H. +apply X; clear X. +induction n; simpl in *; try assumption; +destruct (Qmult_integral _ _ H); +try destruct (Qmult_integral _ _ H0); auto. +Qed. + +Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n. +intros p n Hp. +induction n; simpl; repeat apply Qmult_le_0_compat;assumption. +Qed. + +Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n. +Proof. + intros p [|n|n] Hp; simpl; try discriminate; + try apply Qinv_le_0_compat; apply Qpower_pos_positive; assumption. +Qed. + +Lemma Qmult_power_positive : forall a b n, Qpower_positive (a*b) n == (Qpower_positive a n)*(Qpower_positive b n). +Proof. +induction n; +simpl; repeat rewrite IHn; ring. +Qed. + +Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n. +Proof. + intros a b [|n|n]; simpl; + try rewrite Qmult_power_positive; + try rewrite Qinv_mult_distr; + reflexivity. +Qed. + +Lemma Qinv_power_positive : forall a n, Qpower_positive (/a) n == /(Qpower_positive a n). +Proof. +induction n; +simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity. +Qed. + +Lemma Qinv_power : forall a n, (/a)^n == /a^n. +Proof. + intros a [|n|n]; simpl; + try rewrite Qinv_power_positive; + reflexivity. +Qed. + +Lemma Qdiv_power : forall a b n, (a/b)^n == (a^n/b^n). +Proof. +unfold Qdiv. +intros a b n. +rewrite Qmult_power. +rewrite Qinv_power. +reflexivity. +Qed. + +Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n. +Proof. +intros n p. +rewrite Qmake_Qdiv. +rewrite Qdiv_power. +rewrite Qpower_1. +unfold Qdiv. +ring. +Qed. + +Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_positive a n)*(Qpower_positive a m). +Proof. +intros a n m. +unfold Qpower_positive. +apply pow_pos_Pplus. +apply Q_Setoid. +apply Qmult_comp. +apply Qmult_comm. +apply Qmult_assoc. +Qed. + +Lemma Qpower_opp : forall a n, a^(-n) == /a^n. +Proof. +intros a [|n|n]; simpl; try reflexivity. +symmetry; apply Qinv_involutive. +Qed. + +Lemma Qpower_minus_positive : forall a (n m:positive), (Pcompare n m Eq=Gt)%positive -> Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m). +Proof. +intros a n m H. +destruct (Qeq_dec a 0). + rewrite q. + repeat rewrite Qpower_positive_0. + reflexivity. +rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by + (apply Qpower_not_0_positive; assumption). +apply Qdiv_comp;[|reflexivity]. +rewrite Qmult_comm. +rewrite <- Qpower_plus_positive. +rewrite Pplus_minus. +reflexivity. +assumption. +Qed. + +Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m. +Proof. +intros a [|n|n] [|m|m] H; simpl; try ring; +try rewrite Qpower_plus_positive; +try apply Qinv_mult_distr; try reflexivity; +case_eq ((n ?= m)%positive Eq); intros H0; simpl; + try rewrite Qpower_minus_positive; + try rewrite (Pcompare_Eq_eq _ _ H0); + try (field; try split; apply Qpower_not_0_positive); + try assumption; + apply ZC2; + assumption. +Qed. + +Lemma Qpower_plus' : forall a n m, (n+m <> 0)%Z -> a^(n+m) == a^n*a^m. +Proof. +intros a n m H. +destruct (Qeq_dec a 0)as [X|X]. +rewrite X. +rewrite Qpower_0 by assumption. +destruct n; destruct m; try (elim H; reflexivity); + simpl; repeat rewrite Qpower_positive_0; ring_simplify; + reflexivity. +apply Qpower_plus. +assumption. +Qed. + +Lemma Qpower_mult_positive : forall a n m, Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m. +Proof. +intros a n m. +induction n using Pind. + reflexivity. +rewrite Pmult_Sn_m. +rewrite Pplus_one_succ_l. +do 2 rewrite Qpower_plus_positive. +rewrite IHn. +rewrite Qmult_power_positive. +reflexivity. +Qed. + +Lemma Qpower_mult : forall a n m, a^(n*m) == (a^n)^m. +Proof. +intros a [|n|n] [|m|m]; simpl; + try rewrite Qpower_positive_1; + try rewrite Qpower_mult_positive; + try rewrite Qinv_power_positive; + try rewrite Qinv_involutive; + try reflexivity. +Qed. + +Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n. +Proof. +intros a [|n|n] H;[reflexivity| |elim H; reflexivity]. +induction n using Pind. + replace (a^1)%Z with a by ring. + ring. +rewrite Zpos_succ_morphism. +unfold Zsucc. +rewrite Zpower_exp; auto with *; try discriminate. +rewrite Qpower_plus' by discriminate. +rewrite <- IHn by discriminate. +replace (a^'n*a^1)%Z with (a^'n*a)%Z by ring. +ring_simplify. +reflexivity. +Qed. + +Lemma Qsqr_nonneg : forall a, 0 <= a^2. +Proof. +intros a. +destruct (Qlt_le_dec 0 a) as [A|A]. +apply (Qmult_le_0_compat a a); + (apply Qlt_le_weak; assumption). +setoid_replace (a^2) with ((-a)*(-a)) by ring. +rewrite Qle_minus_iff in A. +setoid_replace (0+ - a) with (-a) in A by ring. +apply Qmult_le_0_compat; assumption. +Qed. + +Theorem Qpower_decomp: forall p x y, + Qpower_positive (x #y) p == x ^ Zpos p # (Z2P ((Zpos y) ^ Zpos p)). +Proof. +induction p; intros; unfold Qmult; simpl. +(* xI *) +rewrite IHp, xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l. +repeat rewrite Zpower_pos_is_exp. +red; unfold Qmult, Qnum, Qden, Zpower. +repeat rewrite Zpos_mult_morphism. +repeat rewrite Z2P_correct. +repeat rewrite Zpower_pos_1_r; ring. +apply Zpower_pos_pos; red; auto. +repeat apply Zmult_lt_0_compat; auto; + apply Zpower_pos_pos; red; auto. +(* xO *) +rewrite IHp, <-Pplus_diag. +repeat rewrite Zpower_pos_is_exp. +red; unfold Qmult, Qnum, Qden, Zpower. +repeat rewrite Zpos_mult_morphism. +repeat rewrite Z2P_correct; try ring. +apply Zpower_pos_pos; red; auto. +repeat apply Zmult_lt_0_compat; auto; + apply Zpower_pos_pos; red; auto. +(* xO *) +unfold Qmult; simpl. +red; simpl; rewrite Zpower_pos_1_r; + rewrite Zpos_mult_morphism; ring. +Qed. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 6bd161f3..c98cef3f 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -6,24 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qreals.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Qreals.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Export Rbase. Require Export QArith_base. -(** A field tactic for rational numbers. *) +(** Injection of rational numbers into real numbers. *) -(** Since field cannot operate on setoid datatypes (yet?), - we translate Q goals into reals before applying field. *) +Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R. intros; apply not_O_IZR; auto with qarith. Qed. -Hint Immediate IZR_nz. -Hint Resolve Rmult_integral_contrapositive. - -Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. +Hint Resolve IZR_nz Rmult_integral_contrapositive. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. Proof. @@ -171,7 +167,7 @@ Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R. unfold Qminus in |- *; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto. Qed. -Lemma Q2R_inv : forall x : Q, ~ x==0#1 -> Q2R (/x) = (/ Q2R x)%R. +Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R. Proof. unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *. case x1. @@ -185,7 +181,7 @@ intros; Qed. Lemma Q2R_div : - forall x y : Q, ~ y==0#1 -> Q2R (x/y) = (Q2R x / Q2R y)%R. + forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R. Proof. unfold Qdiv, Rdiv in |- *. intros; rewrite Q2R_mult. @@ -194,16 +190,24 @@ Qed. Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. +Section LegacyQField. + +(** In the past, the field tactic was not able to deal with setoid datatypes, + so translating from Q to R and applying field on reals was a workaround. + See now Qfield for a direct field tactic on Q. *) + Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto. (** Examples of use: *) -Goal forall x y z : Q, (x+y)*z == (x*z)+(y*z). +Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). intros; QField. -Abort. +Qed. -Goal forall x y : Q, ~ y==0#1 -> (x/y)*y == x. +Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x. intros; QField. intro; apply H; apply eqR_Qeq. rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real. -Abort. +Qed. + +End LegacyQField.
\ No newline at end of file diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 340cac83..9c522f09 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qreduction.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Qreduction.v 10739 2008-04-01 14:45:20Z herbelin $ i*) (** Normalisation functions for rational numbers. *) @@ -145,6 +145,7 @@ Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). Definition Qmult' (p q : Q) := Qred (Qmult p q). +Definition Qminus' x y := Qred (Qminus x y). Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q). Proof. @@ -156,6 +157,11 @@ Proof. intros; unfold Qmult' in |- *; apply Qred_correct; auto. Qed. +Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q). +Proof. + intros; unfold Qminus' in |- *; apply Qred_correct; auto. +Qed. + Add Morphism Qplus' : Qplus'_comp. Proof. intros; unfold Qplus' in |- *. @@ -167,3 +173,21 @@ Add Morphism Qmult' : Qmult'_comp. rewrite H; rewrite H0; auto with qarith. Qed. +Add Morphism Qminus' : Qminus'_comp. + intros; unfold Qminus' in |- *. + rewrite H; rewrite H0; auto with qarith. +Qed. + +Lemma Qred_opp: forall q, Qred (-q) = - (Qred q). +Proof. + intros (x, y); unfold Qred; simpl. + rewrite Zggcd_opp; case Zggcd; intros p1 (p2, p3); simpl. + unfold Qopp; auto. +Qed. + +Theorem Qred_compare: forall x y, + Qcompare x y = Qcompare (Qred x) (Qred y). +Proof. + intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. +Qed. + diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index f9aa3e50..2d45d537 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -6,99 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qring.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) - -Require Export Ring. -Require Export QArith_base. - -(** * A ring tactic for rational numbers *) - -Definition Qeq_bool (x y : Q) := - if Qeq_dec x y then true else false. - -Lemma Qeq_bool_correct : forall x y : Q, Qeq_bool x y = true -> x==y. -Proof. - intros x y; unfold Qeq_bool in |- *; case (Qeq_dec x y); simpl in |- *; auto. - intros _ H; inversion H. -Qed. - -Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq. -Proof. - constructor. - exact Qplus_0_l. - exact Qplus_comm. - exact Qplus_assoc. - exact Qmult_1_l. - exact Qmult_comm. - exact Qmult_assoc. - exact Qmult_plus_distr_l. - reflexivity. - exact Qplus_opp_r. -Qed. - -Ltac isQcst t := - match t with - | inject_Z ?z => isZcst z - | Qmake ?n ?d => - match isZcst n with - true => isPcst d - | _ => false - end - | _ => false - end. - -Ltac Qcst t := - match isQcst t with - true => t - | _ => NotConstant - end. - -Add Ring Qring : Qsrt (decidable Qeq_bool_correct, constants [Qcst]). -(** Exemple of use: *) - -Section Examples. - -Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). - intros. - ring. -Qed. - -Let ex2 : forall x y : Q, x+y == y+x. - intros. - ring. -Qed. - -Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z). - intros. - ring. -Qed. - -Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2). - ring. -Qed. - -Let ex5 : 1+1 == 2#1. - ring. -Qed. - -Let ex6 : (1#1)+(1#1) == 2#1. - ring. -Qed. - -Let ex7 : forall x : Q, x-x== 0#1. - intro. - ring. -Qed. - -End Examples. - -Lemma Qopp_plus : forall a b, -(a+b) == -a + -b. -Proof. - intros; ring. -Qed. - -Lemma Qopp_opp : forall q, - -q==q. -Proof. - intros; ring. -Qed. +(*i $Id: Qring.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +Require Export Qfield. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v new file mode 100644 index 00000000..3f191c75 --- /dev/null +++ b/theories/QArith/Qround.v @@ -0,0 +1,139 @@ +(************************************************************************) +(* 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 Import QArith. + +Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p. +Proof. +intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. +do 2 rewrite <- Zopp_mult_distr_l; omega. +Qed. + +Hint Resolve Qopp_lt_compat : qarith. + +(************) + +Coercion Local inject_Z : Z >-> Q. + +Definition Qfloor (x:Q) := let (n,d) := x in Zdiv n (Zpos d). +Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z. + +Lemma Qfloor_Z : forall z:Z, Qfloor z = z. +Proof. +intros z. +simpl. +auto with *. +Qed. + +Lemma Qceiling_Z : forall z:Z, Qceiling z = z. +Proof. +intros z. +unfold Qceiling. +simpl. +rewrite Zdiv_1_r. +auto with *. +Qed. + +Lemma Qfloor_le : forall x, Qfloor x <= x. +Proof. +intros [n d]. +simpl. +unfold Qle. +simpl. +replace (n*1)%Z with n by ring. +rewrite Zmult_comm. +apply Z_mult_div_ge. +auto with *. +Qed. + +Hint Resolve Qfloor_le : qarith. + +Lemma Qle_ceiling : forall x, x <= Qceiling x. +Proof. +intros x. +apply Qle_trans with (- - x). + rewrite Qopp_involutive. + auto with *. +change (Qceiling x:Q) with (-(Qfloor(-x))). +auto with *. +Qed. + +Hint Resolve Qle_ceiling : qarith. + +Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. +Proof. +eauto with qarith. +Qed. + +Lemma Qlt_floor : forall x, x < (Qfloor x+1)%Z. +Proof. +intros [n d]. +simpl. +unfold Qlt. +simpl. +replace (n*1)%Z with n by ring. +ring_simplify. +replace (n / ' d * ' d + ' d)%Z with + (('d * (n / 'd) + n mod 'd) + 'd - n mod 'd)%Z by ring. +rewrite <- Z_div_mod_eq; auto with*. +rewrite <- Zlt_plus_swap. +destruct (Z_mod_lt n ('d)); auto with *. +Qed. + +Hint Resolve Qlt_floor : qarith. + +Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. +Proof. +intros x. +unfold Qceiling. +replace (- Qfloor (- x) - 1)%Z with (-(Qfloor (-x) + 1))%Z by ring. +change ((- (Qfloor (- x) + 1))%Z:Q) with (-(Qfloor (- x) + 1)%Z). +apply Qlt_le_trans with (- - x); auto with *. +rewrite Qopp_involutive. +auto with *. +Qed. + +Hint Resolve Qceiling_lt : qarith. + +Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. +Proof. +intros [xn xd] [yn yd] Hxy. +unfold Qle in *. +simpl in *. +rewrite <- (Zdiv_mult_cancel_r xn ('xd) ('yd)); auto with *. +rewrite <- (Zdiv_mult_cancel_r yn ('yd) ('xd)); auto with *. +rewrite (Zmult_comm ('yd) ('xd)). +apply Z_div_le; auto with *. +Qed. + +Hint Resolve Qfloor_resp_le : qarith. + +Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. +Proof. +intros x y Hxy. +unfold Qceiling. +cut (Qfloor (-y) <= Qfloor (-x))%Z; auto with *. +Qed. + +Hint Resolve Qceiling_resp_le : qarith. + +Add Morphism Qfloor with signature Qeq ==> @eq _ as Qfloor_comp. +Proof. +intros x y H. +apply Zle_antisym. + auto with *. +symmetry in H; auto with *. +Qed. + +Add Morphism Qceiling with signature Qeq ==> @eq _ as Qceiling_comp. +Proof. +intros x y H. +apply Zle_antisym. + auto with *. +symmetry in H; auto with *. +Qed.
\ No newline at end of file diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 802bfa71..7625cce6 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Alembert.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Alembert.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -25,12 +25,12 @@ Lemma Alembert_C1 : forall An:nat -> R, (forall n:nat, 0 < An n) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros An H H0. cut - (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)). + ({ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } -> + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). intro X; apply X. apply completeness. unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2); @@ -109,18 +109,18 @@ Proof. symmetry in |- *; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity. intro X; elim X; intros. - apply existT with x; apply tech10; + exists x; apply tech10; [ 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 | apply p ]. -Qed. +Defined. Lemma Alembert_C2 : forall An:nat -> R, (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros. set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2). @@ -133,7 +133,7 @@ Proof. assert (H6 := Alembert_C1 Wn H2 H4). elim H5; intros. elim H6; intros. - apply existT with (x - x0); unfold Un_cv in |- *; unfold Un_cv in p; + exists (x - x0); unfold Un_cv in |- *; unfold Un_cv in p; unfold Un_cv in p0; intros; cut (0 < eps / 2). intro; elim (p (eps / 2) H8); clear p; intros. elim (p0 (eps / 2) H8); clear p0; intros. @@ -334,21 +334,21 @@ Proof. rewrite <- Rabs_Ropp; apply RRle_abs. rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H. -Qed. +Defined. Lemma AlembertC3_step1 : forall (An:nat -> R) (x:R), x <> 0 -> (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - sigT (fun l:R => Pser An x l). + { l:R | Pser An x l }. Proof. intros; set (Bn := fun i:nat => An i * x ^ i). cut (forall n:nat, Bn n <> 0). intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0). intro; assert (H4 := Alembert_C2 Bn H2 H3). elim H4; intros. - apply existT with x0; unfold Bn in p; apply tech12; assumption. + exists x0; unfold Bn in p; apply tech12; assumption. unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x). intro; elim (H1 (eps / Rabs x) H4); intros. exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *; @@ -379,13 +379,13 @@ Proof. [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. intro; unfold Bn in |- *; apply prod_neq_R0; [ apply H0 | apply pow_nonzero; assumption ]. -Qed. +Defined. Lemma AlembertC3_step2 : - forall (An:nat -> R) (x:R), x = 0 -> sigT (fun l:R => Pser An x l). + forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }. Proof. - intros; apply existT with (An 0%nat). - unfold Pser in |- *; unfold infinit_sum in |- *; intros; exists 0%nat; intros; + intros; exists (An 0%nat). + unfold Pser in |- *; unfold infinite_sum in |- *; intros; exists 0%nat; intros; replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat). unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. @@ -395,12 +395,12 @@ Proof. [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ]. Qed. -(** An useful criterion of convergence for power series *) +(** A useful criterion of convergence for power series *) Theorem Alembert_C3 : forall (An:nat -> R) (x:R), (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 -> - sigT (fun l:R => Pser An x l). + { l:R | Pser An x l }. Proof. intros; case (total_order_T x 0); intro. elim s; intro. @@ -411,19 +411,19 @@ Proof. cut (x <> 0). intro; apply AlembertC3_step1; assumption. red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r). -Qed. +Defined. Lemma Alembert_C4 : forall (An:nat -> R) (k:R), 0 <= k < 1 -> (forall n:nat, 0 < An n) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros An k Hyp H H0. cut - (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)). + ({ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } -> + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). intro X; apply X. apply completeness. assert (H1 := tech13 _ _ Hyp H0). @@ -524,7 +524,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. - apply existT with x; apply tech10; + exists x; apply tech10; [ 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 @@ -536,21 +536,19 @@ Lemma Alembert_C5 : 0 <= k < 1 -> (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros. cut - (sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)). + ({ l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } -> + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }). intro Hyp0; apply Hyp0. apply cv_cauchy_2. apply cauchy_abs. apply cv_cauchy_1. cut - (sigT - (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l) -> - sigT - (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l)). + ({ l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l } -> + { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l }). intro Hyp; apply Hyp. apply (Alembert_C4 (fun i:nat => Rabs (An i)) k). assumption. @@ -568,11 +566,11 @@ Proof. apply H0. intro X. elim X; intros. - apply existT with x. + exists x. assumption. intro X. elim X; intros. - apply existT with x. + exists x. assumption. Qed. @@ -583,14 +581,12 @@ Lemma Alembert_C6 : 0 < k -> (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> - Rabs x < / k -> sigT (fun l:R => Pser An x l). + Rabs x < / k -> { l:R | Pser An x l }. intros. - cut - (sigT - (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l)). + cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }. intro X. elim X; intros. - apply existT with x0. + exists x0. apply tech12; assumption. case (total_order_T x 0); intro. elim s; intro. @@ -655,7 +651,7 @@ Lemma Alembert_C6 : assumption. apply Rinv_0_lt_compat; apply Rabs_pos_lt. red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a). - apply existT with (An 0%nat). + exists (An 0%nat). unfold Un_cv in |- *. intros. exists 0%nat. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 581c181f..5c4bbd6a 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: AltSeries.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) + (*i $Id: AltSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -153,14 +153,14 @@ Lemma CV_ALT : Un_decreasing Un -> positivity_seq Un -> Un_cv Un 0 -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }. Proof. intros. assert (H2 := CV_ALT_step0 _ H). assert (H3 := CV_ALT_step4 _ H H0). assert (X := growing_cv _ H2 H3). elim X; intros. - apply existT with x. + exists x. unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1; unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p. intros; cut (0 < eps / 2); @@ -220,7 +220,7 @@ Theorem alternated_series : forall Un:nat -> R, Un_decreasing Un -> Un_cv Un 0 -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }. Proof. intros; apply CV_ALT. assumption. @@ -408,7 +408,7 @@ Proof. Qed. Lemma exist_PI : - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }. Proof. apply alternated_series. apply PI_tg_decreasing. @@ -416,9 +416,7 @@ Proof. Qed. (** Now, PI is defined *) -Definition PI : R := 4 * match exist_PI with - | existT a b => a - end. +Definition PI : R := 4 * (let (a,_) := exist_PI in a). (** We can get an approximation of PI with the following inequality *) Lemma PI_ineq : diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index 7dbbd605..7327c64c 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: ArithProp.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) + (*i $Id: ArithProp.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) Require Import Rbase. Require Import Rbasic_fun. diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 10965951..0de639e8 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -6,14 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: Cos_plus.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) + (*i $Id: Cos_plus.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Rtrigo_def. Require Import Cos_rel. -Require Import Max. Open Local Scope nat_scope. Open Local Scope R_scope. +Require Import Max. +Open Local Scope nat_scope. +Open Local Scope R_scope. Definition Majxy (x y:R) (n:nat) : R := Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n). diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index d410e14a..aed481c7 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cos_rel.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Cos_rel.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -263,7 +263,7 @@ assert (H := exist_cos (x * x)). elim H; intros. assert (p_i := p). unfold cos_in in p. -unfold cos_n, infinit_sum in p. +unfold cos_n, infinite_sum in p. unfold R_dist in p. cut (cos x = x0). intro. @@ -295,7 +295,7 @@ assert (H := exist_cos ((x + y) * (x + y))). elim H; intros. assert (p_i := p). unfold cos_in in p. -unfold cos_n, infinit_sum in p. +unfold cos_n, infinite_sum in p. unfold R_dist in p. cut (cos (x + y) = x0). intro. @@ -344,7 +344,7 @@ assert (H0 := exist_sin (x * x)). elim H0; intros. assert (p_i := p). unfold sin_in in p. -unfold sin_n, infinit_sum in p. +unfold sin_n, infinite_sum in p. unfold R_dist in p. cut (sin x = x * x0). intro. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index a16af05c..22a52e67 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -6,10 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DiscrR.v 9178 2006-09-26 11:18:22Z barras $ i*) +(*i $Id: DiscrR.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import RIneq. -Require Import Omega. Open Local Scope R_scope. +Require Import Omega. +Open Local Scope R_scope. Lemma Rlt_R0_R2 : 0 < 2. change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index beb4b744..bf729526 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Exp_prop.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Exp_prop.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -27,7 +27,7 @@ Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x). Proof. intro; unfold exp in |- *; unfold projT1 in |- *. case (exist_exp x); intro. - unfold exp_in, Un_cv in |- *; unfold infinit_sum, E1 in |- *; trivial. + unfold exp_in, Un_cv in |- *; unfold infinite_sum, E1 in |- *; trivial. Qed. Definition Reste_E (x y:R) (N:nat) : R := @@ -734,7 +734,7 @@ Proof. apply Rinv_0_lt_compat; apply INR_fact_lt_0. apply (pow_lt _ n H). unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro. - unfold exp_in in |- *; unfold infinit_sum, Un_cv in |- *; trivial. + unfold exp_in in |- *; unfold infinite_sum, Un_cv in |- *; trivial. Qed. (**********) @@ -769,7 +769,7 @@ Proof. unfold derivable_pt_lim in |- *; intros. set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))). cut (CVN_R fn). - intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)). + intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }). intro cv; cut (forall n:nat, continuity (fn n)). intro; cut (continuity (SFL fn cv)). intro; unfold continuity in H1. @@ -809,13 +809,12 @@ Proof. unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity. apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ]. unfold SFL, exp in |- *. - unfold projT1 in |- *. - case (cv h); case (exist_exp h); intros. + case (cv h); case (exist_exp h); simpl; intros. eapply UL_sequence. apply u. unfold Un_cv in |- *; intros. unfold exp_in in e. - unfold infinit_sum in e. + unfold infinite_sum in e. cut (0 < eps0 * Rabs h). intro; elim (e _ H9); intros N0 H10. exists N0; intros. @@ -871,13 +870,12 @@ Proof. assert (H0 := Alembert_exp). unfold CVN_R in |- *. intro; unfold CVN_r in |- *. - apply existT with (fun N:nat => r ^ N / INR (fact (S N))). + exists (fun N:nat => r ^ N / INR (fact (S N))). cut - (sigT - (fun l:R => + { l:R | Un_cv (fun n:nat => - sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l)). + sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }. intro X. elim X; intros. exists x; intros. diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v index b33274af..3f76e77a 100644 --- a/theories/Reals/LegacyRfield.v +++ b/theories/Reals/LegacyRfield.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id$ i*) +(*i $Id: LegacyRfield.v 10739 2008-04-01 14:45:20Z herbelin $ i*) Require Export Raxioms. Require Export LegacyField. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index 8bb9298a..f22e49e1 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: MVT.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: MVT.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import Rtopology. Open Local Scope R_scope. +Require Import Rtopology. +Open Local Scope R_scope. (* The Mean Value Theorem *) Theorem MVT : @@ -189,7 +190,7 @@ Proof. intros; apply derivable_pt_id. intros; apply derivable_continuous_pt; apply X; assumption. intros; elim H1; intros; apply X; split; left; assumption. - intros; unfold derivable_pt in |- *; apply existT with (f' c); apply H0; + intros; unfold derivable_pt in |- *; exists (f' c); apply H0; apply H1. Qed. @@ -695,11 +696,11 @@ Proof. unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0; clear H0; intros H0 _; exists (g1 a - g2 a); intros; assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x). - intros; unfold derivable_pt in |- *; apply existT with (f x0); elim (H x0 H3); + intros; unfold derivable_pt in |- *; exists (f x0); elim (H x0 H3); intros; eapply derive_pt_eq_1; symmetry in |- *; apply H4. assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x). - intros; unfold derivable_pt in |- *; apply existT with (f x0); + intros; unfold derivable_pt in |- *; exists (f x0); elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry in |- *; apply H5. assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x). diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 306d5ac4..47ae149e 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -6,32 +6,31 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NewtonInt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: NewtonInt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Rtrigo. -Require Import Ranalysis. Open Local Scope R_scope. +Require Import Ranalysis. +Open Local Scope R_scope. (*******************************************) (* Newton's Integral *) (*******************************************) Definition Newton_integrable (f:R -> R) (a b:R) : Type := - sigT (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a). + { g:R -> R | antiderivative f g a b \/ antiderivative f g b a }. Definition NewtonInt (f:R -> R) (a b:R) (pr:Newton_integrable f a b) : R := - let g := match pr with - | existT a b => a - end in g b - g a. + let (g,_) := pr in g b - g a. (* If f is differentiable, then f' is Newton integrable (Tautology ?) *) Lemma FTCN_step1 : forall (f:Differential) (a b:R), Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b. Proof. - intros f a b; unfold Newton_integrable in |- *; apply existT with (d1 f); + intros f a b; unfold Newton_integrable in |- *; exists (d1 f); unfold antiderivative in |- *; intros; case (Rle_dec a b); intro; [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ] @@ -52,7 +51,7 @@ Qed. Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a. Proof. intros f a; unfold Newton_integrable in |- *; - apply existT with (fct_cte (f a) * id)%F; left; + exists (fct_cte (f a) * id)%F; left; unfold antiderivative in |- *; split. intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x). apply derivable_pt_mult. @@ -82,7 +81,7 @@ Lemma NewtonInt_P3 : Newton_integrable f b a. Proof. unfold Newton_integrable in |- *; intros; elim X; intros g H; - apply existT with g; tauto. + exists g; tauto. Defined. (* $\int_a^b f = -\int_b^a f$ *) @@ -94,7 +93,7 @@ Proof. unfold NewtonInt in |- *; case (NewtonInt_P3 f a b - (existT + (exist (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x p)). intros; elim o; intro. @@ -112,7 +111,7 @@ Proof. unfold NewtonInt in |- *; case (NewtonInt_P3 f a b - (existT + (exist (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x p)); intros; elim o; intro. assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros; @@ -325,7 +324,7 @@ Proof. | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) end) x). - unfold derivable_pt in |- *; apply existT with (f x); apply H7. + unfold derivable_pt in |- *; exists (f x); apply H7. exists H8; symmetry in |- *; apply derive_pt_eq_0; apply H7. assert (H5 : a <= x <= b). split; [ assumption | right; assumption ]. @@ -370,7 +369,7 @@ Proof. | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) end) x). - unfold derivable_pt in |- *; apply existT with (f x); apply H13. + unfold derivable_pt in |- *; exists (f x); apply H13. exists H14; symmetry in |- *; apply derive_pt_eq_0; apply H13. assert (H5 : b <= x <= c). split; [ left; assumption | assumption ]. @@ -417,7 +416,7 @@ Proof. | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) end) x). - unfold derivable_pt in |- *; apply existT with (f x); apply H7. + unfold derivable_pt in |- *; exists (f x); apply H7. exists H8; symmetry in |- *; apply derive_pt_eq_0; apply H7. Qed. @@ -482,7 +481,7 @@ Proof. match Rle_dec x b with | left _ => F0 x | right _ => F1 x + (F0 b - F1 b) - end); apply existT with g; left; unfold g in |- *; + end); exists g; left; unfold g in |- *; apply antiderivative_P2. elim H0; intro. assumption. @@ -508,7 +507,7 @@ Proof. elim s0; intro. (* a<b & b<c *) unfold Newton_integrable in |- *; - apply existT with + exists (fun x:R => match Rle_dec x b with | left _ => F0 x @@ -526,7 +525,7 @@ Proof. (* a<b & b>c *) case (total_order_T a c); intro. elim s0; intro. - unfold Newton_integrable in |- *; apply existT with F0. + unfold Newton_integrable in |- *; exists F0. left. elim H1; intro. unfold antiderivative in H; elim H; clear H; intros _ H. @@ -540,7 +539,7 @@ Proof. unfold antiderivative in H2; elim H2; clear H2; intros _ H2. elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)). rewrite b0; apply NewtonInt_P1. - unfold Newton_integrable in |- *; apply existT with F1. + unfold Newton_integrable in |- *; exists F1. right. elim H1; intro. unfold antiderivative in H; elim H; clear H; intros _ H. @@ -560,7 +559,7 @@ Proof. (* a>b & b<c *) case (total_order_T a c); intro. elim s0; intro. - unfold Newton_integrable in |- *; apply existT with F1. + unfold Newton_integrable in |- *; exists F1. left. elim H1; intro. (*****************) @@ -575,7 +574,7 @@ Proof. unfold antiderivative in H; elim H; clear H; intros _ H. elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)). rewrite b0; apply NewtonInt_P1. - unfold Newton_integrable in |- *; apply existT with F0. + unfold Newton_integrable in |- *; exists F0. right. elim H0; intro. unfold antiderivative in H; elim H; clear H; intros _ H. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 64b8e0af..e122a26a 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -6,14 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PSeries_reg.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: PSeries_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Ranalysis1. Require Import Max. -Require Import Even. Open Local Scope R_scope. +Require Import Even. +Open Local Scope R_scope. Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r. @@ -28,25 +29,21 @@ Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) (** Normal convergence *) Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := - sigT - (fun An:nat -> R => - sigT - (fun l:R => + { An:nat -> R & + { l:R | Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\ - (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n))). + (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n) } }. Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r. Definition SFL (fn:nat -> R -> R) - (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)) - (y:R) : R := match cv y with - | existT a b => a - end. + (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) + (y:R) : R := let (a,_) := cv y in a. (** In a complete space, normal convergence implies uniform convergence *) Lemma CVN_CVU : forall (fn:nat -> R -> R) - (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)) + (cv:forall x:R, {l:R | Un_cv (fun N:nat => SP fn N x) l }) (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r. Proof. intros; unfold CVU in |- *; intros. @@ -193,7 +190,7 @@ Qed. (** Continuity and normal convergence *) Lemma SFL_continuity_pt : forall (fn:nat -> R -> R) - (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)) + (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) (r:posreal), CVN_r fn r -> (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) -> @@ -210,7 +207,7 @@ Qed. Lemma SFL_continuity : forall (fn:nat -> R -> R) - (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)), + (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }), CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv). Proof. intros; unfold continuity in |- *; intro. @@ -229,7 +226,7 @@ Qed. (** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) Lemma CVN_R_CVS : forall fn:nat -> R -> R, - CVN_R fn -> forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l). + CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }. Proof. intros; apply R_complete. unfold SP in |- *; set (An := fun N:nat => fn N x). @@ -248,7 +245,7 @@ Proof. rewrite Rminus_0_r. pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. - apply existT with l. + exists l. cut (forall n:nat, 0 <= Bn n). intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros. elim (H3 _ H6); intros. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index a8f72302..d5ae2aca 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PartSum.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: PartSum.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -153,7 +153,7 @@ Lemma tech12 : Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l -> Pser An x l. Proof. - intros; unfold Pser in |- *; unfold infinit_sum in |- *; unfold Un_cv in H; + intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H; assumption. Qed. @@ -218,9 +218,9 @@ Qed. (* Unicity of the limit defined by convergent series *) Lemma uniqueness_sum : forall (An:nat -> R) (l1 l2:R), - infinit_sum An l1 -> infinit_sum An l2 -> l1 = l2. + infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2. Proof. - unfold infinit_sum in |- *; intros. + unfold infinite_sum in |- *; intros. case (Req_dec l1 l2); intro. assumption. cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ]. @@ -450,7 +450,7 @@ Qed. (**********) Lemma cv_cauchy_1 : forall An:nat -> R, - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) -> + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } -> Cauchy_crit_series An. Proof. intros An X. @@ -481,7 +481,7 @@ Qed. Lemma cv_cauchy_2 : forall An:nat -> R, Cauchy_crit_series An -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros. apply R_complete. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 7d98a844..19bdeccd 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RIneq.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: RIneq.v 10762 2008-04-06 16:57:31Z herbelin $ i*) -(***************************************************************************) -(** Basic lemmas for the classical reals numbers *) -(***************************************************************************) +(*********************************************************) +(** * Basic lemmas for the classical real numbers *) +(*********************************************************) Require Export Raxioms. Require Import Rpow_def. @@ -24,21 +24,32 @@ Open Local Scope R_scope. Implicit Type r : R. -(**************************************************************************) -(** * Relation between orders and equality *) -(**************************************************************************) +(*********************************************************) +(** ** Relation between orders and equality *) +(*********************************************************) + +(** Reflexivity of the large order *) + +Lemma Rle_refl : forall r, r <= r. +Proof. + intro; right; reflexivity. +Qed. +Hint Immediate Rle_refl: rorders. + +Lemma Rge_refl : forall r, r <= r. +Proof. exact Rle_refl. Qed. +Hint Immediate Rge_refl: rorders. + +(** Irreflexivity of the strict order *) -(**********) Lemma Rlt_irrefl : forall r, ~ r < r. Proof. generalize Rlt_asym. intuition eauto. Qed. Hint Resolve Rlt_irrefl: real. -Lemma Rle_refl : forall r, r <= r. -Proof. - intro; right; reflexivity. -Qed. +Lemma Rgt_irrefl : forall r, ~ r > r. +Proof. exact Rlt_irrefl. Qed. Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2. Proof. @@ -58,7 +69,7 @@ Proof. Qed. Hint Resolve Rlt_dichotomy_converse: real. -(** Reasoning by case on equalities and order *) +(** Reasoning by case on equality and order *) (**********) Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2. @@ -80,58 +91,104 @@ Proof. intros; generalize (total_order_T r1 r2); tauto. Qed. +(*********************************************************) +(** ** Relating [<], [>], [<=] and [>=] *) +(*********************************************************) -(*********************************************************************************) -(** * Order Lemma : relating [<], [>], [<=] and [>=] *) -(*********************************************************************************) +(*********************************************************) +(** ** Order *) +(*********************************************************) + +(** *** Relating strict and large orders *) -(**********) Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. Proof. intros; red in |- *; tauto. Qed. Hint Resolve Rlt_le: real. +Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. +Proof. + intros; red; tauto. +Qed. + (**********) Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. Proof. destruct 1; red in |- *; auto with real. Qed. - Hint Immediate Rle_ge: real. +Hint Resolve Rle_ge: rorders. -(**********) Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. Proof. destruct 1; red in |- *; auto with real. Qed. - Hint Resolve Rge_le: real. +Hint Immediate Rge_le: rorders. (**********) +Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. +Proof. + trivial. +Qed. +Hint Resolve Rlt_gt: rorders. + +Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. +Proof. + trivial. +Qed. +Hint Immediate Rgt_lt: rorders. + +(**********) + Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1. Proof. intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle in |- *; tauto. Qed. - Hint Immediate Rnot_le_lt: real. +Lemma Rnot_ge_gt : forall r1 r2, ~ r1 >= r2 -> r2 > r1. +Proof. intros; red; apply Rnot_le_lt. auto with real. Qed. + +Lemma Rnot_le_gt : forall r1 r2, ~ r1 <= r2 -> r1 > r2. +Proof. intros; red; apply Rnot_le_lt. auto with real. Qed. + Lemma Rnot_ge_lt : forall r1 r2, ~ r1 >= r2 -> r1 < r2. +Proof. intros; apply Rnot_le_lt. auto with real. Qed. + +Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1. Proof. - intros; apply Rnot_le_lt; auto with real. + intros r1 r2 H; destruct (Rtotal_order r1 r2) as [ | [ H0 | H0 ] ]. + contradiction. subst; auto with rorders. auto with real. Qed. +Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2. +Proof. auto using Rnot_lt_le with real. Qed. + +Lemma Rnot_gt_ge : forall r1 r2, ~ r1 > r2 -> r2 >= r1. +Proof. intros; eauto using Rnot_lt_le with rorders. Qed. + +Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2. +Proof. eauto using Rnot_gt_ge with rorders. Qed. + (**********) Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. Proof. generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *. intuition eauto 3. Qed. +Hint Immediate Rlt_not_le: real. Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. -Proof Rlt_not_le. +Proof. exact Rlt_not_le. Qed. -Hint Immediate Rlt_not_le: real. +Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. +Proof. red; intros; eapply Rlt_not_le; eauto with real. Qed. +Hint Immediate Rlt_not_ge: real. + +Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. +Proof. exact Rlt_not_ge. Qed. Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2. Proof. @@ -139,13 +196,14 @@ Proof. unfold Rle in |- *; intuition. Qed. -(**********) -Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. -Proof. - generalize Rlt_not_le. unfold Rle, Rge in |- *. intuition eauto 3. -Qed. +Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> ~ r1 < r2. +Proof. intros; apply Rle_not_lt; auto with real. Qed. -Hint Immediate Rlt_not_ge: real. +Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> ~ r1 > r2. +Proof. do 2 intro; apply Rle_not_lt. Qed. + +Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> ~ r1 > r2. +Proof. do 2 intro; apply Rge_not_lt. Qed. (**********) Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. @@ -172,25 +230,51 @@ Proof. Qed. Hint Immediate Req_ge_sym: real. +(** *** Asymmetry *) + +(** Remark: [Rlt_asym] is an axiom *) + +Lemma Rgt_asym : forall r1 r2:R, r1 > r2 -> ~ r2 > r1. +Proof. do 2 intro; apply Rlt_asym. Qed. + +(** *** Antisymmetry *) + Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2. Proof. intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle in |- *; intuition. Qed. Hint Resolve Rle_antisym: real. +Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2. +Proof. auto with real. Qed. + (**********) Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2. Proof. intuition. Qed. +Lemma Rge_ge_eq : forall r1 r2, r1 >= r2 /\ r2 >= r1 <-> r1 = r2. +Proof. + intuition. +Qed. + +(** *** Compatibility with equality *) + Lemma Rlt_eq_compat : forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3. Proof. intros x x' y y'; intros; replace x with x'; replace y with y'; assumption. Qed. -(**********) +Lemma Rgt_eq_compat : + forall r1 r2 r3 r4, r1 = r2 -> r2 > r4 -> r4 = r3 -> r1 > r3. +Proof. intros; red; apply Rlt_eq_compat with (r2:=r4) (r4:=r2); auto. Qed. + +(** *** Transitivity *) + +(** Remark: [Rlt_trans] is an axiom *) + Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3. Proof. generalize trans_eq Rlt_trans Rlt_eq_compat. @@ -198,6 +282,12 @@ Proof. intuition eauto 2. Qed. +Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3. +Proof. eauto using Rle_trans with rorders. Qed. + +Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. +Proof. eauto using Rlt_trans with rorders. Qed. + (**********) Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. Proof. @@ -206,21 +296,25 @@ Proof. intuition eauto 2. Qed. -(**********) Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3. Proof. generalize Rlt_trans Rlt_eq_compat; unfold Rle in |- *; intuition eauto 2. Qed. +Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3. +Proof. eauto using Rlt_le_trans with rorders. Qed. + +Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3. +Proof. eauto using Rle_lt_trans with rorders. Qed. + +(** *** (Classical) decidability *) -(** Decidability of the order *) Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}. Proof. intros; generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2); intuition. Qed. -(**********) Lemma Rle_dec : forall r1 r2, {r1 <= r2} + {~ r1 <= r2}. Proof. intros r1 r2. @@ -228,28 +322,44 @@ Proof. intuition eauto 4 with real. Qed. -(**********) Lemma Rgt_dec : forall r1 r2, {r1 > r2} + {~ r1 > r2}. -Proof. - intros; unfold Rgt in |- *; intros; apply Rlt_dec. -Qed. +Proof. do 2 intro; apply Rlt_dec. Qed. -(**********) Lemma Rge_dec : forall r1 r2, {r1 >= r2} + {~ r1 >= r2}. +Proof. intros; edestruct Rle_dec; [left|right]; eauto with rorders. Qed. + +Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}. Proof. - intros; generalize (Rle_dec r2 r1); intuition. + intros; generalize (total_order_T r1 r2); intuition. Qed. -Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}. +Lemma Rgt_ge_dec : forall r1 r2, {r1 > r2} + {r2 >= r1}. +Proof. intros; edestruct Rlt_le_dec; [left|right]; eauto with rorders. Qed. + +Lemma Rle_lt_dec : forall r1 r2, {r1 <= r2} + {r2 < r1}. Proof. intros; generalize (total_order_T r1 r2); intuition. Qed. +Lemma Rge_gt_dec : forall r1 r2, {r1 >= r2} + {r2 > r1}. +Proof. intros; edestruct Rle_lt_dec; [left|right]; eauto with rorders. Qed. + +Lemma Rlt_or_le : forall r1 r2, r1 < r2 \/ r2 <= r1. +Proof. + intros n m; elim (Rle_lt_dec m n); auto with real. +Qed. + +Lemma Rgt_or_ge : forall r1 r2, r1 > r2 \/ r2 >= r1. +Proof. intros; edestruct Rlt_or_le; [left|right]; eauto with rorders. Qed. + Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1. Proof. intros n m; elim (Rlt_le_dec m n); auto with real. Qed. +Lemma Rge_or_gt : forall r1 r2, r1 >= r2 \/ r2 > r1. +Proof. intros; edestruct Rle_or_lt; [left|right]; eauto with rorders. Qed. + Lemma Rle_lt_or_eq_dec : forall r1 r2, r1 <= r2 -> {r1 < r2} + {r1 = r2}. Proof. intros r1 r2 H; generalize (total_order_T r1 r2); intuition. @@ -262,19 +372,11 @@ Proof. intros n m p q; intros; generalize (Rlt_le_dec m q); intuition. Qed. -(****************************************************************) -(** * Field Lemmas *) -(* This part contains lemma involving the Fields operations *) -(****************************************************************) (*********************************************************) -(** ** Addition *) +(** ** Addition *) (*********************************************************) -Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. -Proof. - split; ring. -Qed. -Hint Resolve Rplus_ne: real v62. +(** Remark: [Rplus_0_l] is an axiom *) Lemma Rplus_0_r : forall r, r + 0 = r. Proof. @@ -282,14 +384,22 @@ Proof. Qed. Hint Resolve Rplus_0_r: real. +Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. +Proof. + split; ring. +Qed. +Hint Resolve Rplus_ne: real v62. + (**********) + +(** Remark: [Rplus_opp_r] is an axiom *) + Lemma Rplus_opp_l : forall r, - r + r = 0. Proof. intro; ring. Qed. Hint Resolve Rplus_opp_l: real. - (**********) Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = 0 -> r2 = - r1. Proof. @@ -298,7 +408,6 @@ Proof. rewrite Rplus_assoc; rewrite H; ring. Qed. -(*i New i*) Hint Resolve (f_equal (A:=R)): real. Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2. @@ -325,9 +434,31 @@ Proof. intros r b; pattern r at 2 in |- *; replace r with (r + 0); eauto with real. Qed. -(***********************************************************) -(** ** Multiplication *) -(***********************************************************) +(***********) +Lemma Rplus_eq_0_l : + forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. +Proof. + intros a b H [H0| H0] H1; auto with real. + absurd (0 < a + b). + rewrite H1; auto with real. + apply Rle_lt_trans with (a + 0). + rewrite Rplus_0_r in |- *; assumption. + auto using Rplus_lt_compat_l with real. + rewrite <- H0, Rplus_0_r in H1; assumption. +Qed. + +Lemma Rplus_eq_R0 : + forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0. +Proof. + intros a b; split. + apply Rplus_eq_0_l with b; auto with real. + apply Rplus_eq_0_l with a; auto with real. + rewrite Rplus_comm; auto with real. +Qed. + +(*********************************************************) +(** ** Multiplication *) +(*********************************************************) (**********) Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1. @@ -340,13 +471,13 @@ Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r. Proof. intros; field; trivial. Qed. +Hint Resolve Rinv_l_sym: real. Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r. Proof. intros; field; trivial. Qed. -Hint Resolve Rinv_l_sym Rinv_r_sym: real. - +Hint Resolve Rinv_r_sym: real. (**********) Lemma Rmult_0_r : forall r, r * 0 = 0. @@ -382,7 +513,7 @@ Proof. auto with real. Qed. -(*i OLD i*)Hint Resolve Rmult_eq_compat_l: v62. +(*i Old i*)Hint Resolve Rmult_eq_compat_l: v62. (**********) Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. @@ -423,7 +554,6 @@ Proof. auto with real. Qed. - (**********) Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0. Proof. @@ -439,6 +569,10 @@ Proof. Qed. Hint Resolve Rmult_integral_contrapositive: real. +Lemma Rmult_integral_contrapositive_currified : + forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0. +Proof. auto using Rmult_integral_contrapositive. Qed. + (**********) Lemma Rmult_plus_distr_r : forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3. @@ -446,11 +580,15 @@ Proof. intros; ring. Qed. -(** ** Square function *) +(*********************************************************) +(** ** Square function *) +(*********************************************************) (***********) Definition Rsqr r : R := r * r. +Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope. + (***********) Lemma Rsqr_0 : Rsqr 0 = 0. unfold Rsqr in |- *; auto with real. @@ -462,7 +600,7 @@ Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0. Qed. (*********************************************************) -(** ** Opposite *) +(** ** Opposite *) (*********************************************************) (**********) @@ -509,8 +647,9 @@ Proof. Qed. Hint Resolve Ropp_plus_distr: real. - -(** ** Opposite and multiplication *) +(*********************************************************) +(** ** Opposite and multiplication *) +(*********************************************************) Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2). Proof. @@ -530,7 +669,9 @@ Proof. intros; ring. Qed. -(** ** Substraction *) +(*********************************************************) +(** ** Substraction *) +(*********************************************************) Lemma Rminus_0_r : forall r, r - 0 = r. Proof. @@ -555,7 +696,6 @@ Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2. Proof. intros; ring. Qed. -Hint Resolve Ropp_minus_distr': real. (**********) Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0. @@ -605,7 +745,6 @@ Proof. Qed. Hint Resolve Rminus_not_eq_right: real. - (**********) Lemma Rmult_minus_distr_l : forall r1 r2 r3, r1 * (r2 - r3) = r1 * r2 - r1 * r3. @@ -613,7 +752,10 @@ Proof. intros; ring. Qed. -(** ** Inverse *) +(*********************************************************) +(** ** Inverse *) +(*********************************************************) + Lemma Rinv_1 : / 1 = 1. Proof. field. @@ -677,28 +819,28 @@ Proof. ring. Qed. -(** * Field operations and order *) +(*********************************************************) +(** ** Order and addition *) +(*********************************************************) + +(** *** Compatibility *) -(** ** Order and addition *) +(** Remark: [Rplus_lt_compat_l] is an axiom *) +Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. +Proof. eauto using Rplus_lt_compat_l with rorders. Qed. +Hint Resolve Rplus_gt_compat_l: real. + +(**********) Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r. Proof. intros. rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real. Qed. - Hint Resolve Rplus_lt_compat_r: real. -(**********) -Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. -Proof. - intros; cut (- r + r + r1 < - r + r + r2). - rewrite Rplus_opp_l. - elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1; - auto with zarith real. - rewrite Rplus_assoc; rewrite Rplus_assoc; - apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H). -Qed. +Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. +Proof. do 3 intro; apply Rplus_lt_compat_r. Qed. (**********) Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. @@ -708,6 +850,10 @@ Proof. right; rewrite <- H0; auto with zarith real. Qed. +Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. +Proof. auto using Rplus_le_compat_l with rorders. Qed. +Hint Resolve Rplus_ge_compat_l: real. + (**********) Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r. Proof. @@ -718,23 +864,8 @@ Qed. Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real. -(**********) -Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. -Proof. - unfold Rle in |- *; intros; elim H; intro. - left; apply (Rplus_lt_reg_r r r1 r2 H0). - right; apply (Rplus_eq_reg_l r r1 r2 H0). -Qed. - -(**********) -Lemma sum_inequa_Rle_lt : - forall a x b c y d:R, - a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d. -Proof. - intros; split. - apply Rlt_le_trans with (a + y); auto with real. - apply Rlt_le_trans with (b + y); auto with real. -Qed. +Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. +Proof. auto using Rplus_le_compat_r with rorders. Qed. (*********) Lemma Rplus_lt_compat : @@ -742,12 +873,22 @@ Lemma Rplus_lt_compat : Proof. intros; apply Rlt_trans with (r2 + r3); auto with real. Qed. +Hint Immediate Rplus_lt_compat: real. Lemma Rplus_le_compat : forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. Proof. intros; apply Rle_trans with (r2 + r3); auto with real. Qed. +Hint Immediate Rplus_le_compat: real. + +Lemma Rplus_gt_compat : + forall r1 r2 r3 r4, r1 > r2 -> r3 > r4 -> r1 + r3 > r2 + r4. +Proof. auto using Rplus_lt_compat with rorders. Qed. + +Lemma Rplus_ge_compat : + forall r1 r2 r3 r4, r1 >= r2 -> r3 >= r4 -> r1 + r3 >= r2 + r4. +Proof. auto using Rplus_le_compat with rorders. Qed. (*********) Lemma Rplus_lt_le_compat : @@ -756,19 +897,133 @@ Proof. intros; apply Rlt_le_trans with (r2 + r3); auto with real. Qed. -(*********) Lemma Rplus_le_lt_compat : forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. Proof. intros; apply Rle_lt_trans with (r2 + r3); auto with real. Qed. -Hint Immediate Rplus_lt_compat Rplus_le_compat Rplus_lt_le_compat - Rplus_le_lt_compat: real. +Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: real. + +Lemma Rplus_gt_ge_compat : + forall r1 r2 r3 r4, r1 > r2 -> r3 >= r4 -> r1 + r3 > r2 + r4. +Proof. auto using Rplus_lt_le_compat with rorders. Qed. + +Lemma Rplus_ge_gt_compat : + forall r1 r2 r3 r4, r1 >= r2 -> r3 > r4 -> r1 + r3 > r2 + r4. +Proof. auto using Rplus_le_lt_compat with rorders. Qed. + +(**********) +Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. +Proof. + intros x y; intros; apply Rlt_trans with x; + [ assumption + | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l; + assumption ]. +Qed. + +Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2. +Proof. + intros x y; intros; apply Rle_lt_trans with x; + [ assumption + | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l; + assumption ]. +Qed. + +Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2. +Proof. + intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat; + assumption. +Qed. -(** ** Order and Opposite *) +Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2. +Proof. + intros x y; intros; apply Rle_trans with x; + [ assumption + | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; + assumption ]. +Qed. (**********) +Lemma sum_inequa_Rle_lt : + forall a x b c y d:R, + a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d. +Proof. + intros; split. + apply Rlt_le_trans with (a + y); auto with real. + apply Rlt_le_trans with (b + y); auto with real. +Qed. + +(** *** Cancellation *) + +Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. +Proof. + intros; cut (- r + r + r1 < - r + r + r2). + rewrite Rplus_opp_l. + elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1; + auto with zarith real. + rewrite Rplus_assoc; rewrite Rplus_assoc; + apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H). +Qed. + +Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. +Proof. + unfold Rle in |- *; intros; elim H; intro. + left; apply (Rplus_lt_reg_r r r1 r2 H0). + right; apply (Rplus_eq_reg_l r r1 r2 H0). +Qed. + +Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. +Proof. + unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H). +Qed. + +Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. +Proof. + intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real. +Qed. + +(**********) +Lemma Rplus_le_reg_pos_r : + forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3. +Proof. + intros x y z; intros; apply Rle_trans with (x + y); + [ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; + assumption + | assumption ]. +Qed. + +Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3. +Proof. + intros x y z; intros; apply Rle_lt_trans with (x + y); + [ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; + assumption + | assumption ]. +Qed. + +Lemma Rplus_ge_reg_neg_r : + forall r1 r2 r3, 0 >= r2 -> r1 + r2 >= r3 -> r1 >= r3. +Proof. + intros x y z; intros; apply Rge_trans with (x + y); + [ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_ge_compat_l; + assumption + | assumption ]. +Qed. + +Lemma Rplus_gt_reg_neg_r : forall r1 r2 r3, 0 >= r2 -> r1 + r2 > r3 -> r1 > r3. +Proof. + intros x y z; intros; apply Rge_gt_trans with (x + y); + [ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_ge_compat_l; + assumption + | assumption ]. +Qed. + +(*********************************************************) +(** ** Order and opposite *) +(*********************************************************) + +(** *** Contravariant compatibility *) + Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. unfold Rgt in |- *; intros. @@ -781,55 +1036,44 @@ Proof. Qed. Hint Resolve Ropp_gt_lt_contravar. -(**********) Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. unfold Rgt in |- *; auto with real. Qed. Hint Resolve Ropp_lt_gt_contravar: real. -Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2. -Proof. - intros x y H'. - rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); - auto with real. -Qed. -Hint Immediate Ropp_lt_cancel: real. - +(**********) Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. Proof. auto with real. Qed. Hint Resolve Ropp_lt_contravar: real. +Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. +Proof. auto with real. Qed. + (**********) Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. Proof. - unfold Rge in |- *; intros r1 r2 [H| H]; auto with real. + unfold Rge; intros r1 r2 [H| H]; auto with real. Qed. Hint Resolve Ropp_le_ge_contravar: real. -Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2. +Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. Proof. - intros x y H. - elim H; auto with real. - intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); - rewrite H1; auto with real. + unfold Rle; intros r1 r2 [H| H]; auto with real. Qed. -Hint Immediate Ropp_le_cancel: real. +Hint Resolve Ropp_ge_le_contravar: real. +(**********) Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. Proof. intros r1 r2 H; elim H; auto with real. Qed. Hint Resolve Ropp_le_contravar: real. -(**********) -Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. -Proof. - unfold Rge in |- *; intros r1 r2 [H| H]; auto with real. -Qed. -Hint Resolve Ropp_ge_le_contravar: real. +Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. +Proof. auto using Ropp_le_contravar with real. Qed. (**********) Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. @@ -838,7 +1082,6 @@ Proof. Qed. Hint Resolve Ropp_0_lt_gt_contravar: real. -(**********) Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. Proof. intros; replace 0 with (-0); auto with real. @@ -850,13 +1093,13 @@ Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. +Hint Resolve Ropp_lt_gt_0_contravar: real. -(**********) Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. -Hint Resolve Ropp_lt_gt_0_contravar Ropp_gt_lt_0_contravar: real. +Hint Resolve Ropp_gt_lt_0_contravar: real. (**********) Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. @@ -865,40 +1108,56 @@ Proof. Qed. Hint Resolve Ropp_0_le_ge_contravar: real. -(**********) Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. Proof. intros; replace 0 with (-0); auto with real. Qed. Hint Resolve Ropp_0_ge_le_contravar: real. -(** ** Order and multiplication *) +(** *** Cancellation *) -Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. +Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2. Proof. - intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. + intros x y H'. + rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); + auto with real. Qed. -Hint Resolve Rmult_lt_compat_r. +Hint Immediate Ropp_lt_cancel: real. -Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. +Proof. auto using Ropp_lt_cancel with rorders. Qed. + +Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2. Proof. - intros z x y H H0. - case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. - rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto. - generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False; - generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); - intro; apply (Rlt_irrefl (z * x)); auto. + intros x y H. + elim H; auto with real. + intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); + rewrite H1; auto with real. Qed. +Hint Immediate Ropp_le_cancel: real. +Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. +Proof. auto using Ropp_le_cancel with rorders. Qed. -Lemma Rmult_lt_gt_compat_neg_l : - forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2. +(*********************************************************) +(** ** Order and multiplication *) +(*********************************************************) + +(** Remark: [Rmult_lt_compat_l] is an axiom *) + +(** *** Covariant compatibility *) + +Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. - intros; replace r with (- - r); auto with real. - rewrite (Ropp_mult_distr_l_reverse (- r)); - rewrite (Ropp_mult_distr_l_reverse (- r)). - apply Ropp_lt_gt_contravar; auto with real. + intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. +Hint Resolve Rmult_lt_compat_r. + +Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. +Proof. eauto using Rmult_lt_compat_r with rorders. Qed. + +Lemma Rmult_gt_compat_l : forall r r1 r2, r > 0 -> r1 > r2 -> r * r1 > r * r2. +Proof. eauto using Rmult_lt_compat_l with rorders. Qed. (**********) Lemma Rmult_le_compat_l : @@ -918,18 +1177,59 @@ Proof. Qed. Hint Resolve Rmult_le_compat_r: real. -Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. +Lemma Rmult_ge_compat_l : + forall r r1 r2, r >= 0 -> r1 >= r2 -> r * r1 >= r * r2. +Proof. eauto using Rmult_le_compat_l with rorders. Qed. + +Lemma Rmult_ge_compat_r : + forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r. +Proof. eauto using Rmult_le_compat_r with rorders. Qed. + +(**********) +Lemma Rmult_le_compat : + forall r1 r2 r3 r4, + 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. Proof. - intros z x y H H0; case H0; auto with real. - intros H1; apply Rlt_le. - apply Rmult_lt_reg_l with (r := z); auto. - intros H1; replace x with (/ z * (z * x)); auto with real. - replace y with (/ z * (z * y)). - rewrite H1; auto with real. - rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. - rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. + intros x y z t H' H'0 H'1 H'2. + apply Rle_trans with (r2 := x * t); auto with real. + repeat rewrite (fun x => Rmult_comm x t). + apply Rmult_le_compat_l; auto. + apply Rle_trans with z; auto. +Qed. +Hint Resolve Rmult_le_compat: real. + +Lemma Rmult_ge_compat : + forall r1 r2 r3 r4, + 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. +Proof. auto with real rorders. Qed. + +Lemma Rmult_gt_0_lt_compat : + forall r1 r2 r3 r4, + r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Proof. + intros; apply Rlt_trans with (r2 * r3); auto with real. +Qed. + +(*********) +Lemma Rmult_le_0_lt_compat : + forall r1 r2 r3 r4, + 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Proof. + intros; apply Rle_lt_trans with (r2 * r3); + [ apply Rmult_le_compat_r; [ assumption | left; assumption ] + | apply Rmult_lt_compat_l; + [ apply Rle_lt_trans with r1; assumption | assumption ] ]. Qed. +(*********) +Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2. +Proof. intros; replace 0 with (0 * r2); auto with real. Qed. + +Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0. +Proof Rmult_lt_0_compat. + +(** *** Contravariant compatibility *) + Lemma Rmult_le_compat_neg_l : forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1. Proof. @@ -946,35 +1246,45 @@ Proof. Qed. Hint Resolve Rmult_le_ge_compat_neg_l: real. -Lemma Rmult_le_compat : - forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. +Lemma Rmult_lt_gt_compat_neg_l : + forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2. Proof. - intros x y z t H' H'0 H'1 H'2. - apply Rle_trans with (r2 := x * t); auto with real. - repeat rewrite (fun x => Rmult_comm x t). - apply Rmult_le_compat_l; auto. - apply Rle_trans with z; auto. + intros; replace r with (- - r); auto with real. + rewrite (Ropp_mult_distr_l_reverse (- r)); + rewrite (Ropp_mult_distr_l_reverse (- r)). + apply Ropp_lt_gt_contravar; auto with real. Qed. -Hint Resolve Rmult_le_compat: real. -Lemma Rmult_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +(** *** Cancellation *) + +Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. - intros; apply Rlt_trans with (r2 * r3); auto with real. + intros z x y H H0. + case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. + rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto. + generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False; + generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); + intro; apply (Rlt_irrefl (z * x)); auto. Qed. -(*********) -Lemma Rmult_ge_0_gt_0_lt_compat : - forall r1 r2 r3 r4, - r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. eauto using Rmult_lt_reg_l with rorders. Qed. + +Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. Proof. - intros; apply Rle_lt_trans with (r2 * r3); auto with real. + intros z x y H H0; case H0; auto with real. + intros H1; apply Rlt_le. + apply Rmult_lt_reg_l with (r := z); auto. + intros H1; replace x with (/ z * (z * x)); auto with real. + replace y with (/ z * (z * y)). + rewrite H1; auto with real. + rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. + rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. Qed. - -(** ** Order and Substractions *) +(*********************************************************) +(** ** Order and substraction *) +(*********************************************************) Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. Proof. @@ -985,12 +1295,27 @@ Proof. Qed. Hint Resolve Rlt_minus: real. +Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. +Proof. + intros; apply (Rplus_lt_reg_r r2). + replace (r2 + (r1 - r2)) with r1. + replace (r2 + 0) with r2; auto with real. + ring. +Qed. + (**********) Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0. Proof. destruct 1; unfold Rle in |- *; auto with real. Qed. +Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. +Proof. + destruct 1. + auto using Rgt_minus, Rgt_ge. + right; auto using Rminus_diag_eq with rorders. +Qed. + (**********) Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2. Proof. @@ -999,6 +1324,14 @@ Proof. ring. Qed. +Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2. +Proof. + intros; replace r2 with (0 + r2); auto with real. + replace r1 with (r1 - r2 + r2). + apply Rplus_gt_compat_r; assumption. + ring. +Qed. + (**********) Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2. Proof. @@ -1007,6 +1340,14 @@ Proof. ring. Qed. +Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2. +Proof. + intros; replace r2 with (0 + r2); auto with real. + replace r1 with (r1 - r2 + r2). + apply Rplus_ge_compat_r; assumption. + ring. +Qed. + (**********) Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> r + s <> 0. Proof. @@ -1015,8 +1356,9 @@ Proof. Qed. Hint Immediate tech_Rplus: real. - -(** ** Order and the square function *) +(*********************************************************) +(** ** Order and square function *) +(*********************************************************) Lemma Rle_0_sqr : forall r, 0 <= Rsqr r. Proof. @@ -1036,7 +1378,26 @@ Proof. Qed. Hint Resolve Rle_0_sqr Rlt_0_sqr: real. -(** ** Zero is less than one *) +(***********) +Lemma Rplus_sqr_eq_0_l : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0. +Proof. + intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b); + auto with real. +Qed. + +Lemma Rplus_sqr_eq_0 : + forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0. +Proof. + intros a b; split. + apply Rplus_sqr_eq_0_l with b; auto with real. + apply Rplus_sqr_eq_0_l with a; auto with real. + rewrite Rplus_comm; auto with real. +Qed. + +(*********************************************************) +(** ** Zero is less than one *) +(*********************************************************) + Lemma Rlt_0_1 : 0 < 1. Proof. replace 1 with (Rsqr 1); auto with real. @@ -1050,7 +1411,10 @@ Proof. exact Rlt_0_1. Qed. -(** ** Order and inverse *) +(*********************************************************) +(** ** Order and inverse *) +(*********************************************************) + Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r. Proof. intros; apply Rnot_le_lt; red in |- *; intros. @@ -1099,68 +1463,9 @@ Proof. Qed. Hint Resolve Rinv_1_lt_contravar: real. -(********************************************************) -(** * Greater *) -(********************************************************) - -(**********) -Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2. -Proof. - intros; apply Rle_antisym; auto with real. -Qed. - -(**********) -Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2. -Proof. - intros; unfold Rge in |- *; elim (Rtotal_order r1 r2); intro. - absurd (r1 < r2); trivial. - case H0; auto. -Qed. - -(**********) -Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1. -Proof. - intros; apply Rge_le; apply Rnot_lt_ge; assumption. -Qed. - -(**********) -Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2. -Proof. - intros r1 r2 H; apply Rge_le. - exact (Rnot_lt_ge r2 r1 H). -Qed. - -(**********) -Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. -Proof. - red in |- *; auto with real. -Qed. - - -(**********) -Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3. -Proof. - unfold Rgt in |- *; intros; apply Rlt_le_trans with r2; auto with real. -Qed. - -(**********) -Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3. -Proof. - unfold Rgt in |- *; intros; apply Rle_lt_trans with r2; auto with real. -Qed. - -(**********) -Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. -Proof. - unfold Rgt in |- *; intros; apply Rlt_trans with r2; auto with real. -Qed. - -(**********) -Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3. -Proof. - intros; apply Rle_ge. - apply Rle_trans with r2; auto with real. -Qed. +(*********************************************************) +(** ** Miscellaneous *) +(*********************************************************) (**********) Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1. @@ -1186,121 +1491,9 @@ Proof. pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real. Qed. -(***********) -Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. -Proof. - unfold Rgt in |- *; auto with real. -Qed. -Hint Resolve Rplus_gt_compat_l: real. - -(***********) -Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. -Proof. - unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H). -Qed. - -(***********) -Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. -Proof. - intros; apply Rle_ge; auto with real. -Qed. -Hint Resolve Rplus_ge_compat_l: real. - -(***********) -Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. -Proof. - intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real. -Qed. - -(***********) -Lemma Rmult_ge_compat_r : - forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r. -Proof. - intros; apply Rle_ge; apply Rmult_le_compat_r; apply Rge_le; assumption. -Qed. - -(***********) -Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. -Proof. - intros; replace 0 with (r2 - r2); auto with real. - unfold Rgt, Rminus in |- *; auto with real. -Qed. - -(*********) -Lemma minus_Rgt : forall r1 r2, r1 - r2 > 0 -> r1 > r2. -Proof. - intros; replace r2 with (r2 + 0); auto with real. - intros; replace r1 with (r2 + (r1 - r2)); auto with real. -Qed. - -(**********) -Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. -Proof. - unfold Rge in |- *; intros; elim H; intro. - left; apply (Rgt_minus r1 r2 H0). - right; apply (Rminus_diag_eq r1 r2 H0). -Qed. - -(*********) -Lemma minus_Rge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2. -Proof. - intros; replace r2 with (r2 + 0); auto with real. - intros; replace r1 with (r2 + (r1 - r2)); auto with real. -Qed. - - -(*********) -Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0. -Proof. - unfold Rgt in |- *; intros. - replace 0 with (0 * r2); auto with real. -Qed. - -(*********) -Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2. -Proof Rmult_gt_0_compat. - -(***********) -Lemma Rplus_eq_0_l : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. -Proof. - intros a b [H| H] H0 H1; auto with real. - absurd (0 < a + b). - rewrite H1; auto with real. - replace 0 with (0 + 0); auto with real. -Qed. - - -Lemma Rplus_eq_R0 : - forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0. -Proof. - intros a b; split. - apply Rplus_eq_0_l with b; auto with real. - apply Rplus_eq_0_l with a; auto with real. - rewrite Rplus_comm; auto with real. -Qed. - - -(***********) -Lemma Rplus_sqr_eq_0_l : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0. -Proof. - intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b); - auto with real. -Qed. - -Lemma Rplus_sqr_eq_0 : - forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0. -Proof. - intros a b; split. - apply Rplus_sqr_eq_0_l with b; auto with real. - apply Rplus_sqr_eq_0_l with a; auto with real. - rewrite Rplus_comm; auto with real. -Qed. - - -(**********************************************************) -(** * Injection from [N] to [R] *) -(**********************************************************) +(*********************************************************) +(** ** Injection from [N] to [R] *) +(*********************************************************) (**********) Lemma S_INR : forall n:nat, INR (S n) = INR n + 1. @@ -1323,6 +1516,7 @@ Proof. repeat rewrite S_INR. rewrite Hrecn; ring. Qed. +Hint Resolve plus_INR: real. (**********) Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) = INR n - INR m. @@ -1332,6 +1526,7 @@ Proof. intros; repeat rewrite S_INR; simpl in |- *. rewrite H0; ring. Qed. +Hint Resolve minus_INR: real. (*********) Lemma mult_INR : forall n m:nat, INR (n * m) = INR n * INR m. @@ -1341,16 +1536,15 @@ Proof. intros; repeat rewrite S_INR; simpl in |- *. rewrite plus_INR; rewrite Hrecn; ring. Qed. - -Hint Resolve plus_INR minus_INR mult_INR: real. +Hint Resolve mult_INR: real. (*********) -Lemma lt_INR_0 : forall n:nat, (0 < n)%nat -> 0 < INR n. +Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n. Proof. simple induction 1; intros; auto with real. rewrite S_INR; auto with real. Qed. -Hint Resolve lt_INR_0: real. +Hint Resolve lt_0_INR: real. Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. Proof. @@ -1360,20 +1554,20 @@ Proof. Qed. Hint Resolve lt_INR: real. -Lemma INR_lt_1 : forall n:nat, (1 < n)%nat -> 1 < INR n. +Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. Proof. intros; replace 1 with (INR 1); auto with real. Qed. -Hint Resolve INR_lt_1: real. +Hint Resolve lt_1_INR: real. (**********) -Lemma INR_pos : forall p:positive, 0 < INR (nat_of_P p). +Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (nat_of_P p). Proof. - intro; apply lt_INR_0. + intro; apply lt_0_INR. simpl in |- *; auto with real. apply lt_O_nat_of_P. Qed. -Hint Resolve INR_pos: real. +Hint Resolve pos_INR_nat_of_P: real. (**********) Lemma pos_INR : forall n:nat, 0 <= INR n. @@ -1410,25 +1604,25 @@ Qed. Hint Resolve le_INR: real. (**********) -Lemma not_INR_O : forall n:nat, INR n <> 0 -> n <> 0%nat. +Lemma INR_not_0 : forall n:nat, INR n <> 0 -> n <> 0%nat. Proof. red in |- *; intros n H H1. apply H. rewrite H1; trivial. Qed. -Hint Immediate not_INR_O: real. +Hint Immediate INR_not_0: real. (**********) -Lemma not_O_INR : forall n:nat, n <> 0%nat -> INR n <> 0. +Lemma not_0_INR : forall n:nat, n <> 0%nat -> INR n <> 0. Proof. intro n; case n. intro; absurd (0%nat = 0%nat); trivial. intros; rewrite S_INR. apply Rgt_not_eq; red in |- *; auto with real. Qed. -Hint Resolve not_O_INR: real. +Hint Resolve not_0_INR: real. -Lemma not_nm_INR : forall n m:nat, n <> m -> INR n <> INR m. +Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. Proof. intros n m H; case (le_or_lt n m); intros H1. case (le_lt_or_eq _ _ H1); intros H2. @@ -1436,17 +1630,17 @@ Proof. elimtype False; auto. apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real. Qed. -Hint Resolve not_nm_INR: real. +Hint Resolve not_INR: real. Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m. Proof. intros; case (le_or_lt n m); intros H1. case (le_lt_or_eq _ _ H1); intros H2; auto. cut (n <> m). - intro H3; generalize (not_nm_INR n m H3); intro H4; elimtype False; auto. + intro H3; generalize (not_INR n m H3); intro H4; elimtype False; auto. omega. symmetry in |- *; cut (m <> n). - intro H3; generalize (not_nm_INR m n H3); intro H4; elimtype False; auto. + intro H3; generalize (not_INR m n H3); intro H4; elimtype False; auto. omega. Qed. Hint Resolve INR_eq: real. @@ -1465,9 +1659,9 @@ Proof. Qed. Hint Resolve not_1_INR: real. -(**********************************************************) -(** * Injection from [Z] to [R] *) -(**********************************************************) +(*********************************************************) +(** ** Injection from [Z] to [R] *) +(*********************************************************) (**********) @@ -1541,6 +1735,12 @@ Proof. Qed. (**********) +Lemma succ_IZR : forall n:Z, IZR (Zsucc n) = IZR n + 1. +Proof. + intro; change 1 with (IZR 1); unfold Zsucc; apply plus_IZR. +Qed. + +(**********) Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n. Proof. intro z; case z; simpl in |- *; auto with real. @@ -1554,7 +1754,7 @@ Proof. Qed. (**********) -Lemma lt_O_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. +Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. intro z; case z; simpl in |- *; intros. absurd (0 < 0); auto with real. @@ -1567,7 +1767,7 @@ Qed. Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. Proof. intros z1 z2 H; apply Zlt_0_minus_lt. - apply lt_O_IZR. + apply lt_0_IZR. rewrite <- Z_R_minus. exact (Rgt_minus (IZR z2) (IZR z1) H). Qed. @@ -1578,7 +1778,7 @@ Proof. intro z; destruct z; simpl in |- *; intros; auto with zarith. case (Rlt_not_eq 0 (INR (nat_of_P p))); auto with real. case (Rlt_not_eq (- INR (nat_of_P p)) 0); auto with real. - apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply INR_pos. + apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply pos_INR_nat_of_P. Qed. (**********) @@ -1590,17 +1790,17 @@ Proof. Qed. (**********) -Lemma not_O_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0. +Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0. Proof. intros z H; red in |- *; intros H0; case H. apply eq_IZR; auto. Qed. (*********) -Lemma le_O_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z. +Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z. Proof. unfold Rle in |- *; intros z [H| H]. - red in |- *; intro; apply (Zlt_le_weak 0 z (lt_O_IZR z H)); assumption. + red in |- *; intro; apply (Zlt_le_weak 0 z (lt_0_IZR z H)); assumption. rewrite (eq_IZR_R0 z); auto with zarith real. Qed. @@ -1685,32 +1885,6 @@ Proof. apply H3; apply single_z_r_R1 with r; trivial. Qed. -(*****************************************************************) -(** * Definitions of new types *) -(*****************************************************************) - -Record nonnegreal : Type := mknonnegreal - {nonneg :> R; cond_nonneg : 0 <= nonneg}. - -Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. - -Record nonposreal : Type := mknonposreal - {nonpos :> R; cond_nonpos : nonpos <= 0}. - -Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. - -Record nonzeroreal : Type := mknonzeroreal - {nonzero :> R; cond_nonzero : nonzero <> 0}. - -(**********) -Lemma prod_neq_R0 : forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0. -Proof. - intros x y; intros; red in |- *; intro; generalize (Rmult_integral x y H1); - intro; elim H2; intro; - [ rewrite H3 in H; elim H | rewrite H3 in H0; elim H0 ]; - reflexivity. -Qed. - (*********) Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2. Proof. @@ -1728,67 +1902,18 @@ Proof. intro; rewrite <- double; unfold Rdiv in |- *; rewrite <- Rmult_assoc; symmetry in |- *; apply Rinv_r_simpl_m. replace 2 with (INR 2); - [ apply not_O_INR; discriminate | unfold INR in |- *; ring ]. -Qed. - -(**********************************************************) -(** * Other rules about < and <= *) -(**********************************************************) - -Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - intros x y; intros; apply Rlt_trans with x; - [ assumption - | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l; - assumption ]. -Qed. - -Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2. -Proof. - intros x y; intros; apply Rle_lt_trans with x; - [ assumption - | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l; - assumption ]. -Qed. - -Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2. -Proof. - intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat; - assumption. -Qed. - -Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2. -Proof. - intros x y; intros; apply Rle_trans with x; - [ assumption - | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - assumption ]. -Qed. - -Lemma plus_le_is_le : forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3. -Proof. - intros x y z; intros; apply Rle_trans with (x + y); - [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - assumption - | assumption ]. + [ apply not_0_INR; discriminate | unfold INR in |- *; ring ]. Qed. -Lemma plus_lt_is_lt : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3. -Proof. - intros x y z; intros; apply Rle_lt_trans with (x + y); - [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - assumption - | assumption ]. -Qed. +(*********************************************************) +(** ** Other rules about < and <= *) +(*********************************************************) -Lemma Rmult_le_0_lt_compat : +Lemma Rmult_ge_0_gt_0_lt_compat : forall r1 r2 r3 r4, - 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. + r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. Proof. - intros; apply Rle_lt_trans with (r2 * r3); - [ apply Rmult_le_compat_r; [ assumption | left; assumption ] - | apply Rmult_lt_compat_l; - [ apply Rle_lt_trans with r1; assumption | assumption ] ]. + intros; apply Rle_lt_trans with (r2 * r3); auto with real. Qed. Lemma le_epsilon : @@ -1811,7 +1936,7 @@ Proof. rewrite Rmult_1_r; replace (2 * x) with (x + x). rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption. ring. - replace 2 with (INR 2); [ apply not_O_INR; discriminate | reflexivity ]. + replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. pattern y at 2 in |- *; replace y with (y / 2 + y / 2). unfold Rminus, Rdiv in |- *. repeat rewrite Rmult_plus_distr_r. @@ -1822,12 +1947,12 @@ Proof. unfold Rdiv in |- *. rewrite <- Rmult_assoc; apply Rinv_r_simpl_m. replace 2 with (INR 2). - apply not_O_INR. + apply not_0_INR. discriminate. unfold INR in |- *; reflexivity. intro; ring. cut (0%nat <> 2%nat); - [ intro H0; generalize (lt_INR_0 2 (neq_O_lt 2 H0)); unfold INR in |- *; + [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR in |- *; intro; assumption | discriminate ]. Qed. @@ -1839,3 +1964,37 @@ Lemma completeness_weak : Proof. intros; elim (completeness E H H0); intros; split with x; assumption. Qed. + +(*********************************************************) +(** * Definitions of new types *) +(*********************************************************) + +Record nonnegreal : Type := mknonnegreal + {nonneg :> R; cond_nonneg : 0 <= nonneg}. + +Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. + +Record nonposreal : Type := mknonposreal + {nonpos :> R; cond_nonpos : nonpos <= 0}. + +Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. + +Record nonzeroreal : Type := mknonzeroreal + {nonzero :> R; cond_nonzero : nonzero <> 0}. + +(** Compatibility *) + +Notation prod_neq_R0 := Rmult_integral_contrapositive_currified (only parsing). +Notation minus_Rgt := Rminus_gt (only parsing). +Notation minus_Rge := Rminus_ge (only parsing). +Notation plus_le_is_le := Rplus_le_reg_pos_r (only parsing). +Notation plus_lt_is_lt := Rplus_lt_reg_pos_r (only parsing). +Notation INR_lt_1 := lt_1_INR (only parsing). +Notation lt_INR_0 := lt_0_INR (only parsing). +Notation not_nm_INR := not_INR (only parsing). +Notation INR_pos := pos_INR_nat_of_P (only parsing). +Notation not_INR_O := INR_not_0 (only parsing). +Notation not_O_INR := not_0_INR (only parsing). +Notation not_O_IZR := not_0_IZR (only parsing). +Notation le_O_IZR := le_0_IZR (only parsing). +Notation lt_O_IZR := lt_0_IZR (only parsing). diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 270ea6da..17b6c60d 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -6,10 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqr.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: R_sqr.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. -Require Import Rbasic_fun. Open Local Scope R_scope. +Require Import Rbasic_fun. +Open Local Scope R_scope. (****************************************************) (** Rsqr : some results *) diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 736365a0..63b8940b 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqrt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: R_sqrt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. -Require Import Rsqrt_def. Open Local Scope R_scope. +Require Import Rsqrt_def. +Open Local Scope R_scope. (** * Continuous extension of Rsqrt on R *) Definition sqrt (x:R) : R := diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index d712f74b..f48ce563 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis.v 9319 2006-10-30 12:41:21Z barras $ i*) +(*i $Id: Ranalysis.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -27,7 +27,8 @@ Require Export Rgeom. Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. -Require Export Rpower. Open Local Scope R_scope. +Require Export Rpower. +Open Local Scope R_scope. Axiom AppVar : R. diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 93a66e70..9414f7c9 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis1.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Ranalysis1.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Export Rlimit. -Require Export Rderiv. Open Local Scope R_scope. +Require Export Rderiv. +Open Local Scope R_scope. Implicit Type f : R -> R. (****************************************************) @@ -269,10 +270,10 @@ Definition derivable_pt_lim f (x l:R) : Prop := Definition derivable_pt_abs f (x l:R) : Prop := derivable_pt_lim f x l. -Definition derivable_pt f (x:R) := sigT (derivable_pt_abs f x). +Definition derivable_pt f (x:R) := { l:R | derivable_pt_abs f x l }. Definition derivable f := forall x:R, derivable_pt f x. -Definition derive_pt f (x:R) (pr:derivable_pt f x) := projT1 pr. +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]. @@ -380,9 +381,9 @@ Lemma derive_pt_eq : derive_pt f x pr = l <-> derivable_pt_lim f x l. Proof. intros; split. - intro; assert (H1 := projT2 pr); unfold derive_pt in H; rewrite H in H1; + intro; assert (H1 := proj2_sig pr); unfold derive_pt in H; rewrite H in H1; assumption. - intro; assert (H1 := projT2 pr); unfold derivable_pt_abs in H1. + intro; assert (H1 := proj2_sig pr); unfold derivable_pt_abs in H1. assert (H2 := uniqueness_limite _ _ _ _ H H1). unfold derive_pt in |- *; unfold derivable_pt_abs in |- *. symmetry in |- *; assumption. @@ -486,7 +487,7 @@ Qed. Lemma derivable_derive : forall f (x:R) (pr:derivable_pt f x), exists l : R, derive_pt f x pr = l. Proof. - intros; exists (projT1 pr). + intros; exists (proj1_sig pr). unfold derive_pt in |- *; reflexivity. Qed. @@ -714,7 +715,7 @@ Proof. unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. - apply existT with (x0 + x1). + exists (x0 + x1). apply derivable_pt_lim_plus; assumption. Qed. @@ -723,7 +724,7 @@ Lemma derivable_pt_opp : Proof. unfold derivable_pt in |- *; intros f x X. elim X; intros. - apply existT with (- x0). + exists (- x0). apply derivable_pt_lim_opp; assumption. Qed. @@ -734,7 +735,7 @@ Proof. unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. - apply existT with (x0 - x1). + exists (x0 - x1). apply derivable_pt_lim_minus; assumption. Qed. @@ -745,14 +746,14 @@ Proof. unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. - apply existT with (x0 * f2 x + f1 x * x1). + exists (x0 * f2 x + f1 x * x1). apply derivable_pt_lim_mult; assumption. Qed. Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x. Proof. intros; unfold derivable_pt in |- *. - apply existT with 0. + exists 0. apply derivable_pt_lim_const. Qed. @@ -761,7 +762,7 @@ Lemma derivable_pt_scal : Proof. unfold derivable_pt in |- *; intros f1 a x X. elim X; intros. - apply existT with (a * x0). + exists (a * x0). apply derivable_pt_lim_scal; assumption. Qed. @@ -774,7 +775,7 @@ Qed. Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x. Proof. - unfold derivable_pt in |- *; intro; apply existT with (2 * x). + unfold derivable_pt in |- *; intro; exists (2 * x). apply derivable_pt_lim_Rsqr. Qed. @@ -785,7 +786,7 @@ Proof. unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. - apply existT with (x1 * x0). + exists (x1 * x0). apply derivable_pt_lim_comp; assumption. Qed. @@ -860,9 +861,9 @@ Proof. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - assert (H4 := projT2 pr2). + assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_plus; assumption. Qed. @@ -877,7 +878,7 @@ Proof. elim H; clear H; intros l1 H. elim H0; clear H0; intros l2 H0. rewrite H; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. apply derivable_pt_lim_opp; assumption. Qed. @@ -896,9 +897,9 @@ Proof. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - assert (H4 := projT2 pr2). + assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_minus; assumption. Qed. @@ -917,9 +918,9 @@ Proof. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - assert (H4 := projT2 pr2). + assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_mult; assumption. Qed. @@ -944,7 +945,7 @@ Proof. elim H; clear H; intros l1 H. elim H0; clear H0; intros l2 H0. rewrite H; apply derive_pt_eq_0. - assert (H3 := projT2 pr). + assert (H3 := proj2_sig pr). unfold derive_pt in H; rewrite H in H3. apply derivable_pt_lim_scal; assumption. Qed. @@ -978,9 +979,9 @@ Proof. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - assert (H4 := projT2 pr2). + assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_comp; assumption. Qed. @@ -1046,7 +1047,7 @@ Lemma derivable_pt_pow : forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x. Proof. intros; unfold derivable_pt in |- *. - apply existT with (INR n * x ^ pred n). + exists (INR n * x ^ pred n). apply derivable_pt_lim_pow. Qed. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index fb89da67..54801eb7 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis2.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Ranalysis2.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. -Require Import Ranalysis1. Open Local Scope R_scope. +Require Import Ranalysis1. +Open Local Scope R_scope. (**********) Lemma formule : diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index f50aa2ad..180cf9d6 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis3.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Ranalysis3.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import Ranalysis2. Open Local Scope R_scope. +Require Import Ranalysis2. +Open Local Scope R_scope. (** Division *) Theorem derivable_pt_lim_div : @@ -23,7 +24,7 @@ Theorem derivable_pt_lim_div : Proof. intros f1 f2 x l1 l2 H H0 H1. cut (derivable_pt f2 x); - [ intro X | unfold derivable_pt in |- *; apply existT with l2; exact H0 ]. + [ intro X | unfold derivable_pt in |- *; exists l2; exact H0 ]. assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1). elim H2; clear H2; intros eps_f2 H2. unfold div_fct in |- *. @@ -761,7 +762,7 @@ Proof. intros f1 f2 x X X0 H. elim X; intros. elim X0; intros. - apply existT with ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)). + exists ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)). apply derivable_pt_lim_div; assumption. Qed. @@ -789,9 +790,9 @@ Proof. elim H0; clear H0; intros l2 H0. elim H1; clear H1; intros l H1. rewrite H; rewrite H0; apply derive_pt_eq_0. - assert (H3 := projT2 pr1). + assert (H3 := proj2_sig pr1). unfold derive_pt in H; rewrite H in H3. - assert (H4 := projT2 pr2). + assert (H4 := proj2_sig pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_div; assumption. Qed. diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 205c06b4..95f6d27e 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis4.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Ranalysis4.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -14,7 +14,8 @@ Require Import SeqSeries. Require Import Rtrigo. Require Import Ranalysis1. Require Import Ranalysis3. -Require Import Exp_prop. Open Local Scope R_scope. +Require Import Exp_prop. +Open Local Scope R_scope. (**********) Lemma derivable_pt_inv : @@ -28,7 +29,7 @@ Proof. assumption. assumption. unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros; - unfold derivable_pt in |- *; apply existT with x0; + unfold derivable_pt in |- *; exists x0; unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *; unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; intros; elim (p eps H0); intros; exists x1; intros; @@ -164,10 +165,10 @@ Proof. intros. case (total_order_T x 0); intro. elim s; intro. - unfold derivable_pt in |- *; apply existT with (-1). + unfold derivable_pt in |- *; exists (-1). apply (Rabs_derive_2 x a). elim H; exact b. - unfold derivable_pt in |- *; apply existT with 1. + unfold derivable_pt in |- *; exists 1. apply (Rabs_derive_1 x r). Qed. @@ -294,8 +295,8 @@ Proof. unfold derivable_pt in |- *. assert (H := derivable_pt_lim_finite_sum An x N). induction N as [| N HrecN]. - apply existT with 0; apply H. - apply existT with + exists 0; apply H. + exists (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); apply H. Qed. @@ -352,7 +353,7 @@ Lemma derivable_pt_exp : forall x:R, derivable_pt exp x. Proof. intro. unfold derivable_pt in |- *. - apply existT with (exp x). + exists (exp x). apply derivable_pt_lim_exp. Qed. @@ -360,7 +361,7 @@ Lemma derivable_pt_cosh : forall x:R, derivable_pt cosh x. Proof. intro. unfold derivable_pt in |- *. - apply existT with (sinh x). + exists (sinh x). apply derivable_pt_lim_cosh. Qed. @@ -368,7 +369,7 @@ Lemma derivable_pt_sinh : forall x:R, derivable_pt sinh x. Proof. intro. unfold derivable_pt in |- *. - apply existT with (cosh x). + exists (cosh x). apply derivable_pt_lim_sinh. Qed. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index aaea59f4..6667d2ec 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Raxioms.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Raxioms.v 10710 2008-03-23 09:24:09Z herbelin $ i*) (*********************************************************) (** Axiomatisation of the classical reals *) @@ -130,7 +130,7 @@ Definition IZR (z:Z) : R := Arguments Scope IZR [Z_scope]. (**********************************************************) -(** * [R] Archimedian *) +(** * [R] Archimedean *) (**********************************************************) (**********) @@ -154,4 +154,4 @@ Definition is_lub (E:R -> Prop) (m:R) := Axiom completeness : forall E:R -> Prop, - bound E -> (exists x : R, E x) -> sigT (fun m:R => is_lub E m). + bound E -> (exists x : R, E x) -> { m:R | is_lub E m }. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 98bd607b..a5cc9f19 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbasic_fun.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rbasic_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*) (*********************************************************) (** Complements for the real numbers *) @@ -15,7 +15,8 @@ Require Import Rbase. Require Import R_Ifp. -Require Import Fourier. Open Local Scope R_scope. +Require Import Fourier. +Open Local Scope R_scope. Implicit Type r : R. diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index 16e12d7f..d7fee9c5 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rcomplete.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rcomplete.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -24,7 +24,7 @@ Open Local Scope R_scope. (****************************************************) Theorem R_complete : - forall Un:nat -> R, Cauchy_crit Un -> sigT (fun l:R => Un_cv Un l). + forall Un:nat -> R, Cauchy_crit Un -> { l:R | Un_cv Un l } . Proof. intros. set (Vn := sequence_minorant Un (cauchy_min Un H)). @@ -37,7 +37,7 @@ Proof. elim H1; intros. cut (x = x0). intros. - apply existT with x. + exists x. rewrite <- H2 in p0. unfold Un_cv in |- *. intros. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 330c0042..002ce8d6 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rdefinitions.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rdefinitions.v 10751 2008-04-04 10:23:35Z herbelin $ i*) (*********************************************************) @@ -22,6 +22,8 @@ Delimit Scope R_scope with R. (* Automatically open scope R_scope for arguments of type R *) Bind Scope R_scope with R. +Open Local Scope R_scope. + Parameter R0 : R. Parameter R1 : R. Parameter Rplus : R -> R -> R. @@ -38,33 +40,33 @@ Notation "/ x" := (Rinv x) : R_scope. Infix "<" := Rlt : R_scope. -(*i*******************************************************i*) +(***********************************************************) (**********) -Definition Rgt (r1 r2:R) : Prop := (r2 < r1)%R. +Definition Rgt (r1 r2:R) : Prop := r2 < r1. (**********) -Definition Rle (r1 r2:R) : Prop := (r1 < r2)%R \/ r1 = r2. +Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2. (**********) Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2. (**********) -Definition Rminus (r1 r2:R) : R := (r1 + - r2)%R. +Definition Rminus (r1 r2:R) : R := r1 + - r2. (**********) -Definition Rdiv (r1 r2:R) : R := (r1 * / r2)%R. +Definition Rdiv (r1 r2:R) : R := r1 * / r2. (**********) Infix "-" := Rminus : R_scope. -Infix "/" := Rdiv : R_scope. +Infix "/" := Rdiv : R_scope. Infix "<=" := Rle : R_scope. Infix ">=" := Rge : R_scope. -Infix ">" := Rgt : R_scope. +Infix ">" := Rgt : R_scope. -Notation "x <= y <= z" := ((x <= y)%R /\ (y <= z)%R) : R_scope. -Notation "x <= y < z" := ((x <= y)%R /\ (y < z)%R) : R_scope. -Notation "x < y < z" := ((x < y)%R /\ (y < z)%R) : R_scope. -Notation "x < y <= z" := ((x < y)%R /\ (y <= z)%R) : R_scope. +Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope. +Notation "x <= y < z" := (x <= y /\ y < z) : R_scope. +Notation "x < y < z" := (x < y /\ y < z) : R_scope. +Notation "x < y <= z" := (x < y /\ y <= z) : R_scope. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index e2fd2efe..ba42bad9 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rderiv.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rderiv.v 10710 2008-03-23 09:24:09Z herbelin $ i*) (*********************************************************) (** Definition of the derivative,continuity *) @@ -19,7 +19,8 @@ Require Import Rlimit. Require Import Fourier. Require Import Classical_Prop. Require Import Classical_Pred_Type. -Require Import Omega. Open Local Scope R_scope. +Require Import Omega. +Open Local Scope R_scope. (*********) Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 3d1c0375..b9aec1ea 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rfunctions.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rfunctions.v 10762 2008-04-06 16:57:31Z 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*) @@ -349,8 +349,7 @@ Proof. rewrite Rabs_Rinv; auto. rewrite <- Rinv_pow; auto. rewrite RPow_abs; auto. - rewrite H'0; rewrite Rabs_right; auto with real. - apply Rle_ge; auto with real. + rewrite H'0; rewrite Rabs_right; auto with real rorders. apply Rlt_pow; auto with arith. rewrite Rabs_Rinv; auto. apply Rmult_lt_reg_l with (r := Rabs r). @@ -786,11 +785,14 @@ Proof. Qed. (*******************************) -(** * Infinit Sum *) +(** * Infinite Sum *) (*******************************) (*********) -Definition infinit_sum (s:nat -> R) (l:R) : Prop := +Definition infinite_sum (s:nat -> R) (l:R) : Prop := forall eps:R, eps > 0 -> exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (sum_f_R0 s n) l < eps). + +(** Compatibility with previous versions *) +Notation infinit_sum := infinite_sum (only parsing). diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index 8ac9c07f..c96ae5d6 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rgeom.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rgeom.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Rtrigo. -Require Import R_sqrt. Open Local Scope R_scope. +Require Import R_sqrt. +Open Local Scope R_scope. (** * Distance *) diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 1cba821e..8d069e2d 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RiemannInt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: RiemannInt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rfunctions. Require Import SeqSeries. @@ -15,7 +15,8 @@ Require Import Rbase. Require Import RiemannInt_SF. Require Import Classical_Prop. Require Import Classical_Pred_Type. -Require Import Max. Open Local Scope R_scope. +Require Import Max. +Open Local Scope R_scope. Set Implicit Arguments. @@ -25,13 +26,11 @@ Set Implicit Arguments. Definition Riemann_integrable (f:R -> R) (a b:R) : Type := forall eps:posreal, - sigT - (fun phi:StepFun a b => - sigT - (fun psi:StepFun a b => + { phi:StepFun a b & + { psi:StepFun a b | (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\ - Rabs (RiemannInt_SF psi) < eps)). + Rabs (RiemannInt_SF psi) < eps } }. Definition phi_sequence (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) (n:nat) := @@ -40,12 +39,11 @@ Definition phi_sequence (un:nat -> posreal) (f:R -> R) Lemma phi_sequence_prop : forall (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) (N:nat), - sigT - (fun psi:StepFun a b => + { psi:StepFun a b | (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - phi_sequence un pr N t) <= psi t) /\ - Rabs (RiemannInt_SF psi) < un N). + Rabs (RiemannInt_SF psi) < un N }. Proof. intros; apply (projT2 (pr (un N))). Qed. @@ -55,8 +53,8 @@ Lemma RiemannInt_P1 : Riemann_integrable f a b -> Riemann_integrable f b a. Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros; - elim p; clear p; intros; apply existT with (mkStepFun (StepFun_P6 (pre x))); - apply existT with (mkStepFun (StepFun_P6 (pre x0))); + elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x))); + exists (mkStepFun (StepFun_P6 (pre x0))); elim p; clear p; intros; split. intros; apply (H t); elim H1; clear H1; intros; split; [ apply Rle_trans with (Rmin b a); try assumption; right; @@ -90,7 +88,7 @@ Lemma RiemannInt_P2 : (forall n:nat, (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\ Rabs (RiemannInt_SF (wn n)) < un n) -> - sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l). + { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }. Proof. intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit in |- *; intros; assert (H3 : 0 < eps / 2). @@ -143,7 +141,7 @@ Lemma RiemannInt_P3 : (forall n:nat, (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\ Rabs (RiemannInt_SF (wn n)) < un n) -> - sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l). + { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }. Proof. intros; case (Rle_dec a b); intro. apply RiemannInt_P2 with f un wn; assumption. @@ -181,7 +179,7 @@ Proof. rewrite Rabs_Ropp in H4; apply H4. apply H4. assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros; - apply existT with (- x); unfold Un_cv in |- *; unfold Un_cv in p; + exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; intros; elim (p _ H4); intros; exists x0; intros; generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *; case (Rle_dec b a); case (Rle_dec a b); intros. @@ -205,13 +203,12 @@ Lemma RiemannInt_exists : forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) (un:nat -> posreal), Un_cv un 0 -> - sigT - (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l). + { l:R | Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l }. Proof. intros f; intros; apply RiemannInt_P3 with - f un (fun n:nat => projT1 (phi_sequence_prop un pr n)); - [ apply H | intro; apply (projT2 (phi_sequence_prop un pr n)) ]. + f un (fun n:nat => proj1_sig (phi_sequence_prop un pr n)); + [ apply H | intro; apply (proj2_sig (phi_sequence_prop un pr n)) ]. Qed. Lemma RiemannInt_P4 : @@ -411,9 +408,7 @@ Qed. (**********) Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R := - match RiemannInt_exists pr RinvN RinvN_cv with - | existT a' b' => a' - end. + let (a,_) := RiemannInt_exists pr RinvN RinvN_cv in a. Lemma RiemannInt_P5 : forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b), @@ -433,8 +428,7 @@ Qed. Lemma maxN : forall (a b:R) (del:posreal), - a < b -> - sigT (fun n:nat => a + INR n * del < b /\ b <= a + INR (S n) * del). + a < b -> { n:nat | a + INR n * del < b /\ b <= a + INR (S n) * del }. Proof. intros; set (I := fun n:nat => a + INR n * del < b); assert (H0 : exists n : nat, I n). @@ -478,9 +472,7 @@ Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist := end. Definition max_N (a b:R) (del:posreal) (h:a < b) : nat := - match maxN del h with - | existT N H0 => N - end. + let (N,_) := maxN del h in N. Definition SubEqui (a b:R) (del:posreal) (h:a < b) : Rlist := SubEquiN (S (max_N del h)) a b del. @@ -490,12 +482,11 @@ Lemma Heine_cor1 : a < b -> (forall x:R, a <= x <= b -> continuity_pt f x) -> forall eps:posreal, - sigT - (fun delta:posreal => + { delta:posreal | delta <= b - a /\ (forall x y:R, a <= x <= b -> - a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps)). + a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps) }. Proof. intro f; intros; set @@ -520,7 +511,7 @@ Proof. | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a)); [ assumption | apply Rmin_l ] ]. assert (H3 := completeness E H1 H2); elim H3; intros; cut (0 < x <= b - a). - intro; elim H4; clear H4; intros; apply existT with (mkposreal _ H4); split. + intro; elim H4; clear H4; intros; exists (mkposreal _ H4); split. apply H5. unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6; set (D := Rabs (x0 - y)); elim (classic (exists y : R, D < y /\ E y)); @@ -549,22 +540,21 @@ Lemma Heine_cor2 : forall (f:R -> R) (a b:R), (forall x:R, a <= x <= b -> continuity_pt f x) -> forall eps:posreal, - sigT - (fun delta:posreal => + { delta:posreal | forall x y:R, a <= x <= b -> - a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps). + a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps }. Proof. intro f; intros; case (total_order_T a b); intro. elim s; intro. - assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; apply existT with x; + assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; exists x; elim p; intros; apply H2; assumption. - apply existT with (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y); + exists (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y); [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5; apply Rle_antisym; apply Rle_trans with b; assumption | rewrite H3; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos eps) ]. - apply existT with (mkposreal _ Rlt_0_1); intros; elim H0; intros; + exists (mkposreal _ Rlt_0_1); intros; elim H0; intros; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)). Qed. @@ -664,15 +654,14 @@ Qed. Lemma SubEqui_P9 : forall (a b:R) (del:posreal) (f:R -> R) (h:a < b), - sigT - (fun g:StepFun a b => + { g:StepFun a b | g b = f b /\ (forall i:nat, (i < pred (Rlength (SubEqui del h)))%nat -> constant_D_eq g (co_interval (pos_Rl (SubEqui del h) i) (pos_Rl (SubEqui del h) (S i))) - (f (pos_Rl (SubEqui del h) i)))). + (f (pos_Rl (SubEqui del h) i))) }. Proof. intros; apply StepFun_P38; [ apply SubEqui_P7 | apply SubEqui_P1 | apply SubEqui_P2 ]. @@ -1003,11 +992,11 @@ Proof. do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] | discrR ]. - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro; + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; rewrite Rmin_comm; rewrite RmaxSym; - apply (projT2 (phi_sequence_prop RinvN pr2 n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr1 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). Qed. Lemma RiemannInt_P9 : @@ -1272,11 +1261,11 @@ Proof. case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; eapply UL_sequence; [ apply u0 - | set (psi1 := fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); - set (psi2 := fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); + | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); + set (psi2 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2; [ apply RinvN_cv - | intro; apply (projT2 (phi_sequence_prop RinvN pr1 n)) + | intro; apply (proj2_sig (phi_sequence_prop RinvN pr1 n)) | intro; assert (H1 : @@ -1284,7 +1273,7 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n); - [ apply (projT2 (phi_sequence_prop RinvN pr3 n)) + [ apply (proj2_sig (phi_sequence_prop RinvN pr3 n)) | elim H1; intros; split; try assumption; intros; replace (f t) with (f t + l * g t); [ apply H2; assumption | rewrite H0; ring ] ] @@ -1360,8 +1349,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr1 n0)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr1 n0)). assert (H8 : exists psi2 : nat -> StepFun a b, @@ -1370,8 +1359,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr2 n0)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr2 n0)). assert (H9 : exists psi3 : nat -> StepFun a b, @@ -1380,8 +1369,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr3 n0)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr3 n0)). elim H7; clear H7; intros psi1 H7; elim H8; clear H8; intros psi2 H8; elim H9; clear H9; intros psi3 H9; replace @@ -1552,8 +1541,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi_sequence RinvN pr n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr n)). elim H1; clear H1; intros psi1 H1; set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c)); set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0)); @@ -1647,8 +1636,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr2 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H1 : exists psi2 : nat -> StepFun a b, @@ -1664,8 +1653,8 @@ Proof. (forall t:R, Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr1 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n); clear H1; intros; split; try assumption. intros; unfold phi2 in |- *; simpl in |- *; @@ -1698,8 +1687,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr1 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). elim H1; clear H1; intros psi1 H1; set (phi2 := fun N:nat => phi_sequence RinvN pr2 N). set @@ -1722,8 +1711,8 @@ Proof. (forall t:R, Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr2 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). elim H2; clear H2; intros psi2 H2; apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; try assumption. @@ -2378,8 +2367,8 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr1 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). assert (H2 : exists psi2 : nat -> StepFun b c, @@ -2388,8 +2377,8 @@ Proof. Rmin b c <= t /\ t <= Rmax b c -> Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr2 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H3 : exists psi3 : nat -> StepFun a c, @@ -2398,8 +2387,8 @@ Proof. Rmin a c <= t /\ t <= Rmax a c -> Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). - split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro; - apply (projT2 (phi_sequence_prop RinvN pr3 n)). + split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; + apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3; clear H3; intros psi3 H3; assert (H := RinvN_cv); unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3). @@ -3259,7 +3248,7 @@ Lemma RiemannInt_P30 : forall (f:R -> R) (a b:R), a <= b -> (forall x:R, a <= x <= b -> continuity_pt f x) -> - sigT (fun g:R -> R => antiderivative f g a b). + { g:R -> R | antiderivative f g a b }. Proof. intros; split with (primitive H (FTC_P1 H H0)); apply RiemannInt_P29. Qed. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 0f91d006..7a02544e 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RiemannInt_SF.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: RiemannInt_SF.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -31,7 +31,7 @@ Qed. Lemma Nzorn : forall I:nat -> Prop, (exists n : nat, I n) -> - Nbound I -> sigT (fun n:nat => I n /\ (forall i:nat, I i -> (i <= n)%nat)). + Nbound I -> { n:nat | I n /\ (forall i:nat, I i -> (i <= n)%nat) }. Proof. intros I H H0; set (E := fun x:R => exists i : nat, I i /\ INR i = x); assert (H1 : bound E). @@ -133,10 +133,10 @@ Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:Rlist) := (forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <> pos_Rl l (S i)). Definition is_subdivision (f:R -> R) (a b:R) (l:Rlist) : Type := - sigT (fun l0:Rlist => adapted_couple f a b l l0). + { l0:Rlist & adapted_couple f a b l l0 }. Definition IsStepFun (f:R -> R) (a b:R) : Type := - sigT (fun l:Rlist => is_subdivision f a b l). + { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) Record StepFun (a b:R) : Type := mkStepFun @@ -1779,13 +1779,12 @@ Lemma StepFun_P38 : ordered_Rlist l -> pos_Rl l 0 = a -> pos_Rl l (pred (Rlength l)) = b -> - sigT - (fun g:StepFun a b => + { g:StepFun a b | g b = f b /\ (forall i:nat, (i < pred (Rlength l))%nat -> constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) - (f (pos_Rl l i)))). + (f (pos_Rl l i))) }. Proof. intros l a b f; generalize a; clear a; induction l. intros a H H0 H1; simpl in H0; simpl in H1; @@ -2206,21 +2205,10 @@ Lemma StepFun_P43 : RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) = RiemannInt_SF (mkStepFun pr3). Proof. - intros f; intros; - assert - (H1 : - sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a b l l0))). - apply pr1. - assert - (H2 : - sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f b c l l0))). - apply pr2. - assert - (H3 : - sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))). - apply pr3. - elim H1; clear H1; intros l1 [lf1 H1]; elim H2; clear H2; intros l2 [lf2 H2]; - elim H3; clear H3; intros l3 [lf3 H3]. + intros f; intros. + pose proof pr1 as (l1,(lf1,H1)). + pose proof pr2 as (l2,(lf2,H2)). + pose proof pr3 as (l3,(lf3,H3)). replace (RiemannInt_SF (mkStepFun pr1)) with match Rle_dec a b with | left _ => Int_SF lf1 l1 @@ -2462,7 +2450,7 @@ Proof. (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R), adapted_couple f a b l1 lf1 -> a <= c <= b -> - sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))). + { l:Rlist & { l0:Rlist & adapted_couple f a c l l0 } }). intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X. apply H2. split; assumption. @@ -2578,7 +2566,7 @@ Proof. (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R), adapted_couple f a b l1 lf1 -> a <= c <= b -> - sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f c b l l0))). + { l:Rlist & { l0:Rlist & adapted_couple f c b l l0 } }). intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X; [ apply H2 | split; assumption ]. clear f a b c H0 H H1 H2 l1 lf1; simple induction l1. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 76579ccb..1a2fa03a 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rlimit.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rlimit.v 10710 2008-03-23 09:24:09Z herbelin $ i*) (*********************************************************) (** Definition of the limit *) @@ -16,7 +16,8 @@ Require Import Rbase. Require Import Rfunctions. Require Import Classical_Prop. -Require Import Fourier. Open Local Scope R_scope. +Require Import Fourier. +Open Local Scope R_scope. (*******************************) (** * Calculus *) @@ -560,9 +561,9 @@ Proof. | apply Rlt_le_trans with (Rmin delta1 delta2); [ assumption | apply Rmin_l ] ]. change (0 < eps * (Rsqr l / 2)) in |- *; unfold Rdiv in |- *; - repeat rewrite Rmult_assoc; repeat apply Rmult_lt_0_compat. + repeat rewrite Rmult_assoc; apply Rmult_lt_0_compat. assumption. - apply Rsqr_pos_lt; assumption. + apply Rmult_lt_0_compat. apply Rsqr_pos_lt; assumption. apply Rinv_0_lt_compat; cut (0%nat <> 2%nat); [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *; intro; assumption diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v new file mode 100644 index 00000000..8aadf8f5 --- /dev/null +++ b/theories/Reals/Rlogic.v @@ -0,0 +1,293 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** * This module proves some logical properties of the axiomatics of Reals + +1. Decidablity of arithmetical statements from + the axiom that the order of the real numbers is decidable. + +2. Derivability of the archimedean "axiom" +*) + +(** 1- Proof of the decidablity of arithmetical statements from +excluded middle and the axiom that the order of the real numbers is +decidable. *) + +(** Assuming a decidable predicate [P n], A series is constructed whose +[n]th term is 1/2^n if [P n] holds and 0 otherwise. This sum reaches 2 +only if [P n] holds for all [n], otherwise the sum is less than 2. +Comparing the sum to 2 decides if [forall n, P n] or [~forall n, P n] *) + +(** One can iterate this lemma and use classical logic to decide any +statement in the arithmetical hierarchy. *) + +(** Contributed by Cezary Kaliszyk and Russell O'Connor *) + +Require Import ConstructiveEpsilon. +Require Import Rfunctions. +Require Import PartSum. +Require Import SeqSeries. +Require Import RiemannInt. +Require Import Fourier. + +Section Arithmetical_dec. + +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). +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). +apply Rplus_le_compat_l. + induction (n - S m)%nat; simpl in *. + apply fpos. +replace 0 with (0 + 0) by ring. +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). +intros m n f mn pos. + elim (le_lt_or_eq _ _ mn). + intro; apply ge_fun_sums_ge_lemma; assumption. +intro H; rewrite H; auto with *. +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. +intros e He. +assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R). + apply GP_infinite. + apply Rabs_def1; fourier. +assert (He':e/2 > 0) by fourier. +destruct (X _ He') as [N HN]. +clear X. +exists N. +intros n m Hn Hm. +replace e with (e/2 + e/2)%R by field. +set (g:=(fun n0 : nat => 1 * (1 / 2) ^ n0)) in *. +assert (R_dist (sum_f_R0 g n) (sum_f_R0 g m) < e / 2 + e / 2). + apply Rle_lt_trans with (R_dist (sum_f_R0 g n) 2+R_dist 2 (sum_f_R0 g m))%R. + apply R_dist_tri. + replace (/(1 - 1/2)) with 2 in HN by field. + cut (forall n, (n >= N)%nat -> R_dist (sum_f_R0 g n) 2 < e/2)%R. + intros Z. + apply Rplus_lt_compat. + apply Z; assumption. + rewrite R_dist_sym. + apply Z; assumption. + clear - HN He. + intros n Hn. + apply HN. + auto. +eapply Rle_lt_trans;[|apply H]. +clear -ge_fun_sums_ge n. +cut (forall n m, (m <= n)%nat -> R_dist (sum_f_R0 f n) (sum_f_R0 f m) <= R_dist (sum_f_R0 g n) (sum_f_R0 g m)). + intros H. + destruct (le_lt_dec m n). + apply H; assumption. + rewrite R_dist_sym. + rewrite (R_dist_sym (sum_f_R0 g n)). + apply H; auto with *. +clear n m. +intros n m Hnm. +unfold R_dist. +cut (forall i : nat, (1 / 2) ^ i >= 0). intro RPosPow. +rewrite Rabs_pos_eq. + rewrite Rabs_pos_eq. + cut (sum_f_R0 g m - sum_f_R0 f m <= sum_f_R0 g n - sum_f_R0 f n). + intros; fourier. + do 2 rewrite <- minus_sum. + apply (ge_fun_sums_ge m n (fun i : nat => g i - f i) Hnm). + intro i. + unfold f, g. + elim (HP i); intro; ring_simplify; auto with *. + cut (sum_f_R0 g m <= sum_f_R0 g n). + intro; fourier. + apply (ge_fun_sums_ge m n g Hnm). + intro. unfold g. + ring_simplify. + apply Rge_le. + apply RPosPow. + cut (sum_f_R0 f m <= sum_f_R0 f n). + intro; fourier. + apply (ge_fun_sums_ge m n f Hnm). + intro; unfold f. + elim (HP i); intro; simpl. + apply Rge_le. + apply RPosPow. + auto with *. +intro i. +apply Rle_ge. +apply pow_le. +fourier. +Qed. + +Lemma forall_dec : {forall n, P n} + {~forall n, P n}. +Proof. +destruct (cv_cauchy_2 _ cauchy_crit_geometric_dec_fun). + cut (2 <= x <-> forall n : nat, P n). + intro H. + elim (Rle_dec 2 x); intro X. + left; tauto. + right; tauto. +assert (A:Rabs(1/2) < 1) by (apply Rabs_def1; fourier). +assert (A0:=(GP_infinite (1/2) A)). +symmetry. + split; intro. + replace 2 with (/ (1 - (1 / 2))) by field. + unfold Pser, infinite_sum in A0. + eapply Rle_cv_lim;[|unfold Un_cv; apply A0 |apply u]. + intros n. + clear -n H. + induction n; unfold f;simpl. + destruct (HP 0); auto with *. + elim n; auto. + apply Rplus_le_compat; auto. + destruct (HP (S n)); auto with *. + elim n0; auto. +intros n. +destruct (HP n); auto. +elim (RIneq.Rle_not_lt _ _ H). +assert (B:0< (1/2)^n). + apply pow_lt. + fourier. +apply Rle_lt_trans with (2-(1/2)^n);[|fourier]. +replace (/(1-1/2))%R with 2 in A0 by field. +set (g:= fun m => if (eq_nat_dec m n) then (1/2)^n else 0). +assert (Z: Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)). + intros e He. + exists n. + intros a Ha. + replace (sum_f_R0 g a) with ((1/2)^n). + rewrite (R_dist_eq); assumption. + symmetry. + cut (forall a : nat, ((a >= n)%nat -> sum_f_R0 g a = (1 / 2) ^ n) /\ ((a < n)%nat -> sum_f_R0 g a = 0))%R. + intros H0. + destruct (H0 a). + auto. + clear - g. + induction a. + split; + intros H; + simpl; unfold g; + destruct (eq_nat_dec 0 n); try reflexivity. + elim f; auto with *. + elimtype False; omega. + destruct IHa as [IHa0 IHa1]. + split; + intros H; + simpl; unfold g at 2; + destruct (eq_nat_dec (S a) n). + rewrite IHa1. + ring. + omega. + ring_simplify. + apply IHa0. + omega. + elimtype False; omega. + ring_simplify. + apply IHa1. + omega. +assert (C:=CV_minus _ _ _ _ A0 Z). +eapply Rle_cv_lim;[|apply u |apply C]. +clear - n0 B. +intros m. +simpl. +induction m. + simpl. + unfold f, g. + destruct (eq_nat_dec 0 n). + destruct (HP 0). + elim n0. + congruence. + clear -n. + induction n; simpl; fourier. + destruct (HP); simpl; fourier. +cut (f (S m) <= 1 * ((1 / 2) ^ (S m)) - g (S m)). + intros L. + eapply Rle_trans. + simpl. + apply Rplus_le_compat. + apply IHm. + apply L. + simpl; fourier. +unfold f, g. +destruct (eq_nat_dec (S m) n). + destruct (HP (S m)). + elim n0. + congruence. + rewrite e. + fourier. +destruct (HP (S m)). + fourier. +ring_simplify. +apply pow_le. +fourier. +Qed. + +Lemma sig_forall_dec : {n | ~P n}+{forall n, P n}. +destruct forall_dec. + right; assumption. +left. +apply constructive_indefinite_description_nat; auto. + clear - HP. + firstorder. +apply Classical_Pred_Type.not_all_ex_not. +assumption. +Qed. + +End Arithmetical_dec. + +(** 2- Derivability of the Archimedean axiom *) + +(* This is a standard proof (it has been taken from PlanetMath). It is +formulated negatively so as to avoid the need for classical +logic. Using a proof of {n | ~P n}+{forall n, P n} (the one above or a +variant of it that does not need classical axioms) , we can in +principle also derive [up] and its [specification] *) + +Theorem not_not_archimedean : + forall r : R, ~ (forall n : nat, (INR n <= r)%R). +intros r H. +set (E := fun r => exists n : nat, r = INR n). +assert (exists x : R, E x) by + (exists 0%R; simpl; red; exists 0%nat; reflexivity). +assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H). +destruct (completeness E) as (M,(H3,H4)); try assumption. +set (M' := (M + -1)%R). +assert (H2 : ~ is_upper_bound E M'). + intro H5. + assert (M <= M')%R by (apply H4; exact H5). + apply (Rlt_not_le M M'). + unfold M' in |- *. + pattern M at 2 in |- *. + rewrite <- Rplus_0_l. + pattern (0 + M)%R in |- *. + rewrite Rplus_comm. + rewrite <- (Rplus_opp_r 1). + apply Rplus_lt_compat_l. + rewrite Rplus_comm. + apply Rlt_plus_1. + assumption. +apply H2. +intros N (n,H7). +rewrite H7. +unfold M' in |- *. +assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity). +rewrite S_INR in H5. +assert (H6 : (INR n + 1 + -1 <= M + -1)%R). + apply Rplus_le_compat_r. + assumption. +rewrite Rplus_assoc in H6. +rewrite Rplus_opp_r in H6. +rewrite (Rplus_comm (INR n) 0) in H6. +rewrite Rplus_0_l in H6. +assumption. +Qed. diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 5bdbb76b..90ea9726 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* $Id: Rpow_def.v 10923 2008-05-12 18:25:06Z herbelin $ *) + Require Import Rdefinitions. Fixpoint pow (r:R) (n:nat) {struct n} : R := diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index cb6c59d5..adf53ef9 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rpower.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rpower.v 10710 2008-03-23 09:24:09Z herbelin $ i*) (*i Due to L.Thery i*) (************************************************************) @@ -22,7 +22,8 @@ Require Import Exp_prop. Require Import Rsqrt_def. Require Import R_sqrt. Require Import MVT. -Require Import Ranalysis4. Open Local Scope R_scope. +Require Import Ranalysis4. +Open Local Scope R_scope. Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y). Proof. @@ -90,7 +91,7 @@ Proof. replace (/ INR (fact n)) with (1 ^ n / INR (fact n)). apply (H2 _ H3). unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity. - unfold infinit_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0); + unfold infinite_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0); intros; exists x0; intros; replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n). @@ -150,62 +151,59 @@ Proof. symmetry in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp. Qed. -Lemma ln_exists1 : forall y:R, 0 < y -> 1 <= y -> sigT (fun z:R => y = exp z). +Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }. Proof. - intros; set (f := fun x:R => exp x - y); cut (f 0 <= 0). - intro; cut (continuity f). - intro; cut (0 <= f y). - intro; cut (f 0 * f y <= 0). - intro; assert (X := IVT_cor f 0 y H2 (Rlt_le _ _ H) H4); elim X; intros t H5; - apply existT with t; elim H5; intros; unfold f in H7; - apply Rminus_diag_uniq_sym; exact H7. + intros; set (f := fun x:R => exp x - y). + assert (H0 : 0 < y) by (apply Rlt_le_trans with 1; auto with real). + cut (f 0 <= 0); [intro H1|]. + cut (continuity f); [intro H2|]. + cut (0 <= f y); [intro H3|]. + cut (f 0 * f y <= 0); [intro H4|]. + pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7)); + exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7. pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)); rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; assumption. unfold f in |- *; apply Rplus_le_reg_l with y; left; apply Rlt_trans with (1 + y). rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1. - replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H) | ring ]. + replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | ring ]. unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *; apply continuity_minus; [ apply derivable_continuous; apply derivable_exp | apply derivable_continuous; apply derivable_const ]. unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y; - rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H0 | ring ]. + rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H | ring ]. Qed. (**********) -Lemma ln_exists : forall y:R, 0 < y -> sigT (fun z:R => y = exp z). +Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }. Proof. intros; case (Rle_dec 1 y); intro. - apply (ln_exists1 _ H r). + apply (ln_exists1 _ r). assert (H0 : 1 <= / y). apply Rmult_le_reg_l with y. apply H. rewrite <- Rinv_r_sym. rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n). red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H). - assert (H1 : 0 < / y). - apply Rinv_0_lt_compat; apply H. - assert (H2 := ln_exists1 _ H1 H0); elim H2; intros; apply existT with (- x); + destruct (ln_exists1 _ H0) as (x,p); exists (- x); apply Rmult_eq_reg_l with (exp x / y). unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc; rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; rewrite Rmult_1_r; symmetry in |- *; apply p. - red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H). + red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H). unfold Rdiv in |- *; apply prod_neq_R0. - assert (H3 := exp_pos x); red in |- *; intro; rewrite H4 in H3; + assert (H3 := exp_pos x); red in |- *; intro H4; rewrite H4 in H3; elim (Rlt_irrefl _ H3). - apply Rinv_neq_0_compat; red in |- *; intro; rewrite H3 in H; + apply Rinv_neq_0_compat; red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H). Qed. (* Definition of log R+* -> R *) Definition Rln (y:posreal) : R := - match ln_exists (pos y) (cond_pos y) with - | existT a b => a - end. + let (a,_) := ln_exists (pos y) (cond_pos y) in a. (* Extension on R *) Definition ln (x:R) : R := @@ -403,6 +401,16 @@ Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope. (** * Properties of Rpower *) (******************************************************************) +(** Note: [Rpower] is prolongated to [1] on negative real numbers and + it thus does not extend integer power. The next two lemmas, which + hold for integer power, accidentally hold on negative real numbers + as a side effect of the default value taken on negative real + numbers. Contrastingly, the lemmas that do not hold for the + integer power of a negative number are stated for [Rpower] on the + positive numbers only (even if they accidentally hold due to the + default value of [Rpower] on the negative side, as it is the case + for [Rpower_O]). *) + Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y. Proof. intros x y z; unfold Rpower in |- *. @@ -420,7 +428,7 @@ Qed. Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1. Proof. - intros x H; unfold Rpower in |- *. + intros x _; unfold Rpower in |- *. rewrite Rmult_0_l; apply exp_0. Qed. diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index a84d5149..2113cc8f 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rprod.v 9298 2006-10-27 13:05:29Z notin $ i*) +(*i $Id: Rprod.v 10146 2007-09-27 12:28:12Z herbelin $ i*) Require Import Compare. Require Import Rbase. @@ -16,41 +16,42 @@ Require Import PartSum. Require Import Binomial. Open Local Scope R_scope. -(** TT Ak; 1<=k<=N *) -Boxed Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R := +(** TT Ak; 0<=k<=N *) +Boxed Fixpoint prod_f_R0 (f:nat -> R) (N:nat) {struct N} : R := match N with - | O => 1 - | S p => prod_f_SO An p * An (S p) + | O => f O + | S p => prod_f_R0 f p * f (S p) end. +Notation prod_f_SO := (fun An N => prod_f_R0 (fun n => An (S n)) N). + (**********) Lemma prod_SO_split : forall (An:nat -> R) (n k:nat), - (k <= n)%nat -> - prod_f_SO An n = - prod_f_SO An k * prod_f_SO (fun l:nat => An (k + l)%nat) (n - k). + (k < n)%nat -> + prod_f_R0 An n = + prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1). Proof. intros; induction n as [| n Hrecn]. - cut (k = 0%nat); - [ intro; rewrite H0; simpl in |- *; ring | inversion H; reflexivity ]. - cut (k = S n \/ (k <= n)%nat). - intro; elim H0; intro. - rewrite H1; simpl in |- *; rewrite <- minus_n_n; simpl in |- *; ring. - replace (S n - k)%nat with (S (n - k)). + absurd (k < 0)%nat; omega. + cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|omega]. + replace (S n - k - 1)%nat with O; [rewrite H1; simpl|omega]. + replace (n+1+0)%nat with (S n); ring. + replace (S n - k-1)%nat with (S (n - k-1));[idtac|omega]. simpl in |- *; replace (k + S (n - k))%nat with (S n). + replace (k + 1 + S (n - k - 1))%nat with (S n). rewrite Hrecn; [ ring | assumption ]. omega. omega. - omega. -Qed. +Qed. (**********) Lemma prod_SO_pos : forall (An:nat -> R) (N:nat), - (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_SO An N. + (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_R0 An N. Proof. intros; induction N as [| N HrecN]. - simpl in |- *; left; apply Rlt_0_1. + simpl in |- *; apply H; trivial. simpl in |- *; apply Rmult_le_pos. apply HrecN; intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ]. @@ -61,11 +62,11 @@ Qed. Lemma prod_SO_Rle : forall (An Bn:nat -> R) (N:nat), (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) -> - prod_f_SO An N <= prod_f_SO Bn N. + prod_f_R0 An N <= prod_f_R0 Bn N. Proof. intros; induction N as [| N HrecN]. - right; reflexivity. - simpl in |- *; apply Rle_trans with (prod_f_SO An N * Bn (S N)). + elim H with O; trivial. + simpl in |- *; apply Rle_trans with (prod_f_R0 An N * Bn (S N)). apply Rmult_le_compat_l. apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros; assumption. @@ -79,12 +80,17 @@ Qed. (** Application to factorial *) Lemma fact_prodSO : - forall n:nat, INR (fact n) = prod_f_SO (fun k:nat => INR k) n. + forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => + (match (eq_nat_dec k 0) with + | left _ => 1%R + | right _ => INR k + end)) n. Proof. intro; induction n as [| n Hrecn]. reflexivity. - change (INR (S n * fact n) = prod_f_SO (fun k:nat => INR k) (S n)) in |- *. - rewrite mult_INR; rewrite Rmult_comm; rewrite Hrecn; reflexivity. + simpl; rewrite <- Hrecn. + case n; auto with real. + intros; repeat rewrite plus_INR;rewrite mult_INR;ring. Qed. Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat. @@ -104,40 +110,58 @@ Lemma RfactN_fact2N_factk : (k <= 2 * N)%nat -> Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k). Proof. + assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)). + intros; case (eq_nat_dec n 0); auto with real. + assert (forall (n:nat), (0 < n)%nat -> + (if eq_nat_dec n 0 then 1 else INR n) = INR n). + intros n; case (eq_nat_dec n 0); auto with real. + intros; absurd (0 < n)%nat; omega. intros; unfold Rsqr in |- *; repeat rewrite fact_prodSO. - cut ((k <= N)%nat \/ (N <= k)%nat). - intro; elim H0; intro. - rewrite (prod_SO_split (fun l:nat => INR l) (2 * N - k) N). + cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat). + intro H2; elim H2; intro H3. + rewrite H3; replace (2*N-N)%nat with N;[right; ring|omega]. + case H3; intro; clear H2 H3. + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) (2 * N - k) N). rewrite Rmult_assoc; apply Rmult_le_compat_l. - apply prod_SO_pos; intros; apply pos_INR. - replace (2 * N - k - N)%nat with (N - k)%nat. - rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => INR l) N k). + apply prod_SO_pos; intros; auto. + replace (2 * N - k - N-1)%nat with (N - k-1)%nat. + rewrite Rmult_comm; rewrite (prod_SO_split + (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k). apply Rmult_le_compat_l. - apply prod_SO_pos; intros; apply pos_INR. - apply prod_SO_Rle; intros; split. - apply pos_INR. - apply le_INR; apply plus_le_compat_r; assumption. + apply prod_SO_pos; intros; auto. + apply prod_SO_Rle; intros; split; auto. + rewrite H0. + rewrite H0. + apply le_INR; omega. + omega. + omega. assumption. omega. omega. - rewrite <- (Rmult_comm (prod_f_SO (fun l:nat => INR l) k)); - rewrite (prod_SO_split (fun l:nat => INR l) k N). + rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => + if eq_nat_dec l 0 then 1 else INR l) k)); + rewrite (prod_SO_split (fun l:nat => + if eq_nat_dec l 0 then 1 else INR l) k N). rewrite Rmult_assoc; apply Rmult_le_compat_l. - apply prod_SO_pos; intros; apply pos_INR. + apply prod_SO_pos; intros; auto. rewrite Rmult_comm; - rewrite (prod_SO_split (fun l:nat => INR l) N (2 * N - k)). + rewrite (prod_SO_split (fun l:nat => + if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)). apply Rmult_le_compat_l. - apply prod_SO_pos; intros; apply pos_INR. - replace (N - (2 * N - k))%nat with (k - N)%nat. - apply prod_SO_Rle; intros; split. - apply pos_INR. - apply le_INR; apply plus_le_compat_r. + apply prod_SO_pos; intros; auto. + replace (N - (2 * N - k)-1)%nat with (k - N-1)%nat. + apply prod_SO_Rle; intros; split; auto. + rewrite H0. + rewrite H0. + apply le_INR; omega. + omega. omega. omega. omega. assumption. omega. -Qed. +Qed. + (**********) Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n). diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 38c39bae..702aafa4 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rseries.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rseries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -194,14 +194,14 @@ Section Isequence. Variable An : nat -> R. (*********) - Definition Pser (x l:R) : Prop := infinit_sum (fun n:nat => An n * x ^ n) l. + Definition Pser (x l:R) : Prop := infinite_sum (fun n:nat => An n * x ^ n) l. End Isequence. Lemma GP_infinite : forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)). Proof. - intros; unfold Pser in |- *; unfold infinit_sum in |- *; intros; + intros; unfold Pser in |- *; unfold infinite_sum in |- *; intros; elim (Req_dec x 0). intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1; cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1). diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index cb31d3b2..7cdd4d02 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsigma.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rsigma.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 0a9f7754..0a3af6ca 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rsqrt_def.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rsqrt_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Sumbool. Require Import Rbase. @@ -192,7 +192,7 @@ Qed. Lemma dicho_lb_cv : forall (x y:R) (P:R -> bool), - x <= y -> sigT (fun l:R => Un_cv (dicho_lb x y P) l). + x <= y -> { l:R | Un_cv (dicho_lb x y P) l }. Proof. intros. apply growing_cv. @@ -202,7 +202,7 @@ Qed. Lemma dicho_up_cv : forall (x y:R) (P:R -> bool), - x <= y -> sigT (fun l:R => Un_cv (dicho_up x y P) l). + x <= y -> { l:R | Un_cv (dicho_up x y P) l }. Proof. intros. apply decreasing_cv. @@ -466,7 +466,7 @@ Qed. Lemma IVT : forall (f:R -> R) (x y:R), continuity f -> - x < y -> f x < 0 -> 0 < f y -> sigT (fun z:R => x <= z <= y /\ f z = 0). + x < y -> f x < 0 -> 0 < f y -> { z:R | x <= z <= y /\ f z = 0 }. Proof. intros. cut (x <= y). @@ -478,7 +478,7 @@ Proof. elim X0; intros. assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p). rewrite H4 in p0. - apply existT with x0. + exists x0. split. split. apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0). @@ -602,7 +602,7 @@ Qed. Lemma IVT_cor : forall (f:R -> R) (x y:R), continuity f -> - x <= y -> f x * f y <= 0 -> sigT (fun z:R => x <= z <= y /\ f z = 0). + x <= y -> f x * f y <= 0 -> { z:R | x <= z <= y /\ f z = 0 }. Proof. intros. case (total_order_T 0 (f x)); intro. @@ -628,7 +628,7 @@ Proof. cut (0 < (- f)%F y). intros. elim (H3 H5 H4); intros. - apply existT with x0. + exists x0. elim p; intros. split. assumption. @@ -643,7 +643,7 @@ Proof. assumption. rewrite H2 in a. elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)). - apply existT with x. + exists x. split. split; [ right; reflexivity | assumption ]. symmetry in |- *; assumption. @@ -656,7 +656,7 @@ Proof. assumption. rewrite H2 in r. elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)). - apply existT with y. + exists y. split. split; [ assumption | right; reflexivity ]. symmetry in |- *; assumption. @@ -670,7 +670,7 @@ Qed. (** We can now define the square root function as the reciprocal transformation of the square root function *) Lemma Rsqrt_exists : - forall y:R, 0 <= y -> sigT (fun z:R => 0 <= z /\ y = Rsqr z). + forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }. Proof. intros. set (f := fun x:R => Rsqr x - y). @@ -686,7 +686,7 @@ Proof. intro. assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3). elim X; intros t H4. - apply existT with t. + exists t. elim H4; intros. split. elim H5; intros; assumption. @@ -700,7 +700,7 @@ Proof. rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; left; assumption. - apply existT with 1. + exists 1. split. left; apply Rlt_0_1. rewrite b; symmetry in |- *; apply Rsqr_1. @@ -710,7 +710,7 @@ Proof. intro. assert (X := IVT_cor f 0 y H1 H H3). elim X; intros t H4. - apply existT with t. + exists t. elim H4; intros. split. elim H5; intros; assumption. @@ -739,9 +739,7 @@ Qed. (* Definition of the square root: R+->R *) Definition Rsqrt (y:nonnegreal) : R := - match Rsqrt_exists (nonneg y) (cond_nonneg y) with - | existT a b => a - end. + let (a,_) := Rsqrt_exists (nonneg y) (cond_nonneg y) in a. (**********) Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index aa47d72f..9501bc1e 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -6,15 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtopology.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rtopology.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. Require Import RList. Require Import Classical_Prop. -Require Import Classical_Pred_Type. Open Local Scope R_scope. - +Require Import Classical_Pred_Type. +Open Local Scope R_scope. (** * General definitions and propositions *) diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index b744c788..0baece39 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rtrigo.v 9454 2006-12-15 15:30:59Z bgregoir $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index 89ee1745..d82bafc6 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_alt.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rtrigo_alt.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -137,7 +137,7 @@ Proof. ring. assert (X := exist_sin (Rsqr a)); elim X; intros. cut (x = sin a / a). - intro; rewrite H3 in p; unfold sin_in in p; unfold infinit_sum in p; + intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p; unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. cut (0 < eps / Rabs a). @@ -327,7 +327,7 @@ Proof. apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption. assert (X := exist_cos (Rsqr a0)); elim X; intros. cut (x = cos a0). - intro; rewrite H4 in p; unfold cos_in in p; unfold infinit_sum in p; + intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p; unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. elim (p _ H5); intros N H6. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index b2aeb766..e94d7448 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_def.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rtrigo_def.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -19,7 +19,7 @@ Open Local Scope R_scope. (** * Definition of exponential *) (********************************) Definition exp_in (x l:R) : Prop := - infinit_sum (fun i:nat => / INR (fact i) * x ^ i) l. + infinite_sum (fun i:nat => / INR (fact i) * x ^ i) l. Lemma exp_cof_no_R0 : forall n:nat, / INR (fact n) <> 0. Proof. @@ -28,7 +28,7 @@ Proof. apply INR_fact_neq_0. Qed. -Lemma exist_exp : forall x:R, sigT (fun l:R => exp_in x l). +Lemma exist_exp : forall x:R, { l:R | exp_in x l }. Proof. intro; generalize @@ -37,7 +37,7 @@ Proof. trivial. Defined. -Definition exp (x:R) : R := projT1 (exist_exp x). +Definition exp (x:R) : R := proj1_sig (exist_exp x). Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0. Proof. @@ -45,11 +45,10 @@ Proof. red in |- *; intro; rewrite H0 in H; elim (lt_irrefl _ H). Qed. -(*i Calculus of $e^0$ *) -Lemma exist_exp0 : sigT (fun l:R => exp_in 0 l). +Lemma exist_exp0 : { l:R | exp_in 0 l }. Proof. - apply existT with 1. - unfold exp_in in |- *; unfold infinit_sum in |- *; intros. + exists 1. + unfold exp_in in |- *; unfold infinite_sum in |- *; intros. exists 0%nat. intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1. unfold R_dist in |- *; replace (1 - 1) with 0; @@ -63,6 +62,7 @@ Proof. unfold ge in |- *; apply le_O_n. Defined. +(* Value of [exp 0] *) Lemma exp_0 : exp 0 = 1. Proof. cut (exp_in 0 (exp 0)). @@ -70,8 +70,8 @@ Proof. unfold exp_in in |- *; intros; eapply uniqueness_sum. apply H0. apply H. - exact (projT2 exist_exp0). - exact (projT2 (exist_exp 0)). + exact (proj2_sig exist_exp0). + exact (proj2_sig (exist_exp 0)). Qed. (*****************************************) @@ -235,21 +235,17 @@ Qed. (**********) Definition cos_in (x l:R) : Prop := - infinit_sum (fun i:nat => cos_n i * x ^ i) l. + infinite_sum (fun i:nat => cos_n i * x ^ i) l. (**********) -Lemma exist_cos : forall x:R, sigT (fun l:R => cos_in x l). +Lemma exist_cos : forall x:R, { l:R | cos_in x l }. intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos). unfold Pser, cos_in in |- *; trivial. Qed. (** Definition of cosinus *) -Definition cos (x:R) : R := - match exist_cos (Rsqr x) with - | existT a b => a - end. - +Definition cos (x:R) : R := let (a,_) := exist_cos (Rsqr x) in a. Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)). @@ -348,7 +344,7 @@ Proof. apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR; replace (INR 0) with 0; [ ring | reflexivity ]. -Qed. +Defined. Lemma sin_no_R0 : forall n:nat, sin_n n <> 0. Proof. @@ -359,21 +355,18 @@ Qed. (**********) Definition sin_in (x l:R) : Prop := - infinit_sum (fun i:nat => sin_n i * x ^ i) l. + infinite_sum (fun i:nat => sin_n i * x ^ i) l. (**********) -Lemma exist_sin : forall x:R, sigT (fun l:R => sin_in x l). +Lemma exist_sin : forall x:R, { l:R | sin_in x l }. Proof. intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin). unfold Pser, sin_n in |- *; trivial. -Qed. +Defined. (***********************) (* Definition of sinus *) -Definition sin (x:R) : R := - match exist_sin (Rsqr x) with - | existT a b => x * a - end. +Definition sin (x:R) : R := let (a,_) := exist_sin (Rsqr x) in x * a. (*********************************************) (** * Properties *) @@ -399,10 +392,10 @@ Proof. intros; ring. Qed. -Lemma exist_cos0 : sigT (fun l:R => cos_in 0 l). +Lemma exist_cos0 : { l:R | cos_in 0 l }. Proof. - apply existT with 1. - unfold cos_in in |- *; unfold infinit_sum in |- *; intros; exists 0%nat. + exists 1. + unfold cos_in in |- *; unfold infinite_sum in |- *; intros; exists 0%nat. intros. unfold R_dist in |- *. induction n as [| n Hrecn]. @@ -417,7 +410,7 @@ Proof. simpl in |- *; ring. Defined. -(* Calculus of (cos 0) *) +(* Value of [cos 0] *) Lemma cos_0 : cos 0 = 1. Proof. cut (cos_in 0 (cos 0)). @@ -425,7 +418,7 @@ Proof. unfold cos_in in |- *; intros; eapply uniqueness_sum. apply H0. apply H. - exact (projT2 exist_cos0). - assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *; + exact (proj2_sig exist_cos0). + assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos in |- *; pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. Qed. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index 78ef847f..6eec0329 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_fun.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rtrigo_fun.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -15,8 +15,7 @@ Open Local Scope R_scope. (*****************************************************************) (** To define transcendental functions *) -(** for exponential function *) -(* *) +(** and exponential function *) (*****************************************************************) (*********) diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index b105ca69..139563bf 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_reg.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Rtrigo_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -25,16 +25,15 @@ Proof. unfold CVN_R in |- *; intros. cut ((r:R) <> 0). intro hyp_r; unfold CVN_r in |- *. - apply existT with (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)). + exists (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)). cut - (sigT - (fun l:R => + { l:R | Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k))) - n) l)). + n) l }. intro X; elim X; intros. - apply existT with x. + exists x. split. apply p. intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult. @@ -124,7 +123,7 @@ Lemma continuity_cos : continuity cos. Proof. set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)). cut (CVN_R fn). - intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)). + intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }). intro cv; cut (forall n:nat, continuity (fn n)). intro; cut (forall x:R, cos x = SFL fn cv x). intro; cut (continuity (SFL fn cv) -> continuity cos). @@ -144,7 +143,7 @@ Proof. case (cv x); case (exist_cos (Rsqr x)); intros. symmetry in |- *; eapply UL_sequence. apply u. - unfold cos_in in c; unfold infinit_sum in c; unfold Un_cv in |- *; intros. + unfold cos_in in c; unfold infinite_sum in c; unfold Un_cv in |- *; intros. elim (c _ H0); intros N0 H1. exists N0; intros. unfold R_dist in H1; unfold R_dist, SP in |- *. @@ -200,17 +199,16 @@ Lemma CVN_R_sin : CVN_R fn. Proof. unfold CVN_R in |- *; unfold CVN_r in |- *; intros fn H r. - apply existT with (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)). + exists (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)). cut - (sigT - (fun l:R => + { l:R | Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n) - l)). + l }. intro X; elim X; intros. - apply existT with x. + exists x. split. apply p. intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult; @@ -305,7 +303,7 @@ Proof. set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)). cut (CVN_R fn). - intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)). + intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }). intro cv. set (r := mkposreal _ Rlt_0_1). cut (CVN_r fn r). @@ -331,7 +329,7 @@ Proof. unfold Rdiv in |- *; rewrite (Rinv_r_simpl_m h x0 H6). eapply UL_sequence. apply u. - unfold sin_in in s; unfold sin_n, infinit_sum in s; + unfold sin_in in s; unfold sin_n, infinite_sum in s; unfold SP, fn, Un_cv in |- *; intros. elim (s _ H10); intros N0 H11. exists N0; intros. @@ -584,14 +582,14 @@ Qed. Lemma derivable_pt_sin : forall x:R, derivable_pt sin x. Proof. unfold derivable_pt in |- *; intro. - apply existT with (cos x). + exists (cos x). apply derivable_pt_lim_sin. Qed. Lemma derivable_pt_cos : forall x:R, derivable_pt cos x. Proof. unfold derivable_pt in |- *; intro. - apply existT with (- sin x). + exists (- sin x). apply derivable_pt_lim_cos. Qed. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 96351618..56088a2e 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqProp.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: SeqProp.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -15,6 +15,10 @@ Require Import Classical. Require Import Max. Open Local Scope R_scope. +(*****************************************************************) +(** Convergence properties of sequences *) +(*****************************************************************) + Definition Un_decreasing (Un:nat -> R) : Prop := forall n:nat, Un (S n) <= Un n. Definition opp_seq (Un:nat -> R) (n:nat) : R := - Un n. @@ -23,8 +27,7 @@ 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 -> sigT (fun l:R => Un_cv Un l). + 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]]. @@ -64,11 +67,10 @@ Proof. Qed. Lemma decreasing_cv : - forall Un:nat -> R, - Un_decreasing Un -> has_lb Un -> sigT (fun l:R => Un_cv Un l). + forall Un:nat -> R, Un_decreasing Un -> has_lb Un -> { l:R | Un_cv Un l }. Proof. intros. - cut (sigT (fun l:R => Un_cv (opp_seq Un) l) -> sigT (fun l:R => Un_cv Un l)). + cut ({ l:R | Un_cv (opp_seq Un) l } -> { l:R | Un_cv Un l }). intro X. apply X. apply growing_cv. @@ -76,7 +78,7 @@ Proof. exact H0. intro X. elim X; intros. - apply existT with (- x). + exists (- x). unfold Un_cv in p. unfold R_dist in p. unfold opp_seq in p. @@ -91,8 +93,8 @@ Proof. Qed. (***********) -Lemma maj_sup : - forall Un:nat -> R, has_ub Un -> sigT (fun l:R => is_lub (EUn Un) l). +Lemma ub_to_lub : + forall Un:nat -> R, has_ub Un -> { l:R | is_lub (EUn Un) l }. Proof. intros. unfold has_ub in H. @@ -104,9 +106,8 @@ Proof. Qed. (**********) -Lemma min_inf : - forall Un:nat -> R, - has_lb Un -> sigT (fun l:R => is_lub (EUn (opp_seq Un)) l). +Lemma lb_to_glb : + forall Un:nat -> R, has_lb Un -> { l:R | is_lub (EUn (opp_seq Un)) l }. Proof. intros; unfold has_lb in H. apply completeness. @@ -116,15 +117,17 @@ Proof. reflexivity. Qed. -Definition majorant (Un:nat -> R) (pr:has_ub Un) : R := - match maj_sup Un pr with - | existT a b => a - end. +Definition lub (Un:nat -> R) (pr:has_ub Un) : R := + let (a,_) := ub_to_lub Un pr in a. -Definition minorant (Un:nat -> R) (pr:has_lb Un) : R := - match min_inf Un pr with - | existT a b => - a - end. +Definition glb (Un:nat -> R) (pr:has_lb Un) : R := + let (a,_) := lb_to_glb Un pr in - a. + +(* Compatibility with previous unappropriate terminology *) +Notation maj_sup := ub_to_lub (only parsing). +Notation min_inf := lb_to_glb (only parsing). +Notation majorant := lub (only parsing). +Notation minorant := glb (only parsing). Lemma maj_ss : forall (Un:nat -> R) (k:nat), @@ -162,26 +165,30 @@ Proof. exists (k + x1)%nat; assumption. Qed. -Definition sequence_majorant (Un:nat -> R) (pr:has_ub Un) - (i:nat) : R := majorant (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr). +Definition sequence_ub (Un:nat -> R) (pr:has_ub Un) + (i:nat) : R := lub (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr). + +Definition sequence_lb (Un:nat -> R) (pr:has_lb Un) + (i:nat) : R := glb (fun k:nat => Un (i + k)%nat) (min_ss Un i pr). -Definition sequence_minorant (Un:nat -> R) (pr:has_lb Un) - (i:nat) : R := minorant (fun k:nat => Un (i + k)%nat) (min_ss Un i pr). +(* Compatibility *) +Notation sequence_majorant := sequence_ub (only parsing). +Notation sequence_minorant := sequence_lb (only parsing). Lemma Wn_decreasing : - forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_majorant Un pr). + forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr). Proof. intros. unfold Un_decreasing in |- *. intro. - unfold sequence_majorant in |- *. - assert (H := maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). - assert (H0 := maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). + unfold sequence_ub in |- *. + assert (H := ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). + assert (H0 := ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). elim H; intros. elim H0; intros. - cut (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x); + cut (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x); [ intro Maj1; rewrite Maj1 | idtac ]. - cut (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0); + cut (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0); [ intro Maj2; rewrite Maj2 | idtac ]. unfold is_lub in p. unfold is_lub in p0. @@ -199,47 +206,47 @@ Proof. replace (S n) with (1 + n)%nat; [ ring | ring ]. cut (is_lub (EUn (fun k:nat => Un (n + k)%nat)) - (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))). + (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))). intro. unfold is_lub in p0; unfold is_lub in H1. elim p0; intros; elim H1; intros. assert (H6 := H5 x0 H2). assert - (H7 := H3 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4). + (H7 := H3 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4). apply Rle_antisym; assumption. - unfold majorant in |- *. - case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). + unfold lub in |- *. + case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)). trivial. cut (is_lub (EUn (fun k:nat => Un (S n + k)%nat)) - (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))). + (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))). intro. unfold is_lub in p; unfold is_lub in H1. elim p; intros; elim H1; intros. assert (H6 := H5 x H2). assert (H7 := - H3 (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4). + H3 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4). apply Rle_antisym; assumption. - unfold majorant in |- *. - case (maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). + unfold lub in |- *. + case (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)). trivial. Qed. Lemma Vn_growing : - forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_minorant Un pr). + forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_lb Un pr). Proof. intros. unfold Un_growing in |- *. intro. - unfold sequence_minorant in |- *. - assert (H := min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)). - assert (H0 := min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)). + unfold sequence_lb in |- *. + assert (H := lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)). + assert (H0 := lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)). elim H; intros. elim H0; intros. - cut (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x); + cut (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x); [ intro Maj1; rewrite Maj1 | idtac ]. - cut (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0); + cut (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0); [ intro Maj2; rewrite Maj2 | idtac ]. unfold is_lub in p. unfold is_lub in p0. @@ -260,38 +267,38 @@ Proof. replace (S n) with (1 + n)%nat; [ ring | ring ]. cut (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat))) - (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))). + (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))). intro. unfold is_lub in p0; unfold is_lub in H1. elim p0; intros; elim H1; intros. assert (H6 := H5 x0 H2). assert - (H7 := H3 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4). + (H7 := H3 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4). rewrite <- - (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))) + (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))) . apply Ropp_eq_compat; apply Rle_antisym; assumption. - unfold minorant in |- *. - case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)). + unfold glb in |- *. + case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)); simpl. intro; rewrite Ropp_involutive. trivial. cut (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat))) - (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))). + (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))). intro. unfold is_lub in p; unfold is_lub in H1. elim p; intros; elim H1; intros. assert (H6 := H5 x H2). assert (H7 := - H3 (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4). + H3 (- glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4). rewrite <- (Ropp_involutive - (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))) + (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))) . apply Ropp_eq_compat; apply Rle_antisym; assumption. - unfold minorant in |- *. - case (min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)). + unfold glb in |- *. + case (lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)); simpl. intro; rewrite Ropp_involutive. trivial. Qed. @@ -299,16 +306,15 @@ Qed. (**********) Lemma Vn_Un_Wn_order : forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un) - (n:nat), sequence_minorant Un pr2 n <= Un n <= sequence_majorant Un pr1 n. + (n:nat), sequence_lb Un pr2 n <= Un n <= sequence_ub Un pr1 n. Proof. intros. split. - unfold sequence_minorant in |- *. - cut - (sigT (fun l:R => is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l)). + unfold sequence_lb in |- *. + cut { l:R | is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l }. intro X. elim X; intros. - replace (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x). + replace (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x). unfold is_lub in p. elim p; intros. unfold is_upper_bound in H. @@ -320,28 +326,28 @@ Proof. replace (n + 0)%nat with n; [ reflexivity | ring ]. cut (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat))) - (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))). + (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))). intro. unfold is_lub in p; unfold is_lub in H. elim p; intros; elim H; intros. assert (H4 := H3 x H0). assert - (H5 := H1 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2). + (H5 := H1 (- glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2). rewrite <- - (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))) + (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))) . apply Ropp_eq_compat; apply Rle_antisym; assumption. - unfold minorant in |- *. - case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)). + unfold glb in |- *. + case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)); simpl. intro; rewrite Ropp_involutive. trivial. - apply min_inf. + apply lb_to_glb. apply min_ss; assumption. - unfold sequence_majorant in |- *. - cut (sigT (fun l:R => is_lub (EUn (fun i:nat => Un (n + i)%nat)) l)). + unfold sequence_ub in |- *. + cut { l:R | is_lub (EUn (fun i:nat => Un (n + i)%nat)) l }. intro X. elim X; intros. - replace (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x. + replace (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x. unfold is_lub in p. elim p; intros. unfold is_upper_bound in H. @@ -350,24 +356,24 @@ Proof. replace (n + 0)%nat with n; [ reflexivity | ring ]. cut (is_lub (EUn (fun k:nat => Un (n + k)%nat)) - (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))). + (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))). intro. unfold is_lub in p; unfold is_lub in H. elim p; intros; elim H; intros. assert (H4 := H3 x H0). assert - (H5 := H1 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2). + (H5 := H1 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2). apply Rle_antisym; assumption. - unfold majorant in |- *. - case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)). + unfold lub in |- *. + case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)). intro; trivial. - apply maj_sup. + apply ub_to_lub. apply maj_ss; assumption. Qed. Lemma min_maj : forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un), - has_ub (sequence_minorant Un pr2). + has_ub (sequence_lb Un pr2). Proof. intros. assert (H := Vn_Un_Wn_order Un pr1 pr2). @@ -390,7 +396,7 @@ Qed. Lemma maj_min : forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un), - has_lb (sequence_majorant Un pr1). + has_lb (sequence_ub Un pr1). Proof. intros. assert (H := Vn_Un_Wn_order Un pr1 pr2). @@ -451,7 +457,7 @@ Qed. (**********) Lemma maj_cv : forall (Un:nat -> R) (pr:Cauchy_crit Un), - sigT (fun l:R => Un_cv (sequence_majorant Un (cauchy_maj Un pr)) l). + { l:R | Un_cv (sequence_ub Un (cauchy_maj Un pr)) l }. Proof. intros. apply decreasing_cv. @@ -464,7 +470,7 @@ Qed. (**********) Lemma min_cv : forall (Un:nat -> R) (pr:Cauchy_crit Un), - sigT (fun l:R => Un_cv (sequence_minorant Un (cauchy_min Un pr)) l). + { l:R | Un_cv (sequence_lb Un (cauchy_min Un pr)) l }. Proof. intros. apply growing_cv. @@ -510,40 +516,40 @@ Qed. (**********) Lemma approx_maj : forall (Un:nat -> R) (pr:has_ub Un) (eps:R), - 0 < eps -> exists k : nat, Rabs (majorant Un pr - Un k) < eps. + 0 < eps -> exists k : nat, Rabs (lub Un pr - Un k) < eps. Proof. intros. - set (P := fun k:nat => Rabs (majorant Un pr - Un k) < eps). + 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 (majorant Un pr - Un k) < eps). + 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 (majorant Un pr - Un n) >= eps). + cut (forall n:nat, Rabs (lub Un pr - Un n) >= eps). intro. - cut (is_lub (EUn Un) (majorant Un pr)). + 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 <= majorant Un pr - Un n). + cut (forall n:nat, eps <= lub Un pr - Un n). intro. - cut (forall n:nat, Un n <= majorant Un pr - eps). + cut (forall n:nat, Un n <= lub Un pr - eps). intro. - cut (forall x:R, EUn Un x -> x <= majorant Un pr - eps). + cut (forall x:R, EUn Un x -> x <= lub Un pr - eps). intro. - assert (H9 := H5 (majorant Un pr - eps) H8). + 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 (majorant Un pr - eps). + apply Rplus_le_reg_l with (lub Un pr - eps). rewrite Rplus_0_r. - replace (majorant Un pr - eps + eps) with (majorant Un pr); + replace (lub Un pr - eps + eps) with (lub Un pr); [ assumption | ring ]. intros. unfold EUn in H8. @@ -553,7 +559,7 @@ Proof. 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 + (majorant Un pr - eps)) with (majorant Un pr - Un n). + replace (eps - Un n + (lub Un pr - eps)) with (lub Un pr - Un n). assumption. ring. ring. @@ -565,11 +571,11 @@ Proof. apply Rle_ge. apply Rplus_le_reg_l with (Un n). rewrite Rplus_0_r; - replace (Un n + (majorant Un pr - Un n)) with (majorant Un pr); + replace (Un n + (lub Un pr - Un n)) with (lub Un pr); [ apply H4 | ring ]. exists n; reflexivity. - unfold majorant in |- *. - case (maj_sup Un pr). + unfold lub in |- *. + case (ub_to_lub Un pr). trivial. intro. assert (H2 := H1 n). @@ -579,40 +585,40 @@ Qed. (**********) Lemma approx_min : forall (Un:nat -> R) (pr:has_lb Un) (eps:R), - 0 < eps -> exists k : nat, Rabs (minorant Un pr - Un k) < eps. + 0 < eps -> exists k : nat, Rabs (glb Un pr - Un k) < eps. Proof. intros. - set (P := fun k:nat => Rabs (minorant Un pr - Un k) < eps). + 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 (minorant Un pr - Un k) < eps). + 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 (minorant Un pr - Un n) >= eps). + cut (forall n:nat, Rabs (glb Un pr - Un n) >= eps). intro. - cut (is_lub (EUn (opp_seq Un)) (- minorant Un pr)). + 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 - minorant Un pr). + cut (forall n:nat, eps <= Un n - glb Un pr). intro. - cut (forall n:nat, opp_seq Un n <= - minorant Un pr - eps). + cut (forall n:nat, opp_seq Un n <= - glb Un pr - eps). intro. - cut (forall x:R, EUn (opp_seq Un) x -> x <= - minorant Un pr - eps). + cut (forall x:R, EUn (opp_seq Un) x -> x <= - glb Un pr - eps). intro. - assert (H9 := H5 (- minorant Un pr - eps) H8). + 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 (- minorant Un pr - eps). + apply Rplus_le_reg_l with (- glb Un pr - eps). rewrite Rplus_0_r. - replace (- minorant Un pr - eps + eps) with (- minorant Un pr); + replace (- glb Un pr - eps + eps) with (- glb Un pr); [ assumption | ring ]. intros. unfold EUn in H8. @@ -623,7 +629,7 @@ Proof. 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 + (- minorant Un pr - eps)) with (Un n - minorant Un pr). + replace (eps + Un n + (- glb Un pr - eps)) with (Un n - glb Un pr). assumption. ring. ring. @@ -631,16 +637,16 @@ Proof. assert (H6 := H2 n). rewrite Rabs_left1 in H6. apply Rge_le. - replace (Un n - minorant Un pr) with (- (minorant Un pr - Un n)); + replace (Un n - glb Un pr) with (- (glb Un pr - Un n)); [ assumption | ring ]. - apply Rplus_le_reg_l with (- minorant Un pr). + apply Rplus_le_reg_l with (- glb Un pr). rewrite Rplus_0_r; - replace (- minorant Un pr + (minorant Un pr - Un n)) with (- Un n). + replace (- glb Un pr + (glb Un pr - Un n)) with (- Un n). apply H4. exists n; reflexivity. ring. - unfold minorant in |- *. - case (min_inf Un pr). + unfold glb in |- *. + case (lb_to_glb Un pr); simpl. intro. rewrite Ropp_involutive. trivial. @@ -711,7 +717,7 @@ Qed. (**********) Lemma CV_Cauchy : - forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un. + forall Un:nat -> R, { l:R | Un_cv Un l } -> Cauchy_crit Un. Proof. intros Un X; elim X; intros. unfold Cauchy_crit in |- *; intros. @@ -734,11 +740,11 @@ Qed. (**********) Lemma maj_by_pos : forall Un:nat -> R, - sigT (fun l:R => Un_cv Un l) -> + { l:R | Un_cv Un l } -> exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). Proof. intros Un X; elim X; intros. - cut (sigT (fun l:R => Un_cv (fun k:nat => Rabs (Un k)) l)). + cut { l:R | Un_cv (fun k:nat => Rabs (Un k)) l }. intro X0. assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0). assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H). @@ -760,7 +766,7 @@ Proof. unfold is_upper_bound in H1. apply H1. exists 0%nat; reflexivity. - apply existT with (Rabs x). + exists (Rabs x). apply cv_cvabs; assumption. Qed. @@ -770,7 +776,7 @@ Lemma CV_mult : Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). Proof. intros. - cut (sigT (fun l:R => Un_cv An l)). + cut { l:R | Un_cv An l }. intro X. assert (H1 := maj_by_pos An X). elim H1; intros M H2. @@ -881,7 +887,7 @@ Proof. [ assumption | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ]. - apply existT with l1; assumption. + exists l1; assumption. Qed. Lemma tech9 : diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index bc17cd43..9680b75e 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SeqSeries.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: SeqSeries.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -33,15 +33,9 @@ Lemma sum_maj1 : Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N. Proof. intros; - cut - (sigT - (fun l:R => - Un_cv (fun n:nat => sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) l)). + cut { l:R | Un_cv (fun n => sum_f_R0 (fun l => fn (S N + l)%nat x) n) l }. intro X; - cut - (sigT - (fun l:R => - Un_cv (fun n:nat => sum_f_R0 (fun l:nat => An (S N + l)%nat) n) l)). + cut { l:R | Un_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l }. intro X0; elim X; intros l1N H2. elim X0; intros l2N H3. cut (l1 - SP fn N x = l1N). @@ -131,7 +125,7 @@ Proof. apply le_lt_n_Sm. apply le_plus_l. apply le_O_n. - apply existT with (l2 - sum_f_R0 An N). + exists (l2 - sum_f_R0 An N). unfold Un_cv in H0; unfold Un_cv in |- *; intros. elim (H0 eps H2); intros N0 H3. unfold R_dist in H3; exists N0; intros. @@ -167,7 +161,7 @@ Proof. apply le_lt_n_Sm. apply le_plus_l. apply le_O_n. - apply existT with (l1 - SP fn N x). + exists (l1 - SP fn N x). unfold Un_cv in H; unfold Un_cv in |- *; intros. elim (H eps H2); intros N0 H3. unfold R_dist in H3; exists N0; intros. @@ -216,8 +210,8 @@ Qed. Lemma Rseries_CV_comp : forall An Bn:nat -> R, (forall n:nat, 0 <= An n <= Bn n) -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 Bn N) l) -> - sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l). + { l:R | Un_cv (fun N:nat => sum_f_R0 Bn N) l } -> + { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }. Proof. intros An Bn H X; apply cv_cauchy_2. assert (H0 := cv_cauchy_1 _ X). diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index ff0a72e8..13be46da 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sqrt_reg.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Sqrt_reg.v 10710 2008-03-23 09:24:09Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import R_sqrt. Open Local Scope R_scope. +Require Import R_sqrt. +Open Local Scope R_scope. (**********) Lemma sqrt_var_maj : @@ -309,7 +310,7 @@ Qed. Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x. Proof. unfold derivable_pt in |- *; intros. - apply existT with (/ (2 * sqrt x)). + exists (/ (2 * sqrt x)). apply derivable_pt_lim_sqrt; assumption. Qed. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 7e202359..0638ca8f 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Operators_Properties.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Operators_Properties.v 9598 2007-02-06 19:45:52Z herbelin $ i*) (****************************************************************************) (* Bruno Barras *) diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 4c5a6519..87cd1e6f 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Operators.v 9610 2007-02-07 14:45:18Z herbelin $ i*) +(*i $Id: Relation_Operators.v 10681 2008-03-16 13:40:45Z msozeau $ i*) (****************************************************************************) (* Bruno Barras, Cristina Cornes *) @@ -83,9 +83,9 @@ Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Inductive le_AsB : A + B -> A + B -> Prop := - | le_aa : forall x y:A, leA x y -> le_AsB (inl B x) (inl B y) - | le_ab : forall (x:A) (y:B), le_AsB (inl B x) (inr A y) - | le_bb : forall x y:B, leB x y -> le_AsB (inr A x) (inr A y). + | le_aa : forall x y:A, leA x y -> le_AsB (inl _ x) (inl _ y) + | le_ab : forall (x:A) (y:B), le_AsB (inl _ x) (inr _ y) + | le_bb : forall x y:B, leB x y -> le_AsB (inr _ x) (inr _ y). End Disjoint_Union. diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 9da30e9b..6368ae25 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relations.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Relations.v 9598 2007-02-06 19:45:52Z herbelin $ i*) Require Export Relation_Definitions. Require Export Relation_Operators. diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v index 91d2aaa4..82668006 100644 --- a/theories/Relations/Rstar.v +++ b/theories/Relations/Rstar.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rstar.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Rstar.v 9642 2007-02-12 10:31:53Z herbelin $ i*) (** Properties of a binary relation [R] on type [A] *) @@ -87,7 +87,7 @@ Section Rstar. (** Property of Commutativity of two relations *) - Definition commut (A:Set) (R1 R2:A -> A -> Prop) := + Definition commut (A:Type) (R1 R2:A -> A -> Prop) := forall x y:A, R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & R1 z y'. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 84af7d5d..d6975e91 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -1,4 +1,3 @@ - (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -7,673 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v 9245 2006-10-17 12:53:34Z notin $: i*) - -Require Export Relation_Definitions. - -Set Implicit Arguments. - -(** * Definitions of [Relation_Class] and n-ary [Morphism_Theory] *) - -(* X will be used to distinguish covariant arguments whose type is an *) -(* Asymmetric* relation from contravariant arguments of the same type *) -Inductive X_Relation_Class (X: Type) : Type := - SymmetricReflexive : - forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> X_Relation_Class X - | AsymmetricReflexive : X -> forall A Aeq, reflexive A Aeq -> X_Relation_Class X - | SymmetricAreflexive : forall A Aeq, symmetric A Aeq -> X_Relation_Class X - | AsymmetricAreflexive : X -> forall A (Aeq : relation A), X_Relation_Class X - | Leibniz : Type -> X_Relation_Class X. - -Inductive variance : Set := - Covariant - | Contravariant. - -Definition Argument_Class := X_Relation_Class variance. -Definition Relation_Class := X_Relation_Class unit. - -Inductive Reflexive_Relation_Class : Type := - RSymmetric : - forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> Reflexive_Relation_Class - | RAsymmetric : - forall A Aeq, reflexive A Aeq -> Reflexive_Relation_Class - | RLeibniz : Type -> Reflexive_Relation_Class. - -Inductive Areflexive_Relation_Class : Type := - | ASymmetric : forall A Aeq, symmetric A Aeq -> Areflexive_Relation_Class - | AAsymmetric : forall A (Aeq : relation A), Areflexive_Relation_Class. - -Implicit Type Hole Out: Relation_Class. - -Definition relation_class_of_argument_class : Argument_Class -> Relation_Class. - destruct 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). - exact (Leibniz _ T). -Defined. - -Definition carrier_of_relation_class : forall X, X_Relation_Class X -> Type. - destruct 1. - exact A. - exact A. - exact A. - exact A. - exact T. -Defined. - -Definition relation_of_relation_class : - forall X R, @carrier_of_relation_class X R -> carrier_of_relation_class R -> Prop. - destruct R. - exact Aeq. - exact Aeq. - exact Aeq. - exact Aeq. - exact (@eq T). -Defined. - -Lemma about_carrier_of_relation_class_and_relation_class_of_argument_class : - forall R, - carrier_of_relation_class (relation_class_of_argument_class R) = - carrier_of_relation_class R. - destruct R; reflexivity. -Defined. - -Inductive nelistT (A : Type) : Type := - singl : A -> nelistT A - | necons : A -> nelistT A -> nelistT A. - -Definition Arguments := nelistT Argument_Class. - -Implicit Type In: Arguments. - -Definition function_type_of_morphism_signature : - Arguments -> Relation_Class -> Type. - intros In Out. - induction In. - exact (carrier_of_relation_class a -> carrier_of_relation_class Out). - exact (carrier_of_relation_class a -> IHIn). -Defined. - -Definition make_compatibility_goal_aux: - forall In Out - (f g: function_type_of_morphism_signature In Out), Prop. - intros; induction In; simpl in f, g. - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x, relation_of_relation_class Out (f x) (g x)). - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x, IHIn (f x) (g x)). -Defined. - -Definition make_compatibility_goal := - (fun In Out f => make_compatibility_goal_aux In Out f f). - -Record Morphism_Theory In Out : Type := - { Function : function_type_of_morphism_signature In Out; - Compat : make_compatibility_goal In Out Function }. - -(** The [iff] relation class *) - -Definition Iff_Relation_Class : Relation_Class. - eapply (@SymmetricReflexive unit _ iff). - exact iff_sym. - exact iff_refl. -Defined. - -(** The [impl] relation class *) - -Definition impl (A B: Prop) := A -> B. - -Theorem impl_refl: reflexive _ impl. -Proof. - hnf; unfold impl; tauto. -Qed. - -Definition Impl_Relation_Class : Relation_Class. - eapply (@AsymmetricReflexive unit tt _ impl). - exact impl_refl. -Defined. - -(** Every function is a morphism from Leibniz+ to Leibniz *) - -Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments. - induction 1. - exact (singl (Leibniz _ a)). - exact (necons (Leibniz _ a) IHX). -Defined. - -Definition morphism_theory_of_function : - forall (In: nelistT Type) (Out: Type), - let In' := list_of_Leibniz_of_list_of_types In in - let Out' := Leibniz _ Out in - function_type_of_morphism_signature In' Out' -> - Morphism_Theory In' Out'. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - reflexivity. - intro; apply (IHIn (X x)). -Defined. - -(** Every predicate is a morphism from Leibniz+ to Iff_Relation_Class *) - -Definition morphism_theory_of_predicate : - forall (In: nelistT Type), - let In' := list_of_Leibniz_of_list_of_types In in - function_type_of_morphism_signature In' Iff_Relation_Class -> - Morphism_Theory In' Iff_Relation_Class. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - intro; apply iff_refl. - intro; apply (IHIn (X x)). -Defined. - -(** * Utility functions to prove that every transitive relation is a morphism *) - -Definition equality_morphism_of_symmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(sym: symmetric _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass := SymmetricAreflexive _ sym in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_symmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(sym: symmetric _ Aeq) - (trans: transitive _ Aeq), let ASetoidClass := SymmetricReflexive _ sym refl in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricAreflexive Contravariant Aeq in - let ASetoidClass2 := AsymmetricAreflexive Covariant Aeq in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricReflexive Contravariant refl in - let ASetoidClass2 := AsymmetricReflexive Covariant refl in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -(** * A few examples on [iff] *) - -(** [iff] as a relation *) - -Add Relation Prop iff - reflexivity proved by iff_refl - symmetry proved by iff_sym - transitivity proved by iff_trans -as iff_relation. - -(** [impl] as a relation *) - -Theorem impl_trans: transitive _ impl. -Proof. - hnf; unfold impl; tauto. -Qed. - -Add Relation Prop impl - reflexivity proved by impl_refl - transitivity proved by impl_trans -as impl_relation. - -(** [impl] is a morphism *) - -Add Morphism impl with signature iff ==> iff ==> iff as Impl_Morphism. -Proof. - unfold impl; tauto. -Qed. - -(** [and] is a morphism *) - -Add Morphism and with signature iff ==> iff ==> iff as And_Morphism. - tauto. -Qed. - -(** [or] is a morphism *) - -Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism. -Proof. - tauto. -Qed. - -(** [not] is a morphism *) - -Add Morphism not with signature iff ==> iff as Not_Morphism. -Proof. - tauto. -Qed. - -(** The same examples on [impl] *) - -Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism not with signature impl --> impl as Not_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -(** * The CIC part of the reflexive tactic ([setoid_rewrite]) *) - -Inductive rewrite_direction : Type := - | Left2Right - | Right2Left. - -Implicit Type dir: rewrite_direction. - -Definition variance_of_argument_class : Argument_Class -> option variance. - destruct 1. - exact None. - exact (Some v). - exact None. - exact (Some v). - exact None. -Defined. - -Definition opposite_direction := - fun dir => - match dir with - | Left2Right => Right2Left - | Right2Left => Left2Right - end. - -Lemma opposite_direction_idempotent: - forall dir, (opposite_direction (opposite_direction dir)) = dir. -Proof. - destruct dir; reflexivity. -Qed. - -Inductive check_if_variance_is_respected : - option variance -> rewrite_direction -> rewrite_direction -> Prop := - | MSNone : forall dir dir', check_if_variance_is_respected None dir dir' - | MSCovariant : forall dir, check_if_variance_is_respected (Some Covariant) dir dir - | MSContravariant : - forall dir, - check_if_variance_is_respected (Some Contravariant) dir (opposite_direction dir). - -Definition relation_class_of_reflexive_relation_class: - Reflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (Leibniz _ T). -Defined. - -Definition relation_class_of_areflexive_relation_class: - Areflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). -Defined. - -Definition carrier_of_reflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_reflexive_relation_class R). - -Definition carrier_of_areflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_areflexive_relation_class R). - -Definition relation_of_areflexive_relation_class := - fun R => relation_of_relation_class (relation_class_of_areflexive_relation_class R). - -Inductive Morphism_Context Hole dir : Relation_Class -> rewrite_direction -> Type := - | App : - forall In Out dir', - Morphism_Theory In Out -> Morphism_Context_List Hole dir dir' In -> - Morphism_Context Hole dir Out dir' - | ToReplace : Morphism_Context Hole dir Hole dir - | ToKeep : - forall S dir', - carrier_of_reflexive_relation_class S -> - Morphism_Context Hole dir (relation_class_of_reflexive_relation_class S) dir' - | ProperElementToKeep : - forall S dir' (x: carrier_of_areflexive_relation_class S), - relation_of_areflexive_relation_class S x x -> - Morphism_Context Hole dir (relation_class_of_areflexive_relation_class S) dir' -with Morphism_Context_List Hole dir : - rewrite_direction -> Arguments -> Type -:= - fcl_singl : - forall S dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' (singl S) - | fcl_cons : - forall S L dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' L -> - Morphism_Context_List Hole dir dir'' (necons S L). - -Scheme Morphism_Context_rect2 := Induction for Morphism_Context Sort Type -with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Type. - -Definition product_of_arguments : Arguments -> Type. - induction 1. - exact (carrier_of_relation_class a). - exact (prod (carrier_of_relation_class a) IHX). -Defined. - -Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction. - intros dir R. - destruct (variance_of_argument_class R). - destruct v. - exact dir. (* covariant *) - exact (opposite_direction dir). (* contravariant *) - exact dir. (* symmetric relation *) -Defined. - -Definition directed_relation_of_relation_class: - forall dir (R: Relation_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - destruct 1. - exact (@relation_of_relation_class unit). - intros; exact (relation_of_relation_class _ X0 X). -Defined. - -Definition directed_relation_of_argument_class: - forall dir (R: Argument_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - intros dir R. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class R). - exact (directed_relation_of_relation_class dir (relation_class_of_argument_class R)). -Defined. - - -Definition relation_of_product_of_arguments: - forall dir In, - product_of_arguments In -> product_of_arguments In -> Prop. - induction In. - simpl. - exact (directed_relation_of_argument_class (get_rewrite_direction dir a) a). - - simpl; intros. - destruct X; destruct X0. - apply and. - exact - (directed_relation_of_argument_class (get_rewrite_direction dir a) a c c0). - exact (IHIn p p0). -Defined. - -Definition apply_morphism: - forall In Out (m: function_type_of_morphism_signature In Out) - (args: product_of_arguments In), carrier_of_relation_class Out. - intros. - induction In. - exact (m args). - simpl in m, args. - destruct args. - exact (IHIn (m c) p). -Defined. - -Theorem apply_morphism_compatibility_Right2Left: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Right2Left _ args1 args2 -> - directed_relation_of_relation_class Right2Left _ - (apply_morphism _ _ m2 args1) - (apply_morphism _ _ m1 args2). - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Theorem apply_morphism_compatibility_Left2Right: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Left2Right _ args1 args2 -> - directed_relation_of_relation_class Left2Right _ - (apply_morphism _ _ m1 args1) - (apply_morphism _ _ m2 args2). -Proof. - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - destruct v; simpl in H, H0; apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Definition interp : - forall Hole dir Out dir', carrier_of_relation_class Hole -> - Morphism_Context Hole dir Out dir' -> carrier_of_relation_class Out. - intros Hole dir Out dir' H t. - elim t using - (@Morphism_Context_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -(* CSC: interp and interp_relation_class_list should be mutually defined, since - the proof term of each one contains the proof term of the other one. However - I cannot do that interactively (I should write the Fix by hand) *) -Definition interp_relation_class_list : - forall Hole dir dir' (L: Arguments), carrier_of_relation_class Hole -> - Morphism_Context_List Hole dir dir' L -> product_of_arguments L. - intros Hole dir dir' L H t. - elim t using - (@Morphism_Context_List_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -Theorem setoid_rewrite: - forall Hole dir Out dir' (E1 E2: carrier_of_relation_class Hole) - (E: Morphism_Context Hole dir Out dir'), - (directed_relation_of_relation_class dir Hole E1 E2) -> - (directed_relation_of_relation_class dir' Out (interp E1 E) (interp E2 E)). -Proof. - intros. - elim E using - (@Morphism_Context_rect2 Hole dir - (fun S dir'' E => directed_relation_of_relation_class dir'' S (interp E1 E) (interp E2 E)) - (fun dir'' L fcl => - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 fcl) - (interp_relation_class_list E2 fcl))); intros. - change (directed_relation_of_relation_class dir'0 Out0 - (apply_morphism _ _ (Function m) (interp_relation_class_list E1 m0)) - (apply_morphism _ _ (Function m) (interp_relation_class_list E2 m0))). - destruct dir'0. - apply apply_morphism_compatibility_Left2Right. - exact (Compat m). - exact H0. - apply apply_morphism_compatibility_Right2Left. - exact (Compat m). - exact H0. - - exact H. - - unfold interp, Morphism_Context_rect2. - (* CSC: reflexivity used here *) - destruct S; destruct dir'0; simpl; (apply r || reflexivity). - - destruct dir'0; exact r. - - destruct S; unfold directed_relation_of_argument_class; simpl in H0 |- *; - unfold get_rewrite_direction; simpl. - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; (exact H0 || hnf; symmetry; exact H0). - - change - (directed_relation_of_argument_class (get_rewrite_direction dir'' S) S - (eq_rect _ (fun T : Type => T) (interp E1 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) - (eq_rect _ (fun T : Type => T) (interp E2 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) /\ - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 m0) (interp_relation_class_list E2 m0)). - split. - clear m0 H1; destruct S; simpl in H0 |- *; unfold get_rewrite_direction; simpl. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; symmetry; exact H0). - exact H1. - Qed. - -(** * Miscelenous *) - -(** For backwark compatibility *) +(*i $Id: Setoid.v 10765 2008-04-08 16:15:23Z msozeau $: i*) -Record Setoid_Theory (A: Type) (Aeq: relation A) : Prop := - { Seq_refl : forall x:A, Aeq x x; - Seq_sym : forall x y:A, Aeq x y -> Aeq y x; - Seq_trans : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z }. +Require Export Coq.Classes.SetoidTactics. -Implicit Arguments Setoid_Theory []. -Implicit Arguments Seq_refl []. -Implicit Arguments Seq_sym []. -Implicit Arguments Seq_trans []. +(** For backward compatibility *) +Definition Setoid_Theory := @Equivalence. +Definition Build_Setoid_Theory := @Build_Equivalence. +Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x := + Eval compute in reflexivity. +Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x := + Eval compute in symmetry. +Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z := + Eval compute in transitivity. (** Some tactics for manipulating Setoid Theory not officially declared as Setoid. *) diff --git a/theories/Setoids/Setoid_Prop.v b/theories/Setoids/Setoid_Prop.v new file mode 100644 index 00000000..7300937e --- /dev/null +++ b/theories/Setoids/Setoid_Prop.v @@ -0,0 +1,79 @@ + +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Setoid_Prop.v 10739 2008-04-01 14:45:20Z herbelin $: i*) + +Require Import Setoid_tac. + +(** * A few examples on [iff] *) + +(** [iff] as a relation *) + +Add Relation Prop iff + reflexivity proved by iff_refl + symmetry proved by iff_sym + transitivity proved by iff_trans +as iff_relation. + +(** [impl] as a relation *) + +Theorem impl_trans: transitive _ impl. +Proof. + hnf; unfold impl; tauto. +Qed. + +Add Relation Prop impl + reflexivity proved by impl_refl + transitivity proved by impl_trans +as impl_relation. + +(** [impl] is a morphism *) + +Add Morphism impl with signature iff ==> iff ==> iff as Impl_Morphism. +Proof. + unfold impl; tauto. +Qed. + +(** [and] is a morphism *) + +Add Morphism and with signature iff ==> iff ==> iff as And_Morphism. + tauto. +Qed. + +(** [or] is a morphism *) + +Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism. +Proof. + tauto. +Qed. + +(** [not] is a morphism *) + +Add Morphism not with signature iff ==> iff as Not_Morphism. +Proof. + tauto. +Qed. + +(** The same examples on [impl] *) + +Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2. +Proof. + unfold impl; tauto. +Qed. + +Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2. +Proof. + unfold impl; tauto. +Qed. + +Add Morphism not with signature impl --> impl as Not_Morphism2. +Proof. + unfold impl; tauto. +Qed. + diff --git a/theories/Setoids/Setoid_tac.v b/theories/Setoids/Setoid_tac.v new file mode 100644 index 00000000..cdc4eafe --- /dev/null +++ b/theories/Setoids/Setoid_tac.v @@ -0,0 +1,595 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Setoid_tac.v 10739 2008-04-01 14:45:20Z herbelin $ i*) + +Require Export Relation_Definitions. + +Set Implicit Arguments. + +(** * Definitions of [Relation_Class] and n-ary [Morphism_Theory] *) + +(* X will be used to distinguish covariant arguments whose type is an *) +(* Asymmetric* relation from contravariant arguments of the same type *) +Inductive X_Relation_Class (X: Type) : Type := + SymmetricReflexive : + forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> X_Relation_Class X + | AsymmetricReflexive : X -> forall A Aeq, reflexive A Aeq -> X_Relation_Class X + | SymmetricAreflexive : forall A Aeq, symmetric A Aeq -> X_Relation_Class X + | AsymmetricAreflexive : X -> forall A (Aeq : relation A), X_Relation_Class X + | Leibniz : Type -> X_Relation_Class X. + +Inductive variance : Set := + Covariant + | Contravariant. + +Definition Argument_Class := X_Relation_Class variance. +Definition Relation_Class := X_Relation_Class unit. + +Inductive Reflexive_Relation_Class : Type := + RSymmetric : + forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> Reflexive_Relation_Class + | RAsymmetric : + forall A Aeq, reflexive A Aeq -> Reflexive_Relation_Class + | RLeibniz : Type -> Reflexive_Relation_Class. + +Inductive Areflexive_Relation_Class : Type := + | ASymmetric : forall A Aeq, symmetric A Aeq -> Areflexive_Relation_Class + | AAsymmetric : forall A (Aeq : relation A), Areflexive_Relation_Class. + +Implicit Type Hole Out: Relation_Class. + +Definition relation_class_of_argument_class : Argument_Class -> Relation_Class. + destruct 1. + exact (SymmetricReflexive _ s r). + exact (AsymmetricReflexive tt r). + exact (SymmetricAreflexive _ s). + exact (AsymmetricAreflexive tt Aeq). + exact (Leibniz _ T). +Defined. + +Definition carrier_of_relation_class : forall X, X_Relation_Class X -> Type. + destruct 1. + exact A. + exact A. + exact A. + exact A. + exact T. +Defined. + +Definition relation_of_relation_class : + forall X R, @carrier_of_relation_class X R -> carrier_of_relation_class R -> Prop. + destruct R. + exact Aeq. + exact Aeq. + exact Aeq. + exact Aeq. + exact (@eq T). +Defined. + +Lemma about_carrier_of_relation_class_and_relation_class_of_argument_class : + forall R, + carrier_of_relation_class (relation_class_of_argument_class R) = + carrier_of_relation_class R. + destruct R; reflexivity. +Defined. + +Inductive nelistT (A : Type) : Type := + singl : A -> nelistT A + | necons : A -> nelistT A -> nelistT A. + +Definition Arguments := nelistT Argument_Class. + +Implicit Type In: Arguments. + +Definition function_type_of_morphism_signature : + Arguments -> Relation_Class -> Type. + intros In Out. + induction In. + exact (carrier_of_relation_class a -> carrier_of_relation_class Out). + exact (carrier_of_relation_class a -> IHIn). +Defined. + +Definition make_compatibility_goal_aux: + forall In Out + (f g: function_type_of_morphism_signature In Out), Prop. + intros; induction In; simpl in f, g. + induction a; simpl in f, g. + exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). + destruct x. + exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). + exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). + exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). + destruct x. + exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). + exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). + exact (forall x, relation_of_relation_class Out (f x) (g x)). + induction a; simpl in f, g. + exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). + destruct x. + exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). + exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). + exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). + destruct x. + exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). + exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). + exact (forall x, IHIn (f x) (g x)). +Defined. + +Definition make_compatibility_goal := + (fun In Out f => make_compatibility_goal_aux In Out f f). + +Record Morphism_Theory In Out : Type := + { Function : function_type_of_morphism_signature In Out; + Compat : make_compatibility_goal In Out Function }. + + +(** The [iff] relation class *) + +Definition Iff_Relation_Class : Relation_Class. + eapply (@SymmetricReflexive unit _ iff). + exact iff_sym. + exact iff_refl. +Defined. + +(** The [impl] relation class *) + +Definition impl (A B: Prop) := A -> B. + +Theorem impl_refl: reflexive _ impl. +Proof. + hnf; unfold impl; tauto. +Qed. + +Definition Impl_Relation_Class : Relation_Class. + eapply (@AsymmetricReflexive unit tt _ impl). + exact impl_refl. +Defined. + +(** Every function is a morphism from Leibniz+ to Leibniz *) + +Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments. + induction 1. + exact (singl (Leibniz _ a)). + exact (necons (Leibniz _ a) IHX). +Defined. + +Definition morphism_theory_of_function : + forall (In: nelistT Type) (Out: Type), + let In' := list_of_Leibniz_of_list_of_types In in + let Out' := Leibniz _ Out in + function_type_of_morphism_signature In' Out' -> + Morphism_Theory In' Out'. + intros. + exists X. + induction In; unfold make_compatibility_goal; simpl. + reflexivity. + intro; apply (IHIn (X x)). +Defined. + +(** Every predicate is a morphism from Leibniz+ to Iff_Relation_Class *) + +Definition morphism_theory_of_predicate : + forall (In: nelistT Type), + let In' := list_of_Leibniz_of_list_of_types In in + function_type_of_morphism_signature In' Iff_Relation_Class -> + Morphism_Theory In' Iff_Relation_Class. + intros. + exists X. + induction In; unfold make_compatibility_goal; simpl. + intro; apply iff_refl. + intro; apply (IHIn (X x)). +Defined. + +(** * Utility functions to prove that every transitive relation is a morphism *) + +Definition equality_morphism_of_symmetric_areflexive_transitive_relation: + forall (A: Type)(Aeq: relation A)(sym: symmetric _ Aeq)(trans: transitive _ Aeq), + let ASetoidClass := SymmetricAreflexive _ sym in + (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). + intros. + exists Aeq. + unfold make_compatibility_goal; simpl; split; eauto. +Defined. + +Definition equality_morphism_of_symmetric_reflexive_transitive_relation: + forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(sym: symmetric _ Aeq) + (trans: transitive _ Aeq), let ASetoidClass := SymmetricReflexive _ sym refl in + (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). + intros. + exists Aeq. + unfold make_compatibility_goal; simpl; split; eauto. +Defined. + +Definition equality_morphism_of_asymmetric_areflexive_transitive_relation: + forall (A: Type)(Aeq: relation A)(trans: transitive _ Aeq), + let ASetoidClass1 := AsymmetricAreflexive Contravariant Aeq in + let ASetoidClass2 := AsymmetricAreflexive Covariant Aeq in + (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). + intros. + exists Aeq. + unfold make_compatibility_goal; simpl; unfold impl; eauto. +Defined. + +Definition equality_morphism_of_asymmetric_reflexive_transitive_relation: + forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(trans: transitive _ Aeq), + let ASetoidClass1 := AsymmetricReflexive Contravariant refl in + let ASetoidClass2 := AsymmetricReflexive Covariant refl in + (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). + intros. + exists Aeq. + unfold make_compatibility_goal; simpl; unfold impl; eauto. +Defined. + +(** * The CIC part of the reflexive tactic ([setoid_rewrite]) *) + +Inductive rewrite_direction : Type := + | Left2Right + | Right2Left. + +Implicit Type dir: rewrite_direction. + +Definition variance_of_argument_class : Argument_Class -> option variance. + destruct 1. + exact None. + exact (Some v). + exact None. + exact (Some v). + exact None. +Defined. + +Definition opposite_direction := + fun dir => + match dir with + | Left2Right => Right2Left + | Right2Left => Left2Right + end. + +Lemma opposite_direction_idempotent: + forall dir, (opposite_direction (opposite_direction dir)) = dir. +Proof. + destruct dir; reflexivity. +Qed. + +Inductive check_if_variance_is_respected : + option variance -> rewrite_direction -> rewrite_direction -> Prop := + | MSNone : forall dir dir', check_if_variance_is_respected None dir dir' + | MSCovariant : forall dir, check_if_variance_is_respected (Some Covariant) dir dir + | MSContravariant : + forall dir, + check_if_variance_is_respected (Some Contravariant) dir (opposite_direction dir). + +Definition relation_class_of_reflexive_relation_class: + Reflexive_Relation_Class -> Relation_Class. + induction 1. + exact (SymmetricReflexive _ s r). + exact (AsymmetricReflexive tt r). + exact (Leibniz _ T). +Defined. + +Definition relation_class_of_areflexive_relation_class: + Areflexive_Relation_Class -> Relation_Class. + induction 1. + exact (SymmetricAreflexive _ s). + exact (AsymmetricAreflexive tt Aeq). +Defined. + +Definition carrier_of_reflexive_relation_class := + fun R => carrier_of_relation_class (relation_class_of_reflexive_relation_class R). + +Definition carrier_of_areflexive_relation_class := + fun R => carrier_of_relation_class (relation_class_of_areflexive_relation_class R). + +Definition relation_of_areflexive_relation_class := + fun R => relation_of_relation_class (relation_class_of_areflexive_relation_class R). + +Inductive Morphism_Context Hole dir : Relation_Class -> rewrite_direction -> Type := + | App : + forall In Out dir', + Morphism_Theory In Out -> Morphism_Context_List Hole dir dir' In -> + Morphism_Context Hole dir Out dir' + | ToReplace : Morphism_Context Hole dir Hole dir + | ToKeep : + forall S dir', + carrier_of_reflexive_relation_class S -> + Morphism_Context Hole dir (relation_class_of_reflexive_relation_class S) dir' + | ProperElementToKeep : + forall S dir' (x: carrier_of_areflexive_relation_class S), + relation_of_areflexive_relation_class S x x -> + Morphism_Context Hole dir (relation_class_of_areflexive_relation_class S) dir' +with Morphism_Context_List Hole dir : + rewrite_direction -> Arguments -> Type +:= + fcl_singl : + forall S dir' dir'', + check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> + Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> + Morphism_Context_List Hole dir dir'' (singl S) + | fcl_cons : + forall S L dir' dir'', + check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> + Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> + Morphism_Context_List Hole dir dir'' L -> + Morphism_Context_List Hole dir dir'' (necons S L). + +Scheme Morphism_Context_rect2 := Induction for Morphism_Context Sort Type +with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Type. + +Definition product_of_arguments : Arguments -> Type. + induction 1. + exact (carrier_of_relation_class a). + exact (prod (carrier_of_relation_class a) IHX). +Defined. + +Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction. + intros dir R. + destruct (variance_of_argument_class R). + destruct v. + exact dir. (* covariant *) + exact (opposite_direction dir). (* contravariant *) + exact dir. (* symmetric relation *) +Defined. + +Definition directed_relation_of_relation_class: + forall dir (R: Relation_Class), + carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. + destruct 1. + exact (@relation_of_relation_class unit). + intros; exact (relation_of_relation_class _ X0 X). +Defined. + +Definition directed_relation_of_argument_class: + forall dir (R: Argument_Class), + carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. + intros dir R. + rewrite <- + (about_carrier_of_relation_class_and_relation_class_of_argument_class R). + exact (directed_relation_of_relation_class dir (relation_class_of_argument_class R)). +Defined. + + +Definition relation_of_product_of_arguments: + forall dir In, + product_of_arguments In -> product_of_arguments In -> Prop. + induction In. + simpl. + exact (directed_relation_of_argument_class (get_rewrite_direction dir a) a). + + simpl; intros. + destruct X; destruct X0. + apply and. + exact + (directed_relation_of_argument_class (get_rewrite_direction dir a) a c c0). + exact (IHIn p p0). +Defined. + +Definition apply_morphism: + forall In Out (m: function_type_of_morphism_signature In Out) + (args: product_of_arguments In), carrier_of_relation_class Out. + intros. + induction In. + exact (m args). + simpl in m, args. + destruct args. + exact (IHIn (m c) p). +Defined. + +Theorem apply_morphism_compatibility_Right2Left: + forall In Out (m1 m2: function_type_of_morphism_signature In Out) + (args1 args2: product_of_arguments In), + make_compatibility_goal_aux _ _ m1 m2 -> + relation_of_product_of_arguments Right2Left _ args1 args2 -> + directed_relation_of_relation_class Right2Left _ + (apply_morphism _ _ m2 args1) + (apply_morphism _ _ m1 args2). + induction In; intros. + simpl in m1, m2, args1, args2, H0 |- *. + destruct a; simpl in H; hnf in H0. + apply H; exact H0. + destruct v; simpl in H0; apply H; exact H0. + apply H; exact H0. + destruct v; simpl in H0; apply H; exact H0. + rewrite H0; apply H; exact H0. + + simpl in m1, m2, args1, args2, H0 |- *. + destruct args1; destruct args2; simpl. + destruct H0. + simpl in H. + destruct a; simpl in H. + apply IHIn. + apply H; exact H0. + exact H1. + destruct v. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + apply H; exact H0. + exact H1. + destruct v. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + apply H; exact H0. + exact H1. + rewrite H0; apply IHIn. + apply H. + exact H1. +Qed. + +Theorem apply_morphism_compatibility_Left2Right: + forall In Out (m1 m2: function_type_of_morphism_signature In Out) + (args1 args2: product_of_arguments In), + make_compatibility_goal_aux _ _ m1 m2 -> + relation_of_product_of_arguments Left2Right _ args1 args2 -> + directed_relation_of_relation_class Left2Right _ + (apply_morphism _ _ m1 args1) + (apply_morphism _ _ m2 args2). +Proof. + induction In; intros. + simpl in m1, m2, args1, args2, H0 |- *. + destruct a; simpl in H; hnf in H0. + apply H; exact H0. + destruct v; simpl in H0; apply H; exact H0. + apply H; exact H0. + destruct v; simpl in H0; apply H; exact H0. + rewrite H0; apply H; exact H0. + + simpl in m1, m2, args1, args2, H0 |- *. + destruct args1; destruct args2; simpl. + destruct H0. + simpl in H. + destruct a; simpl in H. + apply IHIn. + apply H; exact H0. + exact H1. + destruct v. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + apply H; exact H0. + exact H1. + apply IHIn. + destruct v; simpl in H, H0; apply H; exact H0. + exact H1. + rewrite H0; apply IHIn. + apply H. + exact H1. +Qed. + +Definition interp : + forall Hole dir Out dir', carrier_of_relation_class Hole -> + Morphism_Context Hole dir Out dir' -> carrier_of_relation_class Out. + intros Hole dir Out dir' H t. + elim t using + (@Morphism_Context_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) + (fun _ L fcl => product_of_arguments L)); + intros. + exact (apply_morphism _ _ (Function m) X). + exact H. + exact c. + exact x. + simpl; + rewrite <- + (about_carrier_of_relation_class_and_relation_class_of_argument_class S); + exact X. + split. + rewrite <- + (about_carrier_of_relation_class_and_relation_class_of_argument_class S); + exact X. + exact X0. +Defined. + +(* CSC: interp and interp_relation_class_list should be mutually defined, since + the proof term of each one contains the proof term of the other one. However + I cannot do that interactively (I should write the Fix by hand) *) +Definition interp_relation_class_list : + forall Hole dir dir' (L: Arguments), carrier_of_relation_class Hole -> + Morphism_Context_List Hole dir dir' L -> product_of_arguments L. + intros Hole dir dir' L H t. + elim t using + (@Morphism_Context_List_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) + (fun _ L fcl => product_of_arguments L)); + intros. + exact (apply_morphism _ _ (Function m) X). + exact H. + exact c. + exact x. + simpl; + rewrite <- + (about_carrier_of_relation_class_and_relation_class_of_argument_class S); + exact X. + split. + rewrite <- + (about_carrier_of_relation_class_and_relation_class_of_argument_class S); + exact X. + exact X0. +Defined. + +Theorem setoid_rewrite: + forall Hole dir Out dir' (E1 E2: carrier_of_relation_class Hole) + (E: Morphism_Context Hole dir Out dir'), + (directed_relation_of_relation_class dir Hole E1 E2) -> + (directed_relation_of_relation_class dir' Out (interp E1 E) (interp E2 E)). +Proof. + intros. + elim E using + (@Morphism_Context_rect2 Hole dir + (fun S dir'' E => directed_relation_of_relation_class dir'' S (interp E1 E) (interp E2 E)) + (fun dir'' L fcl => + relation_of_product_of_arguments dir'' _ + (interp_relation_class_list E1 fcl) + (interp_relation_class_list E2 fcl))); intros. + change (directed_relation_of_relation_class dir'0 Out0 + (apply_morphism _ _ (Function m) (interp_relation_class_list E1 m0)) + (apply_morphism _ _ (Function m) (interp_relation_class_list E2 m0))). + destruct dir'0. + apply apply_morphism_compatibility_Left2Right. + exact (Compat m). + exact H0. + apply apply_morphism_compatibility_Right2Left. + exact (Compat m). + exact H0. + + exact H. + + unfold interp, Morphism_Context_rect2. + (* CSC: reflexivity used here *) + destruct S; destruct dir'0; simpl; (apply r || reflexivity). + + destruct dir'0; exact r. + + destruct S; unfold directed_relation_of_argument_class; simpl in H0 |- *; + unfold get_rewrite_direction; simpl. + destruct dir'0; destruct dir''; + (exact H0 || + unfold directed_relation_of_argument_class; simpl; apply s; exact H0). + (* the following mess with generalize/clear/intros is to help Coq resolving *) + (* second order unification problems. *) + generalize m c H0; clear H0 m c; inversion c; + generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; + (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). + destruct dir'0; destruct dir''; + (exact H0 || + unfold directed_relation_of_argument_class; simpl; apply s; exact H0). + (* the following mess with generalize/clear/intros is to help Coq resolving *) + (* second order unification problems. *) + generalize m c H0; clear H0 m c; inversion c; + generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; + (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). + destruct dir'0; destruct dir''; (exact H0 || hnf; symmetry; exact H0). + + change + (directed_relation_of_argument_class (get_rewrite_direction dir'' S) S + (eq_rect _ (fun T : Type => T) (interp E1 m) _ + (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) + (eq_rect _ (fun T : Type => T) (interp E2 m) _ + (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) /\ + relation_of_product_of_arguments dir'' _ + (interp_relation_class_list E1 m0) (interp_relation_class_list E2 m0)). + split. + clear m0 H1; destruct S; simpl in H0 |- *; unfold get_rewrite_direction; simpl. + destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). + inversion c. + rewrite <- H3; exact H0. + rewrite (opposite_direction_idempotent dir'0); exact H0. + destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). + inversion c. + rewrite <- H3; exact H0. + rewrite (opposite_direction_idempotent dir'0); exact H0. + destruct dir''; destruct dir'0; (exact H0 || hnf; symmetry; exact H0). + exact H1. + Qed. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index 47554ac4..ae2143c8 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Infinite_sets.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Infinite_sets.v 10637 2008-03-07 23:52:56Z letouzey $ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -162,7 +162,7 @@ Section Infinite_sets. generalize (H'3 x). intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ]; auto with sets. - specialize 5Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x); + specialize Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x); intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ]; auto with sets. intros x1 H'4; try assumption. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index c969ad9c..1786edf1 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Integers.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Integers.v 10637 2008-03-07 23:52:56Z letouzey $ i*) Require Export Finite_sets. Require Export Constructive_sets. @@ -87,7 +87,7 @@ Section Integers_sect. apply Totally_ordered_definition. simpl in |- *. intros H' x y H'0. - specialize 2le_or_lt with (n := x) (m := y); intro H'2; elim H'2. + elim le_or_lt with (n := x) (m := y). intro H'1; left; auto with sets arith. intro H'1; right. cut (y <= x); auto with sets arith. @@ -142,8 +142,8 @@ Section Integers_sect. elim H'0; intros H'1 H'2. cut (In nat Integers (S x)). intro H'3. - specialize 1H'2 with (y := S x); intro H'4; lapply H'4; - [ intro H'5; clear H'4 | try assumption; clear H'4 ]. + specialize H'2 with (y := S x); lapply H'2; + [ intro H'5; clear H'2 | try assumption; clear H'2 ]. simpl in H'5. absurd (S x <= x); auto with arith. apply triv_nat. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 7084a82d..d2bff488 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Multiset.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Multiset.v 10616 2008-03-04 17:33:35Z letouzey $ i*) (* G. Huet 1-9-95 *) @@ -16,11 +16,11 @@ Set Implicit Arguments. Section multiset_defs. - Variable A : Set. + Variable A : Type. Variable eqA : A -> A -> Prop. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - Inductive multiset : Set := + Inductive multiset : Type := Bag : (A -> nat) -> multiset. Definition EmptyBag := Bag (fun a:A => 0). diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index a7c3db3a..4380f10c 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permut.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Permut.v 10616 2008-03-04 17:33:35Z letouzey $ i*) (* G. Huet 1-9-95 *) @@ -15,7 +15,7 @@ Section Axiomatisation. - Variable U : Set. + Variable U : Type. Variable op : U -> U -> U. Variable cong : U -> U -> Prop. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 47857705..34c49409 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_Classical_facts.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Powerset_Classical_facts.v 10855 2008-04-27 11:16:15Z msozeau $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 3291f3ee..2374c2bf 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id: Relations_2_facts.v 10637 2008-03-07 23:52:56Z letouzey $ i*) Require Export Relations_1. Require Export Relations_1_facts. @@ -140,10 +140,10 @@ intros U R H' x b H'0; elim H'0. intros x0 a H'1; exists a; auto with sets. intros x0 y z H'1 H'2 H'3 a H'4. red in H'. -specialize 3H' with (x := x0) (a := a) (b := y); intro H'7; lapply H'7; +specialize H' with (x := x0) (a := a) (b := y); lapply H'; [ intro H'8; lapply H'8; - [ intro H'9; try exact H'9; clear H'8 H'7 | clear H'8 H'7 ] - | clear H'7 ]; auto with sets. + [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] + | clear H' ]; auto with sets. elim H'9. intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5. elim (H'3 t); auto with sets. diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index e1e026f5..fe7902aa 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -6,18 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Heap.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Heap.v 10698 2008-03-19 18:46:59Z letouzey $ i*) (** A development of Treesort on Heap trees *) (* G. Huet 1-9-95 uses Multiset *) -Require Import List. -Require Import Multiset. -Require Import Permutation. -Require Import Relations. -Require Import Sorting. - +Require Import List Multiset Permutation Relations Sorting. Section defs. @@ -25,7 +20,7 @@ Section defs. (** ** Definition of trees over an ordered set *) - Variable A : Set. + Variable A : Type. Variable leA : relation A. Variable eqA : relation A. @@ -43,7 +38,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. - Inductive Tree : Set := + Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -87,6 +82,23 @@ Section defs. Qed. (* This lemma ought to be generated automatically by the Inversion tools *) + Lemma is_heap_rect : + forall P:Tree -> Type, + P Tree_Leaf -> + (forall (a:A) (T1 T2:Tree), + leA_Tree a T1 -> + leA_Tree a T2 -> + is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) -> + forall T:Tree, is_heap T -> P T. + Proof. + simple induction T; auto with datatypes. + intros a G PG D PD PN. + elim (invert_heap a G D); auto with datatypes. + intros H1 H2; elim H2; intros H3 H4; elim H4; intros. + apply X0; auto with datatypes. + Qed. + + (* This lemma ought to be generated automatically by the Inversion tools *) Lemma is_heap_rec : forall P:Tree -> Set, P Tree_Leaf -> @@ -100,7 +112,7 @@ Section defs. intros a G PG D PD PN. elim (invert_heap a G D); auto with datatypes. intros H1 H2; elim H2; intros H3 H4; elim H4; intros. - apply H0; auto with datatypes. + apply X; auto with datatypes. Qed. Lemma low_trans : @@ -136,7 +148,7 @@ Section defs. (** ** Specification of heap insertion *) - Inductive insert_spec (a:A) (T:Tree) : Set := + Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, is_heap T1 -> @@ -152,11 +164,11 @@ Section defs. auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. simpl in |- *; unfold meq, munion in |- *; auto using node_is_heap with datatypes. elim (leA_dec a a0); intros. - elim (H3 a0); intros. + elim (X a0); intros. apply insert_exist with (Tree_Node a T2 T0); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. simpl in |- *; apply treesort_twist1; trivial with datatypes. - elim (H3 a); intros T3 HeapT3 ConT3 LeA. + elim (X a); intros T3 HeapT3 ConT3 LeA. apply insert_exist with (Tree_Node a0 T2 T3); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. @@ -169,7 +181,7 @@ Section defs. (** ** Building a heap from a list *) - Inductive build_heap (l:list A) : Set := + Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, is_heap T -> @@ -193,7 +205,7 @@ Section defs. (** ** Building the sorted list *) - Inductive flat_spec (T:Tree) : Set := + Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, sort leA l -> @@ -204,7 +216,7 @@ Section defs. Proof. intros T h; elim h; intros. apply flat_exist with (nil (A:=A)); auto with datatypes. - elim H2; intros l1 s1 i1 m1; elim H4; intros l2 s2 i2 m2. + elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2. elim (merge _ leA_dec eqA_dec s1 s2); intros. apply flat_exist with (a :: l); simpl in |- *; auto with datatypes. apply meq_trans with diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index f4986198..084aae92 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -6,14 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutEq.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: PermutEq.v 10739 2008-04-01 14:45:20Z herbelin $ i*) -Require Import Omega. -Require Import Relations. -Require Import Setoid. -Require Import List. -Require Import Multiset. -Require Import Permutation. +Require Import Omega Relations Setoid List Multiset Permutation. Set Implicit Arguments. @@ -25,7 +20,7 @@ Set Implicit Arguments. Section Perm. - Variable A : Set. + Variable A : Type. Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}. Notation permutation := (permutation _ eq_dec). @@ -214,7 +209,7 @@ Section Perm. apply permut_remove_hd with a; auto. Qed. - Variable B : Set. + Variable B : Type. Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. (** Permutation is compatible with map. *) diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 65369a01..c3888cfa 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -6,14 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PermutSetoid.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: PermutSetoid.v 10739 2008-04-01 14:45:20Z herbelin $ i*) -Require Import Omega. -Require Import Relations. -Require Import List. -Require Import Multiset. -Require Import Permutation. -Require Import SetoidList. +Require Import Omega Relations Multiset Permutation SetoidList. Set Implicit Arguments. @@ -23,7 +18,7 @@ Set Implicit Arguments. Section Perm. -Variable A : Set. +Variable A : Type. Variable eqA : relation A. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. @@ -81,7 +76,7 @@ Proof. rewrite IHl in H1. intros; destruct (eqA_dec a a0) as [H2|H2]; simpl; auto. rewrite multiplicity_InA_O; auto. - swap H0. + contradict H0. apply InA_eqA with a0; auto. intros; constructor. rewrite multiplicity_InA. @@ -185,9 +180,9 @@ Proof. destruct H2; apply eqA_trans with a; auto. Qed. -Lemma NoDupA_eqlistA_permut : +Lemma NoDupA_equivlistA_permut : forall l l', NoDupA eqA l -> NoDupA eqA l' -> - eqlistA eqA l l' -> permutation l l'. + equivlistA eqA l l' -> permutation l l'. Proof. intros. red; unfold meq; intros. @@ -198,7 +193,7 @@ Proof. Qed. -Variable B : Set. +Variable B : Type. Variable eqB : B->B->Prop. Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 3ff026c2..82294b70 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -6,12 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permutation.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Permutation.v 10698 2008-03-19 18:46:59Z letouzey $ i*) -Require Import Relations. -Require Import List. -Require Import Multiset. -Require Import Arith. +Require Import Relations List Multiset Arith. (** This file define a notion of permutation for lists, based on multisets: there exists a permutation between two lists iff every elements have @@ -38,7 +35,7 @@ Section defs. (** * From lists to multisets *) - Variable A : Set. + Variable A : Type. Variable eqA : relation A. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index f895d79e..aed8cd15 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -6,18 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sorting.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Sorting.v 10698 2008-03-19 18:46:59Z letouzey $ i*) -Require Import List. -Require Import Multiset. -Require Import Permutation. -Require Import Relations. +Require Import List Multiset Permutation Relations. Set Implicit Arguments. Section defs. - Variable A : Set. + Variable A : Type. Variable leA : relation A. Variable eqA : relation A. @@ -59,6 +56,16 @@ Section defs. intros; inversion H; auto with datatypes. Qed. + Lemma sort_rect : + forall P:list A -> Type, + P nil -> + (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) -> + forall y:list A, sort y -> P y. + Proof. + simple induction y; auto with datatypes. + intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes. + Qed. + Lemma sort_rec : forall P:list A -> Set, P nil -> @@ -71,7 +78,7 @@ Section defs. (** * Merging two sorted lists *) - Inductive merge_lem (l1 l2:list A) : Set := + Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, sort l -> @@ -85,7 +92,7 @@ Section defs. Proof. simple induction 1; intros. apply merge_exist with l2; auto with datatypes. - elim H3; intros. + elim H2; intros. apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes. elim (leA_dec a a0); intros. @@ -104,7 +111,7 @@ Section defs. apply lelistA_inv with l; trivial with datatypes. (* 2 (leA a0 a) *) - elim H5; simpl in |- *; intros. + elim X0; simpl in |- *; intros. apply merge_exist with (a0 :: l3); simpl in |- *; auto using cons_sort, cons_leA with datatypes. apply meq_trans with diff --git a/theories/Strings/String.v b/theories/Strings/String.v index f2c58364..53260480 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: String.v 8026 2006-02-11 19:40:49Z herbelin $ *) +(* $Id: String.v 10855 2008-04-27 11:16:15Z msozeau $ *) (** Contributed by Laurent Théry (INRIA); Adapted to Coq V8 by the Coq Development Team *) @@ -110,8 +110,8 @@ Proof. intros s1; elim s1; simpl in |- *; auto. intros s2 n; rewrite plus_comm; simpl in |- *; auto. intros a s1' Rec s2 n; case n; simpl in |- *; auto. -generalize (Rec s2 0); simpl in |- *; auto. -intros n0; rewrite <- Plus.plus_Snm_nSm; auto. +generalize (Rec s2 0); simpl in |- *; auto. intros. +rewrite <- Plus.plus_Snm_nSm; auto. Qed. (** *** Substrings *) diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v new file mode 100644 index 00000000..32b892b6 --- /dev/null +++ b/theories/Unicode/Utf8.v @@ -0,0 +1,60 @@ +(* -*- coding:utf-8 -* *) +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* 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). +*) + +(* Arithmetic *) +Notation "x ≤ y" := (le x y) (at level 70, no associativity). +Notation "x ≥ y" := (ge x y) (at level 70, no associativity). + +(* test *) +(* +Goal ∀ x, True -> (∃ y , x ≥ y + 1) ∨ x ≤ 0. +*) + +(* Integer Arithmetic *) +(* TODO: this should come after ZArith +Notation "x ≤ y" := (Zle x y) (at level 1, y at level 10). +*) diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index 1e22730b..6adf629d 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Disjoint_Union.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Disjoint_Union.v 10681 2008-03-16 13:40:45Z msozeau $ i*) (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory @@ -15,7 +15,7 @@ Require Import Relation_Operators. Section Wf_Disjoint_Union. - Variables A B : Set. + Variables A B : Type. Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. @@ -52,4 +52,4 @@ Section Wf_Disjoint_Union. apply (H0 b). Qed. -End Wf_Disjoint_Union.
\ No newline at end of file +End Wf_Disjoint_Union. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index 44e07d0b..e5ef4a70 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inclusion.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Inclusion.v 9642 2007-02-12 10:31:53Z herbelin $ i*) (** Author: Bruno Barras *) Require Import Relation_Definitions. Section WfInclusion. - Variable A : Set. + Variable A : Type. Variables R1 R2 : A -> A -> Prop. Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z. @@ -29,4 +29,4 @@ Section WfInclusion. unfold well_founded in |- *; auto with sets. Qed. -End WfInclusion.
\ No newline at end of file +End WfInclusion. diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index 210cc757..29fe7bb2 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inverse_Image.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Inverse_Image.v 9642 2007-02-12 10:31:53Z herbelin $ i*) (** Author: Bruno Barras *) Section Inverse_Image. - Variables A B : Set. + Variables A B : Type. Variable R : B -> B -> Prop. Variable f : A -> B. diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index efdf0495..4dfcb24b 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -6,14 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lexicographic_Exponentiation.v 9610 2007-02-07 14:45:18Z herbelin $ i*) +(*i $Id: Lexicographic_Exponentiation.v 9609 2007-02-07 14:42:26Z herbelin $ i*) (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory L. Paulson JSC (1986) 2, 325-355 *) -Require Import Eqdep. Require Import List. Require Import Relation_Operators. Require Import Transitive_Closure. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 051c8127..818084b2 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lexicographic_Product.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Lexicographic_Product.v 9598 2007-02-06 19:45:52Z herbelin $ i*) (** Authors: Bruno Barras, Cristina Cornes *) diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index bd4e4fec..e552598c 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Transitive_Closure.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Transitive_Closure.v 9598 2007-02-06 19:45:52Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 634576ad..8589c18f 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Union.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Union.v 9642 2007-02-12 10:31:53Z herbelin $ i*) (** Author: Bruno Barras *) @@ -15,7 +15,7 @@ Require Import Relation_Definitions. Require Import Transitive_Closure. Section WfUnion. - Variable A : Set. + Variable A : Type. Variables R1 R2 : relation A. Notation Union := (union A R1 R2). @@ -72,4 +72,4 @@ Section WfUnion. apply Acc_union; auto with sets. Qed. -End WfUnion.
\ No newline at end of file +End WfUnion. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index f691f2b7..af8832ec 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Well_Ordering.v 9597 2007-02-06 19:44:05Z herbelin $ i*) +(*i $Id: Well_Ordering.v 9598 2007-02-06 19:45:52Z herbelin $ i*) (** Author: Cristina Cornes. From: Constructing Recursion Operators in Type Theory diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 71e48360..1ff88604 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinInt.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: BinInt.v 11015 2008-05-28 20:06:42Z herbelin $ i*) (***********************************************************) -(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) +(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) (***********************************************************) Require Export BinPos. @@ -40,43 +40,48 @@ Arguments Scope Zneg [positive_scope]. Definition Zdouble_plus_one (x:Z) := match x with | Z0 => Zpos 1 - | Zpos p => Zpos (xI p) + | 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 (xI p) + | 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 (xO p) - | Zneg p => Zneg (xO p) + | 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 - | xI x', xI y' => Zdouble (ZPminus x' y') - | xI x', xO y' => Zdouble_plus_one (ZPminus x' y') - | xI x', xH => Zpos (xO x') - | xO x', xI y' => Zdouble_minus_one (ZPminus x' y') - | xO x', xO y' => Zdouble (ZPminus x' y') - | xO x', xH => Zpos (Pdouble_minus_one x') - | xH, xI y' => Zneg (xO y') - | xH, xO y' => Zneg (Pdouble_minus_one y') - | xH, xH => Z0 + | 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 - | x, Z0 => x + | 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 @@ -217,6 +222,7 @@ Qed. (**********************************************************************) + (** ** Properties of opposite on binary integer numbers *) Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p. @@ -247,30 +253,6 @@ Proof. | simplify_eq H; intro E; rewrite E; trivial ]. Qed. -(*************************************************************************) -(** ** Properties of the direct definition of successor and predecessor *) - -Lemma Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n. -Proof. - intro x; destruct x; simpl in |- *. - reflexivity. - destruct p; simpl in |- *; try rewrite Pdouble_minus_one_o_succ_eq_xI; - reflexivity. - destruct p; simpl in |- *; try rewrite Psucc_o_double_minus_one_eq_xO; - reflexivity. -Qed. - -Lemma Zsucc'_discr : forall n:Z, n <> Zsucc' 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. -Qed. - (**********************************************************************) (** ** Other properties of binary integer numbers *) @@ -313,10 +295,15 @@ Qed. Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m. Proof. intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q]; - simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); + simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); reflexivity. Qed. +Theorem Zopp_succ : forall n:Z, Zopp (Zsucc n) = Zpred (Zopp n). +Proof. +intro; unfold Zsucc; now rewrite Zopp_plus_distr. +Qed. + (** ** opposite is inverse for addition *) Theorem Zplus_opp_r : forall n:Z, n + - n = Z0. @@ -520,11 +507,13 @@ Proof. trivial with arith. Qed. -Lemma Zplus_succ_r : forall n m:Z, Zsucc (n + m) = n + Zsucc m. +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. Qed. +Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing). + Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m. Proof. unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc; @@ -586,10 +575,10 @@ Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n). Proof. intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *; rewrite Zplus_0_r; trivial with arith. -Qed. +Qed. Hint Immediate Zsucc_pred: zarith. - + Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n). Proof. intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *; @@ -603,7 +592,59 @@ Proof. do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1)); unfold Zsucc in H; rewrite H; trivial with arith. Qed. - + +(*************************************************************************) +(** ** Properties of the direct definition of successor and predecessor *) + +Theorem Zsucc_succ' : forall n:Z, Zsucc n = Zsucc' n. +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. +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. +Proof. +intros n m; do 2 rewrite <- Zsucc_succ'; now apply Zsucc_inj. +Qed. + +Theorem Zsucc'_pred' : forall n:Z, Zsucc' (Zpred' n) = n. +Proof. +intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred'; +symmetry; apply Zsucc_pred. +Qed. + +Theorem Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n. +Proof. +intro; apply Zsucc'_inj; now rewrite Zsucc'_pred'. +Qed. + +Theorem Zpred'_inj : forall n m:Z, Zpred' n = Zpred' m -> n = m. +Proof. +intros n m H. +rewrite <- (Zsucc'_pred' n); rewrite <- (Zsucc'_pred' m); now rewrite H. +Qed. + +Theorem Zsucc'_discr : forall n:Z, n <> Zsucc' 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. +Qed. + (** Misc properties, usually redundant or non natural *) Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m. @@ -645,6 +686,22 @@ Qed. (** ** Relating [minus] with [plus] and [Zsucc] *) +Lemma Zminus_plus_distr : forall n m p:Z, n - (m + p) = n - m - p. +Proof. +intros; unfold Zminus; rewrite Zopp_plus_distr; apply Zplus_assoc. +Qed. + +Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m. +Proof. + intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m)); + rewrite <- Zplus_assoc; apply Zplus_comm. +Qed. + +Lemma Zminus_succ_r : forall n m:Z, n - (Zsucc m) = Zpred (n - m). +Proof. +intros; unfold Zsucc; now rewrite Zminus_plus_distr. +Qed. + Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m. Proof. intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m); @@ -665,12 +722,6 @@ Proof. apply Zplus_0_r. Qed. -Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m. -Proof. - intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m)); - rewrite <- Zplus_assoc; apply Zplus_comm. -Qed. - Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m. Proof. intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr; @@ -696,6 +747,16 @@ Proof. reflexivity. Qed. +Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt -> + Zpos (b-a) = Zpos b - Zpos a. +Proof. + intros. + simpl. + change Eq with (CompOpp Eq). + rewrite <- Pcompare_antisym. + rewrite H; simpl; auto. +Qed. + (** ** Misc redundant properties *) Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0. @@ -805,6 +866,19 @@ Proof. reflexivity). Qed. +(** ** Multiplication and Doubling *) + +Lemma Zdouble_mult : forall z, Zdouble z = (Zpos 2) * z. +Proof. + reflexivity. +Qed. + +Lemma Zdouble_plus_one_mult : forall z, + Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1). +Proof. + destruct z; simpl; auto with zarith. +Qed. + (** ** Multiplication and Opposite *) Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m. @@ -967,22 +1041,37 @@ Qed. (**********************************************************************) (** * Relating binary positive numbers and binary integers *) -Lemma Zpos_xI : forall p:positive, Zpos (xI p) = Zpos 2 * Zpos p + Zpos 1. +Lemma Zpos_eq : forall p q:positive, p = q -> Zpos p = Zpos q. +Proof. + intros; f_equal; auto. +Qed. + +Lemma Zpos_eq_rev : forall p q:positive, Zpos p = Zpos q -> p = q. +Proof. + inversion 1; auto. +Qed. + +Lemma Zpos_eq_iff : forall p q:positive, p = q <-> Zpos p = Zpos q. +Proof. + split; [apply Zpos_eq|apply Zpos_eq_rev]. +Qed. + +Lemma Zpos_xI : forall p:positive, Zpos p~1 = Zpos 2 * Zpos p + Zpos 1. Proof. intro; apply refl_equal. Qed. -Lemma Zpos_xO : forall p:positive, Zpos (xO p) = Zpos 2 * Zpos p. +Lemma Zpos_xO : forall p:positive, Zpos p~0 = Zpos 2 * Zpos p. Proof. intro; apply refl_equal. Qed. -Lemma Zneg_xI : forall p:positive, Zneg (xI p) = Zpos 2 * Zneg p - Zpos 1. +Lemma Zneg_xI : forall p:positive, Zneg p~1 = Zpos 2 * Zneg p - Zpos 1. Proof. intro; apply refl_equal. Qed. -Lemma Zneg_xO : forall p:positive, Zneg (xO p) = Zpos 2 * Zneg p. +Lemma Zneg_xO : forall p:positive, Zneg p~0 = Zpos 2 * Zneg p. Proof. reflexivity. Qed. @@ -1057,7 +1146,8 @@ Definition Zabs_N (z:Z) := | Zneg p => Npos p end. -Definition Z_of_N (x:N) := match x with - | N0 => Z0 - | Npos p => Zpos p - end. +Definition Z_of_N (x:N) := + match x with + | N0 => Z0 + | Npos p => Zpos p + end. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 3cee9190..fcb44d6f 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -7,11 +7,11 @@ (***********************************************************************) (* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre + * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: Int.v 9319 2006-10-30 12:41:21Z barras $ *) +(* $Id: Int.v 10739 2008-04-01 14:45:20Z herbelin $ *) (** An axiomatization of integers. *) @@ -352,46 +352,15 @@ Module MoreInt (I:Int). Ltac i2z_refl := i2z_gen; match goal with |- ?t => - let e := p2ep t - in - (change (ep2p e); - apply norm_ep_correct2; - simpl) + let e := p2ep t in + change (ep2p e); apply norm_ep_correct2; simpl end. - Ltac iauto := i2z_refl; auto. - Ltac iomega := i2z_refl; intros; romega. - - Open Scope Z_scope. - - Lemma max_spec : forall (x y:Z), - x >= y /\ Zmax x y = x \/ - x < y /\ Zmax x y = y. - Proof. - intros; unfold Zmax, Zlt, Zge. - destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate. - Qed. - - Ltac omega_max_genspec x y := - generalize (max_spec x y); - (let z := fresh "z" in let Hz := fresh "Hz" in - set (z:=Zmax x y); clearbody z). - - Ltac omega_max_loop := - match goal with - (* hack: we don't want [i2z (height ...)] to be reduced by romega later... *) - | |- context [ i2z (?f ?x) ] => - let i := fresh "i2z" in (set (i:=i2z (f x)); clearbody i); omega_max_loop - | |- context [ Zmax ?x ?y ] => omega_max_genspec x y; omega_max_loop - | _ => intros - end. - - Ltac omega_max := i2z_refl; omega_max_loop; try romega. + (* i2z_refl can be replaced below by (simpl in *; i2z). + The reflexive version improves compilation of AVL files by about 15% *) - Ltac false_omega := i2z_refl; intros; romega. - Ltac false_omega_max := elimtype False; omega_max. + Ltac omega_max := i2z_refl; romega with Z. - Open Scope Int_scope. End MoreInt. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index 7febbf6a..b831afee 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZArith_dec.v 9958 2007-07-06 22:47:40Z letouzey $ i*) +(*i $Id: ZArith_dec.v 9759 2007-04-12 17:46:54Z notin $ i*) Require Import Sumbool. diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v new file mode 100644 index 00000000..03e061f2 --- /dev/null +++ b/theories/ZArith/ZOdiv.v @@ -0,0 +1,953 @@ +(************************************************************************) +(* 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 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 <= a -> 0 < b -> a <= q*b -> a/b <= q. +Proof. + intros a b q H1 H2 H3. + apply Zmult_le_reg_r with b; auto with zarith. + apply Zle_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_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 <= a -> 0 < b -> q*b <= a -> q <= a/b. +Proof. + intros a b q H1 H2 H3. + assert (q < a / b + 1); auto with zarith. + apply Zmult_lt_reg_r with b; auto with zarith. + apply Zle_lt_trans with (1 := H3). + pattern a at 1; rewrite (ZO_div_mod_eq a b); auto with zarith. + rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (ZOmod_lt_pos_pos a b); + 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 new file mode 100644 index 00000000..2c84765e --- /dev/null +++ b/theories/ZArith/ZOdiv_def.v @@ -0,0 +1,136 @@ +(************************************************************************) +(* 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 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) {struct a} : 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/Zabs.v b/theories/ZArith/Zabs.v index ed641358..c15493e3 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -5,14 +5,16 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zabs.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: Zabs.v 10302 2007-11-08 09:54:31Z letouzey $ i*) -(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) +(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) Require Import Arith_base. Require Import BinPos. Require Import BinInt. Require Import Zorder. +Require Import Zmax. +Require Import Znat. Require Import ZArith_dec. Open Local Scope Z_scope. @@ -63,6 +65,11 @@ 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; @@ -70,6 +77,13 @@ Proof. (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. @@ -106,25 +120,106 @@ Proof. intros z1 z2; case z1; case z2; simpl in |- *; auto. Qed. -(** * Absolute value in nat is compatible with order *) +Theorem Zabs_square : forall a, Zabs a * Zabs a = a * a. +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 /\ n < m -> (Zabs_nat n < Zabs_nat m)%nat. + 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. +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. - intros x y. case x; simpl in |- *. case y; simpl in |- *. + destruct a; simpl; auto. +Qed. - intro. absurd (0 < 0). compute in |- *. intro H0. discriminate H0. intuition. - intros. elim (ZL4 p). intros. rewrite H0. auto with arith. - intros. elim (ZL4 p). intros. rewrite H0. auto with arith. - - case y; simpl in |- *. - intros. absurd (Zpos p < 0). compute in |- *. intro H0. discriminate H0. intuition. - intros. change (nat_of_P p > nat_of_P p0)%nat in |- *. - apply nat_of_P_gt_Gt_compare_morphism. - elim H; auto with arith. intro. exact (ZC2 p0 p). +(** A characterization of the sign function: *) - intros. absurd (Zpos p0 < Zneg p). - compute in |- *. intro H0. discriminate H0. intuition. +Lemma Zsgn_spec : forall x:Z, + 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. +Qed. - intros. absurd (0 <= Zneg p). compute in |- *. auto with arith. intuition. +Lemma Zsgn_pos : forall x:Z, Zsgn x = 1 <-> 0 < x. +Proof. + destruct x; now intuition. Qed. + +Lemma Zsgn_neg : forall x:Z, Zsgn x = -1 <-> x < 0. +Proof. + destruct x; now intuition. +Qed. + +Lemma Zsgn_null : forall x:Z, Zsgn x = 0 <-> x = 0. +Proof. + destruct x; now intuition. +Qed. + diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index 7da91c44..34114d46 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zbool.v 9245 2006-10-17 12:53:34Z notin $ *) +(* $Id: Zbool.v 10063 2007-08-08 14:21:03Z emakarov $ *) Require Import BinInt. Require Import Zeven. @@ -104,7 +104,7 @@ Qed. Lemma Zle_bool_imp_le : forall n m:Z, Zle_bool n m = true -> (n <= m)%Z. Proof. - unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *. + unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *. case (x ?= y)%Z; intros; discriminate. Qed. @@ -178,6 +178,18 @@ Proof. intro. apply Zle_ge. apply Zle_bool_imp_le. assumption. Qed. +Lemma Zlt_is_lt_bool : forall n m:Z, (n < m)%Z <-> Zlt_bool n m = true. +Proof. +intros n m; unfold Zlt_bool, Zlt. +destruct (n ?= m)%Z; simpl; split; now intro. +Qed. + +Lemma Zgt_is_gt_bool : forall n m:Z, (n > m)%Z <-> Zgt_bool n m = true. +Proof. +intros n m; unfold Zgt_bool, Zgt. +destruct (n ?= m)%Z; simpl; split; now intro. +Qed. + Lemma Zlt_is_le_bool : forall n m:Z, (n < m)%Z <-> Zle_bool n (m - 1) = true. Proof. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index 78c8a976..c6ade934 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zcomplements.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Zcomplements.v 10617 2008-03-04 18:07:16Z letouzey $ i*) Require Import ZArithRing. Require Import ZArith_base. -Require Import Omega. +Require Export Omega. Require Import Wf_nat. Open Local Scope Z_scope. @@ -160,7 +160,7 @@ Qed. Require Import List. -Fixpoint Zlength_aux (acc:Z) (A:Set) (l:list A) {struct l} : Z := +Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) {struct l} : Z := match l with | nil => acc | _ :: l => Zlength_aux (Zsucc acc) A l @@ -171,7 +171,7 @@ Implicit Arguments Zlength [A]. Section Zlength_properties. - Variable A : Set. + Variable A : Type. Implicit Type l : list A. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 31f68207..4c560c6b 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zdiv.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Zdiv.v 10999 2008-05-27 15:55:22Z letouzey $ i*) -(* Contribution by Claude Marché and Xavier Urbain *) +(* Contribution by Claude Marché and Xavier Urbain *) (** Euclidean Division @@ -21,6 +21,7 @@ Require Import Zbool. Require Import Omega. Require Import ZArithRing. Require Import Zcomplements. +Require Export Setoid. Open Local Scope Z_scope. (** * Definitions of Euclidian operations *) @@ -70,8 +71,21 @@ Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : 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|. + smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when + r is not null). +*) + +(* 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. + + * 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). + * 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 := @@ -96,7 +110,7 @@ Definition Zdiv_eucl (a b:Z) : Z * Z := (** 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. @@ -108,20 +122,20 @@ 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). -Eval Compute in `(Zdiv_eucl (-7) 3)`. +Eval compute in (Zdiv_eucl (-7) 3). -Eval Compute in `(Zdiv_eucl 7 (-3))`. +Eval compute in (Zdiv_eucl 7 (-3)). -Eval Compute in `(Zdiv_eucl (-7) (-3))`. +Eval compute in (Zdiv_eucl (-7) (-3)). *) (** * Main division theorem *) -(** First a lemma for positive *) +(** First a lemma for two positive arguments *) Lemma Z_div_mod_POS : forall b:Z, @@ -129,7 +143,8 @@ Lemma Z_div_mod_POS : forall a:positive, let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b. Proof. -simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *. +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)). @@ -147,6 +162,7 @@ case (Zge_bool b 2); (intros; split; [ try ring | omega ]). omega. Qed. +(** Then the usual situation of a positive [b] and no restriction on [a] *) Theorem Z_div_mod : forall a b:Z, @@ -166,27 +182,131 @@ Proof. intros [H1 H2]. split; trivial. - replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ]. + change (Zneg p0) with (- Zpos p0); rewrite H1; ring. intros p1 [H1 H2]. split; trivial. - replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ]. + change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zgt_pos_0 p1); omega. intros p1 [H1 H2]. split; trivial. - replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ]. + change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zlt_neg_0 p1); omega. intros; discriminate. Qed. -(** Existence theorems *) +(** For stating the fully general result, let's give a short name + to the condition on the remainder. *) -Theorem Zdiv_eucl_exist : - forall b:Z, - b > 0 -> - forall a:Z, {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}. +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. + +(* 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. *) + +Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. +Proof. + intros; unfold Remainder, Remainder_alt; omega with *. +Qed. + +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. +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 *. +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. +Proof. + unfold Zmod; intros a b Hb; generalize (Z_div_mod a b Hb). + destruct Zdiv_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_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_div_mod_eq : forall a b:Z, b > 0 -> a = b*(a/b) + (a mod b). +Proof. + intros; apply Z_div_mod_eq_full; 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 : 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. + +(** Existence theorem *) + +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). @@ -195,70 +315,180 @@ Qed. Implicit Arguments Zdiv_eucl_exist. -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}. + +(** Uniqueness theorems *) + +Theorem Zdiv_mod_unique : + forall b q1 q2 r1 r2:Z, + 0 <= r1 < Zabs b -> 0 <= r2 < Zabs b -> + b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. 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 ]. - cut (- b > 0); [ intro Hb'' | omega ]. - elim (Zdiv_eucl_exist Hb'' a); intros qr. - elim qr; intros q r Hqr. - exists (- q, r). - elim Hqr; intros. - split. - rewrite <- Zmult_opp_comm; assumption. - rewrite Zabs_non_eq; [ assumption | omega ]. +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. -Implicit Arguments Zdiv_eucl_extended. +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. -(** * Auxiliary lemmas about [Zdiv] and [Zmod] *) +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. -Lemma Z_div_mod_eq : forall a b:Z, b > 0 -> a = b * Zdiv a b + Zmod a b. +Theorem Zdiv_unique: + forall a b q r, 0 <= r < b -> + a = b*q + r -> q = a/b. Proof. - unfold Zdiv, Zmod in |- *. - intros a b Hb. - generalize (Z_div_mod a b Hb). - case Zdiv_eucl; tauto. + intros; eapply Zdiv_unique_full; eauto. Qed. -Lemma Z_mod_lt : forall a b:Z, b > 0 -> 0 <= Zmod a b < b. +Theorem Zmod_unique_full: + forall a b q r, Remainder r b -> + a = b*q + r -> r = a mod b. Proof. - unfold Zmod in |- *. - intros a b Hb. - generalize (Z_div_mod a b Hb). - case (Zdiv_eucl a b); tauto. + 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. -Lemma Z_div_POS_ge0 : - forall (b:Z) (a:positive), let (q, _) := Zdiv_eucl_POS a b in q >= 0. +Theorem Zmod_unique: + forall a b q r, 0 <= r < b -> + a = b*q + r -> r = a mod b. Proof. - simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *. - intro p; case (Zdiv_eucl_POS p b). - intros; case (Zgt_bool b (2 * z0 + 1)); intros; omega. - intro p; case (Zdiv_eucl_POS p b). - intros; case (Zgt_bool b (2 * z0)); intros; omega. - case (Zge_bool b 2); simpl in |- *; omega. + intros; eapply Zmod_unique_full; eauto. Qed. -Lemma Z_div_ge0 : forall a b:Z, b > 0 -> a >= 0 -> Zdiv a b >= 0. +(** * Basic values of divisions and modulo. *) + +Lemma Zmod_0_l: forall a, 0 mod a = 0. Proof. - intros a b Hb; unfold Zdiv, Zdiv_eucl in |- *; case a; simpl in |- *; intros. - case b; simpl in |- *; trivial. - generalize Hb; case b; try trivial. - auto with zarith. - intros p0 Hp0; generalize (Z_div_POS_ge0 (Zpos p0) p). - case (Zdiv_eucl_POS p (Zpos p0)); simpl in |- *; tauto. - intros; discriminate. - elim H; trivial. + destruct a; simpl; auto. +Qed. + +Lemma Zmod_0_r: forall a, a mod 0 = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zdiv_0_l: forall a, 0/a = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zdiv_0_r: forall a, a/0 = 0. +Proof. + destruct a; simpl; auto. +Qed. + +Lemma Zmod_1_r: forall a, a mod 1 = 0. +Proof. + intros; symmetry; apply Zmod_unique with a; auto with zarith. Qed. -Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> Zdiv a b < a. +Lemma Zdiv_1_r: forall a, a/1 = a. +Proof. + intros; symmetry; apply Zdiv_unique with 0; auto with zarith. +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. + +Lemma Zmod_1_l: forall a, 1 < a -> 1 mod a = 1. +Proof. + intros; symmetry; apply Zmod_unique with 0; auto with zarith. +Qed. + +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. + +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. + +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. + +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. + +(** * 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. + +Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0. +Proof. + intros; generalize (Z_div_pos a b H); auto with zarith. +Qed. + +(** As soon as the divisor is greater or equal than 2, + 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). @@ -271,9 +501,24 @@ Proof. auto with zarith. Qed. -(** * Other lemmas (now using the syntax for [Zdiv] and [Zmod]). *) -Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a / c >= b / c. +(** 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. + +(** 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. + +(** [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). @@ -285,13 +530,8 @@ Proof. intro. absurd (b - a >= 1). omega. - rewrite H0. - rewrite H2. - assert - (c * (b / c) + b mod c - (c * (a / c) + a mod c) = - c * (b / c - a / c) + b mod c - a mod c). - ring. - rewrite H3. + 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. @@ -301,111 +541,639 @@ Proof. omega. Qed. -Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c. +(** 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 cPos. - generalize (Z_div_mod_eq a c cPos). - generalize (Z_mod_lt a c cPos). - generalize (Z_div_mod_eq (a + b * c) c cPos). - generalize (Z_mod_lt (a + b * c) c cPos). - intros. + intros a b c H H0. + apply Zge_le. + apply Z_div_ge; auto with *. +Qed. - assert ((a + b * c) mod c - a mod c = c * (b + a / c - (a + b * c) / c)). - replace ((a + b * c) mod c) with (a + b * c - c * ((a + b * c) / c)). - replace (a mod c) with (a - c * (a / c)). - ring. - omega. - omega. - set (q := b + a / c - (a + b * c) / c) in *. - apply (Zcase_sign q); intros. - assert (c * q = 0). - rewrite H4; ring. - rewrite H5 in H3. - omega. +(** With our choice of division, rounding of (a/b) is always done toward bottom: *) - assert (c * q >= c). - pattern c at 2 in |- *; replace c with (c * 1). - apply Zmult_ge_compat_l; omega. - ring. - omega. +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. + +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. + +(** 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. + +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. + +(** 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. + +(** Some additionnal inequalities about Zdiv. *) + +Theorem Zdiv_le_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_le_reg_r with b; auto with zarith. + apply Zle_trans with (2 := H3). + 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. + +Theorem Zdiv_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 (Z_div_mod_eq a b); auto with zarith. + rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. +Qed. + +Theorem Zdiv_le_lower_bound: + forall a b q, 0 <= a -> 0 < b -> q*b <= a -> q <= a/b. +Proof. + intros a b q H1 H2 H3. + assert (q < a / b + 1); auto with zarith. + apply Zmult_lt_reg_r with b; auto with zarith. + apply Zle_lt_trans with (1 := H3). + pattern a at 1; rewrite (Z_div_mod_eq a b); auto with zarith. + rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (Z_mod_lt a b); + auto with zarith. +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. + +Theorem Zdiv_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; + generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; + destruct Zdiv_eucl_POS 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. + +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. + +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. - assert (c * q <= - c). - replace (- c) with (c * -1). - apply Zmult_le_compat_l; omega. +(** [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. + +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. + +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. - omega. Qed. -Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b. +Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> + (-a) mod b = b - (a mod b). Proof. - intros a b c cPos. - generalize (Z_div_mod_eq a c cPos). - generalize (Z_mod_lt a c cPos). - generalize (Z_div_mod_eq (a + b * c) c cPos). - generalize (Z_mod_lt (a + b * c) c cPos). intros. - apply Zmult_reg_l with c. omega. - replace (c * ((a + b * c) / c)) with (a + b * c - (a + b * c) mod c). - rewrite (Z_mod_plus a b c cPos). - pattern a at 1 in |- *; rewrite H2. - ring. - pattern (a + b * c) at 1 in |- *; rewrite H0. - ring. + 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. -Lemma Z_div_mult : forall a b:Z, b > 0 -> a * b / b = a. - intros; replace (a * b) with (0 + a * b); auto. - rewrite Z_div_plus; auto. +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. -Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b * (a / b) <= a. +Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> + a mod (-b) = (a mod b) - b. Proof. - intros a b bPos. - generalize (Z_div_mod_eq a _ bPos); intros. - generalize (Z_mod_lt a _ bPos); intros. - pattern a at 2 in |- *; rewrite H. - omega. + intros. + pattern a at 1; rewrite <- (Zopp_involutive a). + rewrite Zmod_opp_opp. + rewrite Z_mod_nz_opp_full; auto; omega. +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. -Lemma Z_mod_same : forall a:Z, a > 0 -> a mod a = 0. +Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> + (-a)/b = -(a/b)-1. Proof. - intros a aPos. - generalize (Z_mod_plus 0 1 a aPos). - replace (0 + 1 * a) with a. intros. - rewrite H. - compute in |- *. - trivial. - ring. + 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. + +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. + +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. + +(** Cancellations. *) + +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. -Lemma Z_div_same : forall a:Z, a > 0 -> a / a = 1. +Lemma Zdiv_mult_cancel_l : forall a b c:Z, + c<>0 -> (c*a)/(c*b) = a/b. Proof. - intros a aPos. - generalize (Z_div_plus 0 1 a aPos). - replace (0 + 1 * a) with a. intros. - rewrite H. - compute in |- *. - trivial. + rewrite (Zmult_comm c a); rewrite (Zmult_comm c b). + apply Zdiv_mult_cancel_r; 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. Qed. -Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b * (a / b) -> a mod b = 0. - intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *. - case (Zdiv_eucl a b); intros q r; omega. +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. +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. + +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. -Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b * (a / b). - intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *. - case (Zdiv_eucl a b); intros q r; omega. +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. -Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> - a mod b = 0. - intros a b Hb. +Theorem Zminus_mod: forall a b n, + (a - b) mod n = (a mod n - b mod n) mod n. +Proof. intros. - rewrite Z_div_exact_2 with a b; auto. - replace (- (b * (a / b))) with (0 + - (a / b) * b). - rewrite Z_mod_plus; auto. + replace (a - b) with (a + (-1) * b); auto with zarith. + replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith. + rewrite Zplus_mod. + rewrite Zmult_mod. + rewrite Zplus_mod with (b:=(-1) * (b mod n)). + rewrite Zmult_mod. + rewrite Zmult_mod with (b:= b mod n). + repeat rewrite Zmod_mod; auto. +Qed. + +Lemma Zplus_mod_idemp_l: forall a b n, (a mod n + b) mod n = (a + b) mod n. +Proof. + intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto. +Qed. + +Lemma Zplus_mod_idemp_r: forall a b n, (b + a mod n) mod n = (b + a) mod n. +Proof. + intros; rewrite Zplus_mod, Zmod_mod, <- Zplus_mod; auto. +Qed. + +Lemma Zminus_mod_idemp_l: forall a b n, (a mod n - b) mod n = (a - b) mod n. +Proof. + intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto. +Qed. + +Lemma Zminus_mod_idemp_r: forall a b n, (a - b mod n) mod n = (a - b) mod n. +Proof. + intros; rewrite Zminus_mod, Zmod_mod, <- Zminus_mod; auto. +Qed. + +Lemma Zmult_mod_idemp_l: forall a b n, (a mod n * b) mod n = (a * b) mod n. +Proof. + intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. +Qed. + +Lemma Zmult_mod_idemp_r: forall a b n, (b * (a mod n)) mod n = (b * a) mod n. +Proof. + intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. +Qed. + +(** For a specific number n, equality modulo n is hence a nice setoid + equivalence, compatible with the usual operations. Due to restrictions + with Coq setoids, we cannot state this in a section, but it works + at least with a module. *) + +Module Type SomeNumber. + Parameter n:Z. +End SomeNumber. + +Module EqualityModulo (M:SomeNumber). + + Definition eqm a b := (a mod M.n = b mod M.n). + Infix "==" := eqm (at level 70). + + Lemma eqm_refl : forall a, a == a. + Proof. unfold eqm; auto. Qed. + + Lemma eqm_sym : forall a b, a == b -> b == a. + Proof. unfold eqm; auto. Qed. + + Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. + Proof. unfold eqm; eauto with *. Qed. + + Add Relation Z eqm + reflexivity proved by eqm_refl + symmetry proved by eqm_sym + transitivity proved by eqm_trans as eqm_setoid. + + Add Morphism Zplus : Zplus_eqm. + Proof. + unfold eqm; intros; rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. + Qed. + + Add Morphism Zminus : Zminus_eqm. + Proof. + unfold eqm; intros; rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. + Qed. + + Add Morphism Zmult : Zmult_eqm. + Proof. + unfold eqm; intros; rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. + Qed. + + Add Morphism Zopp : Zopp_eqm. + Proof. + intros; change (-x == -y) with (0-x == 0-y). + rewrite H; red; auto. + Qed. + + Lemma Zmod_eqm : forall a, a mod M.n == a. + Proof. + unfold eqm; intros; apply Zmod_mod. + Qed. + + (* Zmod and Zdiv are not full morphisms with respect to eqm. + For instance, take n=2. Then 3 == 1 but we don't have + 1 mod 3 == 1 mod 1 nor 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. +Qed. + +(** Unfortunately, the previous result isn't always true on negative numbers. + For instance: 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) *) + +(** A last inequality: *) + +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. + +(** 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 *. +Qed. + +(** * Compatibility *) + +(** Weaker results kept only for compatibility *) + +Lemma Z_mod_same : forall a, a > 0 -> a mod a = 0. +Proof. + intros; apply Z_mod_same_full. +Qed. + +Lemma Z_div_same : forall a, a > 0 -> a/a = 1. +Proof. + intros; apply Z_div_same_full; auto with zarith. +Qed. + +Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b. +Proof. + intros; apply Z_div_plus_full; auto with zarith. +Qed. + +Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a. +Proof. + intros; apply Z_div_mult_full; auto with zarith. Qed. + +Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c. +Proof. + intros; apply Z_mod_plus_full; auto with zarith. +Qed. + +Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b*(a/b) -> a mod b = 0. +Proof. + intros; apply Z_div_exact_full_1; auto with zarith. +Qed. + +Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b). +Proof. + intros; apply Z_div_exact_full_2; auto with zarith. +Qed. + +Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0. +Proof. + intros; apply Z_mod_zero_opp_full; auto with zarith. +Qed. + +(** * A direct way to compute Zmod *) + +Fixpoint Zmod_POS (a : positive) (b : Z) {struct a} : Z := + match a with + | 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) + | 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 + end. + +Definition Zmod' a b := + match a with + | Z0 => 0 + | Zpos a' => + match b with + | Z0 => 0 + | Zpos _ => Zmod_POS a' b + | Zneg b' => + let r := Zmod_POS a' (Zpos b') in + match r with Z0 => 0 | _ => b + r end + end + | Zneg a' => + match b with + | Z0 => 0 + | Zpos _ => + let r := Zmod_POS a' b in + match r with Z0 => 0 | _ => b - r end + | Zneg b' => - (Zmod_POS a' (Zpos b')) + end + end. + + +Theorem Zmod_POS_correct: forall a b, Zmod_POS a b = (snd (Zdiv_eucl_POS 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. +Qed. + +Theorem Zmod'_correct: forall a b, Zmod' a b = Zmod a b. +Proof. + intros a b; unfold Zmod; 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. + 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. + intros p1; rewrite Zmod_POS_correct; simpl; auto. + case (Zdiv_eucl_POS p (Zpos p1)); auto. +Qed. + + +(** Another convention is possible for division by negative numbers: + * quotient is always the biggest integer smaller than or equal to a/b + * remainder is hence always positive or null. *) + +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}. +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 ]. + cut (- b > 0); [ intro Hb'' | omega ]. + elim (Zdiv_eucl_exist Hb'' a); intros qr. + elim qr; intros q r Hqr. + exists (- q, r). + elim Hqr; intros. + split. + rewrite <- Zmult_opp_comm; assumption. + rewrite Zabs_non_eq; [ assumption | omega ]. +Qed. + +Implicit Arguments Zdiv_eucl_extended. + +(** A third convention: Ocaml. + + See files ZOdiv_def.v and ZOdiv.v. + + 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). +*) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 6fab4461..4a402c61 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -6,10 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zeven.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Zeven.v 10291 2007-11-06 02:18:53Z letouzey $ i*) Require Import BinInt. +Open Scope Z_scope. + (*******************************************************************) (** About parity: even and odd predicates on Z, division by 2 on Z *) @@ -135,14 +137,14 @@ Hint Unfold Zeven Zodd: zarith. Definition Zdiv2 (z:Z) := match z with - | Z0 => 0%Z - | Zpos xH => 0%Z + | Z0 => 0 + | Zpos xH => 0 | Zpos p => Zpos (Pdiv2 p) - | Zneg xH => 0%Z + | Zneg xH => 0 | Zneg p => Zneg (Pdiv2 p) end. -Lemma Zeven_div2 : forall n:Z, Zeven n -> n = (2 * Zdiv2 n)%Z. +Lemma Zeven_div2 : forall n:Z, Zeven n -> n = 2 * Zdiv2 n. Proof. intro x; destruct x. auto with arith. @@ -154,27 +156,27 @@ Proof. intros. absurd (Zeven (-1)); red in |- *; auto with arith. Qed. -Lemma Zodd_div2 : forall n:Z, (n >= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n + 1)%Z. +Lemma Zodd_div2 : forall n:Z, n >= 0 -> Zodd n -> n = 2 * Zdiv2 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)%Z; red in |- *; auto with arith. + intros. absurd (Zneg p >= 0); red in |- *; auto with arith. Qed. Lemma Zodd_div2_neg : - forall n:Z, (n <= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n - 1)%Z. + forall n:Z, n <= 0 -> Zodd n -> n = 2 * Zdiv2 n - 1. Proof. intro x; destruct x. intros. absurd (Zodd 0); red in |- *; auto with arith. - intros. absurd (Zneg p >= 0)%Z; 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. Qed. Lemma Z_modulo_2 : - forall n:Z, {y : Z | n = (2 * y)%Z} + {y : Z | n = (2 * y + 1)%Z}. + forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. Proof. intros x. elim (Zeven_odd_dec x); intro. @@ -193,7 +195,7 @@ Qed. Lemma Zsplit2 : forall n:Z, {p : Z * Z | - let (x1, x2) := p in n = (x1 + x2)%Z /\ (x1 = x2 \/ x2 = (x1 + 1)%Z)}. + let (x1, x2) := p in n = x1 + x2 /\ (x1 = x2 \/ x2 = x1 + 1)}. Proof. intros x. elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy; @@ -206,3 +208,109 @@ Proof. right; reflexivity. Qed. + +Theorem Zeven_ex: forall n, Zeven n -> exists m, n = 2 * m. +Proof. + intro n; exists (Zdiv2 n); apply Zeven_div2; auto. +Qed. + +Theorem Zodd_ex: forall n, Zodd n -> exists m, n = 2 * m + 1. +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). +Qed. + +Theorem Zeven_2p: forall p, Zeven (2 * p). +Proof. + destruct p; simpl; auto. +Qed. + +Theorem Zodd_2p_plus_1: forall p, Zodd (2 * p + 1). +Proof. + destruct p; simpl; auto. + destruct p; simpl; auto. +Qed. + +Theorem Zeven_plus_Zodd: forall a b, + Zeven a -> Zodd b -> Zodd (a + b). +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. +Qed. + +Theorem Zeven_plus_Zeven: forall a b, + Zeven a -> Zeven b -> Zeven (a + b). +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. +Qed. + +Theorem Zodd_plus_Zeven: forall a b, + Zodd a -> Zeven b -> Zodd (a + b). +Proof. + intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto. +Qed. + +Theorem Zodd_plus_Zodd: forall a b, + Zodd a -> Zodd b -> Zeven (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 * (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. +Qed. + +Theorem Zeven_mult_Zeven_l: forall a b, + Zeven a -> Zeven (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. +Qed. + +Theorem Zeven_mult_Zeven_r: forall a b, + 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. +Qed. + +Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l + Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand. + +Theorem Zodd_mult_Zodd: forall 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. +Qed. + +(* for compatibility *) +Close Scope Z_scope. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v new file mode 100644 index 00000000..286dd710 --- /dev/null +++ b/theories/ZArith/Zgcd_alt.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 *) +(************************************************************************) + +(*i $Id: Zgcd_alt.v 10997 2008-05-27 15:16:40Z letouzey $ i*) + +(** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *) + +(** +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 + here due to both its intrinsic interest and its use as reference + point when proving gcd on Int31 numbers *) + +Require Import ZArith_base. +Require Import ZArithRing. +Require Import Zdiv. +Require Import Znumtheory. + +Open Scope Z_scope. + +(** In Coq, we need to control the number of iteration of modulo. + For that, we use an explicit measure in [nat], and we prove later + that using [2*d] is enough, where [d] is the number of binary + digits of the first argument. *) + + Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b => + match n with + | O => 1 (* arbitrary, since n should be big enough *) + | S n => match a with + | Z0 => Zabs b + | Zpos _ => Zgcdn n (Zmod b a) a + | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a) + end + end. + + Definition Zgcd_bound (a:Z) := + match a with + | Z0 => S O + | Zpos p => let n := Psize p in (n+n)%nat + | Zneg p => let n := Psize p in (n+n)%nat + end. + + Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b. + + (** A first obvious fact : [Zgcd a b] is positive. *) + + Lemma Zgcdn_pos : forall n a b, + 0 <= Zgcdn n a b. + Proof. + induction n. + simpl; auto with zarith. + destruct a; simpl; intros; auto with zarith; auto. + Qed. + + Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b. + Proof. + intros; unfold Zgcd; apply Zgcdn_pos; auto. + Qed. + + (** We now prove that Zgcd is indeed a gcd. *) + + (** 1) We prove a weaker & easier bound. *) + + Lemma Zgcdn_linear_bound : forall n a b, + Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b). + Proof. + induction n. + simpl; intros. + elimtype False; generalize (Zabs_pos a); omega. + destruct a; intros; simpl; + [ generalize (Zis_gcd_0_abs b); intuition | | ]; + unfold Zmod; + generalize (Z_div_mod b (Zpos p) (refl_equal Gt)); + destruct (Zdiv_eucl b (Zpos p)) as (q,r); + intros (H0,H1); + rewrite inj_S in H; simpl Zabs in H; + (assert (H2: Zabs r < Z_of_nat n) by + (rewrite Zabs_eq; auto with zarith)); + assert (IH:=IHn r (Zpos p) H2); clear IHn; + simpl in IH |- *; + rewrite H0. + apply Zis_gcd_for_euclid2; auto. + apply Zis_gcd_minus; apply Zis_gcd_sym. + apply Zis_gcd_for_euclid2; auto. + Qed. + + (** 2) For Euclid's algorithm, the worst-case situation corresponds + to Fibonacci numbers. Let's define them: *) + + Fixpoint fibonacci (n:nat) : Z := + match n with + | O => 1 + | S O => 1 + | S (S n as p) => fibonacci p + fibonacci n + end. + + Lemma fibonacci_pos : forall n, 0 <= fibonacci n. + Proof. + cut (forall N n, (n<N)%nat -> 0<=fibonacci n). + eauto. + induction N. + inversion 1. + intros. + destruct n. + simpl; auto with zarith. + destruct n. + simpl; auto with zarith. + change (0 <= fibonacci (S n) + fibonacci n). + generalize (IHN n) (IHN (S n)); omega. + Qed. + + Lemma fibonacci_incr : + forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. + Proof. + induction 1. + auto with zarith. + apply Zle_trans with (fibonacci m); auto. + clear. + destruct m. + simpl; auto with zarith. + change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). + generalize (fibonacci_pos m); omega. + Qed. + + (** 3) We prove that fibonacci numbers are indeed worst-case: + for a given number [n], if we reach a conclusion about [gcd(a,b)] in + exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *) + + Lemma Zgcdn_worst_is_fibonacci : forall n a b, + 0 < a < b -> + Zis_gcd a b (Zgcdn (S n) a b) -> + Zgcdn n a b <> Zgcdn (S n) a b -> + fibonacci (S n) <= a /\ + fibonacci (S (S n)) <= b. + Proof. + induction n. + simpl; intros. + destruct a; omega. + intros. + destruct a; [simpl in *; omega| | destruct H; discriminate]. + revert H1; revert H0. + set (m:=S n) in *; (assert (m=S n) by auto); clearbody m. + pattern m at 2; rewrite H0. + simpl Zgcdn. + unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). + destruct (Zdiv_eucl b (Zpos p)) as (q,r). + intros (H1,H2). + destruct H2. + destruct (Zle_lt_or_eq _ _ H2). + generalize (IHn _ _ (conj H4 H3)). + intros H5 H6 H7. + replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto. + assert (r = Zpos p * (-q) + b) by (rewrite H1; ring). + destruct H5; auto. + pattern r at 1; rewrite H8. + apply Zis_gcd_sym. + apply Zis_gcd_for_euclid2; auto. + apply Zis_gcd_sym; auto. + split; auto. + rewrite H1. + apply Zplus_le_compat; auto. + apply Zle_trans with (Zpos p * 1); auto. + ring_simplify (Zpos p * 1); auto. + apply Zmult_le_compat_l. + destruct q. + omega. + assert (0 < Zpos p0) by (compute; auto). + omega. + assert (Zpos p * Zneg p0 < 0) by (compute; auto). + omega. + compute; intros; discriminate. + (* r=0 *) + subst r. + simpl; rewrite H0. + intros. + simpl in H4. + simpl in H5. + destruct n. + simpl in H5. + simpl. + omega. + simpl in H5. + elim H5; auto. + Qed. + + (** 3b) We reformulate the previous result in a more positive way. *) + + Lemma Zgcdn_ok_before_fibonacci : forall n a b, + 0 < a < b -> a < fibonacci (S n) -> + Zis_gcd a b (Zgcdn n a b). + Proof. + destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate]. + cut (forall k n b, + k = (S (nat_of_P p) - n)%nat -> + 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> + Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)). + destruct 2; eauto. + clear n; induction k. + intros. + assert (nat_of_P p < n)%nat by omega. + apply Zgcdn_linear_bound. + simpl. + generalize (inj_le _ _ H2). + rewrite inj_S. + rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto. + omega. + intros. + generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros. + assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)). + apply IHk; auto. + omega. + replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto. + generalize (fibonacci_pos n); omega. + replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. + generalize (H2 H3); clear H2 H3; omega. + Qed. + + (** 4) The proposed bound leads to a fibonacci number that is big enough. *) + + Lemma Zgcd_bound_fibonacci : + forall a, 0 < a -> a < fibonacci (Zgcd_bound a). + Proof. + destruct a; [omega| | intro H; discriminate]. + intros _. + induction p; [ | | compute; auto ]; + simpl Zgcd_bound in *; + rewrite plus_comm; simpl plus; + set (n:= (Psize p+Psize p)%nat) in *; simpl; + assert (n <> O) by (unfold n; destruct p; simpl; auto). + + destruct n as [ |m]; [elim H; auto| ]. + generalize (fibonacci_pos m); rewrite Zpos_xI; omega. + + destruct n as [ |m]; [elim H; auto| ]. + generalize (fibonacci_pos m); rewrite Zpos_xO; omega. + Qed. + + (* 5) the end: we glue everything together and take care of + situations not corresponding to [0<a<b]. *) + + Lemma Zgcdn_is_gcd : + forall n a b, (Zgcd_bound a <= n)%nat -> + Zis_gcd a b (Zgcdn n a b). + Proof. + destruct a; intros. + simpl in H. + destruct n; [elimtype False; omega | ]. + simpl; generalize (Zis_gcd_0_abs b); intuition. + (*Zpos*) + generalize (Zgcd_bound_fibonacci (Zpos p)). + simpl Zgcd_bound in *. + remember (Psize p+Psize p)%nat as m. + assert (1 < m)%nat. + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + auto with arith. + destruct m as [ |m]; [inversion H0; auto| ]. + destruct n as [ |n]; [inversion H; auto| ]. + simpl Zgcdn. + unfold Zmod. + generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). + destruct (Zdiv_eucl b (Zpos p)) as (q,r). + intros (H2,H3) H4. + rewrite H2. + apply Zis_gcd_for_euclid2. + destruct H3. + destruct (Zle_lt_or_eq _ _ H1). + apply Zgcdn_ok_before_fibonacci; auto. + apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto]. + subst r; simpl. + destruct m as [ |m]; [elimtype False; omega| ]. + destruct n as [ |n]; [elimtype False; omega| ]. + simpl; apply Zis_gcd_sym; apply Zis_gcd_0. + (*Zneg*) + generalize (Zgcd_bound_fibonacci (Zpos p)). + simpl Zgcd_bound in *. + remember (Psize p+Psize p)%nat as m. + assert (1 < m)%nat. + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + auto with arith. + destruct m as [ |m]; [inversion H0; auto| ]. + destruct n as [ |n]; [inversion H; auto| ]. + simpl Zgcdn. + unfold Zmod. + generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). + destruct (Zdiv_eucl b (Zpos p)) as (q,r). + intros (H1,H2) H3. + rewrite H1. + apply Zis_gcd_minus. + apply Zis_gcd_sym. + apply Zis_gcd_for_euclid2. + destruct H2. + destruct (Zle_lt_or_eq _ _ H2). + apply Zgcdn_ok_before_fibonacci; auto. + apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto]. + subst r; simpl. + destruct m as [ |m]; [elimtype False; omega| ]. + destruct n as [ |n]; [elimtype False; omega| ]. + simpl; apply Zis_gcd_sym; apply Zis_gcd_0. + Qed. + + Lemma Zgcd_is_gcd : + forall a b, Zis_gcd a b (Zgcd_alt a b). + Proof. + unfold Zgcd_alt; intros; apply Zgcdn_is_gcd; auto. + Qed. + + diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index 8af9b891..0d6fc94a 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmax.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: Zmax.v 10291 2007-11-06 02:18:53Z letouzey $ i*) Require Import Arith_base. Require Import BinInt. @@ -38,6 +38,28 @@ Proof. destruct (n ?= m); (apply H1|| apply H2); discriminate. Qed. +Lemma Zmax_spec : forall x y:Z, + x >= y /\ Zmax x y = x \/ + x < y /\ Zmax x y = y. +Proof. + intros; unfold Zmax, Zlt, Zge. + destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate. +Qed. + +Lemma Zmax_left : forall n m:Z, n>=m -> Zmax n m = n. +Proof. + intros n m; unfold Zmax, Zge; destruct (n ?= m); auto. + intro H; elim H; auto. +Qed. + +Lemma Zmax_right : forall n m:Z, n<=m -> Zmax n m = m. +Proof. + intros n m; unfold Zmax, Zle. + generalize (Zcompare_Eq_eq n m). + destruct (n ?= m); auto. + intros _ H; elim H; auto. +Qed. + (** * Least upper bound properties of max *) Lemma Zle_max_l : forall n m:Z, n <= Zmax n m. @@ -106,3 +128,39 @@ Proof. rewrite (Zcompare_plus_compat x y n). case (x ?= y); apply Zplus_comm. Qed. + +(** * Maximum and Zpos *) + +Lemma Zpos_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 Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p. +Proof. + intros; unfold Zmax; simpl; destruct p; simpl; auto. +Qed. + +(** * 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. + case_eq (Pcompare p q Eq). + intros H; rewrite (Pcompare_Eq_eq _ _ H). + rewrite Zminus_diag. + unfold Zmax; simpl. + unfold Pminus; rewrite Pminus_mask_diag; auto. + intros; rewrite Pminus_Lt; auto. + destruct (Zmax_spec 1 (Zpos p - Zpos q)) as [(H1,H2)|(H1,H2)]; auto. + elimtype False; clear H2. + assert (H1':=Zlt_trans 0 1 _ Zlt_0_1 H1). + generalize (Zlt_0_minus_lt _ _ H1'). + unfold Zlt; simpl. + rewrite (ZC2 _ _ H); intro; discriminate. + intros; simpl; rewrite H. + symmetry; apply Zpos_max_1. +Qed. + diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index 37d78a74..bad40a32 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -5,9 +5,9 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmin.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: Zmin.v 10028 2007-07-18 22:38:06Z letouzey $ i*) -(** Initial version from Pierre Crégut (CNET, Lannion, France), 1996. +(** Initial version from Pierre Crégut (CNET, Lannion, France), 1996. Further extensions by the Coq development team, with suggestions from Russell O'Connor (Radbout U., Nijmegen, The Netherlands). *) @@ -43,6 +43,14 @@ Proof. intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith. Qed. +Lemma Zmin_spec : forall x y:Z, + x <= y /\ Zmin x y = x \/ + x > y /\ Zmin x y = y. +Proof. + intros; unfold Zmin, Zle, Zgt. + destruct (Zcompare x y); [ left | left | right ]; split; auto; discriminate. +Qed. + (** * Greatest lower bound properties of min *) Lemma Zle_min_l : forall n m:Z, Zmin n m <= n. @@ -128,3 +136,11 @@ Proof. Qed. Notation Zmin_plus := Zplus_min_distr_r (only parsing). + +(** * Minimum and Zpos *) + +Lemma Zpos_min : forall p q, Zpos (Pmin p q) = Zmin (Zpos p) (Zpos q). +Proof. + intros; unfold Zmin, Pmin; simpl; destruct Pcompare; auto. +Qed. + diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index d01cada6..0634096e 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -6,8 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmisc.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Zmisc.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +Require Import Wf_nat. Require Import BinInt. Require Import Zcompare. Require Import Zorder. @@ -18,37 +19,23 @@ Open Local Scope Z_scope. (** Iterators *) (** [n]th iteration of the function [f] *) -Fixpoint iter_nat (n:nat) (A:Set) (f:A -> A) (x:A) {struct n} : A := - match n with - | O => x - | S n' => f (iter_nat n' A f x) - end. -Fixpoint iter_pos (n:positive) (A:Set) (f:A -> A) (x:A) {struct n} : A := +Fixpoint iter_pos (n:positive) (A:Type) (f:A -> A) (x:A) {struct n} : 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:Set) (f:A -> A) (x:A) := +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_plus : - forall (n m:nat) (A:Set) (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. - Theorem iter_nat_of_P : - forall (p:positive) (A:Set) (f:A -> A) (x:A), + 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| ]; @@ -63,7 +50,7 @@ Proof. Qed. Theorem iter_pos_plus : - forall (p q:positive) (A:Set) (f:A -> A) (x:A), + 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. @@ -78,7 +65,7 @@ Qed. then the iterates of [f] also preserve it. *) Theorem iter_nat_invariant : - forall (n:nat) (A:Set) (f:A -> A) (Inv:A -> Prop), + 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. @@ -89,7 +76,7 @@ Proof. Qed. Theorem iter_pos_invariant : - forall (p:positive) (A:Set) (f:A -> A) (Inv:A -> Prop), + 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. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index f0a3d47b..c5b5edc1 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znat.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: Znat.v 10726 2008-03-28 18:15:23Z notin $ i*) -(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) +(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) Require Export Arith_base. Require Import BinPos. @@ -17,6 +17,7 @@ Require Import Zcompare. Require Import Zorder. Require Import Decidable. Require Import Peano_dec. +Require Import Min Max Zmin Zmax. Require Export Compare_dec. Open Local Scope Z_scope. @@ -26,6 +27,13 @@ Definition neq (x y:nat) := x <> y. (************************************************) (** Properties of the injection from nat into Z *) +(** Injection and successor *) + +Theorem inj_0 : Z_of_nat 0 = 0%Z. +Proof. + reflexivity. +Qed. + Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n). Proof. intro y; induction y as [| n H]; @@ -33,25 +41,12 @@ Proof. | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *; rewrite Zpos_succ_morphism; trivial with arith ]. Qed. - -Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat 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 ]. -Qed. -Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m. +(** Injection and equality. *) + +Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat 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 x y H; rewrite H; trivial with arith. Qed. Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m). @@ -66,6 +61,24 @@ Proof. intros E; rewrite E; auto with arith ]. Qed. +Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m. +Proof. + intros x y H. + destruct (eq_nat_dec x y) as [H'|H']; auto. + elimtype False. + exact (inj_neq _ _ H' H). +Qed. + +Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m. +Proof. + split; [apply inj_eq | apply inj_eq_rev]. +Qed. + + +(** Injection and order relations: *) + +(** One way ... *) + Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m. Proof. intros x y; intros H; elim H; @@ -81,29 +94,100 @@ Proof. exact H. Qed. +Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m. +Proof. + intros x y H; apply Zle_ge; apply inj_le; apply H. +Qed. + Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m. Proof. intros x y H; apply Zlt_gt; apply inj_lt; exact H. Qed. -Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m. +(** The other way ... *) + +Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat. Proof. - intros x y H; apply Zle_ge; apply inj_le; apply H. + intros x y H. + destruct (le_lt_dec x y) as [H0|H0]; auto. + elimtype False. + assert (H1:=inj_lt _ _ H0). + red in H; red in H1. + rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. Qed. -Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m. +Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat. Proof. - intros x y H; rewrite H; trivial with arith. + intros x y H. + destruct (le_lt_dec y x) as [H0|H0]; auto. + elimtype False. + assert (H1:=inj_le _ _ H0). + red in H; red in H1. + rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. Qed. -Theorem intro_Z : - forall n:nat, exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0. +Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat. 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 ]. + intros x y H. + destruct (le_lt_dec y x) as [H0|H0]; auto. + elimtype False. + assert (H1:=inj_gt _ _ H0). + red in H; red in H1. + rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto. +Qed. + +Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat. +Proof. + intros x y H. + destruct (le_lt_dec x y) as [H0|H0]; auto. + elimtype False. + assert (H1:=inj_ge _ _ H0). + red in H; red in H1. + rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto. +Qed. + +(* Both ways ... *) + +Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m. +Proof. + split; [apply inj_le | apply inj_le_rev]. +Qed. + +Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m. +Proof. + split; [apply inj_lt | apply inj_lt_rev]. +Qed. + +Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m. +Proof. + split; [apply inj_ge | apply inj_ge_rev]. +Qed. + +Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m. +Proof. + split; [apply inj_gt | apply inj_gt_rev]. +Qed. + +(** Injection and usual operations *) + +Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat 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 ]. +Qed. + +Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat 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 ]. Qed. Theorem inj_minus1 : @@ -121,6 +205,46 @@ Proof. [ trivial with arith | apply gt_not_le; assumption ]. Qed. +Theorem inj_minus : forall n m:nat, + Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m). +Proof. + intros. + rewrite Zmax_comm. + unfold Zmax. + destruct (le_lt_dec m n) as [H|H]. + + 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. + + 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. +Qed. + +Theorem inj_min : forall n m:nat, + Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m). +Proof. + induction n; destruct m; try (compute; auto; fail). + simpl min. + do 3 rewrite inj_S. + rewrite <- Zsucc_min_distr; f_equal; auto. +Qed. + +Theorem inj_max : forall n m:nat, + Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m). +Proof. + induction n; destruct m; try (compute; auto; fail). + simpl max. + do 3 rewrite inj_S. + rewrite <- Zsucc_max_distr; f_equal; auto. +Qed. + +(** Composition of injections **) + Theorem Zpos_eq_Z_of_nat_o_nat_of_P : forall p:positive, Zpos p = Z_of_nat (nat_of_P p). Proof. @@ -136,3 +260,26 @@ Proof. rewrite inj_plus; repeat rewrite <- H. rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity. Qed. + +(** Misc *) + +Theorem intro_Z : + forall n:nat, exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 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 ]. +Qed. + +Lemma Zpos_P_of_succ_nat : forall n:nat, + Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n). +Proof. + intros. + unfold Z_of_nat. + destruct n. + simpl; auto. + simpl (P_of_succ_nat (S n)). + apply Zpos_succ_morphism. +Qed. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index d89ec052..e77475e0 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -6,13 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znumtheory.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Znumtheory.v 10295 2007-11-06 22:46:21Z letouzey $ i*) Require Import ZArith_base. Require Import ZArithRing. Require Import Zcomplements. Require Import Zdiv. -Require Import Ndigits. Require Import Wf_nat. Open Local Scope Z_scope. @@ -156,21 +155,27 @@ Qed. 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. + 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. (** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *) @@ -194,6 +199,134 @@ Proof. subst q; omega. Qed. +(** [Zdivide] can be expressed using [Zmod]. *) + +Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a). +Proof. + intros a b H H0. + apply Zdivide_intro with (a / b). + pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H). + rewrite H0; ring. +Qed. + +Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0. +Proof. + intros a b; simple destruct 2; intros; subst. + change (q * b) with (0 + q * b) in |- *. + rewrite Z_mod_plus; auto. +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). +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. + +Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) -> (a | b). +Proof. + intros a b [x H]; subst b. + pattern (Zabs a); apply Zabs_intro. + exists (- x); ring. + exists x; ring. +Qed. + +Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) -> (Zabs a | b). +Proof. + intros a b [x H]; subst b. + pattern (Zabs a); apply Zabs_intro. + exists (- x); ring. + exists x; ring. +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. +Qed. + +Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, + 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. + 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. +Qed. + +Lemma Zmod_div_mod: forall 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. +Qed. + +Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> + a mod b = c -> (b | a - c). +Proof. + intros a b c H H1; apply Zmod_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. +Qed. + +Lemma Zdivide_mod_minus: forall a b c : Z, 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. + 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. +Qed. + (** * Greatest common divisor (gcd). *) (** There is no unicity of the gcd; hence we define the predicate [gcd a b d] @@ -246,6 +379,18 @@ Proof. Qed. Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. + +Theorem Zis_gcd_unique: forall a b c d : Z, + Zis_gcd a b c -> Zis_gcd a b d -> c = d \/ c = (- d). +Proof. +intros a b c d H1 H2. +inversion_clear H1 as [Hc1 Hc2 Hc3]. +inversion_clear H2 as [Hd1 Hd2 Hd3]. +assert (H3: Zdivide c d); auto. +assert (H4: Zdivide d c); auto. +apply Zdivide_antisym; auto. +Qed. + (** * Extended Euclid algorithm. *) @@ -463,6 +608,7 @@ Qed. Lemma Zis_gcd_rel_prime : forall a b g:Z, b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g). +Proof. intros a b g; intros. assert (g <> 0). intro. @@ -491,6 +637,68 @@ Lemma Zis_gcd_rel_prime : exists q; auto with zarith. Qed. +Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a. +Proof. + intros a b H; auto with zarith. + red; apply Zis_gcd_sym; auto with zarith. +Qed. + +Theorem rel_prime_div: forall p q r, + rel_prime p q -> (r | p) -> rel_prime r q. +Proof. + intros p q r H (u, H1); subst. + inversion_clear H as [H1 H2 H3]. + red; apply Zis_gcd_intro; try apply Zone_divide. + intros x H4 H5; apply H3; auto. + apply Zdivide_mult_r; auto. +Qed. + +Theorem rel_prime_1: forall n, rel_prime 1 n. +Proof. + intros n; red; apply Zis_gcd_intro; auto. + exists 1; auto with zarith. + exists n; auto with zarith. +Qed. + +Theorem not_rel_prime_0: forall n, 1 < n -> ~ rel_prime 0 n. +Proof. + intros n H H1; absurd (n = 1 \/ n = -1). + intros [H2 | H2]; subst; contradict H; auto with zarith. + case (Zis_gcd_unique 0 n n 1); auto. + apply Zis_gcd_intro; auto. + exists 0; auto with zarith. + exists 1; auto with zarith. +Qed. + +Theorem rel_prime_mod: forall p q, 0 < q -> + rel_prime p q -> rel_prime (p mod q) q. +Proof. + intros p q H H0. + assert (H1: Bezout p q 1). + apply rel_prime_bezout; auto. + inversion_clear H1 as [q1 r1 H2]. + apply bezout_rel_prime. + apply Bezout_intro with q1 (r1 + q1 * (p / q)). + rewrite <- H2. + pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. +Qed. + +Theorem rel_prime_mod_rev: forall p q, 0 < q -> + rel_prime (p mod q) q -> rel_prime p q. +Proof. + intros p q H H0. + rewrite (Z_div_mod_eq p q); auto with zarith; red. + apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith. +Qed. + +Theorem Zrel_prime_neq_mod_0: forall a b, 1 < b -> rel_prime a b -> a mod b <> 0. +Proof. + intros a b H H1 H2. + case (not_rel_prime_0 _ H). + rewrite <- H2. + apply rel_prime_mod; auto with zarith. +Qed. + (** * Primality *) Inductive prime (p:Z) : Prop := @@ -543,42 +751,19 @@ Qed. Hint Resolve prime_rel_prime: zarith. -(** [Zdivide] can be expressed using [Zmod]. *) +(** As a consequence, a prime number is relatively prime with smaller numbers *) -Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a). +Theorem rel_prime_le_prime: + forall a p, prime p -> 1 <= a < p -> rel_prime a p. Proof. - intros a b H H0. - apply Zdivide_intro with (a / b). - pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H). - rewrite H0; ring. + intros a p Hp [H1 H2]. + apply rel_prime_sym; apply prime_rel_prime; auto. + intros [q Hq]; subst a. + case (Zle_or_lt q 0); intros Hl. + absurd (q * p <= 0 * p); auto with zarith. + absurd (1 * p <= q * p); auto with zarith. Qed. -Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0. -Proof. - intros a b; simple destruct 2; intros; subst. - change (q * b) with (0 + q * b) in |- *. - rewrite Z_mod_plus; auto. -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. (** If a prime [p] divides [ab] then it divides either [a] or [b] *) @@ -590,6 +775,108 @@ Proof. right; apply Gauss with a; auto with zarith. Qed. +Lemma not_prime_0: ~ prime 0. +Proof. + intros H1; case (prime_divisors _ H1 2); auto with zarith. +Qed. + +Lemma not_prime_1: ~ prime 1. +Proof. + intros H1; absurd (1 < 1); auto with zarith. + inversion H1; auto. +Qed. + +Lemma prime_2: prime 2. +Proof. + apply prime_intro; auto with zarith. + intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith; + clear H1; intros H1. + contradict H2; auto with zarith. + subst n; red; auto with zarith. + apply Zis_gcd_intro; auto with zarith. +Qed. + +Theorem prime_3: prime 3. +Proof. + apply prime_intro; auto with zarith. + intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith; + clear H1; intros H1. + case (Zle_lt_or_eq 2 n); auto with zarith; clear H1; intros H1. + contradict H2; auto with zarith. + subst n; red; auto with zarith. + apply Zis_gcd_intro; auto with zarith. + intros x [q1 Hq1] [q2 Hq2]. + exists (q2 - q1). + apply trans_equal with (3 - 2); auto with zarith. + rewrite Hq1; rewrite Hq2; ring. + subst n; red; auto with zarith. + apply Zis_gcd_intro; auto with zarith. +Qed. + +Theorem prime_ge_2: forall p, prime p -> 2 <= p. +Proof. + intros p Hp; inversion Hp; auto with zarith. +Qed. + +Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)). + +Theorem prime_alt: + forall p, prime' p <-> prime p. +Proof. + split; destruct 1; intros. + (* prime -> prime' *) + constructor; auto; intros. + red; apply Zis_gcd_intro; auto with zarith; intros. + case (Zle_lt_or_eq 0 (Zabs x)); auto with zarith; intros H6. + case (Zle_lt_or_eq 1 (Zabs x)); auto with zarith; intros H7. + case (Zle_lt_or_eq (Zabs x) p); auto with zarith. + apply Zdivide_le; auto with zarith. + apply Zdivide_Zabs_inv_l; auto. + intros H8; case (H0 (Zabs x)); auto. + apply Zdivide_Zabs_inv_l; auto. + intros H8; subst p; absurd (Zabs x <= n); auto with zarith. + apply Zdivide_le; auto with zarith. + apply Zdivide_Zabs_inv_l; auto. + rewrite H7; pattern (Zabs x); apply Zabs_intro; auto with zarith. + absurd (0%Z = p); auto with zarith. + assert (x=0) by (destruct x; simpl in *; now auto). + subst x; elim H3; intro q; rewrite Zmult_0_r; auto. + (* prime' -> prime *) + split; auto; intros. + intros H2. + case (Zis_gcd_unique n p n 1); auto with zarith. + apply Zis_gcd_intro; auto with zarith. + apply H0; auto with zarith. +Qed. + +Theorem square_not_prime: forall a, ~ prime (a * a). +Proof. + intros a Ha. + rewrite <- (Zabs_square a) in Ha. + assert (0 <= Zabs a) by auto with zarith. + set (b:=Zabs a) in *; clearbody b. + rewrite <- prime_alt in Ha; destruct Ha. + case (Zle_lt_or_eq 0 b); auto with zarith; intros Hza1; [ | subst; omega]. + case (Zle_lt_or_eq 1 b); auto with zarith; intros Hza2; [ | subst; omega]. + assert (Hza3 := Zmult_lt_compat_r 1 b b Hza1 Hza2). + rewrite Zmult_1_l in Hza3. + elim (H1 _ (conj Hza2 Hza3)). + exists b; auto. +Qed. + +Theorem prime_div_prime: forall p q, + prime p -> prime q -> (p | q) -> p = q. +Proof. + intros p q H H1 H2; + assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. + assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. + case prime_divisors with (2 := H2); auto. + intros H4; contradict Hp; subst; auto with zarith. + intros [H4| [H4 | H4]]; subst; auto. + contradict H; auto; apply not_prime_1. + contradict Hp; auto with zarith. +Qed. + (** We could obtain a [Zgcd] function via Euclid algorithm. But we propose here a binary version of [Zgcd], faster and executable within Coq. @@ -617,105 +904,34 @@ Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive := | 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. - -Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (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 + | 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. -Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b. -Open Scope Z_scope. +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. - -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. +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. Proof. unfold Zgcd; destruct a; destruct b; auto with zarith. Qed. -Lemma Psize_monotone : forall p q, Pcompare p q Eq = Lt -> (Psize p <= Psize q)%nat. -Proof. - induction p; destruct q; simpl; auto with arith; intros; try discriminate. - intros; generalize (Pcompare_Gt_Lt _ _ H); auto with arith. - intros; destruct (Pcompare_Lt_Lt _ _ H); auto with arith; subst; auto. -Qed. - -Lemma Pminus_Zminus : forall a b, Pcompare a b Eq = Lt -> - Zpos (b-a) = Zpos b - Zpos a. -Proof. - intros. - repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P. - rewrite nat_of_P_minus_morphism. - apply inj_minus1. - apply lt_le_weak. - apply nat_of_P_lt_Lt_compare_morphism; auto. - rewrite ZC4; rewrite H; auto. -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. @@ -758,12 +974,12 @@ Proof. assert (Psize (b-a) <= Psize b)%nat. apply Psize_monotone. change (Zpos (b-a) < Zpos b). - rewrite (Pminus_Zminus _ _ H1). + rewrite (Zpos_minus_morphism _ _ H1). assert (0 < Zpos a) by (compute; auto). omega. omega. rewrite Zpos_xO; do 2 rewrite Zpos_xI. - rewrite Pminus_Zminus; auto. + rewrite Zpos_minus_morphism; auto. omega. (* a = xI, b = xI, compare = Gt *) apply Zis_gcd_for_euclid with 1. @@ -775,13 +991,13 @@ Proof. assert (Psize (a-b) <= Psize a)%nat. apply Psize_monotone. change (Zpos (a-b) < Zpos a). - rewrite (Pminus_Zminus b 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 Pminus_Zminus; auto. + rewrite Zpos_minus_morphism; auto. omega. rewrite ZC4; rewrite H1; auto. (* a = xI, b = xO *) @@ -840,6 +1056,230 @@ Proof. apply Pgcd_correct. 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]. +Qed. + +Theorem Zdivide_Zgcd: forall p q r : Z, + (p | q) -> (p | r) -> (p | Zgcd 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. +Qed. + +Theorem Zis_gcd_gcd: forall a b c : Z, + 0 <= c -> Zis_gcd a b c -> Zgcd 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. +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. + +Theorem Zgcd_div_swap0 : forall a b : Z, + 0 < Zgcd a b -> + 0 < b -> + (a / Zgcd a b) * b = a * (b/Zgcd 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. + 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 < b -> + (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b). +Proof. + intros a b c 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. + repeat rewrite Zmult_assoc; f_equal. + rewrite Zdivide_Zdiv_eq_2; auto. + repeat rewrite <- Zmult_assoc; f_equal. + rewrite Zmult_comm. + rewrite <- Zdivide_Zdiv_eq; auto. +Qed. + +Theorem Zgcd_1_rel_prime : forall a b, + Zgcd a b = 1 <-> rel_prime a b. +Proof. + unfold rel_prime; split; intro H. + rewrite <- H; apply Zgcd_is_gcd. + case (Zis_gcd_unique a b (Zgcd a b) 1); auto. + apply Zgcd_is_gcd. + intros H2; absurd (0 <= Zgcd a b); auto with zarith. + generalize (Zgcd_is_pos a b); auto with zarith. +Qed. + +Definition rel_prime_dec: forall a b, + { rel_prime a b }+{ ~ rel_prime a b }. +Proof. + intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1. + left; apply -> Zgcd_1_rel_prime; auto. + right; contradict H1; apply <- Zgcd_1_rel_prime; auto. +Defined. + +Definition prime_dec_aux: + forall p m, + { forall n, 1 < n < m -> rel_prime n p } + + { exists n, 1 < n < m /\ ~ rel_prime n p }. +Proof. + intros p m. + case (Z_lt_dec 1 m); intros H1; + [ | left; intros; elimtype False; omega ]. + pattern m; apply natlike_rec; auto with zarith. + left; intros; elimtype False; omega. + intros x Hx IH; destruct IH as [F|E]. + destruct (rel_prime_dec x p) as [Y|N]. + left; intros n [HH1 HH2]. + case (Zgt_succ_gt_or_eq x n); auto with zarith. + intros HH3; subst x; auto. + case (Z_lt_dec 1 x); intros HH1. + right; exists x; split; auto with zarith. + left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. + right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. +Defined. + +Definition prime_dec: forall p, { prime p }+{ ~ prime p }. +Proof. + intros p; case (Z_lt_dec 1 p); intros H1. + case (prime_dec_aux p p); intros H2. + left; apply prime_intro; auto. + intros n [Hn1 Hn2]; case Zle_lt_or_eq with ( 1 := Hn1 ); auto. + intros HH; subst n. + red; apply Zis_gcd_intro; auto with zarith. + right; intros H3; inversion_clear H3 as [Hp1 Hp2]. + case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. +Defined. + +Theorem not_prime_divide: + forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p /\ (n | p). +Proof. + intros p Hp Hp1. + case (prime_dec_aux p p); intros H1. + elim Hp1; constructor; auto. + intros n [Hn1 Hn2]. + case Zle_lt_or_eq with ( 1 := Hn1 ); auto with zarith. + intros H2; subst n; red; apply Zis_gcd_intro; auto with zarith. + case H1; intros n [Hn1 Hn2]. + generalize (Zgcd_is_pos n p); intros Hpos. + case (Zle_lt_or_eq 0 (Zgcd n p)); auto with zarith; intros H3. + case (Zle_lt_or_eq 1 (Zgcd n p)); auto with zarith; intros H4. + exists (Zgcd n p); split; auto. + split; auto. + apply Zle_lt_trans with n; auto with zarith. + generalize (Zgcd_is_gcd n p); intros tmp; inversion_clear tmp as [Hr1 Hr2 Hr3]. + case Hr1; intros q Hq. + case (Zle_or_lt q 0); auto with zarith; intros Ht. + absurd (n <= 0 * Zgcd n p) ; auto with zarith. + pattern n at 1; rewrite Hq; auto with zarith. + apply Zle_trans with (1 * Zgcd n p); auto with zarith. + pattern n at 2; rewrite Hq; auto with zarith. + generalize (Zgcd_is_gcd n p); intros Ht; inversion Ht; auto. + case Hn2; red. + rewrite H4; apply Zgcd_is_gcd. + generalize (Zgcd_is_gcd n p); rewrite <- H3; intros tmp; + inversion_clear tmp as [Hr1 Hr2 Hr3]. + 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) { struct n } : (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. @@ -870,8 +1310,8 @@ 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). + let (aa,bb):=p in + (a=g*aa) /\ (b=g*bb). Proof. induction n. simpl; auto. @@ -910,30 +1350,32 @@ 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). + 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. -Open Scope Z_scope. +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). + 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 Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}. +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 y; exists (Zgcd x y). - split; [apply Zgcd_is_gcd | apply Zgcd_is_pos]. +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 47490be6..425aa83b 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -5,9 +5,9 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zorder.v 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: Zorder.v 10291 2007-11-06 02:18:53Z letouzey $ i*) -(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) +(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) Require Import BinPos. Require Import BinInt. @@ -549,7 +549,7 @@ Hint Immediate Zeq_le: zarith. (** Transitivity using successor *) -Lemma Zge_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p. +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 ]. @@ -997,5 +997,31 @@ Proof. rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. Qed. +Lemma Zmult_lt_compat: + forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q. +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. +Qed. + +Lemma Zmult_lt_compat2: + forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q. +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. +Qed. + (** For compatibility *) Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing). diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v new file mode 100644 index 00000000..3d4d235a --- /dev/null +++ b/theories/ZArith/Zpow_facts.v @@ -0,0 +1,465 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i $Id: Zpow_facts.v 11098 2008-06-11 09:16:22Z letouzey $ i*) + +Require Import ZArith_base. +Require Import ZArithRing. +Require Import Zcomplements. +Require Export Zpower. +Require Import Zdiv. +Require Import Znumtheory. +Open Local 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. + +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. + +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_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. + + +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. + +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. + +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, + 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. + +Theorem Zpower_lt_monotone: forall 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. + +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 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. + +Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith. + +Theorem Zpower_le_monotone3: forall 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. + +Lemma Zpower_le_monotone_inv: forall 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; elimtype False;omega. + destruct c;try discriminate z0. simpl in H1. elimtype False;omega. + assert (H4 := Zpower_lt_monotone a c b H). elimtype False;omega. +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. + +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_le_lin: forall n, 0 <= n -> n <= 2^n. +Proof. + intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto. +Qed. + +Lemma Zpower2_Psize : + forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize 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. +Qed. + +(** * Zpower and modulo *) + +Theorem Zpower_mod: forall 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. +Qed. + +(** A direct way to compute Zpower modulo **) + +Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z := + match m with + | xH => a mod n + | xO m' => + let z := Zpow_mod_pos a m' n in + match z with + | 0 => 0 + | _ => (z * z) mod n + end + | xI m' => + let z := Zpow_mod_pos a m' n in + match z with + | 0 => 0 + | _ => (z * z * a) mod n + end + end. + +Definition Zpow_mod a m n := + match m with + | 0 => 1 + | 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. +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. +Qed. + +Theorem Zpow_mod_correct: forall a m n, 1 < n -> 0 <= m -> + 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. +Qed. + +(* Complements about power and number theory. *) + +Lemma Zpower_divide: forall 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. +Qed. + +Theorem rel_prime_Zpower_r: forall 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. + 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). +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. +Qed. + +Theorem prime_power_prime: forall 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. +Qed. + +Theorem Zdivide_power_2: forall 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. + 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. + (* 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. + 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. + (* x = 1 *) + exists 0; rewrite Zpower_0_r; auto. + (* x = 0 *) + exists n; destruct H; rewrite Zmult_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. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index c9cee31d..1912f5e1 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -6,89 +6,75 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpower.v 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: Zpower.v 11072 2008-06-08 16:13:37Z herbelin $ i*) +Require Import Wf_nat. Require Import ZArith_base. Require Export Zpow_def. Require Import Omega. Require Import Zcomplements. Open Local Scope Z_scope. -Section section1. +Infix "^" := Zpower : Z_scope. (** * 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. - - (** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for - [plus : nat->nat] and [Zmult : 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 ]. - Qed. - - (** This theorem shows that powers of unary and binary integers - are the same thing, modulo the function convert : [positive -> nat] *) - - Theorem Zpower_pos_nat : - forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p). - Proof. - intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *; - apply iter_nat_of_P. - 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] *) - - Theorem Zpower_pos_is_exp : - forall (n m:positive) (z:Z), - Zpower_pos z (n + m) = Zpower_pos z n * Zpower_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. - Qed. - - Infix "^" := Zpower : Z_scope. - - Hint Immediate Zpower_nat_is_exp: zarith. - Hint Immediate Zpower_pos_is_exp: zarith. - Hint Unfold Zpower_pos: zarith. - Hint Unfold Zpower_nat: zarith. - - Lemma Zpower_exp : - forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m. - Proof. - destruct n; destruct m; auto with zarith. - simpl in |- *; intros; apply Zred_factor0. - simpl in |- *; auto with zarith. - intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith. - intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith. - Qed. - -End section1. - -(** Exporting notation "^" *) - -Infix "^" := Zpower : Z_scope. - -Hint Immediate Zpower_nat_is_exp: zarith. -Hint Immediate Zpower_pos_is_exp: zarith. -Hint Unfold Zpower_pos: zarith. -Hint Unfold Zpower_nat: zarith. +Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1. + +(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for + [plus : nat->nat] and [Zmult : 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 ]. +Qed. + +(** This theorem shows that powers of unary and binary integers + are the same thing, modulo the function convert : [positive -> nat] *) + +Lemma Zpower_pos_nat : + forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p). +Proof. + intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *; + apply iter_nat_of_P. +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] *) + +Lemma Zpower_pos_is_exp : + forall (n m:positive) (z:Z), + Zpower_pos z (n + m) = Zpower_pos z n * Zpower_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. +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. +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. +Qed. Section Powers_of_2. diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v index 3f475a63..6ea952e6 100644 --- a/theories/ZArith/Zsqrt.v +++ b/theories/ZArith/Zsqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zsqrt.v 9551 2007-01-29 15:13:35Z bgregoir $ *) +(* $Id: Zsqrt.v 10295 2007-11-06 22:46:21Z letouzey $ *) Require Import ZArithRing. Require Import Omega. @@ -148,6 +148,7 @@ Definition Zsqrt_plain (x:Z) : Z := end. (** A basic theorem about Zsqrt_plain *) + Theorem Zsqrt_interval : forall n:Z, 0 <= n -> @@ -162,3 +163,53 @@ Proof. intros p Hle; elim Hle; auto. Qed. +(** Positivity *) + +Theorem Zsqrt_plain_is_pos: forall n, 0 <= n -> 0 <= Zsqrt_plain n. +Proof. + intros n m; case (Zsqrt_interval n); auto with zarith. + intros H1 H2; case (Zle_or_lt 0 (Zsqrt_plain n)); auto. + intros H3; contradict H2; auto; apply Zle_not_lt. + apply Zle_trans with ( 2 := H1 ). + replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1)) + with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1)); + auto with zarith. + ring. +Qed. + +(** Direct correctness on squares. *) + +Theorem Zsqrt_square_id: forall a, 0 <= a -> Zsqrt_plain (a * a) = a. +Proof. + intros a H. + generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa. + case (Zsqrt_interval (a * a)); auto with zarith. + intros H1 H2. + case (Zle_or_lt a (Zsqrt_plain (a * a))); intros H3; auto. + case Zle_lt_or_eq with (1:=H3); auto; clear H3; intros H3. + contradict H1; auto; apply Zlt_not_le; auto with zarith. + apply Zle_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith. + apply Zmult_lt_compat_r; auto with zarith. + contradict H2; auto; apply Zle_not_lt; auto with zarith. + apply Zmult_le_compat; auto with zarith. +Qed. + +(** [Zsqrt_plain] is increasing *) + +Theorem Zsqrt_le: + forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. +Proof. + intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; + [ | subst q; auto with zarith]. + case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. + assert (Hp: (0 <= Zsqrt_plain q)). + apply Zsqrt_plain_is_pos; auto with zarith. + absurd (q <= p); auto with zarith. + apply Zle_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)). + case (Zsqrt_interval q); auto with zarith. + apply Zle_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith. + apply Zmult_le_compat; auto with zarith. + case (Zsqrt_interval p); auto with zarith. +Qed. + + |