diff options
Diffstat (limited to 'theories')
225 files changed, 14620 insertions, 1651 deletions
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 114a60ee..59d9b2b1 100755..100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Arith.v,v 1.11.2.2 2004/08/03 17:42:42 herbelin Exp $ i*) +(*i $Id: Arith.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Le. Require Export Lt. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 448ce002..7680997d 100755..100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Between.v,v 1.12.2.1 2004/07/16 19:30:59 herbelin Exp $ i*) +(*i $Id: Between.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Le. Require Import Lt. diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index 55dfd47f..fed650ab 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bool_nat.v,v 1.5.2.1 2004/07/16 19:30:59 herbelin Exp $ *) +(* $Id: Bool_nat.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Compare_dec. Require Export Peano_dec. diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v index 46827bae..b11f0517 100755..100644 --- a/theories/Arith/Compare.v +++ b/theories/Arith/Compare.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare.v,v 1.12.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Compare.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Equality is decidable on [nat] *) Open Local Scope nat_scope. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index ea21437d..3a87ee1a 100755..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,v 1.13.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Compare_dec.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Le. Require Import Lt. diff --git a/theories/Arith/Div.v b/theories/Arith/Div.v index adb5593d..9011cee3 100755..100644 --- a/theories/Arith/Div.v +++ b/theories/Arith/Div.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Div.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Div.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Euclidean division *) diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index c005f061..6e5d292f 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,v 1.15.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Div2.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Lt. Require Import Plus. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 2e99e068..09df9464 100755..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,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: EqNat.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Equality on natural numbers *) diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index e50e3d70..23bc7cdb 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Euclid.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Euclid.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Mult. Require Import Compare_dec. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index f7a2ad71..cdbc86df 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,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Even.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 4db211e4..2767f9f0 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Factorial.v,v 1.5.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Factorial.v 6338 2004-11-22 09:10:51Z gregoire $ i*) Require Import Plus. Require Import Mult. @@ -15,7 +15,7 @@ Open Local Scope nat_scope. (** Factorial *) -Fixpoint fact (n:nat) : nat := +Boxed Fixpoint fact (n:nat) : nat := match n with | O => 1 | S n => S n * fact n @@ -47,4 +47,4 @@ assumption. simpl (1 * fact n) in H0. rewrite <- plus_n_O in H0. assumption. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index 299c664d..90f893a3 100755..100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Gt.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Gt.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Le. Require Import Lt. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index a5378cff..e95ef408 100755..100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Le.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Le.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Order on natural numbers *) Open Local Scope nat_scope. @@ -62,15 +62,14 @@ Hint Immediate le_Sn_le: arith v62. Theorem le_S_n : forall n m, S n <= S m -> n <= m. Proof. intros n m H; change (pred (S n) <= pred (S m)) in |- *. -elim H; simpl in |- *; auto with arith. +destruct H; simpl; auto with arith. Qed. Hint Immediate le_S_n: arith v62. Theorem le_pred : forall n m, n <= m -> pred n <= pred m. Proof. -induction n as [| n IHn]. simpl in |- *. auto with arith. -destruct m as [| m]. simpl in |- *. intro H. inversion H. -simpl in |- *. auto with arith. +destruct n; simpl; auto with arith. +destruct m; simpl; auto with arith. Qed. (** Comparison to 0 *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index e1b3e4b8..eeb4e35e 100755..100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lt.v,v 1.11.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Lt.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Le. Open Local Scope nat_scope. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 82673ed0..7f5c1148 100755..100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Max.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Max.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Arith. @@ -69,17 +69,11 @@ induction n; induction m; simpl in |- *; auto with arith. elim (IHn m); intro H; elim H; auto. Qed. -Lemma max_case : forall n m (P:nat -> Set), P n -> P m -> P (max n m). -Proof. -induction n; simpl in |- *; auto with arith. -induction m; intros; simpl in |- *; auto with arith. -pattern (max n m) in |- *; apply IHn; auto with arith. -Qed. - -Lemma max_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (max n m). +Lemma max_case : forall n m (P:nat -> Type), P n -> P m -> P (max n m). Proof. induction n; simpl in |- *; auto with arith. induction m; intros; simpl in |- *; auto with arith. pattern (max n m) in |- *; apply IHn; auto with arith. Qed. +Notation max_case2 := max_case (only parsing). diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index 912e7ba3..38351817 100755..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,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Min.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Arith. @@ -68,16 +68,12 @@ induction n; induction m; simpl in |- *; auto with arith. elim (IHn m); intro H; elim H; auto. Qed. -Lemma min_case : forall n m (P:nat -> Set), P n -> P m -> P (min n m). +Lemma min_case : forall n m (P:nat -> Type), P n -> P m -> P (min n m). Proof. induction n; simpl in |- *; auto with arith. induction m; intros; simpl in |- *; auto with arith. pattern (min n m) in |- *; apply IHn; auto with arith. Qed. -Lemma min_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (min n m). -Proof. -induction n; simpl in |- *; auto with arith. -induction m; intros; simpl in |- *; auto with arith. -pattern (min n m) in |- *; apply IHn; auto with arith. -Qed.
\ No newline at end of file +Notation min_case2 := min_case (only parsing). + diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index ba9a46ad..dfecd7cf 100755..100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Minus.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Minus.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Subtraction (difference between two natural numbers) *) diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index abfade57..051f8645 100755..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,v 1.21.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Mult.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Plus. Require Export Minus. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 01204ee6..4aef7dc0 100755..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,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Peano_dec.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Decidable. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index e4ac631e..56e1c58a 100755..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,v 1.18.2.1 2004/07/16 19:31:00 herbelin Exp $ i*) +(*i $Id: Plus.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Properties of addition *) @@ -199,4 +199,29 @@ 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. intro m; rewrite <- IHn; simpl in |- *; auto. -Qed.
\ No newline at end of file +Qed. + +(** Discrimination *) + +Lemma succ_plus_discr : forall n m, n <> S (plus m n). +Proof. +intros n m; induction n as [|n IHn]. + discriminate. + intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; + reflexivity. +Qed. + +Lemma n_SSn : forall n, n <> S (S n). +Proof. +intro n; exact (succ_plus_discr n 1). +Qed. + +Lemma n_SSSn : forall n, n <> S (S (S n)). +Proof. +intro n; exact (succ_plus_discr n 2). +Qed. + +Lemma n_SSSSn : forall n, n <> S (S (S (S n))). +Proof. +intro n; exact (succ_plus_discr n 3). +Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 8bf237b5..e1bbfad9 100755..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,v 1.16.2.1 2004/07/16 19:31:01 herbelin Exp $ i*) +(*i $Id: Wf_nat.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Well-founded relations and natural numbers *) @@ -36,10 +36,12 @@ apply Acc_intro. unfold ltof in |- *; intros b ltfafb. apply IHn. apply lt_le_trans with (f a); auto with arith. -Qed. +Defined. Theorem well_founded_gtof : well_founded gtof. -Proof well_founded_ltof. +Proof. +exact well_founded_ltof. +Defined. (** It is possible to directly prove the induction principle going back to primitive recursion on natural numbers ([induction_ltof1]) @@ -113,31 +115,30 @@ apply Acc_intro. intros b ltfafb. apply IHn. apply lt_le_trans with (f a); auto with arith. -Qed. +Defined. End Well_founded_Nat. Lemma lt_wf : well_founded lt. -Proof well_founded_ltof nat (fun m => m). +Proof. +exact (well_founded_ltof nat (fun m => m)). +Defined. Lemma lt_wf_rec1 : forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. Proof. -exact - (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) => - induction_ltof1 nat (fun m => m) P F p). +exact (fun p P F => induction_ltof1 nat (fun m => m) P F p). Defined. Lemma lt_wf_rec : forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n. Proof. -exact - (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) => - induction_ltof2 nat (fun m => m) P F p). +exact (fun p P F => induction_ltof2 nat (fun m => m) P F p). Defined. Lemma lt_wf_ind : forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n. +Proof. intro p; intros; elim (lt_wf p); auto with arith. Qed. @@ -154,8 +155,9 @@ Proof lt_wf_ind. Lemma lt_wf_double_rec : forall P:nat -> nat -> Set, (forall n m, - (forall p (q:nat), p < n -> P p q) -> + (forall p q, p < n -> P p q) -> (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. +Proof. intros P Hrec p; pattern p in |- *; apply lt_wf_rec. intros n H q; pattern q in |- *; apply lt_wf_rec; auto with arith. Defined. @@ -165,6 +167,7 @@ Lemma lt_wf_double_ind : (forall n m, (forall p (q:nat), p < n -> P p q) -> (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m. +Proof. intros P Hrec p; pattern p in |- *; apply lt_wf_ind. intros n H q; pattern q in |- *; apply lt_wf_ind; auto with arith. Qed. @@ -178,29 +181,29 @@ Variable R : A -> A -> Prop. (* Relational form of inversion *) Variable F : A -> nat -> Prop. -Definition inv_lt_rel x y := - exists2 n : _, F x n & (forall m, F y m -> n < m). +Definition inv_lt_rel x y := exists2 n, F x n & (forall m, F y m -> n < m). Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y. -Remark acc_lt_rel : forall x:A, (exists n : _, F x n) -> Acc R x. -intros x [n fxn]; generalize x fxn; clear x fxn. +Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x. +Proof. +intros x [n fxn]; generalize dependent x. pattern n in |- *; apply lt_wf_ind; intros. constructor; intros. -case (F_compat y x); trivial; intros. +destruct (F_compat y x) as (x0,H1,H2); trivial. apply (H x0); auto. Qed. Theorem well_founded_inv_lt_rel_compat : well_founded R. +Proof. constructor; intros. case (F_compat y a); trivial; intros. apply acc_lt_rel; trivial. exists x; trivial. Qed. - End LT_WF_REL. 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.
\ No newline at end of file +Qed. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 854eb9e3..ff87eb96 100755..100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -6,32 +6,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Bool.v,v 1.29.2.1 2004/07/16 19:31:01 herbelin Exp $ i*) +(*i $Id: Bool.v 8642 2006-03-17 10:09:02Z notin $ i*) -(** Booleans *) +(** ** Booleans *) (** The type [bool] is defined in the prelude as [Inductive bool : Set := true : bool | false : bool] *) -(** Interpretation of booleans as Proposition *) +(** Interpretation of booleans as propositions *) Definition Is_true (b:bool) := match b with | true => True | false => False end. -Hint Unfold Is_true: bool. -Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x. -Proof. - intros; rewrite H; auto with bool. -Qed. +(*****************) +(** Decidability *) +(*****************) -Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x. +Lemma bool_dec : forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}. Proof. - intros; rewrite <- H; auto with bool. -Qed. - -Hint Immediate Is_true_eq_right Is_true_eq_left: bool. + decide equality. +Defined. (*******************) (** Discrimination *) @@ -40,24 +36,26 @@ Hint Immediate Is_true_eq_right Is_true_eq_left: bool. Lemma diff_true_false : true <> false. Proof. unfold not in |- *; intro contr; change (Is_true false) in |- *. -elim contr; simpl in |- *; trivial with bool. +elim contr; simpl in |- *; trivial. Qed. -Hint Resolve diff_true_false: bool v62. +Hint Resolve diff_true_false : bool v62. Lemma diff_false_true : false <> true. -Proof. +Proof. red in |- *; intros H; apply diff_true_false. symmetry in |- *. assumption. Qed. -Hint Resolve diff_false_true: bool v62. +Hint Resolve diff_false_true : bool v62. +Hint Extern 1 (false <> true) => exact diff_false_true. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. +Proof. intros b H; rewrite H; auto with bool. Qed. -Hint Resolve eq_true_false_abs: bool. Lemma not_true_is_false : forall b:bool, b <> true -> b = false. +Proof. destruct b. intros. red in H; elim H. @@ -67,6 +65,7 @@ reflexivity. Qed. Lemma not_false_is_true : forall b:bool, b <> false -> b = true. +Proof. destruct b. intros. reflexivity. @@ -85,6 +84,8 @@ Definition leb (b1 b2:bool) := end. Hint Unfold leb: bool v62. +(* Infix "<=" := leb : bool_scope. *) + (*************) (** Equality *) (*************) @@ -97,24 +98,9 @@ Definition eqb (b1 b2:bool) : bool := | false, false => true end. -Lemma eqb_refl : forall x:bool, Is_true (eqb x x). -destruct x; simpl in |- *; auto with bool. -Qed. - -Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y. -destruct x; destruct y; simpl in |- *; tauto. -Qed. - -Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. -destruct x; simpl in |- *; tauto. -Qed. - -Lemma Is_true_eq_true2 : forall x:bool, x = true -> Is_true x. -destruct x; simpl in |- *; auto with bool. -Qed. - Lemma eqb_subst : forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2. +Proof. unfold eqb in |- *. intros P b1. intros b2. @@ -130,6 +116,7 @@ trivial with bool. Qed. Lemma eqb_reflx : forall b:bool, eqb b b = true. +Proof. intro b. case b. trivial with bool. @@ -137,6 +124,7 @@ trivial with bool. Qed. Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b. +Proof. destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity. Qed. @@ -165,10 +153,7 @@ Definition xorb (b1 b2:bool) : bool := | false, false => false end. -Definition negb (b:bool) := match b with - | true => false - | false => true - 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. @@ -179,30 +164,37 @@ Delimit Scope bool_scope with bool. Bind Scope bool_scope with bool. -(**************************) -(** Lemmas about [negb] *) -(**************************) +(****************************) +(** De Morgan laws *) +(****************************) -Lemma negb_intro : forall b:bool, b = negb (negb b). +Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. Proof. -destruct b; reflexivity. + destruct b1; destruct b2; simpl in |- *; reflexivity. Qed. -Lemma negb_elim : forall b:bool, negb (negb b) = b. +Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2. Proof. -destruct b; reflexivity. + destruct b1; destruct b2; simpl in |- *; reflexivity. Qed. - -Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2. + +(********************************) +(** *** Properties of [negb] *) +(********************************) + +Lemma negb_involutive : forall b:bool, negb (negb b) = b. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. +destruct b; reflexivity. Qed. -Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2. +Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b). Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. +destruct b; reflexivity. Qed. +Notation negb_elim := negb_involutive (only parsing). +Notation negb_intro := negb_involutive_reverse (only parsing). + Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'. Proof. destruct b; destruct b'; intros; simpl in |- *; trivial with bool. @@ -215,12 +207,14 @@ destruct b; simpl in |- *; intro; apply diff_true_false; Qed. Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false. +Proof. destruct b. trivial with bool. trivial with bool. Qed. Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false. +Proof. destruct b. trivial with bool. trivial with bool. @@ -235,22 +229,25 @@ Proof. Qed. -(****************************) -(** A few lemmas about [or] *) -(****************************) +(********************************) +(** *** Properties of [orb] *) +(********************************) -Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. -destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); - auto with bool. -Qed. +Lemma orb_true_elim : + forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. +Proof. +destruct b1; simpl in |- *; auto with bool. +Defined. -Lemma orb_prop2 : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. +Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. +Proof. destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); auto with bool. Qed. Lemma orb_true_intro : forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true. +Proof. destruct b1; auto with bool. destruct 1; intros. elim diff_true_false; auto with bool. @@ -258,37 +255,45 @@ rewrite H; trivial with bool. Qed. Hint Resolve orb_true_intro: bool v62. -Lemma orb_b_true : forall b:bool, b || true = true. +Lemma orb_false_intro : + forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. +Proof. +intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool. +Qed. +Hint Resolve orb_false_intro: bool v62. + +(** [true] is a zero for [orb] *) + +Lemma orb_true_r : forall b:bool, b || true = true. +Proof. auto with bool. Qed. -Hint Resolve orb_b_true: bool v62. +Hint Resolve orb_true_r: bool v62. -Lemma orb_true_b : forall b:bool, true || b = true. +Lemma orb_true_l : forall b:bool, true || b = true. +Proof. trivial with bool. Qed. -Definition orb_true_elim : - forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. -destruct b1; simpl in |- *; auto with bool. -Defined. +Notation orb_b_true := orb_true_r (only parsing). +Notation orb_true_b := orb_true_l (only parsing). -Lemma orb_false_intro : - forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. -intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool. -Qed. -Hint Resolve orb_false_intro: bool v62. +(** [false] is neutral for [orb] *) -Lemma orb_b_false : forall b:bool, b || false = b. +Lemma orb_false_r : forall b:bool, b || false = b. Proof. destruct b; trivial with bool. Qed. -Hint Resolve orb_b_false: bool v62. +Hint Resolve orb_false_r: bool v62. -Lemma orb_false_b : forall b:bool, false || b = b. +Lemma orb_false_l : forall b:bool, false || b = b. Proof. destruct b; trivial with bool. Qed. -Hint Resolve orb_false_b: bool v62. +Hint Resolve orb_false_l: bool v62. + +Notation orb_b_false := orb_false_r (only parsing). +Notation orb_false_b := orb_false_l (only parsing). Lemma orb_false_elim : forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. @@ -300,49 +305,48 @@ Proof. auto with bool. Qed. -Lemma orb_neg_b : forall b:bool, b || negb b = true. +(** Complementation *) + +Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. destruct b; reflexivity. Qed. -Hint Resolve orb_neg_b: bool v62. +Hint Resolve orb_negb_r: bool v62. + +Notation orb_neg_b := orb_negb_r (only parsing). + +(** Commutativity *) Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1. +Proof. destruct b1; destruct b2; reflexivity. Qed. +(** Associativity *) + Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. destruct b1; destruct b2; destruct b3; reflexivity. Qed. +Hint Resolve orb_comm orb_assoc: bool v62. -Hint Resolve orb_comm orb_assoc orb_b_false orb_false_b: bool v62. - -(*****************************) -(** A few lemmas about [and] *) -(*****************************) +(*********************************) +(** *** Properties of [andb] *) +(*********************************) Lemma andb_prop : forall a b:bool, a && b = true -> a = true /\ b = true. - Proof. destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); auto with bool. Qed. Hint Resolve andb_prop: bool v62. -Definition andb_true_eq : +Lemma andb_true_eq : forall a b:bool, true = a && b -> true = a /\ true = b. Proof. destruct a; destruct b; auto. Defined. -Lemma andb_prop2 : - forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b. -Proof. - destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); - auto with bool. -Qed. -Hint Resolve andb_prop2: bool v62. - Lemma andb_true_intro : forall b1 b2:bool, b1 = true /\ b2 = true -> b1 && b2 = true. Proof. @@ -350,61 +354,130 @@ Proof. Qed. Hint Resolve andb_true_intro: bool v62. -Lemma andb_true_intro2 : - forall b1 b2:bool, Is_true b1 -> Is_true b2 -> Is_true (b1 && b2). -Proof. - destruct b1; destruct b2; simpl in |- *; tauto. -Qed. -Hint Resolve andb_true_intro2: 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. Qed. Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false. +Proof. destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. Qed. -Lemma andb_b_false : forall b:bool, b && false = false. +(** [false] is a zero for [andb] *) + +Lemma andb_false_r : forall b:bool, b && false = false. +Proof. destruct b; auto with bool. Qed. -Lemma andb_false_b : forall b:bool, false && b = false. +Lemma andb_false_l : forall b:bool, false && b = false. +Proof. trivial with bool. Qed. -Lemma andb_b_true : forall b:bool, b && true = b. +Notation andb_b_false := andb_false_r (only parsing). +Notation andb_false_b := andb_false_l (only parsing). + +(** [true] is neutral for [andb] *) + +Lemma andb_true_r : forall b:bool, b && true = b. +Proof. destruct b; auto with bool. Qed. -Lemma andb_true_b : forall b:bool, true && b = b. +Lemma andb_true_l : forall b:bool, true && b = b. +Proof. trivial with bool. Qed. -Definition andb_false_elim : +Notation andb_b_true := andb_true_r (only parsing). +Notation andb_true_b := andb_true_l (only parsing). + +Lemma andb_false_elim : forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}. +Proof. destruct b1; simpl in |- *; auto with bool. Defined. Hint Resolve andb_false_elim: bool v62. -Lemma andb_neg_b : forall b:bool, b && negb b = false. +(** Complementation *) + +Lemma andb_negb_r : forall b:bool, b && negb b = false. +Proof. destruct b; reflexivity. Qed. -Hint Resolve andb_neg_b: bool v62. +Hint Resolve andb_negb_r: bool v62. + +Notation andb_neg_b := andb_negb_r (only parsing). + +(** Commutativity *) Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1. +Proof. destruct b1; destruct b2; reflexivity. Qed. +(** Associativity *) + Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3. +Proof. destruct b1; destruct b2; destruct b3; reflexivity. Qed. Hint Resolve andb_comm andb_assoc: bool v62. -(*******************************) -(** Properties of [xorb] *) -(*******************************) +(*******************************************) +(** *** Properties mixing [andb] and [orb] *) +(*******************************************) + +(** Distributivity *) + +Lemma andb_orb_distrib_r : + forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3. +Proof. +destruct b1; destruct b2; destruct b3; reflexivity. +Qed. + +Lemma andb_orb_distrib_l : + forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3. +Proof. +destruct b1; destruct b2; destruct b3; reflexivity. +Qed. + +Lemma orb_andb_distrib_r : + forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3). +Proof. +destruct b1; destruct b2; destruct b3; reflexivity. +Qed. + +Lemma orb_andb_distrib_l : + forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3). +Proof. +destruct b1; destruct b2; destruct b3; reflexivity. +Qed. + +(* Compatibility *) +Notation demorgan1 := andb_orb_distrib_r (only parsing). +Notation demorgan2 := andb_orb_distrib_l (only parsing). +Notation demorgan3 := orb_andb_distrib_r (only parsing). +Notation demorgan4 := orb_andb_distrib_l (only parsing). + +(** Absorption *) + +Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1. +Proof. + destruct b1; destruct b2; simpl in |- *; reflexivity. +Qed. + +Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1. +Proof. + destruct b1; destruct b2; simpl in |- *; reflexivity. +Qed. + +(***********************************) +(** *** Properties of [xorb] *) +(***********************************) Lemma xorb_false : forall b:bool, xorb b false = b. Proof. @@ -473,71 +546,156 @@ Proof. intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false. Qed. -(*******************************) -(** De Morgan's law *) -(*******************************) +(** Lemmas about the [b = true] embedding of [bool] to [Prop] *) -Lemma demorgan1 : - forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3. -destruct b1; destruct b2; destruct b3; reflexivity. +Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. +Proof. + intros b1 b2; case b1; case b2; intuition. Qed. -Lemma demorgan2 : - forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3. -destruct b1; destruct b2; destruct b3; reflexivity. +Notation bool_1 := eq_true_iff_eq. (* Compatibility *) + +Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true. +Proof. + destruct b; intuition. Qed. -Lemma demorgan3 : - forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3). -destruct b1; destruct b2; destruct b3; reflexivity. +Notation bool_3 := eq_true_negb_classical. (* Compatibility *) + +Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. +Proof. + destruct b; intuition. Qed. -Lemma demorgan4 : - forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3). -destruct b1; destruct b2; destruct b3; reflexivity. +Notation bool_6 := eq_true_not_negb. (* Compatibility *) + +Hint Resolve eq_true_not_negb : bool. + +(* An interesting lemma for auto but too strong to keep compatibility *) + +Lemma absurd_eq_bool : forall b b':bool, False -> b = b'. +Proof. + contradiction. Qed. -Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1. +(* A more specific one that preserves compatibility with old hint bool_3 *) + +Lemma absurd_eq_true : forall b, False -> b = true. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + contradiction. Qed. +Hint Resolve absurd_eq_true. -Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1. +(* A specific instance of trans_eq that preserves compatibility with + old hint bool_2 *) + +Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. - destruct b1; destruct b2; simpl in |- *; reflexivity. + apply trans_eq. +Qed. +Hint Resolve trans_eq_bool. + +(*****************************************) +(** *** Reflection of [bool] into [Prop] *) +(*****************************************) + +(** [Is_true] and equality *) + +Hint Unfold Is_true: bool. + +Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. +Proof. +destruct x; simpl in |- *; tauto. +Qed. + +Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x. +Proof. + intros; rewrite H; auto with bool. +Qed. + +Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x. +Proof. + intros; rewrite <- H; auto with bool. +Qed. + +Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). + +Hint Immediate Is_true_eq_right Is_true_eq_left: bool. + +Lemma eqb_refl : forall x:bool, Is_true (eqb x x). +Proof. + destruct x; simpl; auto with bool. +Qed. + +Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y. +Proof. + destruct x; destruct y; simpl; tauto. Qed. +(** [Is_true] and connectives *) + +Lemma orb_prop_elim : + forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. +Proof. + destruct a; destruct b; simpl; tauto. +Qed. -(** Misc. equalities between booleans (to be used by Auto) *) +Notation orb_prop2 := orb_prop_elim (only parsing). + +Lemma orb_prop_intro : + forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b). +Proof. + destruct a; destruct b; simpl; tauto. +Qed. + +Lemma andb_prop_intro : + forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2). +Proof. + destruct b1; destruct b2; simpl in |- *; tauto. +Qed. +Hint Resolve andb_prop_intro: bool v62. -Lemma bool_1 : forall b1 b2:bool, (b1 = true <-> b2 = true) -> b1 = b2. +Notation andb_true_intro2 := + (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2)) + (only parsing). + +Lemma andb_prop_elim : + forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b. +Proof. + destruct a; destruct b; simpl in |- *; try (intro H; discriminate H); + auto with bool. +Qed. +Hint Resolve andb_prop_elim: bool v62. + +Notation andb_prop2 := andb_prop_elim (only parsing). + +Lemma eq_bool_prop_intro : + forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. Proof. - intros b1 b2; case b1; case b2; intuition. + destruct b1; destruct b2; simpl in *; intuition. Qed. -Lemma bool_2 : forall b1 b2:bool, b1 = b2 -> b1 = true -> b2 = true. +Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2). Proof. intros b1 b2; case b1; case b2; intuition. Qed. -Lemma bool_3 : forall b:bool, negb b <> true -> b = true. +Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b. Proof. - destruct b; intuition. + destruct b; intuition. Qed. -Lemma bool_4 : forall b:bool, b = true -> negb b <> true. +Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b). Proof. - destruct b; intuition. + destruct b; simpl in *; intuition. Qed. -Lemma bool_5 : forall b:bool, negb b = true -> b <> true. +Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b. Proof. - destruct b; intuition. + destruct b; intuition. Qed. -Lemma bool_6 : forall b:bool, b <> true -> negb b = true. +Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b). Proof. - destruct b; intuition. + destruct b; intuition. Qed. - -Hint Resolve bool_1 bool_2 bool_3 bool_4 bool_5 bool_6. diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index e038b3da..806ac70f 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BoolEq.v,v 1.4.2.1 2004/07/16 19:31:02 herbelin Exp $ i*) +(*i $Id: BoolEq.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (* Cuihtlauac Alvarado - octobre 2000 *) (** Properties of a boolean equality *) diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 51d940cf..b58ed280 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,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Bvector.v 6844 2005-03-16 13:09:55Z herbelin $ i*) (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *) @@ -17,7 +17,7 @@ Require Import Arith. Open Local Scope nat_scope. (* -On s'inspire de PolyList pour fabriquer les vecteurs de bits. +On s'inspire de List.v pour fabriquer les vecteurs de bits. La dimension du vecteur est un paramètre trop important pour se contenter de la fonction "length". La première idée est de faire un record avec la liste et la longueur. @@ -26,42 +26,9 @@ 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. - -(En effet une définition comme : -Fixpoint Vunaire [n:nat; v:(vector n)]: (vector n) := -Cases v of - | Vnil => Vnil - | (Vcons a p v') => (Vcons (f a) p (Vunaire p v')) -end. -provoque ce message d'erreur : -Coq < Error: Inference of annotation not yet implemented in this case). - - - Inductive list [A : Set] : Set := - nil : (list A) | cons : A->(list A)->(list A). - head = [A:Set; l:(list A)] Cases l of - | nil => Error - | (cons x _) => (Value x) - end - : (A:Set)(list A)->(option A). - tail = [A:Set; l:(list A)]Cases l of - | nil => (nil A) - | (cons _ m) => m - end - : (A:Set)(list A)->(list A). - length = [A:Set] Fix length {length [l:(list A)] : nat := - Cases l of - | nil => O - | (cons _ m) => (S (length m)) - end} - : (A:Set)(list A)->nat. - map = [A,B:Set; f:(A->B)] Fix map {map [l:(list A)] : (list B) := - Cases l of - | nil => (nil B) - | (cons a t) => (cons (f a) (map t)) - end} - : (A,B:Set)(A->B)->(list A)->(list B) +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. *) Section VECTORS. @@ -141,13 +108,6 @@ Proof. exact (Vcons a (S (S n)) (f H0)). Defined. -(* -Lemma S_minus_S : (n,p:nat) (gt n (S p)) -> (S (minus n (S p)))=(minus n p). -Proof. - Intros. -Save. -*) - Lemma Vtrunc : forall n p:nat, n > p -> vector n -> vector (n - p). Proof. induction p as [| p f]; intros H v. @@ -203,7 +163,7 @@ Implicit Arguments Vcons [A n]. Section BOOLEAN_VECTORS. -(* +(* Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. ATTENTION : le stockage s'effectue poids FAIBLE en tête. On en extrait le bit de poids faible (head) et la fin du vecteur (tail). diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index 1998fb8e..b95b25fd 100755..100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DecBool.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: DecBool.v 8642 2006-03-17 10:09:02Z notin $ i*) Set Implicit Arguments. diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index a00449d8..0a98c32a 100755..100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: IfProp.v,v 1.7.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: IfProp.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Bool. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 8188f038..2842437d 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sumbool.v,v 1.12.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Sumbool.v 7235 2005-07-15 17:11:57Z coq $ i*) (** Here are collected some results about the type sumbool (see INIT/Specif.v) [sumbool A B], which is written [{A}+{B}], is the informative @@ -63,8 +63,8 @@ Defined. End connectives. -Hint Resolve sumbool_and sumbool_or sumbool_not: core. - +Hint Resolve sumbool_and sumbool_or: core. +Hint Immediate sumbool_not : core. (** Any decidability function in type [sumbool] can be turned into a function returning a boolean with the corresponding specification: *) diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index b654e556..c9abf94a 100755..100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zerob.v,v 1.8.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Zerob.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Arith. Require Import Bool. diff --git a/theories/FSets/DecidableType.v b/theories/FSets/DecidableType.v new file mode 100644 index 00000000..635f6bdb --- /dev/null +++ b/theories/FSets/DecidableType.v @@ -0,0 +1,151 @@ +(***********************************************************************) +(* 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: DecidableType.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +Require Export SetoidList. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Types with decidable Equalities (but no ordering) *) + +Module Type DecidableType. + + Parameter t : Set. + + Parameter 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. + + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans. + +End DecidableType. + + +Module PairDecidableType(D:DecidableType). + Import D. + + Section Elt. + Variable elt : Set. + Notation key:=t. + + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Hint Unfold eqk eqke. + Hint Extern 2 (eqke ?a ?b) => split. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* eqk, eqke are equalities *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + Hint Resolve InA_eqke_eqk. + + Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. + Proof. + intros; apply InA_eqA with p; auto; apply eqk_trans; auto. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y. + exists e; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1. + inversion_clear H0; eauto. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Resolve In_inv_2 In_inv_3. + + +End PairDecidableType. diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v new file mode 100644 index 00000000..dde74a0a --- /dev/null +++ b/theories/FSets/FMapInterface.v @@ -0,0 +1,245 @@ +(***********************************************************************) +(* 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: FMapInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an interface for finite maps *) + +(* begin hide *) +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. +*) + + +Module Type S. + + Declare Module E : OrderedType. + + 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'). + + 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. + + (** 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 : sort lt_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'. + + (* 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 *) + +End S. + + +Module Type Sord. + + Declare Module Data : OrderedType. + Declare Module MapS : S. + Import MapS. + + Definition t := MapS.t Data.t. + + Parameter eq : t -> t -> Prop. + Parameter lt : t -> t -> Prop. + + Axiom eq_refl : forall m : t, eq m m. + Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. + Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. + Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. + Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. + + 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 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. *) + +End Sord.
\ No newline at end of file diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v new file mode 100644 index 00000000..2d083d5b --- /dev/null +++ b/theories/FSets/FMapList.v @@ -0,0 +1,1271 @@ +(***********************************************************************) +(* 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: FMapList.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [FMapInterface.S] using lists of pairs ordered (increasing) with respect to + left projection. *) + +Require Import FSetInterface. +Require Import FMapInterface. + +Set Implicit Arguments. +Unset Strict Implicit. + +Arguments Scope list [type_scope]. + +Module Raw (X:OrderedType). + +Module E := X. +Module MX := OrderedTypeFacts X. +Module PX := PairOrderedType X. +Import MX. +Import PX. + +Definition key := X.t. +Definition t (elt:Set) := list (X.t * elt). + +Section Elt. +Variable elt : Set. + +(* Now in PairOrderedtype: +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. +*) + +Notation eqk := (eqk (elt:=elt)). +Notation eqke := (eqke (elt:=elt)). +Notation ltk := (ltk (elt:=elt)). +Notation MapsTo := (MapsTo (elt:=elt)). +Notation In := (In (elt:=elt)). +Notation Sort := (sort ltk). +Notation Inf := (lelistA (ltk)). + +(** * [empty] *) + +Definition empty : t elt := nil. + +Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + +Lemma empty_1 : Empty empty. +Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. +Qed. +Hint Resolve empty_1. + +Lemma empty_sorted : Sort empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros (k,e) l inlist. + absurd (InA eqke (k, e) ((k, e) :: l));auto. +Qed. + +Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. +Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => + match X.compare k k' with + | LT _ => false + | EQ _ => true + | GT _ => mem k l + end + end. + +Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. +Proof. + intros m Hm x; generalize Hm; clear Hm. + functional induction mem x m;intros sorted belong1;trivial. + + inversion belong1. inversion H. + + absurd (In k ((k', e) :: l));try assumption. + apply Sort_Inf_NotIn with e;auto. + + apply H. + elim (sort_inv sorted);auto. + elim (In_inv belong1);auto. + intro abs. + absurd (X.eq k k');auto. +Qed. + +Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. +Proof. + intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. + functional induction mem x m; intros sorted hyp;try ((inversion hyp);fail). + exists e; auto. + induction H; auto. + exists x; auto. + inversion_clear sorted; auto. +Qed. + +(** * [find] *) + +Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => + match X.compare k k' with + | LT _ => None + | EQ _ => Some x + | GT _ => find k s' + end + end. + +Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. +Proof. + intros m x. unfold PX.MapsTo. + functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto. +Qed. + +Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. +Proof. + intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction find x m;simpl; subst; try clear H_eq_1. + + inversion 2. + + inversion_clear 2. + compute in H0; destruct H0; order. + generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. + + inversion_clear 2. + compute in H0; destruct H0; intuition congruence. + generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. + + do 2 inversion_clear 1; auto. + compute in H3; destruct H3; order. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => + match X.compare k k' with + | LT _ => (k,x)::s + | EQ _ => (k,x)::l + | GT _ => (k',y) :: add k x l + end + end. + +Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). +Proof. + intros m x y e; generalize y; clear y. + unfold PX.MapsTo. + functional induction add x e m;simpl;auto. +Qed. + +Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). +Proof. + intros m x y e e'. + generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto; clear H_eq_1. + intros y' e' eqky'; inversion_clear 1; destruct H0; simpl in *. + order. + auto. + auto. + intros y' e' eqky'; inversion_clear 1; intuition. +Qed. + +Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. +Proof. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl; intros. + apply (In_inv_3 H0); compute; auto. + apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. + inversion_clear H1; auto. +Qed. + +Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), + Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0,H1. + simpl; case (X.compare x x''); intuition. +Qed. +Hint Resolve add_Inf. + +Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. + constructor; auto. + apply Inf_eq with (x',e'); auto. +Qed. + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => + match X.compare k k' with + | LT _ => s + | EQ _ => l + | GT _ => (k',x) :: remove k l + end + end. + +Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). +Proof. + intros m Hm x y; generalize Hm; clear Hm. + functional induction remove x m;simpl;intros;subst;try clear H_eq_1. + + red; inversion 1; inversion H1. + + apply Sort_Inf_NotIn with x; auto. + constructor; compute; order. + + inversion_clear Hm. + apply Sort_Inf_NotIn with x; auto. + apply Inf_eq with (k',x);auto; compute; apply X.eq_trans with k; auto. + + inversion_clear Hm. + assert (notin:~ In y (remove k l)) by auto. + intros (x0,abs). + inversion_clear abs. + compute in H3; destruct H3; order. + apply notin; exists x0; auto. +Qed. + +Lemma remove_2 : forall m (Hm:Sort m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto; try clear H_eq_1. + inversion_clear 3; auto. + compute in H1; destruct H1; order. + + inversion_clear 1; inversion_clear 2; auto. +Qed. + +Lemma remove_3 : forall m (Hm:Sort m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + inversion_clear 1; inversion_clear 1; auto. +Qed. + +Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), + Inf (x',e') m -> Inf (x',e') (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0. + simpl; case (X.compare x x''); intuition. + inversion_clear Hm. + apply Inf_lt with (x'',e''); auto. +Qed. +Hint Resolve remove_Inf. + +Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. +Qed. + +(** * [elements] *) + +Definition elements (m: t elt) := m. + +Lemma elements_1 : forall m x e, + MapsTo x e m -> InA eqke (x,e) (elements m). +Proof. + auto. +Qed. + +Lemma elements_2 : forall m x e, + InA eqke (x,e) (elements m) -> MapsTo x e m. +Proof. + auto. +Qed. + +Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). +Proof. + auto. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A := + fun acc => + 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), + 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. +Qed. + +(** * [equal] *) + +Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := + match m, m' with + | nil, nil => true + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => cmp e e' && equal cmp l l' + | _ => false + end + | _, _ => false + end. + +Definition 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). + +Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equal 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; auto; unfold Equal; + intuition; subst; try clear H_eq_3. + + destruct p as (k,e). + destruct (H0 k). + destruct H2. + exists e; auto. + inversion H2. + + destruct (H0 x). + destruct H. + exists e; auto. + inversion H. + + destruct (H0 x). + assert (In x ((x',e')::l')). + apply H; auto. + exists e; auto. + destruct (In_inv H3). + order. + inversion_clear Hm'. + assert (Inf (x,e) l'). + apply Inf_lt with (x',e'); auto. + elim (Sort_Inf_NotIn H5 H7 H4). + + assert (cmp e e' = true). + apply H2 with x; auto. + rewrite H0; simpl. + apply H; auto. + inversion_clear Hm; auto. + inversion_clear Hm'; auto. + unfold Equal; intuition. + destruct (H1 k). + assert (In k ((x,e) ::l)). + destruct H3 as (e'', hyp); exists e''; auto. + destruct (In_inv (H4 H6)); auto. + inversion_clear Hm. + elim (Sort_Inf_NotIn H8 H9). + destruct H3 as (e'', hyp); exists e''; auto. + apply MapsTo_eq with k; auto; order. + destruct (H1 k). + assert (In k ((x',e') ::l')). + destruct H3 as (e'', hyp); exists e''; auto. + destruct (In_inv (H5 H6)); auto. + inversion_clear Hm'. + elim (Sort_Inf_NotIn H8 H9). + destruct H3 as (e'', hyp); exists e''; auto. + apply MapsTo_eq with k; auto; order. + apply H2 with k; destruct (eq_dec x k); auto. + + destruct (H0 x'). + assert (In x' ((x,e)::l)). + apply H2; auto. + exists e'; auto. + destruct (In_inv H3). + order. + inversion_clear Hm. + assert (Inf (x',e') l). + apply Inf_lt with (x,e); auto. + elim (Sort_Inf_NotIn H5 H7 H4). +Qed. + +Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, + equal cmp m m' = true -> Equal cmp m m'. +Proof. + intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. + functional induction equal cmp m m'; simpl; auto; unfold Equal; + intuition; try discriminate; subst; try clear H_eq_3; + try solve [inversion H0]; destruct (andb_prop _ _ H0); clear H0; + inversion_clear Hm; inversion_clear Hm'. + + destruct (H H0 H5 H3). + destruct (In_inv H1). + exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. + destruct (H7 k). + destruct (H10 H9) as (e'',hyp). + exists e''; auto. + + destruct (H H0 H5 H3). + destruct (In_inv H1). + exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. + destruct (H7 k). + destruct (H11 H9) as (e'',hyp). + exists e''; auto. + + destruct (H H0 H6 H4). + inversion_clear H1. + destruct H10; simpl in *; subst. + inversion_clear H2. + destruct H10; simpl in *; subst; auto. + elim (Sort_Inf_NotIn H6 H7). + exists e'0; apply MapsTo_eq with k; auto; order. + inversion_clear H2. + destruct H1; simpl in *; subst; auto. + elim (Sort_Inf_NotIn H0 H5). + exists e1; apply MapsTo_eq with k; auto; order. + apply H9 with k; auto. +Qed. + +(** This lemma isn't part of the spec of [Equal], 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)). +Proof. + intros. + inversion H; subst. + inversion H0; subst. + destruct x; destruct y; compute in H1, H2. + split; intros. + apply equal_2; auto. + simpl. + elim_comp. + rewrite H2; simpl. + apply equal_1; auto. + apply equal_2; auto. + generalize (equal_1 H H0 H3). + simpl. + elim_comp. + rewrite H2; simpl; auto. +Qed. + +Variable elt':Set. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +End Elt. +Section Elt2. +(* A new section is necessary for previous definitions to work + with different [elt], especially [MapsTo]... *) + +Variable elt elt' : Set. + +(** Specification of [map] *) + +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). +Proof. + intros m x e f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + constructor 2. + unfold MapsTo in *; auto. +Qed. + +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. +Proof. + intros m x f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x0,e0). + inversion_clear H; auto. +Qed. + +Hint Resolve map_lelistA. + +Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), + sort (@ltk elt') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + exact (map_lelistA _ _ H0). +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). +Proof. + intros m x e f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + exists x'. + destruct H0; simpl in *. + split; auto. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + destruct IHm as (y, hyp); auto. + exists y; intuition. +Qed. + + +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. +Proof. + intros m x f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,f x e) (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear H; auto. +Qed. + +Hint Resolve mapi_lelistA. + +Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), + sort (@ltk elt') (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. +Qed. + +End Elt2. +Section Elt3. + +(** * [map2] *) + +Variable elt elt' elt'' : Set. +Variable f : option elt -> option elt' -> option elt''. + +Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + +Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil + | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) + end. + +Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil + | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') + end. + +Fixpoint map2 (m : t elt) : t elt' -> t elt'' := + match m with + | nil => map2_r + | (k,e) :: l => + fix map2_aux (m' : t elt') : t elt'' := + match m' with + | nil => map2_l m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => option_cons k (f (Some e) None) (map2 l m') + | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') + | GT _ => option_cons k' (f None (Some e')) (map2_aux l') + end + end + end. + +Notation oee' := (option elt * option elt')%type. + +Fixpoint combine (m : t elt) : t elt' -> t oee' := + match m with + | nil => map (fun e' => (None,Some e')) + | (k,e) :: l => + fix combine_aux (m':t elt') : list (key * oee') := + match m' with + | nil => map (fun e => (Some e,None)) m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => (k,(Some e, None))::combine l m' + | EQ _ => (k,(Some e, Some e'))::combine l l' + | GT _ => (k',(None,Some e'))::combine_aux l' + end + end + end. + +Definition fold_right_pair (A B C:Set)(f: A->B->C->C)(l:list (A*B))(i:C) := + List.fold_right (fun p => f (fst p) (snd p)) i l. + +Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + +Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. +Proof. + unfold map2_alt. + induction m. + simpl; auto; intros. + (* map2_r *) + induction m'; try destruct a; simpl; auto. + rewrite IHm'; auto. + (* fin map2_r *) + induction m'; destruct a. + simpl; f_equal. + (* map2_l *) + clear IHm. + induction m; try destruct a; simpl; auto. + rewrite IHm; auto. + (* fin map2_l *) + destruct a0. + simpl. + destruct (X.compare t0 t1); simpl; f_equal. + apply IHm. + apply IHm. + apply IHm'. +Qed. + +Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> + lelistA (@ltk oee') (x,e'') (combine m m'). +Proof. + induction m. + intros. + simpl. + exact (map_lelistA _ _ H0). + induction m'. + intros. + destruct a. + replace (combine ((t0, e0) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. + exact (map_lelistA _ _ H). + intros. + simpl. + destruct a as (k,e0); destruct a0 as (k',e0'). + destruct (X.compare k k'). + inversion_clear H; auto. + inversion_clear H; auto. + inversion_clear H0; auto. +Qed. +Hint Resolve combine_lelistA. + +Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk oee') (combine m m'). +Proof. + induction m. + intros; clear Hm. + simpl. + apply map_sorted; auto. + induction m'. + intros; clear Hm'. + destruct a. + replace (combine ((t0, e) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. + apply map_sorted; auto. + intros. + simpl. + destruct a as (k,e); destruct a0 as (k',e'). + destruct (X.compare k k'). + inversion_clear Hm. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. + exact (combine_lelistA _ H0 H1). + inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') m') by apply Inf_eq with (k',e'); auto. + exact (combine_lelistA _ H0 H3). + inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) + (combine ((k,e)::m) m')). + assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. + exact (combine_lelistA _ H3 H2). +Qed. + +Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk elt'') (map2 m m'). +Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H0:=combine_sorted Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_sorted (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + simpl; auto. + inversion_clear H1. + destruct a; destruct o; auto. + simpl. + constructor; auto. + clear IHl1. + induction l1. + simpl; auto. + destruct a; destruct o; simpl; auto. + inversion_clear H0; auto. + inversion_clear H0. + red in H1; simpl in H1. + inversion_clear H. + apply IHl1; auto. + apply Inf_lt with (t1, None (A:=elt'')); auto. +Qed. + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + +Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). +Proof. + induction m. + intros. + simpl. + induction m'. + intros; simpl; auto. + simpl; destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + inversion_clear Hm'; auto. + induction m'. + (* m' = nil *) + intros; destruct a; simpl. + destruct (X.compare x t0); simpl; auto. + inversion_clear Hm; clear H0 l Hm' IHm t0. + induction m; simpl; auto. + inversion_clear H. + destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + (* m' <> nil *) + intros. + destruct a as (k,e); destruct a0 as (k',e'); simpl. + inversion Hm; inversion Hm'; subst. + destruct (X.compare k k'); simpl; + destruct (X.compare x k); + elim_comp || destruct (X.compare x k'); simpl; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = + at_least_one (find x m) (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. +Qed. + +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + +Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_sorted Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.compare x k); simpl in *. + (* x < k *) + destruct (f' (oo,oo')); simpl. + elim_comp. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct (IHm0 H0) as (H2,_); apply H2; auto. + rewrite <- H. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). + exists p; apply find_2; auto. + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + destruct o; destruct o'; simpl in *; inversion_clear H; auto. + rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). + exists p; apply find_2; auto. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (H3,_); apply H3; auto. + destruct (IHm0 H0) as (H3,_); apply H3; auto. + + (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.compare x k). + (* x < k *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). + exists p; apply find_2; auto. + (* x = k *) + discriminate. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. +Qed. + +(** Specification of [map2] *) + +Lemma map2_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). +Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. +Qed. + +Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. +Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_sorted Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + left; exists e0; auto. + left; exists e0; auto. + right; exists e0; auto. + discriminate. +Qed. + +End Elt3. +End Raw. + +Module Make (X: OrderedType) <: S with Module E := X. +Module Raw := Raw X. +Module E := X. + +Definition key := X.t. + +Record slist (elt:Set) : Set := + {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. +Definition t (elt:Set) := slist elt. + +Section Elt. + Variable elt elt' elt'':Set. + + Implicit Types m : t elt. + + Definition empty := Build_slist (Raw.empty_sorted elt). + Definition is_empty m := Raw.is_empty m.(this). + Definition add x e m := Build_slist (Raw.add_sorted m.(sorted) x e). + Definition find x m := Raw.find x m.(this). + Definition remove x m := Build_slist (Raw.remove_sorted m.(sorted) x). + Definition mem x m := Raw.mem x m.(this). + Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). + Definition mapi f m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). + Definition elements m := @Raw.elements elt m.(this). + Definition fold A f m i := @Raw.fold elt A f m.(this) i. + Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this). + + Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this). + Definition In x m := Raw.PX.In x m.(this). + Definition Empty m := Raw.Empty m.(this). + Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition eq_key := Raw.PX.eqk. + Definition eq_key_elt := Raw.PX.eqke. + Definition lt_key := Raw.PX.ltk. + + Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this). + + Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(sorted). + Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(sorted). + + Definition empty_1 := @Raw.empty_1. + + Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this). + Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this). + + Definition add_1 m := @Raw.add_1 elt m.(this). + Definition add_2 m := @Raw.add_2 elt m.(this). + Definition add_3 m := @Raw.add_3 elt m.(this). + + Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(sorted). + Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(sorted). + Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(sorted). + + Definition find_1 m := @Raw.find_1 elt m.(this) m.(sorted). + Definition find_2 m := @Raw.find_2 elt m.(this). + + Definition elements_1 m := @Raw.elements_1 elt m.(this). + Definition elements_2 m := @Raw.elements_2 elt m.(this). + Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(sorted). + + Definition fold_1 m := @Raw.fold_1 elt m.(this). + + Definition map_1 m := @Raw.map_1 elt elt' m.(this). + Definition map_2 m := @Raw.map_2 elt elt' m.(this). + + Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this). + Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this). + + Definition map2_1 m (m':t elt') x f := + @Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x. + Definition map2_2 m (m':t elt') x f := + @Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x. + + Definition equal_1 m m' := + @Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted). + Definition equal_2 m m' := + @Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted). + + End Elt. +End Make. + +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D + with Module MapS.E := X. + +Module Data := D. +Module MapS := Make(X). +Import MapS. + +Module MD := OrderedTypeFacts(D). +Import MD. + +Definition t := MapS.t D.t. + +Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. + +Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := + match m, m' with + | nil, nil => True + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => D.eq e e' /\ eq_list l l' + | _ => False + end + | _, _ => False + end. + +Definition eq m m' := eq_list m.(this) m'.(this). + +Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := + match m, m' with + | nil, nil => False + | nil, _ => True + | _, nil => False + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | LT _ => True + | GT _ => False + | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') + end + end. + +Definition lt m m' := lt_list m.(this) m'.(this). + +Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. +Proof. + intros (l,Hl); induction l. + intros (l',Hl'); unfold eq; simpl. + destruct l'; unfold equal; simpl; intuition. + intros (l',Hl'); unfold eq. + destruct l'. + destruct a; unfold equal; simpl; intuition. + destruct a as (x,e). + destruct p as (x',e'). + unfold equal; simpl. + destruct (X.compare x x'); simpl; intuition. + unfold cmp at 1. + MD.elim_comp; clear H; simpl. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H5; simpl in H5; auto. + destruct (andb_prop _ _ H); clear H. + generalize H0; unfold cmp. + MD.elim_comp; auto; intro; discriminate. + destruct (andb_prop _ _ H); clear H. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H6; simpl in H6; auto. +Qed. + +Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'. +Proof. + intros. + generalize (@equal_1 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. +Qed. + +Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'. +Proof. + intros. + generalize (@equal_2 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. +Qed. + +Lemma eq_refl : forall m : t, eq m m. +Proof. + intros (m,Hm); induction m; unfold eq; simpl; auto. + destruct a. + destruct (X.compare t0 t0); auto. + apply (MapS.Raw.MX.lt_antirefl l); auto. + split. + apply D.eq_refl. + inversion_clear Hm. + apply (IHm H). + apply (MapS.Raw.MX.lt_antirefl l); auto. +Qed. + +Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. +Proof. + intros (m,Hm); induction m; + intros (m', Hm'); destruct m'; unfold eq; simpl; + try destruct a as (x,e); try destruct p as (x',e'); auto. + destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition. + inversion_clear Hm; inversion_clear Hm'. + apply (IHm H0 (Build_slist H4)); auto. +Qed. + +Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp. + intuition. + apply D.eq_trans with e'; auto. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. +Qed. + +Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; auto. + intuition. + left; apply D.lt_trans with e'; auto. + left; apply lt_eq with e'; auto. + left; apply eq_lt with e'; auto. + right. + split. + apply D.eq_trans with e'; auto. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. +Qed. + +Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try contradiction; auto. + destruct (X.compare x x'); auto. + intuition. + exact (D.lt_not_eq H0 H1). + inversion_clear Hm1; inversion_clear Hm2. + apply (IHm1 H0 (Build_slist H5)); intuition. +Qed. + +Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. + +Definition compare : forall m1 m2, Compare lt eq m1 m2. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + [ apply EQ | apply LT | apply GT | ]; cmp_solve. + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); + [ apply LT | | apply GT ]; cmp_solve. + destruct (D.compare e e'); + [ apply LT | | apply GT ]; cmp_solve. + assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). + inversion_clear Hm1; auto. + assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). + inversion_clear Hm2; auto. + destruct (IHm1 Hm11 (Build_slist Hm22)); + [ apply LT | apply EQ | apply GT ]; cmp_solve. +Qed. + +End Make_ord. diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v new file mode 100644 index 00000000..90ebeffc --- /dev/null +++ b/theories/FSets/FMapWeak.v @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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 8639 2006-03-16 19:21:55Z letouzey $ *) + +Require Export FMapWeakInterface. +Require Export FMapWeakList. diff --git a/theories/FSets/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v new file mode 100644 index 00000000..b6df4da5 --- /dev/null +++ b/theories/FSets/FMapWeakInterface.v @@ -0,0 +1,201 @@ +(***********************************************************************) +(* 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 new file mode 100644 index 00000000..ce3893e0 --- /dev/null +++ b/theories/FSets/FMapWeakList.v @@ -0,0 +1,960 @@ +(***********************************************************************) +(* 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: FMapWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [FMapInterface.S] using lists of pairs, unordered but without redundancy. *) + +Require Import FSetInterface. +Require Import FSetWeakInterface. +Require Import FMapWeakInterface. + +Set Implicit Arguments. +Unset Strict Implicit. + +Arguments Scope list [type_scope]. + +Module Raw (X:DecidableType). + +Module PX := PairDecidableType X. +Import PX. + +Definition key := X.t. +Definition t (elt:Set) := list (X.t * elt). + +Section Elt. + +Variable elt : Set. + +(* now in PairDecidableType: +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'). +*) + +Notation eqk := (eqk (elt:=elt)). +Notation eqke := (eqke (elt:=elt)). +Notation MapsTo := (MapsTo (elt:=elt)). +Notation In := (In (elt:=elt)). +Notation NoDupA := (NoDupA eqk). + +(** * [empty] *) + +Definition empty : t elt := nil. + +Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m. + +Lemma empty_1 : Empty empty. +Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. +Qed. + +Hint Resolve empty_1. + +Lemma empty_NoDup : NoDupA empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros p l inlist. + destruct p. + absurd (InA eqke (t0, e) ((t0, e) :: l));auto. +Qed. + +Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. +Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => if X.eq_dec k k' then true else mem k l + end. + +Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. +Proof. + intros m Hm x; generalize Hm; clear Hm. + functional induction mem x m;intros NoDup belong1;trivial. + inversion belong1. inversion H. + inversion_clear NoDup. + inversion_clear belong1. + inversion_clear H3. + compute in H4; destruct H4. + elim H; auto. + apply H0; auto. + exists x; auto. +Qed. + +Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. +Proof. + intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. + functional induction mem x m; intros NoDup hyp; try discriminate. + exists e; auto. + inversion_clear NoDup. + destruct H0; auto. + exists x; auto. +Qed. + +(** * [find] *) + +Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' + end. + +Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. +Proof. + intros m x. unfold PX.MapsTo. + functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto. +Qed. + +Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. +Proof. + intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction find x m;simpl; subst; try clear H_eq_1. + + inversion 2. + + do 2 inversion_clear 1. + compute in H3; destruct H3; subst; trivial. + elim H0; apply InA_eqk with (k,e); auto. + + do 2 inversion_clear 1; auto. + compute in H4; destruct H4; elim H; auto. +Qed. + +(* Not part of the exported specifications, used later for [combine]. *) + +Lemma find_eq : forall m (Hm:NoDupA m) x x', + X.eq x x' -> find x m = find x' m. +Proof. + induction m; simpl; auto; destruct a; intros. + inversion_clear Hm. + rewrite (IHm H1 x x'); auto. + destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial. + elim n; apply X.eq_trans with x; auto. + elim n; apply X.eq_trans with x'; auto. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l + end. + +Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). +Proof. + intros m x y e; generalize y; clear y; unfold PX.MapsTo. + functional induction add x e m;simpl;auto. +Qed. + +Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). +Proof. + intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto. + intros y' e' eqky'; inversion_clear 1. + destruct H1; simpl in *. + elim eqky'; apply X.eq_trans with k'; auto. + auto. + intros y' e' eqky'; inversion_clear 1; intuition. +Qed. + +Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. +Proof. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto. + intros; apply (In_inv_3 H0); auto. + constructor 2; apply (In_inv_3 H1); auto. + inversion_clear 2; auto. +Qed. + +Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Proof. + intros m x y e e'. generalize y e; clear y e. + functional induction add x e' m;simpl;auto. + inversion_clear 2. + compute in H1; elim H; auto. + inversion H1. + constructor 2; inversion_clear H1; auto. + compute in H2; elim H0; auto. + inversion_clear 2; auto. +Qed. + +Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). +Proof. + induction m. + simpl; constructor; auto; red; inversion 1. + intros. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. + constructor; auto. + swap H. + apply InA_eqk with (x,e); auto. + constructor; auto. + swap H; apply add_3' with x e; auto. +Qed. + +(* Not part of the exported specifications, used later for [combine]. *) + +Lemma add_eq : forall m (Hm:NoDupA m) x a e, + X.eq x a -> find x (add a e m) = Some e. +Proof. + intros. + apply find_1; auto. + apply add_NoDup; auto. + apply add_1; auto. +Qed. + +Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, + ~X.eq x a -> find x (add a e m) = find x m. +Proof. + intros. + case_eq (find x m); intros. + apply find_1; auto. + apply add_NoDup; auto. + apply add_2; auto. + apply find_2; auto. + case_eq (find x (add a e m)); intros; auto. + rewrite <- H0; symmetry. + apply find_1; auto. + apply add_3 with a e; auto. + apply find_2; auto. +Qed. + + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l + end. + +Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). +Proof. + intros m Hm x y; generalize Hm; clear Hm. + functional induction remove x m;simpl;intros;auto. + + red; inversion 1; inversion H1. + + inversion_clear Hm. + subst. + swap H1. + destruct H3 as (e,H3); unfold PX.MapsTo in H3. + apply InA_eqk with (y,e); auto. + compute; apply X.eq_trans with k; auto. + + intro H2. + destruct H2 as (e,H2); inversion_clear H2. + compute in H3; destruct H3. + elim H; apply X.eq_trans with y; auto. + inversion_clear Hm. + elim (H0 H4 H1). + exists e; auto. +Qed. + +Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + inversion_clear 3; auto. + compute in H2; destruct H2. + elim H0; apply X.eq_trans with k'; auto. + + inversion_clear 1; inversion_clear 2; auto. +Qed. + +Lemma remove_3 : forall m (Hm:NoDupA m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + do 2 inversion_clear 1; auto. +Qed. + +Lemma remove_3' : forall m (Hm:NoDupA m) x y e, + InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + do 2 inversion_clear 1; auto. +Qed. + +Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + inversion_clear Hm. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); auto. + constructor; auto. + swap H; apply remove_3' with x; auto. +Qed. + +(** * [elements] *) + +Definition elements (m: t elt) := m. + +Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). +Proof. + auto. +Qed. + +Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. +Proof. +auto. +Qed. + +Lemma elements_3 : forall m (Hm:NoDupA m), NoDupA (elements m). +Proof. + auto. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A := + fun acc => + 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), + 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. +Qed. + +(** * [equal] *) + +Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with + | None => false + | Some e' => cmp e e' + end. + +Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + +Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). + +Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Definition 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). + +Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + destruct a; simpl; intros. + destruct H. + inversion_clear Hm. + assert (H3 : In t0 m'). + apply H; exists e; auto. + destruct H3 as (e', H3). + unfold check at 2; rewrite (find_1 Hm' H3). + rewrite (H0 t0); simpl; auto. + eapply IHm; auto. + split; intuition. + apply H. + destruct H5 as (e'',H5); exists e''; auto. + apply H0 with k; auto. +Qed. + +Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + intuition. + destruct H0; inversion H0. + inversion H0. + + destruct a; simpl; intros. + inversion_clear Hm. + rewrite andb_b_true in H. + assert (check cmp t0 e m' = true). + clear H1 H0 Hm' IHm. + set (b:=check cmp t0 e m') in *. + generalize H; clear H; generalize b; clear b. + induction m; simpl; auto; intros. + destruct a; simpl in *. + destruct (andb_prop _ _ (IHm _ H)); auto. + rewrite H2 in H. + destruct (IHm H1 m' Hm' cmp H); auto. + unfold check in H2. + case_eq (find t0 m'); [intros e' H5 | intros H5]; + rewrite H5 in H2; try discriminate. + split; intros. + destruct H6 as (e0,H6); inversion_clear H6. + compute in H7; destruct H7; subst. + exists e'. + apply PX.MapsTo_eq with t0; auto. + apply find_2; auto. + apply H3. + exists e0; auto. + inversion_clear H6. + compute in H8; destruct H8; subst. + rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. + apply H4 with k; auto. +Qed. + +(** Specification of [equal] *) + +Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equal cmp m m' -> equal cmp m m' = true. +Proof. + unfold Equal, 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'. +Proof. + unfold Equal, equal. + intros. + destruct (andb_prop _ _ H); clear H. + generalize (submap_2 Hm Hm' H0). + generalize (submap_2 Hm' Hm H1). + firstorder. +Qed. + +Variable elt':Set. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +End Elt. +Section Elt2. +(* A new section is necessary for previous definitions to work + with different [elt], especially [MapsTo]... *) + +Variable elt elt' : Set. + +(** Specification of [map] *) + +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). +Proof. + intros m x e f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + constructor 2. + unfold MapsTo in *; auto. +Qed. + +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. +Proof. + intros m x f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), + NoDupA (@eqk elt') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + swap 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. +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). +Proof. + intros m x e f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + exists x'. + destruct H0; simpl in *. + split; auto. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + destruct IHm as (y, hyp); auto. + exists y; intuition. +Qed. + +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. +Proof. + intros m x f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), + NoDupA (@eqk elt') (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. + constructor; auto. + swap H. + clear IHm H0. + induction m; simpl in *; auto. + inversion_clear H1. + destruct a; inversion_clear H1; auto. +Qed. + +End Elt2. +Section Elt3. + +Variable elt elt' elt'' : Set. + +Notation oee' := (option elt * option elt')%type. + +Definition combine_l (m:t elt)(m':t elt') : t oee' := + mapi (fun k e => (Some e, find k m')) m. + +Definition combine_r (m:t elt)(m':t elt') : t oee' := + mapi (fun k e' => (find k m, Some e')) m'. + +Definition fold_right_pair (A B C:Set)(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' := + let l := combine_l m m' in + let r := combine_r m m' in + fold_right_pair (add (elt:=oee')) l r. + +Lemma fold_right_pair_NoDup : + forall l r (Hl: NoDupA (eqk (elt:=oee')) l) + (Hl: NoDupA (eqk (elt:=oee')) r), + NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r). +Proof. + induction l; simpl; auto. + destruct a; simpl; auto. + inversion_clear 1. + intros; apply add_NoDup; auto. +Qed. +Hint Resolve fold_right_pair_NoDup. + +Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk oee') (combine m m'). +Proof. + unfold combine, combine_r, combine_l. + intros. + set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). + set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). + generalize (mapi_NoDup Hm f1). + generalize (mapi_NoDup Hm' f2). + set (l := mapi f1 m); clearbody l. + set (r := mapi f2 m'); clearbody r. + auto. +Qed. + +Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None + | _ => Some (o,o') + end. + +Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None + | _ => Some (o,o') + end. + +Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). +Proof. + unfold combine_l. + intros. + case_eq (find x m); intros. + simpl. + apply find_1. + apply mapi_NoDup; auto. + destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm' (X.eq_sym H0)); auto. + simpl. + case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. + destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). + exists p; apply find_2; auto. + rewrite (find_1 Hm H1) in H; discriminate. +Qed. + +Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). +Proof. + unfold combine_r. + intros. + case_eq (find x m'); intros. + simpl. + apply find_1. + apply mapi_NoDup; auto. + destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm (X.eq_sym H0)); auto. + simpl. + case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. + destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). + exists p; apply find_2; auto. + rewrite (find_1 Hm' H1) in H; discriminate. +Qed. + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + +Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). +Proof. + unfold combine. + intros. + generalize (combine_r_1 Hm Hm' x). + generalize (combine_l_1 Hm Hm' x). + assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). + unfold combine_l; apply mapi_NoDup; auto. + assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). + unfold combine_r; apply mapi_NoDup; auto. + set (l := combine_l m m') in *; clearbody l. + set (r := combine_r m m') in *; clearbody r. + set (o := find x m); clearbody o. + set (o' := find x m'); clearbody o'. + clear Hm' Hm m m'. + induction l. + destruct o; destruct o'; simpl; intros; discriminate || auto. + destruct a; simpl in *; intros. + destruct (X.eq_dec x t0); simpl in *. + unfold at_least_left in H1. + destruct o; simpl in *; try discriminate. + inversion H1; subst. + apply add_eq; auto. + inversion_clear H; auto. + inversion_clear H. + rewrite <- IHl; auto. + apply add_not_eq; auto. +Qed. + +Variable f : option elt -> option elt' -> option elt''. + +Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + +Definition map2 m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + +Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk elt'') (map2 m m'). +Proof. + intros. + unfold map2. + assert (H0:=combine_NoDup Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_NoDup (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + simpl; auto. + inversion_clear H1. + destruct a; destruct o; simpl; auto. + constructor; auto. + swap H. + clear IHl1. + induction l1. + inversion H1. + inversion_clear H0. + destruct a; destruct o; simpl in *; auto. + inversion_clear H1; auto. +Qed. + +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + +Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Proof. + intros. + unfold map2. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_NoDup Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.eq_dec x k); simpl in *. + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + destruct o; destruct o'; simpl in *; inversion_clear H; auto. + rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); try absurd_hyp n; auto. + destruct (IHm0 H1) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + elim H0. + apply InA_eqk with (x,p); auto. + apply InA_eqke_eqk. + exact (find_2 H3). + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (IHm0 H1) as (H3,_); apply H3; auto. + destruct (IHm0 H1) as (H3,_); apply H3; auto. + + (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.eq_dec x k). + (* x = k *) + discriminate. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (IHm0 H1) as (_,H4); apply H4; auto. + destruct (IHm0 H1) as (_,H4); apply H4; auto. +Qed. + +(** Specification of [map2] *) +Lemma map2_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). +Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. +Qed. + +Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. +Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_NoDup Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + left; exists e0; auto. + left; exists e0; auto. + right; exists e0; auto. + discriminate. +Qed. + +End Elt3. +End Raw. + + +Module Make (X: DecidableType) <: S with Module E:=X. + Module Raw := Raw X. + + Module E := X. + Definition key := X.t. + + Record slist (elt:Set) : Set := + {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. + Definition t (elt:Set) := slist elt. + + Section Elt. + Variable elt elt' elt'':Set. + + Implicit Types m : t elt. + + Definition empty := Build_slist (Raw.empty_NoDup elt). + Definition is_empty m := Raw.is_empty m.(this). + Definition add x e m := Build_slist (Raw.add_NoDup m.(NoDup) x e). + Definition find x m := Raw.find x m.(this). + Definition remove x m := Build_slist (Raw.remove_NoDup m.(NoDup) x). + Definition mem x m := Raw.mem x m.(this). + Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). + Definition mapi f m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). + Definition elements m := @Raw.elements elt m.(this). + Definition fold A f m i := @Raw.fold elt A f m.(this) i. + Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this). + + Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this). + Definition In x m := Raw.PX.In x m.(this). + Definition Empty m := Raw.Empty m.(this). + Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition eq_key (p p':key*elt) := X.eq (fst p) (fst p'). + + Definition eq_key_elt (p p':key*elt) := + X.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this). + + Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(NoDup). + Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(NoDup). + + Definition empty_1 := @Raw.empty_1. + + Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this). + Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this). + + Definition add_1 m := @Raw.add_1 elt m.(this). + Definition add_2 m := @Raw.add_2 elt m.(this). + Definition add_3 m := @Raw.add_3 elt m.(this). + + Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(NoDup). + Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(NoDup). + Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(NoDup). + + Definition find_1 m := @Raw.find_1 elt m.(this) m.(NoDup). + Definition find_2 m := @Raw.find_2 elt m.(this). + + Definition elements_1 m := @Raw.elements_1 elt m.(this). + Definition elements_2 m := @Raw.elements_2 elt m.(this). + Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(NoDup). + + Definition fold_1 m := @Raw.fold_1 elt m.(this). + + Definition map_1 m := @Raw.map_1 elt elt' m.(this). + Definition map_2 m := @Raw.map_2 elt elt' m.(this). + + Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this). + Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this). + + Definition map2_1 m (m':t elt') x f := + @Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x. + Definition map2_2 m (m':t elt') x f := + @Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x. + + Definition equal_1 m m' := @Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup). + Definition equal_2 m m' := @Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup). + + End Elt. +End Make. + + diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v new file mode 100644 index 00000000..ae5b86c9 --- /dev/null +++ b/theories/FSets/FMaps.v @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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: FMaps.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +Require Export FMapInterface. +Require Export FMapList. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v new file mode 100644 index 00000000..3ea50df8 --- /dev/null +++ b/theories/FSets/FSetBridge.v @@ -0,0 +1,750 @@ +(***********************************************************************) +(* 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: FSetBridge.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This module implements bridges (as functors) from dependent + to/from non-dependent set signature. *) + +Require Export FSetInterface. +Set Implicit Arguments. +Unset Strict Implicit. +Set Firstorder Depth 2. + +(** * From non-dependent signature [S] to dependent signature [Sdep]. *) + +Module DepOfNodep (M: S) <: Sdep with Module E := M.E. + Import M. + + Module ME := OrderedTypeFacts E. + + Definition empty : {s : t | Empty s}. + Proof. + exists empty; auto. + Qed. + + Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. + Proof. + intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)). + case (is_empty s); intuition. + Qed. + + + Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. + Proof. + intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)). + case (mem x s); intuition. + Qed. + + Definition Add (x : elt) (s s' : t) := + forall y : elt, In y s' <-> E.eq x y \/ In y s. + + Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. + Proof. + intros; exists (add x s); auto. + unfold Add in |- *; intuition. + elim (ME.eq_dec x y); auto. + intros; right. + eapply add_3; eauto. + Qed. + + Definition singleton : + forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. + Proof. + intros; exists (singleton x); intuition. + Qed. + + Definition remove : + forall (x : elt) (s : t), + {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. + apply In_1 with y; auto. + elim (ME.eq_dec x y); intros; auto. + absurd (In x (remove x s)); auto. + apply In_1 with y; auto. + eauto. + Qed. + + Definition union : + forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. + Proof. + intros; exists (union s s'); intuition. + Qed. + + 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. + 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. + Qed. + + Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. + Proof. + intros. + generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). + case (equal s s'); intuition. + Qed. + + Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. + Proof. + intros. + generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). + case (subset s s'); intuition. + Qed. + + Definition elements : + forall s : t, + {l : list elt | ME.Sort l /\ (forall x : elt, In x s <-> ME.In x l)}. + Proof. + intros; exists (elements s); intuition. + Defined. + + Definition fold : + forall (A : Set) (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. + intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). + Qed. + + Definition cardinal : + forall s : t, + {r : nat | let (l,_) := elements s in r = length l }. + Proof. + intros; exists (cardinal s); exact (cardinal_1 s). + Qed. + + Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (x : elt) := if Pdec x then true else false. + + Lemma compat_P_aux : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), + compat_P E.eq P -> compat_bool E.eq (fdec Pdec). + Proof. + unfold compat_P, compat_bool, fdec in |- *; intros. + generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. + Qed. + + Hint Resolve compat_P_aux. + + Definition filter : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. + Proof. + intros. + exists (filter (fdec Pdec) s). + intro H; assert (compat_bool E.eq (fdec Pdec)); auto. + intuition. + eauto. + generalize (filter_2 H0 H1). + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H2. + apply filter_3; auto. + unfold fdec in |- *; simpl in |- *. + case (Pdec x); intuition. + Qed. + + Definition for_all : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. + Proof. + intros. + generalize (for_all_1 (s:=s) (f:=fdec Pdec)) + (for_all_2 (s:=s) (f:=fdec Pdec)). + case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ]; + intros. + assert (compat_bool E.eq (fdec Pdec)); auto. + generalize (H0 H3 (refl_equal _) _ H2). + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H4. + intuition. + absurd (false = true); [ auto with bool | apply H; auto ]. + intro. + unfold fdec in |- *. + case (Pdec x); intuition. + Qed. + + Definition exists_ : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. + Proof. + intros. + generalize (exists_1 (s:=s) (f:=fdec Pdec)) + (exists_2 (s:=s) (f:=fdec Pdec)). + case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ]; + intros. + elim H0; auto; intros. + exists x; intuition. + generalize H4. + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H2. + intuition. + elim H2; intros. + absurd (false = true); [ auto with bool | apply H; auto ]. + exists x; intuition. + unfold fdec in |- *. + case (Pdec x); intuition. + Qed. + + Definition partition : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {partition : t * t | + let (s1, s2) := partition in + compat_P E.eq P -> + For_all P s1 /\ + For_all (fun x => ~ P x) s2 /\ + (forall x : elt, In x s <-> In x s1 \/ In x s2)}. + Proof. + intros. + exists (partition (fdec Pdec) s). + generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)). + case (partition (fdec Pdec) s). + intros s1 s2; simpl in |- *. + intros; assert (compat_bool E.eq (fdec Pdec)); auto. + intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))). + generalize H2; unfold compat_bool in |- *; intuition; + apply (f_equal negb); auto. + intuition. + generalize H4; unfold For_all, Equal in |- *; intuition. + elim (H0 x); intros. + assert (fdec Pdec x = true). + eauto. + generalize H8; unfold fdec in |- *; case (Pdec x); intuition. + inversion H9. + generalize H; unfold For_all, Equal in |- *; intuition. + elim (H0 x); intros. + cut ((fun x => negb (fdec Pdec x)) x = true). + unfold fdec in |- *; case (Pdec x); intuition. + change ((fun x => negb (fdec Pdec x)) x = true) in |- *. + apply (filter_2 (s:=s) (x:=x)); auto. + 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. + apply filter_3; auto. + rewrite H5; auto. + eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; + auto. + eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; 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. + Qed. + + Definition min_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. + Proof. + intros; + generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). + case (min_elt s); [ left | right ]; auto. + exists e; unfold For_all in |- *; eauto. + Qed. + + Definition max_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. + Proof. + intros; + generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). + case (max_elt s); [ left | right ]; auto. + exists e; unfold For_all in |- *; eauto. + Qed. + + Module E := E. + + Definition elt := elt. + Definition t := t. + + Definition In := In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := + exists x : elt, In x s /\ P x. + + Definition eq_In := In_1. + + Definition eq := Equal. + Definition lt := lt. + Definition eq_refl := eq_refl. + Definition eq_sym := eq_sym. + Definition eq_trans := eq_trans. + Definition lt_trans := lt_trans. + Definition lt_not_eq := lt_not_eq. + Definition compare := compare. + +End DepOfNodep. + + +(** * From dependent signature [Sdep] to non-dependent signature [S]. *) + +Module NodepOfDep (M: Sdep) <: S with Module E := M.E. + Import M. + + Module ME := OrderedTypeFacts E. + + Definition empty : t := let (s, _) := empty in s. + + Lemma empty_1 : Empty empty. + Proof. + unfold empty in |- *; case M.empty; auto. + Qed. + + Definition is_empty (s : t) : bool := + if is_empty s then true else false. + + Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. + Proof. + intros; unfold is_empty in |- *; case (M.is_empty s); auto. + Qed. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + Proof. + intro s; unfold is_empty in |- *; case (M.is_empty s); auto. + intros; discriminate H. + Qed. + + Definition mem (x : elt) (s : t) : bool := + if mem x s then true else false. + + Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true. + Proof. + intros; unfold mem in |- *; case (M.mem x s); auto. + Qed. + + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. + Proof. + intros s x; unfold mem in |- *; case (M.mem x s); auto. + intros; discriminate H. + Qed. + + Definition equal (s s' : t) : bool := + if equal s s' then true else false. + + Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. + Proof. + intros; unfold equal in |- *; case M.equal; intuition. + Qed. + + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. + Proof. + intros s s'; unfold equal in |- *; case (M.equal s s'); intuition; + inversion H. + Qed. + + Definition subset (s s' : t) : bool := + if subset s s' then true else false. + + Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. + Proof. + intros; unfold subset in |- *; case M.subset; intuition. + Qed. + + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. + Proof. + intros s s'; unfold subset in |- *; case (M.subset s s'); intuition; + inversion H. + Qed. + + Definition choose (s : t) : option elt := + match choose s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + intros s x; unfold choose in |- *; case (M.choose s). + simple destruct s0; intros; injection H; intros; subst; auto. + intros; discriminate H. + Qed. + + Lemma choose_2 : forall s : t, choose s = None -> Empty s. + Proof. + intro s; unfold choose in |- *; case (M.choose s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition elements (s : t) : list elt := let (l, _) := elements s in l. + + Lemma elements_1 : forall (s : t) (x : elt), In x s -> ME.In x (elements s). + Proof. + intros; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Lemma elements_2 : forall (s : t) (x : elt), ME.In x (elements s) -> In x s. + Proof. + intros s x; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Lemma elements_3 : forall s : t, ME.Sort (elements s). + Proof. + intros; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Definition min_elt (s : t) : option elt := + match min_elt s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Proof. + intros s x; unfold min_elt in |- *; case (M.min_elt s). + simple destruct s0; intros; injection H; intros; subst; intuition. + intros; discriminate H. + Qed. + + Lemma min_elt_2 : + forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + intros s x y; unfold min_elt in |- *; case (M.min_elt s). + unfold For_all in |- *; simple destruct s0; intros; injection H; intros; + subst; firstorder. + intros; discriminate H. + Qed. + + Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. + Proof. + intros s; unfold min_elt in |- *; case (M.min_elt s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition max_elt (s : t) : option elt := + match max_elt s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + intros s x; unfold max_elt in |- *; case (M.max_elt s). + simple destruct s0; intros; injection H; intros; subst; intuition. + intros; discriminate H. + Qed. + + Lemma max_elt_2 : + forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + intros s x y; unfold max_elt in |- *; case (M.max_elt s). + unfold For_all in |- *; simple destruct s0; intros; injection H; intros; + subst; firstorder. + intros; discriminate H. + Qed. + + Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. + Proof. + intros s; unfold max_elt in |- *; case (M.max_elt s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. + + Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s). + Proof. + intros; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s). + Proof. + intros; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Lemma add_3 : + forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s. + Proof. + intros s x y; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'. + + Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s). + Proof. + intros; unfold remove in |- *; case (M.remove x s); firstorder. + Qed. + + Lemma remove_2 : + forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s). + Proof. + intros; unfold remove in |- *; case (M.remove x s); firstorder. + Qed. + + Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s. + Proof. + intros s x y; unfold remove in |- *; case (M.remove x s); firstorder. + Qed. + + Definition singleton (x : elt) : t := let (s, _) := singleton x in s. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. + Proof. + intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. + Qed. + + Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). + Proof. + intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. + Qed. + + Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. + + Lemma union_1 : + forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. + Proof. + intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. + Qed. + + Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). + Proof. + intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. + Qed. + + Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). + Proof. + intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. + Qed. + + Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. + + Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. + Proof. + intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. + Qed. + + Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. + Proof. + intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. + Qed. + + Lemma inter_3 : + forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). + Proof. + intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. + Qed. + + Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. + + Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. + Proof. + intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. + Qed. + + Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. + Proof. + intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. + Qed. + + Lemma diff_3 : + forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). + Proof. + intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. + Qed. + + Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f. + + Lemma cardinal_1 : forall s, cardinal s = length (elements s). + Proof. + intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; + destruct (M.elements s); auto. + Qed. + + Definition fold (B : Set) (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), + 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 *; + destruct (M.elements s); auto. + Qed. + + Definition f_dec : + forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. + Proof. + intros; case (f x); auto with bool. + Defined. + + Lemma compat_P_aux : + forall f : elt -> bool, + compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). + Proof. + unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder. + Qed. + + Hint Resolve compat_P_aux. + + Definition filter (f : elt -> bool) (s : t) : t := + let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. + + Lemma filter_1 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x (filter f s) -> In x s. + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Lemma filter_2 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x (filter f s) -> f x = true. + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Lemma filter_3 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Definition for_all (f : elt -> bool) (s : t) : bool := + if for_all (P:=fun x => f x = true) (f_dec f) s + then true + else false. + + Lemma for_all_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. + intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n; + auto. + Qed. + + Lemma for_all_2 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. + intros s f; unfold for_all in |- *; case M.for_all; intuition; + inversion H0. + Qed. + + Definition exists_ (f : elt -> bool) (s : t) : bool := + if exists_ (P:=fun x => f x = true) (f_dec f) s + then true + else false. + + Lemma exists_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. + intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n; + auto. + Qed. + + Lemma exists_2 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. + intros s f; unfold exists_ in |- *; case M.exists_; intuition; + inversion H0. + Qed. + + Definition partition (f : elt -> bool) (s : t) : + t * t := + let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. + + Lemma partition_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). + Proof. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. + generalize (H (compat_P_aux C)); clear H; intro H. + simpl in |- *; unfold Equal in |- *; intuition. + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). + eapply filter_1; eauto. + elim H3; intros; auto. + absurd (f a = true). + exact (H a H6). + eapply filter_2; eauto. + Qed. + + Lemma partition_2 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. + generalize (H (compat_P_aux C)); clear H; intro H. + assert (D : compat_bool E.eq (fun x => negb (f x))). + generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb); + auto. + simpl in |- *; unfold Equal in |- *; intuition. + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). + eapply filter_1; eauto. + elim H3; intros; auto. + absurd (f a = true). + intro. + generalize (filter_2 D H1). + rewrite H7; intros H8; inversion H8. + exact (H0 a H6). + Qed. + + + Module E := E. + Definition elt := elt. + Definition t := t. + + Definition In := In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Add (x : elt) (s s' : t) := + forall y : elt, In y s' <-> E.eq y x \/ In y s. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := + exists x : elt, In x s /\ P x. + + Definition In_1 := eq_In. + + Definition eq := Equal. + Definition lt := lt. + Definition eq_refl := eq_refl. + Definition eq_sym := eq_sym. + Definition eq_trans := eq_trans. + Definition lt_trans := lt_trans. + Definition lt_not_eq := lt_not_eq. + Definition compare := compare. + +End NodepOfDep. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v new file mode 100644 index 00000000..006d78c7 --- /dev/null +++ b/theories/FSets/FSetEqProperties.v @@ -0,0 +1,923 @@ +(***********************************************************************) +(* 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: FSetEqProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This module proves many properties of finite sets that + are consequences of the axiomatization in [FsetInterface] + Contrary to the functor in [FsetProperties] it uses + sets operations instead of predicates over sets, i.e. + [mem x s=true] instead of [In x s], + [equal s s'=true] instead of [Equal s s'], etc. *) + + +Require Import FSetProperties. +Require Import Zerob. +Require Import Sumbool. +Require Import Omega. + +Module EqProperties (M:S). +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. + +Section BasicProperties. + +(** Some old specifications written with boolean equalities. *) + +Variable s s' s'': t. +Variable x y z : elt. + +Lemma mem_eq: + E.eq x y -> mem x s=mem y s. +Proof. +intro H; rewrite H; auto. +Qed. + +Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. +Proof. +intros; apply equal_1; unfold Equal; intros. +do 2 rewrite mem_iff; rewrite H; tauto. +Qed. + +Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. +Proof. +intros; apply subset_1; unfold Subset; intros a. +do 2 rewrite mem_iff; auto. +Qed. + +Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. +Proof. +intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. +Qed. + +Lemma empty_mem: mem x empty=false. +Proof. +rewrite <- not_mem_iff; auto. +Qed. + +Lemma is_empty_equal_empty: is_empty s = equal s empty. +Proof. +apply bool_1; split; intros. +rewrite <- (empty_is_empty_1 (s:=empty)); auto with set. +rewrite <- is_empty_iff; auto with set. +Qed. + +Lemma choose_mem_1: choose s=Some x -> mem x s=true. +Proof. +auto. +Qed. + +Lemma choose_mem_2: choose s=None -> is_empty s=true. +Proof. +auto. +Qed. + +Lemma add_mem_1: mem x (add x s)=true. +Proof. +auto. +Qed. + +Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. +Proof. +apply add_neq_b. +Qed. + +Lemma remove_mem_1: mem x (remove x s)=false. +Proof. +rewrite <- not_mem_iff; auto. +Qed. + +Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. +Proof. +apply remove_neq_b. +Qed. + +Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. +Proof. +rewrite (singleton_equal_add x); auto with set. +Qed. + +Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. +Proof. +apply union_b. +Qed. + +Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. +Proof. +apply inter_b. +Qed. + +Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). +Proof. +apply diff_b. +Qed. + +(** properties of [mem] *) + +Lemma mem_3 : ~In x s -> mem x s=false. +Proof. +intros; rewrite <- not_mem_iff; auto. +Qed. + +Lemma mem_4 : mem x s=false -> ~In x s. +Proof. +intros; rewrite not_mem_iff; auto. +Qed. + +(** Properties of [equal] *) + +Lemma equal_refl: equal s s=true. +Proof. +auto with set. +Qed. + +Lemma equal_sym: equal s s'=equal s' s. +Proof. +intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. +Qed. + +Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. +Proof. +auto with set. +Qed. + +(* Properties of [subset] *) + +Lemma subset_refl: subset s s=true. +Proof. +auto with set. +Qed. + +Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. +Proof. +auto with set. +Qed. + +Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. +Proof. +do 3 rewrite <- subset_iff; intros. +apply subset_trans with s'; auto. +Qed. + +Lemma subset_equal: + equal s s'=true -> subset s s'=true. +Proof. +auto with set. +Qed. + +(** Properties of [choose] *) + +Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. +Proof. +intros. +generalize (@choose_1 s) (@choose_2 s). +destruct (choose s);intros. +exists e;auto. +generalize (H1 (refl_equal None)); clear H1. +intros; rewrite (is_empty_1 H1) in H; discriminate. +Qed. + +Lemma choose_mem_4: choose empty=None. +Proof. +generalize (@choose_1 empty). +case (@choose empty);intros;auto. +elim (@empty_1 e); auto. +Qed. + +(** Properties of [add] *) + +Lemma add_mem_3: + mem y s=true -> mem y (add x s)=true. +Proof. +auto. +Qed. + +Lemma add_equal: + mem x s=true -> equal (add x s) s=true. +Proof. +auto with set. +Qed. + +(** Properties of [remove] *) + +Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. +Proof. +rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. +Qed. + +Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. +Proof. +intros; apply equal_1; apply remove_equal. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. +Proof. +intros; apply equal_1; apply add_remove; auto. +Qed. + +Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. +Proof. +intros; apply equal_1; apply remove_add; auto. +rewrite not_mem_iff; auto. +Qed. + +(** Properties of [is_empty] *) + +Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). +Proof. +intros; apply bool_1; split; intros. +rewrite cardinal_1; simpl; auto. +assert (cardinal s = 0) by apply zerob_true_elim; auto. +auto. +Qed. + +(** Properties of [singleton] *) + +Lemma singleton_mem_1: mem x (singleton x)=true. +Proof. +auto with set. +Qed. + +Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. +Proof. +intros; rewrite singleton_b. +unfold ME.eqb; destruct (ME.eq_dec x y); intuition. +Qed. + +Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. +Proof. +auto. +Qed. + +(** Properties of [union] *) + +Lemma union_sym: + equal (union s s') (union s' s)=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. +Proof. +auto with set. +Qed. + +Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. +Proof. +auto with set. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma union_subset_1: subset s (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_2: subset s' (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_3: + subset s s''=true -> subset s' s''=true -> + subset (union s s') s''=true. +Proof. +intros; apply subset_1; apply union_subset_3; auto. +Qed. + +(** Properties of [inter] *) + +Lemma inter_sym: equal (inter s s') (inter s' s)=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. +Proof. +intros; apply equal_1; apply inter_add_2. +rewrite not_mem_iff; auto. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma inter_subset_1: subset (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_2: subset (inter s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_3: + subset s'' s=true -> subset s'' s'=true -> + subset s'' (inter s s')=true. +Proof. +intros; apply subset_1; apply inter_subset_3; auto. +Qed. + +(** Properties of [diff] *) + +Lemma diff_subset: subset (diff s s') s=true. +Proof. +auto with set. +Qed. + +Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. +Proof. +auto with set. +Qed. + +Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. +Proof. +auto with set. +Qed. + +End BasicProperties. + +Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. +Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + +(** General recursion principes based on [cardinal] *) + +Lemma cardinal_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. +Proof. +intros. +apply cardinal_induction with n; 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 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. +Proof. +intros; do 2 rewrite not_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 (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. +Proof. +apply fold_empty; auto. +Qed. + +Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). +Proof. +intros; apply fold_equal with (eqA:=eqA); auto. +Qed. + +Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). +Proof. +intros; apply fold_add with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). +Proof. +intros; apply add_fold with (eqA:=eqA); auto. +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. +Qed. + +Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). +Proof. +intros; apply remove_fold_2 with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). +Proof. +intros; apply fold_union with (eqA:=eqA); auto. +intros; rewrite exclusive_set; auto. +Qed. + +End Fold. + +(** Properties of [cardinal] *) + +Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). +Proof. +intros; apply add_cardinal_2; auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. +Proof. +intros; apply remove_cardinal_1; auto. +Qed. + +Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. +Proof. +intros; apply union_cardinal; auto; intros. +rewrite exclusive_set; auto. +Qed. + +Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. +Proof. +intros; apply subset_cardinal; auto. +Qed. + +Section Bool. + +(** Properties of [filter] *) + +Variable f:elt->bool. +Variable Comp: compat_bool E.eq f. + +Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Proof. +unfold compat_bool in *; intros; f_equal; auto. +Qed. + +Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. +Proof. +intros; apply filter_b; auto. +Qed. + +Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). +Proof. +intros; apply bool_1; split; intros. +apply is_empty_1. +unfold Empty; intros. +rewrite filter_iff; auto. +red; destruct 1. +rewrite <- (@for_all_iff s f) in H; auto. +rewrite (H a H0) in H1; discriminate. +apply for_all_1; auto; red; intros. +revert H; rewrite <- is_empty_iff. +unfold Empty; intro H; generalize (H x); clear H. +rewrite filter_iff; auto. +destruct (f x); auto. +Qed. + +Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). +Proof. +intros; apply bool_1; split; intros. +destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). +apply bool_6. +red; intros; apply (@is_empty_2 _ H0 a); auto. +generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). +destruct (choose (filter f s)). +intros H0 _; apply exists_1; auto. +exists e; generalize (H0 e); rewrite filter_iff; auto. +intros _ H0. +rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. +Qed. + +Lemma partition_filter_1: + forall s, equal (fst (partition f s)) (filter f s)=true. +Proof. +auto. +Qed. + +Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. +Proof. +auto. +Qed. + +Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). +Proof. +unfold Add, MP.Add; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +assert (E.eq x y -> f y = true) by + intro H0; rewrite <- (Comp _ _ H0); auto. +tauto. +Qed. + +Lemma add_filter_2 : forall s s' x, + f x=false -> (Add x s s') -> filter f s [=] filter f s'. +Proof. +unfold Add, MP.Add, Equal; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +assert (f a = true -> ~E.eq x a). + intros H0 H1. + rewrite (Comp _ _ H1) in H. + rewrite H in H0; discriminate. +tauto. +Qed. + +Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> + forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. +Proof. +clear Comp' Comp f. +intros. +assert (compat_bool E.eq (fun x => orb (f x) (g x))). + unfold compat_bool; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. +assert (f a || g a = true <-> f a = true \/ g a = true). + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. +tauto. +Qed. + +(** Properties of [for_all] *) + +Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. +Proof. +intros. +rewrite for_all_filter; auto. +rewrite is_empty_equal_empty. +apply equal_mem_1;intros. +rewrite filter_b; auto. +rewrite empty_mem. +generalize (H a); case (mem a s);intros;auto. +rewrite H0;auto. +Qed. + +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Proof. +intros. +rewrite for_all_filter in H; auto. +rewrite is_empty_equal_empty in H. +generalize (equal_mem_2 _ _ H x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H0; simpl;intros. +replace true with (negb false);auto;apply negb_sym;auto. +Qed. + +Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. +Proof. +intros. +apply (bool_eq_ind (for_all f s));intros;auto. +rewrite for_all_filter in H1; auto. +rewrite is_empty_equal_empty in H1. +generalize (equal_mem_2 _ _ H1 x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H. +rewrite H0. +simpl;auto. +Qed. + +Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. +Proof. +intros. +rewrite for_all_filter in H; auto. +destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. +exists x. +rewrite filter_b in H1; auto. +elim (andb_prop _ _ H1). +split;auto. +replace false with (negb true);auto;apply negb_sym;auto. +Qed. + +(** Properties of [exists] *) + +Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). +Proof. +intros. +rewrite for_all_b; auto. +rewrite exists_b; auto. +induction (elements s); simpl; auto. +destruct (f a); simpl; auto. +Qed. + +End Bool. +Section Bool'. + +Variable f:elt->bool. +Variable Comp: compat_bool E.eq f. + +Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Proof. +unfold compat_bool in *; intros; f_equal; auto. +Qed. + +Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite for_all_mem_1;auto with bool. +intros;generalize (H x H0);intros. +symmetry;apply negb_sym;simpl;auto. +Qed. + +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Proof. +intros. +rewrite for_all_exists in H; auto. +replace false with (negb true);auto;apply negb_sym;symmetry. +rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto. +replace true with (negb false);auto;apply negb_sym;auto. +Qed. + +Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. +Proof. +intros. +rewrite for_all_exists; auto. +symmetry;apply negb_sym;simpl. +apply for_all_mem_3 with x;auto. +rewrite H0;auto. +Qed. + +Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. +Proof. +intros. +rewrite for_all_exists in H; auto. +elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros. +elim p;intros. +exists x;split;auto. +replace true with (negb false);auto;apply negb_sym;auto. +replace false with (negb true);auto;apply negb_sym;auto. +Qed. + +End Bool'. + +Section Sum. + +(** Adding a valuation function on all elements of a set. *) + +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. + +Lemma sum_plus : + forall f g, compat_nat E.eq f -> compat_nat E.eq g -> + forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. +Proof. +unfold sum. +intros f g Hf Hg. +assert (fc : compat_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 (st := gen_st nat). +intros s;pattern s; apply set_rec. +intros. +rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). +rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). +rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. +intros; do 3 (rewrite (fold_add _ _ st);auto). +rewrite H0;simpl;omega. +intros; do 3 rewrite (fold_empty _ _ st);auto. +Qed. + +Lemma sum_filter : forall f, (compat_bool E.eq f) -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). +Proof. +unfold sum; intros f Hf. +assert (st := gen_st nat). +assert (cc : compat_op E.eq (@eq _) (fun x => plus (if f x then 1 else 0))). + unfold compat_op; 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. +intros s;pattern s; apply set_rec. +intros. +change elt with E.t. +rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). +rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. +intros; rewrite (fold_add _ _ st _ cc ct); auto. +generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . +assert (~ In x (filter f s0)). + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. +case (f x); simpl; intros. +rewrite (MP.cardinal_2 H1 (H2 (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. +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)) + (f g:elt->A->A), + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). +Proof. +intros A eqA st f g fc ft gc gt i. +intro s; pattern s; apply set_rec; intros. +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. +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)). +sym_st; apply fold_add with (eqA:=eqA); auto. +trans_st i; [idtac | sym_st ]; apply fold_empty; auto. +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. +Qed. + +End Sum. + +End EqProperties. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v new file mode 100644 index 00000000..d8c0b802 --- /dev/null +++ b/theories/FSets/FSetFacts.v @@ -0,0 +1,409 @@ +(***********************************************************************) +(* 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: FSetFacts.v 8681 2006-04-05 11:56:14Z 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 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] *) + +(** * 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 <-> ME.In x (elements s). +Proof. +split; [apply elements_1 | apply elements_2]. +Qed. + +End IffSpec. + +(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + +Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + +(** * Specifications written using boolean predicates *) + +Section BoolSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma mem_b : E.eq x y -> mem x s = mem y s. +Proof. +intros. +generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). +destruct (mem x s); destruct (mem y s); intuition. +Qed. + +Lemma 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. +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. +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; [apply eq_refl | apply eq_sym | apply eq_trans]. +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; order. +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/FSetInterface.v b/theories/FSets/FSetInterface.v new file mode 100644 index 00000000..c177abfe --- /dev/null +++ b/theories/FSets/FSetInterface.v @@ -0,0 +1,420 @@ +(***********************************************************************) +(* 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: FSetInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *) + +(** * Finite set library *) + +(** Set interfaces *) + +(* begin hide *) +Require Export Bool. +Require Export OrderedType. +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. + +(** 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 : OrderedType. + 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. *) + + 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. *) + + 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], in increasing order. *) + + 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. + 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 *) + + 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 *) + + Section Spec. + + Variable s s' s'' : t. + Variable x y z : 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'. + + (** Specification of [subset] *) + Parameter subset_1 : s[<=]s' -> subset s s' = true. + Parameter subset_2 : subset s s' = true -> 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 -> + 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. + + (** 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 : sort E.lt (elements s). + + (** Specification of [min_elt] *) + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_3 : min_elt s = None -> Empty s. + + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_3 : max_elt s = None -> Empty s. + + (** Specification of [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'). *) + + End Filter. + 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 *) + +End S. + +(** * Dependent signature + + Signature [Sdep] presents sets using dependent types *) + +Module Type Sdep. + + Declare Module E : OrderedType. + Definition elt := E.t. + + Parameter t : Set. + + 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 Add x s s' := forall y, In y s' <-> E.eq x y \/ In y 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). + + Definition eq : t -> t -> Prop := Equal. + Parameter lt : t -> t -> Prop. + Parameter compare : forall s s' : t, Compare lt eq s s'. + + Parameter eq_refl : forall s : t, eq s s. + Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s. + Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. + Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. + Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'. + + Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s. + + Parameter empty : {s : t | Empty s}. + + Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}. + + Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. + + Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}. + + Parameter + singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. + + Parameter + remove : + forall (x : elt) (s : t), + {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. + + Parameter + union : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. + + Parameter + inter : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. + + Parameter + diff : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. + + Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. + + Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. + + Parameter + filter : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. + + Parameter + for_all : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. + + Parameter + exists_ : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. + + Parameter + partition : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {partition : t * t | + let (s1, s2) := partition in + compat_P E.eq P -> + For_all P s1 /\ + For_all (fun x => ~ P x) s2 /\ + (forall x : elt, In x s <-> In x s1 \/ In x s2)}. + + Parameter + elements : + forall s : t, + {l : list elt | + sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. + + Parameter + fold : + forall (A : Set) (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}. + + Parameter + cardinal : + forall s : t, + {r : nat | let (l,_) := elements s in r = length l }. + + Parameter + min_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. + + Parameter + max_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. + + Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. + +End Sdep. diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v new file mode 100644 index 00000000..ca86ffcc --- /dev/null +++ b/theories/FSets/FSetList.v @@ -0,0 +1,1163 @@ +(***********************************************************************) +(* 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: FSetList.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +(** * Finite sets library *) + +(** This file proposes an implementation of the non-dependant + interface [FSetInterface.S] using strictly ordered list. *) + +Require Export FSetInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Functions over lists + + First, we provide sets as lists which are not necessarily sorted. + The specs are proved under the additional condition of being sorted. + And the functions returning sets are proved to preserve this invariant. *) + +Module Raw (X: OrderedType). + + Module E := X. + Module MX := OrderedTypeFacts X. + Import MX. + + Definition elt := X.t. + Definition t := list elt. + + Definition empty : t := nil. + + Definition is_empty (l : t) : bool := if l then true else false. + + (** ** The set operations. *) + + Fixpoint mem (x : elt) (s : t) {struct s} : bool := + match s with + | nil => false + | y :: l => + match X.compare x y with + | LT _ => false + | EQ _ => true + | GT _ => mem x l + end + end. + + Fixpoint add (x : elt) (s : t) {struct s} : t := + match s with + | nil => x :: nil + | y :: l => + match X.compare x y with + | LT _ => x :: s + | EQ _ => s + | GT _ => y :: add x l + end + end. + + Definition singleton (x : elt) : t := x :: nil. + + Fixpoint remove (x : elt) (s : t) {struct s} : t := + match s with + | nil => nil + | y :: l => + match X.compare x y with + | LT _ => s + | EQ _ => l + | GT _ => y :: remove x l + end + end. + + Fixpoint union (s : t) : t -> t := + match s with + | nil => fun s' => s' + | x :: l => + (fix union_aux (s' : t) : t := + match s' with + | nil => s + | x' :: l' => + match X.compare x x' with + | LT _ => x :: union l s' + | EQ _ => x :: union l l' + | GT _ => x' :: union_aux l' + end + end) + end. + + Fixpoint inter (s : t) : t -> t := + match s with + | nil => fun _ => nil + | x :: l => + (fix inter_aux (s' : t) : t := + match s' with + | nil => nil + | x' :: l' => + match X.compare x x' with + | LT _ => inter l s' + | EQ _ => x :: inter l l' + | GT _ => inter_aux l' + end + end) + end. + + Fixpoint diff (s : t) : t -> t := + match s with + | nil => fun _ => nil + | x :: l => + (fix diff_aux (s' : t) : t := + match s' with + | nil => s + | x' :: l' => + match X.compare x x' with + | LT _ => x :: diff l s' + | EQ _ => diff l l' + | GT _ => diff_aux l' + end + end) + end. + + Fixpoint equal (s : t) : t -> bool := + fun s' : t => + match s, s' with + | nil, nil => true + | x :: l, x' :: l' => + match X.compare x x' with + | EQ _ => equal l l' + | _ => false + end + | _, _ => false + end. + + Fixpoint subset (s s' : t) {struct s'} : bool := + match s, s' with + | nil, _ => true + | x :: l, x' :: l' => + match X.compare x x' with + | LT _ => false + | EQ _ => subset l l' + | GT _ => subset s l' + end + | _, _ => false + end. + + Fixpoint fold (B : Set) (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) + end. + + Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := + match s with + | nil => nil + | x :: l => if f x then x :: filter f l else filter f l + end. + + Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := + match s with + | nil => true + | x :: l => if f x then for_all f l else false + end. + + Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := + match s with + | nil => false + | x :: l => if f x then true else exists_ f l + end. + + Fixpoint partition (f : elt -> bool) (s : t) {struct s} : + t * t := + match s with + | nil => (nil, nil) + | x :: l => + let (s1, s2) := partition f l in + if f x then (x :: s1, s2) else (s1, x :: s2) + end. + + Definition cardinal (s : t) : nat := length s. + + Definition elements (x : t) : list elt := x. + + Definition min_elt (s : t) : option elt := + match s with + | nil => None + | x :: _ => Some x + end. + + Fixpoint max_elt (s : t) : option elt := + match s with + | nil => None + | x :: nil => Some x + | _ :: l => max_elt l + end. + + Definition choose := min_elt. + + (** ** Proofs of set operation specifications. *) + + Notation Sort := (sort X.lt). + Notation Inf := (lelistA X.lt). + Notation In := (InA X.eq). + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. + + Lemma mem_1 : + forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. + Proof. + simple induction s; intros. + inversion H. + inversion_clear Hs. + inversion_clear H0. + simpl; elim_comp; trivial. + simpl; elim_comp_gt x a; auto. + apply Sort_Inf_In with l; trivial. + Qed. + + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. + Proof. + simple induction s. + intros; inversion H. + intros a l Hrec x. + simpl. + case (X.compare x a); intros; try discriminate; auto. + Qed. + + Lemma add_Inf : + forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition; inversion H0; + intuition. + Qed. + Hint Resolve add_Inf. + + Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; + auto. + Qed. + + Lemma add_1 : + forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); inversion_clear Hs; auto. + constructor; apply X.eq_trans with x; auto. + Qed. + + Lemma add_2 : + forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition. + inversion_clear Hs; inversion_clear H0; auto. + Qed. + + Lemma add_3 : + forall (s : t) (Hs : Sort s) (x y : elt), + ~ X.eq x y -> In y (add x s) -> In y s. + Proof. + simple induction s. + simpl; inversion_clear 3; auto; order. + simpl; intros a l Hrec Hs x y; case (X.compare x a); intros; + inversion_clear H0; inversion_clear Hs; auto. + order. + constructor 2; apply Hrec with x; auto. + Qed. + + Lemma remove_Inf : + forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto. + inversion_clear Hs; apply Inf_lt with a; auto. + Qed. + Hint Resolve remove_Inf. + + Lemma remove_sort : + forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto. + Qed. + + Lemma remove_1 : + forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s). + Proof. + simple induction s. + simpl; red; intros; inversion H0. + simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. + inversion_clear H1. + order. + generalize (Sort_Inf_In H2 H3 H4); order. + generalize (Sort_Inf_In H2 H3 H1); order. + inversion_clear H1. + order. + apply (H H2 _ _ H0 H4). + Qed. + + Lemma remove_2 : + forall (s : t) (Hs : Sort s) (x y : elt), + ~ X.eq x y -> In y s -> In y (remove x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; + inversion_clear H1; auto. + destruct H0; apply X.eq_trans with a; auto. + Qed. + + Lemma remove_3 : + forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s. + Proof. + simple induction s. + simpl; intuition. + simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition. + inversion_clear Hs; inversion_clear H; auto. + constructor 2; apply Hrec with x; auto. + Qed. + + Lemma singleton_sort : forall x : elt, Sort (singleton x). + Proof. + unfold singleton; simpl; auto. + Qed. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. + Proof. + unfold singleton; simpl; intuition. + inversion_clear H; auto; inversion H0. + Qed. + + Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). + Proof. + unfold singleton; simpl; auto. + Qed. + + Ltac DoubleInd := + simple induction s; + [ simpl; auto; try solve [ intros; inversion H ] + | intros x l Hrec; simple induction s'; + [ simpl; auto; try solve [ intros; inversion H ] + | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst; + simpl ] ]. + + Lemma union_Inf : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), + Inf a s -> Inf a s' -> Inf a (union s s'). + Proof. + DoubleInd. + intros i His His'; inversion_clear His; inversion_clear His'. + case (X.compare x x'); auto. + Qed. + Hint Resolve union_Inf. + + Lemma union_sort : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s'). + Proof. + DoubleInd; case (X.compare x x'); intuition; constructor; auto. + apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto. + change (Inf x' (union (x :: l) l')); auto. + Qed. + + Lemma union_1 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x (union s s') -> In x s \/ In x s'. + Proof. + DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition. + elim (Hrec (x' :: l') H1 Hs' x0); intuition. + elim (Hrec l' H1 H5 x0); intuition. + elim (H0 x0); intuition. + Qed. + + Lemma union_2 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x s -> In x (union s s'). + Proof. + DoubleInd. + intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto. + Qed. + + Lemma union_3 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x s' -> In x (union s s'). + Proof. + DoubleInd. + intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition. + constructor; apply X.eq_trans with x'; auto. + Qed. + + Lemma inter_Inf : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), + Inf a s -> Inf a s' -> Inf a (inter s s'). + Proof. + DoubleInd. + intros i His His'; inversion His; inversion His'; subst. + case (X.compare x x'); intuition. + apply Inf_lt with x; auto. + apply H3; auto. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve inter_Inf. + + Lemma inter_sort : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s'). + Proof. + DoubleInd; case (X.compare x x'); auto. + constructor; auto. + apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto. + Qed. + + Lemma inter_1 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x (inter s s') -> In x s. + Proof. + DoubleInd; case (X.compare x x'); intuition. + constructor 2; apply Hrec with (x'::l'); auto. + inversion_clear H; auto. + constructor 2; apply Hrec with l'; auto. + Qed. + + Lemma inter_2 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x (inter s s') -> In x s'. + Proof. + DoubleInd; case (X.compare x x'); intuition; inversion_clear H. + constructor 1; apply X.eq_trans with x; auto. + constructor 2; auto. + Qed. + + Lemma inter_3 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x s -> In x s' -> In x (inter s s'). + Proof. + DoubleInd. + intros i His His'; elim (X.compare x x'); intuition. + + inversion_clear His; auto. + generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order. + + inversion_clear His; auto; inversion_clear His'; auto. + constructor; apply X.eq_trans with x'; auto. + + change (In i (inter (x :: l) l')). + inversion_clear His'; auto. + generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order. + Qed. + + Lemma diff_Inf : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), + Inf a s -> Inf a s' -> Inf a (diff s s'). + Proof. + DoubleInd. + intros i His His'; inversion His; inversion His'. + case (X.compare x x'); intuition. + apply Hrec; trivial. + apply Inf_lt with x; auto. + apply Inf_lt with x'; auto. + apply H10; trivial. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve diff_Inf. + + Lemma diff_sort : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s'). + Proof. + DoubleInd; case (X.compare x x'); auto. + Qed. + + Lemma diff_1 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x (diff s s') -> In x s. + Proof. + DoubleInd; case (X.compare x x'); intuition. + inversion_clear H; auto. + constructor 2; apply Hrec with (x'::l'); auto. + constructor 2; apply Hrec with l'; auto. + Qed. + + Lemma diff_2 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x (diff s s') -> ~ In x s'. + Proof. + DoubleInd. + intros; intro Abs; inversion Abs. + case (X.compare x x'); intuition. + + inversion_clear H. + generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order. + apply Hrec with (x'::l') x0; auto. + + inversion_clear H3. + generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order. + apply Hrec with l' x0; auto. + + inversion_clear H3. + generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order. + apply H0 with x0; auto. + Qed. + + Lemma diff_3 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), + In x s -> ~ In x s' -> In x (diff s s'). + Proof. + DoubleInd. + intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto. + elim His'; constructor; apply X.eq_trans with x; auto. + Qed. + + Lemma equal_1 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), + Equal s s' -> equal s s' = true. + Proof. + simple induction s; unfold Equal. + intro s'; case s'; auto. + simpl; intuition. + elim (H e); intros; assert (A : In e nil); auto; inversion A. + intros x l Hrec s'. + case s'. + intros; elim (H x); intros; assert (A : In x nil); auto; inversion A. + intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst. + simpl; case (X.compare x); intros; auto. + + elim (H x); intros. + assert (A : In x (x' :: l')); auto; inversion_clear A. + order. + generalize (Sort_Inf_In H5 H6 H4); order. + + apply Hrec; intuition; elim (H a); intros. + assert (A : In a (x' :: l')); auto; inversion_clear A; auto. + generalize (Sort_Inf_In H1 H2 H0); order. + assert (A : In a (x :: l)); auto; inversion_clear A; auto. + generalize (Sort_Inf_In H5 H6 H0); order. + + elim (H x'); intros. + assert (A : In x' (x :: l)); auto; inversion_clear A. + order. + generalize (Sort_Inf_In H1 H2 H4); order. + Qed. + + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. + Proof. + simple induction s; unfold Equal. + intro s'; case s'; intros. + intuition. + simpl in H; discriminate H. + intros x l Hrec s'. + case s'. + intros; simpl in H; discriminate. + intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate. + elim (Hrec l' H a); intuition; inversion_clear H2; auto. + constructor; apply X.eq_trans with x; auto. + constructor; apply X.eq_trans with x'; auto. + Qed. + + Lemma subset_1 : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), + Subset s s' -> subset s s' = true. + Proof. + intros s s'; generalize s' s; clear s s'. + simple induction s'; unfold Subset. + intro s; case s; auto. + intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. + intros x' l' Hrec s; case s. + simpl; auto. + intros x l Hs Hs'; inversion Hs; inversion Hs'; subst. + simpl; case (X.compare x); intros; auto. + + assert (A : In x (x' :: l')); auto; inversion_clear A. + order. + generalize (Sort_Inf_In H5 H6 H0); order. + + apply Hrec; intuition. + assert (A : In a (x' :: l')); auto; inversion_clear A; auto. + generalize (Sort_Inf_In H1 H2 H0); order. + + apply Hrec; intuition. + assert (A : In a (x' :: l')); auto; inversion_clear A; auto. + inversion_clear H0. + order. + generalize (Sort_Inf_In H1 H2 H4); order. + Qed. + + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. + Proof. + intros s s'; generalize s' s; clear s s'. + simple induction s'; unfold Subset. + intro s; case s; auto. + simpl; intros; discriminate H. + intros x' l' Hrec s; case s. + intros; inversion H0. + intros x l; simpl; case (X.compare x); intros; auto. + discriminate H. + inversion_clear H0. + constructor; apply X.eq_trans with x; auto. + constructor 2; apply Hrec with l; auto. + constructor 2; apply Hrec with (x::l); auto. + Qed. + + Lemma empty_sort : Sort empty. + Proof. + unfold empty; constructor. + Qed. + + Lemma empty_1 : Empty empty. + Proof. + unfold Empty, empty; intuition; inversion H. + Qed. + + Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. + Proof. + unfold Empty; intro s; case s; simpl; intuition. + elim (H e); auto. + Qed. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + Proof. + unfold Empty; intro s; case s; simpl; intuition; + inversion H0. + Qed. + + Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. + Proof. + unfold elements; auto. + Qed. + + Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (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. + Qed. + + Lemma min_elt_2 : + forall (s : t) (Hs : Sort s) (x y : elt), + min_elt s = Some x -> In y s -> ~ X.lt y x. + Proof. + simple induction s; simpl. + intros; inversion H. + intros a l; case l; intros; inversion H0; inversion_clear H1; subst. + order. + inversion H2. + order. + inversion_clear Hs. + inversion_clear H3. + generalize (H H1 e y (refl_equal (Some e)) H2); order. + Qed. + + Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. + Proof. + unfold Empty; intro s; case s; simpl; intuition; + inversion H; inversion H0. + Qed. + + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + simple induction s; simpl. + intros; inversion H. + intros x l; case l; simpl. + intuition. + inversion H0; auto. + intros. + constructor 2; apply (H _ H0). + Qed. + + Lemma max_elt_2 : + forall (s : t) (Hs : Sort s) (x y : elt), + max_elt s = Some x -> In y s -> ~ X.lt x y. + Proof. + simple induction s; simpl. + intros; inversion H. + intros x l; case l; simpl. + intuition. + inversion H0; subst. + inversion_clear H1. + order. + inversion H3. + intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1. + assert (In e (e::l0)) by auto. + generalize (H H2 x0 e H0 H1); order. + generalize (H H2 x0 y H0 H3); order. + Qed. + + Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. + Proof. + unfold Empty; simple induction s; simpl. + red; intros; inversion H0. + intros x l; case l; simpl; intros. + inversion H0. + elim (H H0 e); auto. + Qed. + + Definition choose_1 : + forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1. + + Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3. + + Lemma fold_1 : + forall (s : t) (Hs : Sort s) (A : Set) (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; trivial. + intros. + inversion_clear Hs. + simpl; auto. + Qed. + + Lemma cardinal_1 : + forall (s : t) (Hs : Sort s), + cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_Inf : + forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool), + Inf x s -> Inf x (filter f s). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha. + case (f x). + constructor; auto. + apply Hrec; auto. + apply Inf_lt with x; auto. + Qed. + + Lemma filter_sort : + forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + case (f x); auto. + constructor; auto. + apply filter_Inf; auto. + Qed. + + Lemma filter_1 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool X.eq f -> In x (filter f s) -> In x s. + Proof. + simple induction s; simpl. + intros; inversion H0. + intros x l Hrec a f Hf. + case (f x); simpl. + inversion_clear 1. + constructor; auto. + constructor 2; apply (Hrec a f Hf); trivial. + constructor 2; apply (Hrec a f Hf); trivial. + Qed. + + Lemma filter_2 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool X.eq f -> In x (filter f s) -> f x = true. + Proof. + simple induction s; simpl. + intros; inversion H0. + intros x l Hrec a f Hf. + generalize (Hf x); case (f x); simpl; auto. + inversion_clear 2; auto. + symmetry; auto. + Qed. + + Lemma filter_3 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). + Proof. + simple induction s; simpl. + intros; inversion H0. + intros x l Hrec a f Hf. + generalize (Hf x); case (f x); simpl. + inversion_clear 2; auto. + inversion_clear 2; auto. + rewrite <- (H a (X.eq_sym H1)); intros; discriminate. + Qed. + + Lemma for_all_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. + simple induction s; simpl; auto; unfold For_all. + intros x l Hrec f Hf. + generalize (Hf x); case (f x); simpl. + auto. + intros; rewrite (H x); auto. + Qed. + + Lemma for_all_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. + simple induction s; simpl; auto; unfold For_all. + intros; inversion H1. + intros x l Hrec f Hf. + intros A a; intros. + assert (f x = true). + generalize A; case (f x); auto. + rewrite H0 in A; simpl in A. + inversion_clear H; auto. + rewrite (Hf a x); auto. + Qed. + + Lemma exists_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. + simple induction s; simpl; auto; unfold Exists. + intros. + elim H0; intuition. + inversion H2. + intros x l Hrec f Hf. + generalize (Hf x); case (f x); simpl. + auto. + destruct 2 as [a (A1,A2)]. + inversion_clear A1. + rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. + apply Hrec; auto. + exists a; auto. + Qed. + + Lemma exists_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. + simple induction s; simpl; auto; unfold Exists. + intros; discriminate. + intros x l Hrec f Hf. + case_eq (f x); intros. + exists x; auto. + destruct (Hrec f Hf H0) as [a (A1,A2)]. + exists a; auto. + Qed. + + Lemma partition_Inf_1 : + forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), + Inf x s -> Inf x (fst (partition f s)). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. + generalize (Hrec H f a). + case (f x); case (partition f l); simpl. + auto. + intros; apply H2; apply Inf_lt with x; auto. + Qed. + + Lemma partition_Inf_2 : + forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), + Inf x s -> Inf x (snd (partition f s)). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. + generalize (Hrec H f a). + case (f x); case (partition f l); simpl. + intros; apply H2; apply Inf_lt with x; auto. + auto. + Qed. + + Lemma partition_sort_1 : + forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + generalize (Hrec H f); generalize (partition_Inf_1 H f). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_sort_2 : + forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + generalize (Hrec H f); generalize (partition_Inf_2 H f). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + split; auto. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + constructor 2; rewrite <- H; auto. + constructor 2; rewrite H; auto. + Qed. + + Lemma partition_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + split; auto. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + destruct (partition f l) as [s1 s2]; simpl; intros. + case (f x); simpl; auto. + split; inversion_clear 1; auto. + constructor 2; rewrite <- H; auto. + constructor 2; rewrite H; auto. + Qed. + + Definition eq : t -> t -> Prop := Equal. + + Lemma eq_refl : forall s : t, eq s s. + Proof. + unfold eq, Equal; intuition. + Qed. + + Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. + Proof. + unfold eq, Equal; intros; destruct (H a); intuition. + Qed. + + Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. + Proof. + unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition. + Qed. + + Inductive lt : t -> t -> Prop := + | lt_nil : forall (x : elt) (s : t), lt nil (x :: s) + | lt_cons_lt : + forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s') + | lt_cons_eq : + forall (x y : elt) (s s' : t), + X.eq x y -> lt s s' -> lt (x :: s) (y :: s'). + Hint Constructors lt. + + Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. + Proof. + intros s s' s'' H; generalize s''; clear s''; elim H. + intros x l s'' H'; inversion_clear H'; auto. + intros x x' l l' E s'' H'; inversion_clear H'; auto. + constructor; apply X.lt_trans with x'; auto. + constructor; apply lt_eq with x'; auto. + intros. + inversion_clear H3. + constructor; apply eq_lt with y; auto. + constructor 3; auto; apply X.eq_trans with y; auto. + Qed. + + Lemma lt_not_eq : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'. + Proof. + unfold eq, Equal. + intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro. + elim (H0 x); intros. + assert (X : In x nil); auto; inversion X. + inversion_clear Hs; inversion_clear Hs'. + elim (H1 x); intros. + assert (X : In x (y :: s'0)); auto; inversion_clear X. + order. + generalize (Sort_Inf_In H4 H5 H8); order. + inversion_clear Hs; inversion_clear Hs'. + elim H2; auto; split; intros. + generalize (Sort_Inf_In H4 H5 H8); intros. + elim (H3 a); intros. + assert (X : In a (y :: s'0)); auto; inversion_clear X; auto. + order. + generalize (Sort_Inf_In H6 H7 H8); intros. + elim (H3 a); intros. + assert (X : In a (x :: s0)); auto; inversion_clear X; auto. + order. + Qed. + + Definition compare : + forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'. + Proof. + simple induction s. + intros; case s'. + constructor 2; apply eq_refl. + constructor 1; auto. + intros a l Hrec s'; case s'. + constructor 3; auto. + intros a' l' Hs Hs'. + case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto. + elim (Hrec l'); + [ constructor 1 + | constructor 2 + | constructor 3 + | inversion Hs + | inversion Hs' ]; auto. + generalize e; unfold eq, Equal; intuition; inversion_clear H. + constructor; apply X.eq_trans with a; auto. + destruct (e1 a0); auto. + constructor; apply X.eq_trans with a'; auto. + destruct (e1 a0); auto. + Defined. + +End Raw. + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of strictly ordered lists. *) + +Module Make (X: OrderedType) <: S with Module E := X. + + Module E := X. + Module Raw := Raw X. + + Record slist : Set := {this :> Raw.t; sorted : sort X.lt this}. + Definition t := slist. + Definition elt := X.t. + + Definition In (x : elt) (s : t) := InA X.eq x s.(this). + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Definition In_1 (s : t) := Raw.MX.In_eq (l:=s.(this)). + + Definition mem (x : elt) (s : t) := Raw.mem x s. + Definition mem_1 (s : t) := Raw.mem_1 (sorted s). + Definition mem_2 (s : t) := Raw.mem_2 (s:=s). + + Definition add x s := Build_slist (Raw.add_sort (sorted s) x). + Definition add_1 (s : t) := Raw.add_1 (sorted s). + Definition add_2 (s : t) := Raw.add_2 (sorted s). + Definition add_3 (s : t) := Raw.add_3 (sorted s). + + Definition remove x s := Build_slist (Raw.remove_sort (sorted s) x). + Definition remove_1 (s : t) := Raw.remove_1 (sorted s). + Definition remove_2 (s : t) := Raw.remove_2 (sorted s). + Definition remove_3 (s : t) := Raw.remove_3 (sorted s). + + Definition singleton x := Build_slist (Raw.singleton_sort x). + Definition singleton_1 := Raw.singleton_1. + Definition singleton_2 := Raw.singleton_2. + + Definition union (s s' : t) := + Build_slist (Raw.union_sort (sorted s) (sorted s')). + Definition union_1 (s s' : t) := Raw.union_1 (sorted s) (sorted s'). + Definition union_2 (s s' : t) := Raw.union_2 (sorted s) (sorted s'). + Definition union_3 (s s' : t) := Raw.union_3 (sorted s) (sorted s'). + + Definition inter (s s' : t) := + Build_slist (Raw.inter_sort (sorted s) (sorted s')). + Definition inter_1 (s s' : t) := Raw.inter_1 (sorted s) (sorted s'). + Definition inter_2 (s s' : t) := Raw.inter_2 (sorted s) (sorted s'). + Definition inter_3 (s s' : t) := Raw.inter_3 (sorted s) (sorted s'). + + Definition diff (s s' : t) := + Build_slist (Raw.diff_sort (sorted s) (sorted s')). + Definition diff_1 (s s' : t) := Raw.diff_1 (sorted s) (sorted s'). + Definition diff_2 (s s' : t) := Raw.diff_2 (sorted s) (sorted s'). + Definition diff_3 (s s' : t) := Raw.diff_3 (sorted s) (sorted s'). + + Definition equal (s s' : t) := Raw.equal s s'. + Definition equal_1 (s s' : t) := Raw.equal_1 (sorted s) (sorted s'). + Definition equal_2 (s s' : t) := Raw.equal_2 (s:=s) (s':=s'). + + Definition subset (s s' : t) := Raw.subset s s'. + Definition subset_1 (s s' : t) := Raw.subset_1 (sorted s) (sorted s'). + Definition subset_2 (s s' : t) := Raw.subset_2 (s:=s) (s':=s'). + + Definition empty := Build_slist Raw.empty_sort. + Definition empty_1 := Raw.empty_1. + + Definition is_empty (s : t) := Raw.is_empty s. + Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s). + Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s). + + Definition elements (s : t) := Raw.elements s. + Definition elements_1 (s : t) := Raw.elements_1 (s:=s). + Definition elements_2 (s : t) := Raw.elements_2 (s:=s). + Definition elements_3 (s : t) := Raw.elements_3 (sorted s). + + Definition min_elt (s : t) := Raw.min_elt s. + Definition min_elt_1 (s : t) := Raw.min_elt_1 (s:=s). + Definition min_elt_2 (s : t) := Raw.min_elt_2 (sorted s). + Definition min_elt_3 (s : t) := Raw.min_elt_3 (s:=s). + + Definition max_elt (s : t) := Raw.max_elt s. + Definition max_elt_1 (s : t) := Raw.max_elt_1 (s:=s). + Definition max_elt_2 (s : t) := Raw.max_elt_2 (sorted s). + Definition max_elt_3 (s : t) := Raw.max_elt_3 (s:=s). + + Definition choose := min_elt. + Definition choose_1 := min_elt_1. + Definition choose_2 := min_elt_3. + + Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. + Definition fold_1 (s : t) := Raw.fold_1 (sorted s). + + Definition cardinal (s : t) := Raw.cardinal s. + Definition cardinal_1 (s : t) := Raw.cardinal_1 (sorted s). + + Definition filter (f : elt -> bool) (s : t) := + Build_slist (Raw.filter_sort (sorted s) f). + Definition filter_1 (s : t) := Raw.filter_1 (s:=s). + Definition filter_2 (s : t) := Raw.filter_2 (s:=s). + Definition filter_3 (s : t) := Raw.filter_3 (s:=s). + + Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s. + Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). + Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). + + Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s. + Definition exists_1 (s : t) := Raw.exists_1 (s:=s). + Definition exists_2 (s : t) := Raw.exists_2 (s:=s). + + Definition partition (f : elt -> bool) (s : t) := + let p := Raw.partition f s in + (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f), + Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)). + Definition partition_1 (s : t) := Raw.partition_1 s. + Definition partition_2 (s : t) := Raw.partition_2 s. + + Definition eq (s s' : t) := Raw.eq s s'. + Definition eq_refl (s : t) := Raw.eq_refl s. + Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s'). + Definition eq_trans (s s' s'' : t) := + Raw.eq_trans (s:=s) (s':=s') (s'':=s''). + + Definition lt (s s' : t) := Raw.lt s s'. + Definition lt_trans (s s' s'' : t) := + Raw.lt_trans (s:=s) (s':=s') (s'':=s''). + Definition lt_not_eq (s s' : t) := Raw.lt_not_eq (sorted s) (sorted s'). + + Definition compare : forall s s' : t, Compare lt eq s s'. + Proof. + intros; elim (Raw.compare (sorted s) (sorted s')); + [ constructor 1 | constructor 2 | constructor 3 ]; + auto. + Defined. + +End Make. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v new file mode 100644 index 00000000..23843084 --- /dev/null +++ b/theories/FSets/FSetProperties.v @@ -0,0 +1,1007 @@ +(***********************************************************************) +(* 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: FSetProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This functor derives additional properties from [FSetInterface.S]. + Contrary to the functor in [FSetEqProperties] 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 FSetInterface. +Require Import FSetFacts. +Set Implicit Arguments. +Unset Strict Implicit. + +Section Misc. +Variable A B : Set. +Variable eqA : A -> A -> Prop. +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'. + +End Misc. +Hint Unfold transpose compat_op compat_nat. + +Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. + +Ltac trans_st x := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_trans _ _ H) with x; auto + end. + +Ltac sym_st := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_sym _ _ H); auto + end. + +Ltac refl_st := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_refl _ _ H); auto + end. + +Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A). +Proof. auto. Qed. + +Module Properties (M: S). + Module ME := OrderedTypeFacts M.E. + Import ME. + 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. + Variable s s' s'' s1 s2 s3 : t. + Variable x : elt. + + (** properties of [Equal] *) + + Lemma equal_refl : s[=]s. + Proof. + apply eq_refl. + Qed. + + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. + apply eq_sym. + Qed. + + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. + intros; apply eq_trans with s2; auto. + Qed. + + (** 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. + + (** 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. + + (** 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 eq_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 eq_refl. + Qed. + + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. + intros; rewrite H; apply eq_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 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 eq_refl. + Qed. + + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. + intros; rewrite H; apply eq_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 : set. + + Notation NoDup := (NoDupA E.eq). + Notation EqList := (eqlistA E.eq). + + Section NoDupA_Remove. + + Let ListAdd x l l' := forall y : elt, ME.In y l' <-> E.eq x y \/ ME.In y l. + + Lemma removeA_add : + forall s s' x x', NoDup s -> NoDup (x' :: s') -> + ~ E.eq x x' -> ~ ME.In x s -> + ListAdd x s (x' :: s') -> ListAdd x (removeA eq_dec x' s) s'. + Proof. + unfold ListAdd; intros. + inversion_clear H0. + rewrite removeA_InA; auto; [apply E.eq_trans|]. + split; intros. + destruct (eq_dec x y); auto; intros. + right; split; auto. + destruct (H3 y); clear H3. + destruct H6; intuition. + swap H4; apply In_eq with y; auto. + destruct H0. + assert (ME.In y (x' :: s')) by rewrite H3; auto. + inversion_clear H6; auto. + elim H1; apply E.eq_trans with y; auto. + destruct H0. + assert (ME.In y (x' :: s')) by rewrite H3; auto. + inversion_clear H7; auto. + elim H6; auto. + Qed. + + 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). + Variables (i:A). + + Lemma removeA_fold_right_0 : + forall s x, NoDup s -> ~ME.In x s -> + eqA (fold_right f i s) (fold_right f i (removeA eq_dec x s)). + Proof. + simple induction s; simpl; intros. + refl_st. + inversion_clear H0. + destruct (eq_dec x a); simpl; intros. + absurd_hyp e; auto. + apply Comp; auto. + Qed. + + Lemma removeA_fold_right : + forall s x, NoDup s -> ME.In x s -> + eqA (fold_right f i s) (f x (fold_right f i (removeA eq_dec x s))). + Proof. + simple induction s; simpl. + inversion_clear 2. + intros. + inversion_clear H0. + destruct (eq_dec x a); simpl; intros. + apply Comp; auto. + apply removeA_fold_right_0; auto. + swap H2; apply ME.In_eq with x; auto. + inversion_clear H1. + destruct n; auto. + trans_st (f a (f x (fold_right f i (removeA eq_dec x l)))). + Qed. + + Lemma fold_right_equal : + forall s s', NoDup s -> NoDup s' -> + EqList s s' -> eqA (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 t0). + assert (X : ME.In t0 nil); auto; inversion X. + intros x l Hrec s' N N' E; simpl in *. + trans_st (f x (fold_right f i (removeA eq_dec x s'))). + apply Comp; auto. + apply Hrec; auto. + inversion N; auto. + apply removeA_NoDupA; auto; apply E.eq_trans. + apply removeA_eqlistA; auto; [apply E.eq_trans|]. + 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, NoDup s -> NoDup s' -> ~ ME.In x s -> + ListAdd x s s' -> eqA (fold_right f i s') (f x (fold_right f i s)). + Proof. + simple induction s'. + unfold ListAdd; intros. + destruct (H2 x); clear H2. + assert (X : ME.In x nil); auto; inversion X. + intros x' l' Hrec s x N N' IN EQ; simpl. + (* if x=x' *) + destruct (eq_dec x x'). + apply Comp; auto. + apply fold_right_equal; auto. + inversion_clear N'; trivial. + unfold eqlistA; unfold ListAdd in EQ; intros. + destruct (EQ x0); clear EQ. + split; intros. + destruct H; auto. + inversion_clear N'. + destruct H2; apply In_eq with x0; auto; order. + assert (X:ME.In x0 (x' :: l')); auto; inversion_clear X; auto. + destruct IN; apply In_eq with x0; auto; order. + (* else x<>x' *) + trans_st (f x' (f x (fold_right f i (removeA eq_dec x' s)))). + apply Comp; auto. + apply Hrec; auto. + apply removeA_NoDupA; auto; apply E.eq_trans. + inversion_clear N'; auto. + rewrite removeA_InA; auto; [apply E.eq_trans|intuition]. + apply removeA_add; auto. + trans_st (f x (f x' (fold_right f i (removeA eq_dec x' s)))). + apply Comp; auto. + sym_st. + apply removeA_fold_right; auto. + destruct (EQ x'). + destruct H; auto; destruct n; auto. + Qed. + + End NoDupA_Remove. + + (** * Alternative (weaker) specifications for [fold] *) + + Section Old_Spec_Now_Properties. + + (** 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 := eqA); auto. + 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 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_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/FSetWeak.v b/theories/FSets/FSetWeak.v new file mode 100644 index 00000000..7ed61c9f --- /dev/null +++ b/theories/FSets/FSetWeak.v @@ -0,0 +1,14 @@ +(***********************************************************************) +(* 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 8641 2006-03-17 09:56:54Z letouzey $ *) + +Require Export DecidableType. +Require Export FSetWeakInterface. +Require Export FSetFacts. +Require Export FSetWeakList. diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v new file mode 100644 index 00000000..46a73cc9 --- /dev/null +++ b/theories/FSets/FSetWeakFacts.v @@ -0,0 +1,415 @@ +(***********************************************************************) +(* 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 8681 2006-04-05 11:56:14Z 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 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 new file mode 100644 index 00000000..c1845494 --- /dev/null +++ b/theories/FSets/FSetWeakInterface.v @@ -0,0 +1,248 @@ +(***********************************************************************) +(* 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 8641 2006-03-17 09:56:54Z 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' s'' : t. + Variable x y z : 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). + + (** 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. + + (** Specification of [choose] *) + Parameter choose_1 : choose s = Some x -> In x s. + Parameter choose_2 : choose s = None -> Empty s. + + End Filter. + 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. + +End S. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v new file mode 100644 index 00000000..74c81f37 --- /dev/null +++ b/theories/FSets/FSetWeakList.v @@ -0,0 +1,873 @@ +(***********************************************************************) +(* 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: FSetWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This file proposes an implementation of the non-dependant + interface [FSetWeakInterface.S] using lists without redundancy. *) + +Require Import FSetWeakInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Functions over lists + + First, we provide sets as lists which are (morally) without redundancy. + The specs are proved under the additional condition of no redundancy. + 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. + + Definition empty : t := nil. + + Definition is_empty (l : t) : bool := if l then true else false. + + (** ** The set operations. *) + + Fixpoint mem (x : elt) (s : t) {struct s} : bool := + match s with + | nil => false + | y :: l => + if X.eq_dec x y then true else mem x l + end. + + Fixpoint add (x : elt) (s : t) {struct s} : t := + match s with + | nil => x :: nil + | y :: l => + if X.eq_dec x y then s else y :: add x l + end. + + Definition singleton (x : elt) : t := x :: nil. + + Fixpoint remove (x : elt) (s : t) {struct s} : t := + match s with + | nil => nil + | y :: l => + 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} : + B -> B := fun i => match s with + | nil => i + | x :: l => fold f l (f x i) + end. + + Definition union (s : t) : t -> t := fold add s. + + Definition diff (s s' : t) : t := fold remove s' s. + + Definition inter (s s': t) : t := + fold (fun x s => if mem x s' then add x s else s) s nil. + + Definition subset (s s' : t) : bool := is_empty (diff s s'). + + Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). + + Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := + match s with + | nil => nil + | x :: l => if f x then x :: filter f l else filter f l + end. + + Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := + match s with + | nil => true + | x :: l => if f x then for_all f l else false + end. + + Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := + match s with + | nil => false + | x :: l => if f x then true else exists_ f l + end. + + Fixpoint partition (f : elt -> bool) (s : t) {struct s} : + t * t := + match s with + | nil => (nil, nil) + | x :: l => + let (s1, s2) := partition f l in + if f x then (x :: s1, s2) else (s1, x :: s2) + end. + + Definition cardinal (s : t) : nat := length s. + + Definition elements (s : t) : list elt := s. + + Definition choose (s : t) : option elt := + match s with + | nil => None + | x::_ => Some x + end. + + (** ** Proofs of set operation specifications. *) + + Notation NoDup := (NoDupA X.eq). + Notation In := (InA X.eq). + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Lemma In_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. + Qed. + Hint Immediate In_eq. + + Lemma mem_1 : + forall (s : t)(x : elt), In x s -> mem x s = true. + Proof. + induction s; intros. + inversion H. + simpl; destruct (X.eq_dec x a); trivial. + inversion_clear H; auto. + Qed. + + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. + Proof. + induction s. + intros; inversion H. + intros x; simpl. + destruct (X.eq_dec x a); firstorder; discriminate. + Qed. + + Lemma add_1 : + forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s). + Proof. + induction s. + simpl; intuition. + simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; + firstorder. + eauto. + Qed. + + Lemma add_2 : + forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s). + Proof. + induction s. + simpl; intuition. + simpl; intros; case (X.eq_dec x a); intuition. + inversion_clear Hs; eauto; inversion_clear H; intuition. + Qed. + + Lemma add_3 : + forall (s : t) (Hs : NoDup s) (x y : elt), + ~ X.eq x y -> In y (add x s) -> In y s. + Proof. + induction s. + simpl; intuition. + inversion_clear H0; firstorder; absurd (X.eq x y); auto. + simpl; intros Hs x y; case (X.eq_dec x a); intros; + inversion_clear H0; inversion_clear Hs; firstorder; + absurd (X.eq x y); auto. + Qed. + + Lemma add_unique : + forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s). + Proof. + induction s. + simpl; intuition. + constructor; auto. + intro H0; inversion H0. + intros. + inversion_clear Hs. + simpl. + destruct (X.eq_dec x a). + constructor; auto. + constructor; auto. + intro H1; apply H. + eapply add_3; eauto. + Qed. + + Lemma remove_1 : + forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s). + Proof. + simple induction s. + simpl; red; intros; inversion H0. + simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. + elim H2. + apply In_eq with y; eauto. + inversion_clear H1; eauto. + Qed. + + Lemma remove_2 : + forall (s : t) (Hs : NoDup s) (x y : elt), + ~ X.eq x y -> In y s -> In y (remove x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; + inversion_clear H1; auto. + absurd (X.eq x y); eauto. + Qed. + + Lemma remove_3 : + forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s. + Proof. + simple induction s. + simpl; intuition. + simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition. + inversion_clear Hs; inversion_clear H; firstorder. + Qed. + + Lemma remove_unique : + forall (s : t) (Hs : NoDup s) (x : elt), NoDup (remove x s). + Proof. + simple induction s. + simpl; intuition. + simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; + auto. + constructor; auto. + intro H2; elim H0. + eapply remove_3; eauto. + Qed. + + Lemma singleton_unique : forall x : elt, NoDup (singleton x). + Proof. + unfold singleton; simpl; constructor; auto; intro H; inversion H. + Qed. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. + Proof. + unfold singleton; simpl; intuition. + inversion_clear H; auto; inversion H0. + Qed. + + Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). + Proof. + unfold singleton; simpl; intuition. + Qed. + + Lemma empty_unique : NoDup empty. + Proof. + unfold empty; constructor. + Qed. + + Lemma empty_1 : Empty empty. + Proof. + unfold Empty, empty; intuition; inversion H. + Qed. + + Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. + Proof. + unfold Empty; intro s; case s; simpl; intuition. + elim (H e); auto. + Qed. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + Proof. + unfold Empty; intro s; case s; simpl; intuition; + inversion H0. + Qed. + + Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. + Proof. + unfold elements; auto. + Qed. + + Lemma elements_3 : 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), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + induction s; simpl; auto; intros. + inversion_clear Hs; auto. + Qed. + + Lemma union_unique : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (union s s'). + Proof. + unfold union; induction s; simpl; auto; intros. + inversion_clear Hs. + apply IHs; auto. + apply add_unique; auto. + Qed. + + Lemma union_1 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (union s s') -> In x s \/ In x s'. + Proof. + unfold union; induction s; simpl; auto; intros. + inversion_clear Hs. + destruct (X.eq_dec x a). + left; auto. + destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition. + right; eapply add_3; eauto. + Qed. + + Lemma union_0 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x s \/ In x s' -> In x (union s s'). + Proof. + unfold union; induction s; simpl; auto; intros. + inversion_clear H; auto. + inversion_clear H0. + inversion_clear Hs. + apply IHs; auto. + apply add_unique; auto. + destruct H. + inversion_clear H; auto. + right; apply add_1; auto. + right; apply add_2; auto. + Qed. + + Lemma union_2 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x s -> In x (union s s'). + Proof. + intros; apply union_0; auto. + Qed. + + Lemma union_3 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x s' -> In x (union s s'). + Proof. + intros; apply union_0; auto. + Qed. + + Lemma inter_unique : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (inter s s'). + Proof. + unfold inter; intros s. + set (acc := nil (A:=elt)). + assert (NoDup acc) by (unfold acc; auto). + clearbody acc; generalize H; clear H; generalize acc; clear acc. + induction s; simpl; auto; intros. + inversion_clear Hs. + apply IHs; auto. + destruct (mem a s'); intros; auto. + apply add_unique; auto. + Qed. + + Lemma inter_0 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (inter s s') -> In x s /\ In x s'. + Proof. + unfold inter; intros. + set (acc := nil (A:=elt)) in *. + assert (NoDup acc) by (unfold acc; auto). + cut ((In x s /\ In x s') \/ In x acc). + destruct 1; auto. + inversion H1. + clearbody acc. + generalize H0 H Hs' Hs; clear H0 H Hs Hs'. + generalize acc x s'; clear acc x s'. + induction s; simpl; auto; intros. + inversion_clear Hs. + case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H. + destruct (IHs _ _ _ (add_unique H0 a) H); auto. + left; intuition. + destruct (X.eq_dec x a); auto. + left; intuition. + apply In_eq with a; eauto. + apply mem_2; auto. + right; eapply add_3; eauto. + destruct (IHs _ _ _ H0 H); auto. + left; intuition. + Qed. + + Lemma inter_1 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (inter s s') -> In x s. + Proof. + intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. + Qed. + + Lemma inter_2 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (inter s s') -> In x s'. + Proof. + intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. + Qed. + + Lemma inter_3 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x s -> In x s' -> In x (inter s s'). + Proof. + intros s s' Hs Hs' x. + cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')). + intuition. + unfold inter. + set (acc := nil (A:=elt)) in *. + assert (NoDup acc) by (unfold acc; auto). + clearbody acc. + generalize H Hs' Hs; clear H Hs Hs'. + generalize acc x s'; clear acc x s'. + induction s; simpl; auto; intros. + destruct H0; auto. + destruct H0; inversion H0. + inversion_clear Hs. + case_eq (mem a s'); intros H3; apply IHs; auto. + apply add_unique; auto. + destruct H0. + destruct H0. + inversion_clear H0. + right; apply add_1; auto. + left; auto. + right; apply add_2; auto. + destruct H0; auto. + destruct H0. + inversion_clear H0; auto. + absurd (In x s'); auto. + red; intros. + rewrite (mem_1 (In_eq H5 H0)) in H3. + discriminate. + Qed. + + Lemma diff_unique : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (diff s s'). + Proof. + unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. + induction s'; simpl; auto; intros. + inversion_clear Hs'. + apply IHs'; auto. + apply remove_unique; auto. + Qed. + + Lemma diff_0 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (diff s s') -> In x s /\ ~ In x s'. + Proof. + unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. + induction s'; simpl; auto; intros. + inversion_clear Hs'. + split; auto; intro H1; inversion H1. + inversion_clear Hs'. + destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H). + split. + eapply remove_3; eauto. + red; intros. + inversion_clear H4; auto. + destruct (remove_1 Hs (X.eq_sym H5) H2). + Qed. + + Lemma diff_1 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (diff s s') -> In x s. + Proof. + intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. + Qed. + + Lemma diff_2 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x (diff s s') -> ~ In x s'. + Proof. + intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. + Qed. + + Lemma diff_3 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), + In x s -> ~ In x s' -> In x (diff s s'). + Proof. + unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. + induction s'; simpl; auto; intros. + inversion_clear Hs'. + apply IHs'; auto. + apply remove_unique; auto. + apply remove_2; auto. + Qed. + + Lemma subset_1 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), + Subset s s' -> subset s s' = true. + Proof. + unfold subset, Subset; intros. + apply is_empty_1. + unfold Empty; intros. + intro. + destruct (diff_2 Hs Hs' H0). + apply H. + eapply diff_1; eauto. + Qed. + + Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), + subset s s' = true -> Subset s s'. + Proof. + unfold subset, Subset; intros. + generalize (is_empty_2 H); clear H; unfold Empty; intros. + generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s'). + intuition. + intros. + destruct (H a). + apply diff_3; intuition. + Qed. + + Lemma equal_1 : + forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), + Equal s s' -> equal s s' = true. + Proof. + unfold Equal, equal; intros. + apply andb_true_intro; split; apply subset_1; firstorder. + Qed. + + Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), + equal s s' = true -> Equal s s'. + Proof. + unfold Equal, equal; intros. + destruct (andb_prop _ _ H); clear H. + split; apply subset_2; auto. + Qed. + + Definition choose_1 : + forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + destruct s; simpl; intros; inversion H; auto. + Qed. + + Definition choose_2 : forall s : t, choose s = None -> Empty s. + Proof. + destruct s; simpl; intros. + intros x H0; inversion H0. + inversion H. + Qed. + + Lemma cardinal_1 : + forall (s : t) (Hs : NoDup s), cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_1 : + forall (s : t) (x : elt) (f : elt -> bool), + In x (filter f s) -> In x s. + Proof. + simple induction s; simpl. + intros; inversion H. + intros x l Hrec a f. + case (f x); simpl. + inversion_clear 1. + constructor; auto. + constructor 2; apply (Hrec a f); trivial. + constructor 2; apply (Hrec a f); trivial. + Qed. + + Lemma filter_2 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool X.eq f -> In x (filter f s) -> f x = true. + Proof. + simple induction s; simpl. + intros; inversion H0. + intros x l Hrec a f Hf. + generalize (Hf x); case (f x); simpl; auto. + inversion_clear 2; auto. + symmetry; auto. + Qed. + + Lemma filter_3 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). + Proof. + simple induction s; simpl. + intros; inversion H0. + intros x l Hrec a f Hf. + generalize (Hf x); case (f x); simpl. + inversion_clear 2; auto. + inversion_clear 2; auto. + rewrite <- (H a (X.eq_sym H1)); intros; discriminate. + Qed. + + Lemma filter_unique : + forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (filter f s). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + case (f x); auto. + constructor; auto. + intro H1; apply H. + eapply filter_1; eauto. + Qed. + + + Lemma for_all_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. + simple induction s; simpl; auto; unfold For_all. + intros x l Hrec f Hf. + generalize (Hf x); case (f x); simpl. + auto. + intros; rewrite (H x); auto. + Qed. + + Lemma for_all_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. + simple induction s; simpl; auto; unfold For_all. + intros; inversion H1. + intros x l Hrec f Hf. + intros A a; intros. + assert (f x = true). + generalize A; case (f x); auto. + rewrite H0 in A; simpl in A. + inversion_clear H; auto. + rewrite (Hf a x); auto. + Qed. + + Lemma exists_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. + simple induction s; simpl; auto; unfold Exists. + intros. + elim H0; intuition. + inversion H2. + intros x l Hrec f Hf. + generalize (Hf x); case (f x); simpl. + auto. + destruct 2 as [a (A1,A2)]. + inversion_clear A1. + rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. + apply Hrec; auto. + exists a; auto. + Qed. + + Lemma exists_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. + simple induction s; simpl; auto; unfold Exists. + intros; discriminate. + intros x l Hrec f Hf. + case_eq (f x); intros. + exists x; auto. + destruct (Hrec f Hf H0) as [a (A1,A2)]. + exists a; auto. + Qed. + + Lemma partition_1 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). + Proof. + simple induction s; simpl; auto; unfold Equal. + firstorder. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_2 : + forall (s : t) (f : elt -> bool), + compat_bool X.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + simple induction s; simpl; auto; unfold Equal. + firstorder. + intros x l Hrec f Hf. + generalize (Hrec f Hf); clear Hrec. + case (partition f l); intros s1 s2; simpl; intros. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. + Qed. + + Lemma partition_aux_1 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), + In x (fst (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. + inversion_clear Hs. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Lemma partition_aux_2 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), + In x (snd (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. + inversion_clear Hs. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Lemma partition_unique_1 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + generalize (@partition_aux_1 _ H0 f x). + generalize (Hrec H0 f). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_unique_2 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec Hs f; inversion_clear Hs. + generalize (@partition_aux_2 _ H0 f x). + 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_sym : forall s s' : t, eq s s' -> eq s' s. + Proof. + unfold eq, Equal; firstorder. + Qed. + + Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. + Proof. + unfold eq, Equal; firstorder. + Qed. + +End Raw. + +(** * Encapsulation + + 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 E := X. + Module Raw := Raw X. + + Record slist : Set := {this :> Raw.t; unique : NoDupA X.eq this}. + Definition t := slist. + Definition elt := X.t. + + Definition In (x : elt) (s : t) := InA X.eq x s.(this). + 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 : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. + + Definition In_1 (s : t) := Raw.In_eq (s:=s). + + Definition mem (x : elt) (s : t) := Raw.mem x s. + Definition mem_1 (s : t) := Raw.mem_1 (s:=s). + Definition mem_2 (s : t) := Raw.mem_2 (s:=s). + + Definition add x s := Build_slist (Raw.add_unique (unique s) x). + Definition add_1 (s : t) := Raw.add_1 (unique s). + Definition add_2 (s : t) := Raw.add_2 (unique s). + Definition add_3 (s : t) := Raw.add_3 (unique s). + + Definition remove x s := Build_slist (Raw.remove_unique (unique s) x). + Definition remove_1 (s : t) := Raw.remove_1 (unique s). + Definition remove_2 (s : t) := Raw.remove_2 (unique s). + Definition remove_3 (s : t) := Raw.remove_3 (unique s). + + Definition singleton x := Build_slist (Raw.singleton_unique x). + Definition singleton_1 := Raw.singleton_1. + Definition singleton_2 := Raw.singleton_2. + + Definition union (s s' : t) := + Build_slist (Raw.union_unique (unique s) (unique s')). + Definition union_1 (s s' : t) := Raw.union_1 (unique s) (unique s'). + Definition union_2 (s s' : t) := Raw.union_2 (unique s) (unique s'). + Definition union_3 (s s' : t) := Raw.union_3 (unique s) (unique s'). + + Definition inter (s s' : t) := + Build_slist (Raw.inter_unique (unique s) (unique s')). + Definition inter_1 (s s' : t) := Raw.inter_1 (unique s) (unique s'). + Definition inter_2 (s s' : t) := Raw.inter_2 (unique s) (unique s'). + Definition inter_3 (s s' : t) := Raw.inter_3 (unique s) (unique s'). + + Definition diff (s s' : t) := + Build_slist (Raw.diff_unique (unique s) (unique s')). + Definition diff_1 (s s' : t) := Raw.diff_1 (unique s) (unique s'). + Definition diff_2 (s s' : t) := Raw.diff_2 (unique s) (unique s'). + Definition diff_3 (s s' : t) := Raw.diff_3 (unique s) (unique s'). + + Definition equal (s s' : t) := Raw.equal s s'. + Definition equal_1 (s s' : t) := Raw.equal_1 (unique s) (unique s'). + Definition equal_2 (s s' : t) := Raw.equal_2 (unique s) (unique s'). + + Definition subset (s s' : t) := Raw.subset s s'. + Definition subset_1 (s s' : t) := Raw.subset_1 (unique s) (unique s'). + Definition subset_2 (s s' : t) := Raw.subset_2 (unique s) (unique s'). + + Definition empty := Build_slist Raw.empty_unique. + Definition empty_1 := Raw.empty_1. + + Definition is_empty (s : t) := Raw.is_empty s. + Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s). + Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s). + + Definition elements (s : t) := Raw.elements s. + Definition elements_1 (s : t) := Raw.elements_1 (s:=s). + Definition elements_2 (s : t) := Raw.elements_2 (s:=s). + Definition elements_3 (s : t) := Raw.elements_3 (unique s). + + Definition choose (s:t) := Raw.choose s. + Definition choose_1 (s : t) := Raw.choose_1 (s:=s). + Definition choose_2 (s : t) := Raw.choose_2 (s:=s). + + Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. + Definition fold_1 (s : t) := Raw.fold_1 (unique s). + + Definition cardinal (s : t) := Raw.cardinal s. + Definition cardinal_1 (s : t) := Raw.cardinal_1 (unique s). + + Definition filter (f : elt -> bool) (s : t) := + Build_slist (Raw.filter_unique (unique s) f). + Definition filter_1 (s : t)(x:elt)(f: elt -> bool)(H:compat_bool X.eq f) := + @Raw.filter_1 s x f. + Definition filter_2 (s : t) := Raw.filter_2 (s:=s). + Definition filter_3 (s : t) := Raw.filter_3 (s:=s). + + Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s. + Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). + Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). + + Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s. + Definition exists_1 (s : t) := Raw.exists_1 (s:=s). + Definition exists_2 (s : t) := Raw.exists_2 (s:=s). + + Definition partition (f : elt -> bool) (s : t) := + let p := Raw.partition f s in + (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f), + Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)). + Definition partition_1 (s : t) := Raw.partition_1 s. + Definition partition_2 (s : t) := Raw.partition_2 s. + + Definition eq (s s' : t) := Raw.eq s s'. + Definition eq_refl (s : t) := Raw.eq_refl s. + Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s'). + Definition eq_trans (s s' s'' : t) := + Raw.eq_trans (s:=s) (s':=s') (s'':=s''). + +End Make. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v new file mode 100644 index 00000000..9dfcd51f --- /dev/null +++ b/theories/FSets/FSets.v @@ -0,0 +1,16 @@ +(***********************************************************************) +(* 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: FSets.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +Require Export OrderedType. +Require Export FSetInterface. +Require Export FSetBridge. +Require Export FSetProperties. +Require Export FSetEqProperties. +Require Export FSetList. diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v new file mode 100644 index 00000000..2bf08dc7 --- /dev/null +++ b/theories/FSets/OrderedType.v @@ -0,0 +1,566 @@ +(***********************************************************************) +(* 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: OrderedType.v 8667 2006-03-28 11:59:44Z 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 := + | 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 eq : t -> t -> Prop. + Parameter 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. + Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + + Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. + + Parameter compare : forall x y : t, Compare lt eq x y. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + +End OrderedType. + +(** * Ordered types properties *) + +(** Additional properties that can be derived from signature + [OrderedType]. *) + +Module OrderedTypeFacts (O: OrderedType). + Import O. + + Lemma lt_antirefl : forall x, ~ lt x x. + Proof. + intros; intro; absurd (eq x x); auto. + Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + intros; destruct (compare x z); auto. + elim (lt_not_eq H); apply eq_trans with z; auto. + elim (lt_not_eq (lt_trans l H)); auto. + Qed. + + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Proof. + intros; destruct (compare x z); auto. + elim (lt_not_eq H0); apply eq_trans with x; auto. + elim (lt_not_eq (lt_trans H0 l)); auto. + Qed. + + Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z. + Proof. + intros; intro; destruct H; apply lt_eq with z; auto. + Qed. + + Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z. + Proof. + intros; intro; destruct H0; apply eq_lt with x; auto. + Qed. + + Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z. + Proof. + intros; intro; destruct H; apply eq_trans with z; auto. + Qed. + + Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z. + Proof. + intros; intro; destruct H0; apply eq_trans with x; auto. + Qed. + + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. + + Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z. + Proof. + intros; destruct (compare y x); auto. + elim (H l). + apply eq_lt with y; auto. + apply lt_trans with y; auto. + Qed. + + Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z. + Proof. + intros; destruct (compare z y); auto. + elim (H0 l). + apply lt_eq with y; auto. + apply lt_trans with y; auto. + Qed. + + Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x. + Proof. + intros; destruct (compare x y); intuition. + Qed. + + Lemma neq_sym : forall x y, ~eq x y -> ~eq y x. + Proof. + intuition. + Qed. + +Ltac abstraction := match goal with + (* First, some obvious simplifications *) + | H : False |- _ => elim H + | H : lt ?x ?x |- _ => elim (lt_antirefl H) + | H : ~eq ?x ?x |- _ => elim (H (eq_refl x)) + | H : eq ?x ?x |- _ => clear H; abstraction + | H : ~lt ?x ?x |- _ => clear H; abstraction + | |- eq ?x ?x => exact (eq_refl x) + | |- lt ?x ?x => elimtype False; abstraction + | |- ~ _ => intro; abstraction + | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => + generalize (le_neq H1 H2); clear H1 H2; intro; abstraction + | 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 : eq ?x ?y |- _ => revert H; abstraction + | _ => idtac +end. + +Ltac do_eq a b EQ := match goal with + | |- lt ?x ?y -> _ => let H := fresh "H" in + (intro H; + (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) || + (generalize (lt_eq H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- ~lt ?x ?y -> _ => let H := fresh "H" in + (intro H; + (generalize (eq_le (eq_sym EQ) H); clear H; intro H) || + (generalize (le_eq H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- eq ?x ?y -> _ => let H := fresh "H" in + (intro H; + (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) || + (generalize (eq_trans H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- ~eq ?x ?y -> _ => let H := fresh "H" in + (intro H; + (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) || + (generalize (neq_eq H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- lt a ?y => apply eq_lt with b; [exact EQ|] + | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)] + | |- eq a ?y => apply eq_trans with b; [exact EQ|] + | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym EQ)] + | _ => idtac + end. + +Ltac propagate_eq := abstraction; clear; match goal with + (* the abstraction tactic leaves equality facts in head position...*) + | |- eq ?a ?b -> _ => + let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); + propagate_eq + | _ => idtac +end. + +Ltac do_lt x y LT := match goal with + (* LT *) + | |- lt x y -> _ => intros _; do_lt x y LT + | |- lt y ?z -> _ => let H := fresh "H" in + (intro H; generalize (lt_trans LT H); intro); do_lt x y LT + | |- 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 *) + | |- ~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 + | |- ~lt ?z y -> _ => let H := fresh "H" in + (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT + | |- ~lt _ _ -> _ => intro; do_lt x y LT + | _ => idtac + end. + +Definition hide_lt := lt. + +Ltac propagate_lt := abstraction; match goal with + (* when no [=] remains, the abstraction tactic leaves [<] facts first. *) + | |- lt ?x ?y -> _ => + let LT := fresh "LT" in (intro LT; do_lt x y LT; + change (hide_lt x y) in LT); + propagate_lt + | _ => unfold hide_lt in * +end. + +Ltac order := + intros; + propagate_eq; + propagate_lt; + auto; + propagate_lt; + eauto. + +Ltac false_order := elimtype False; order. + + Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y. + Proof. + order. + Qed. + + Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y. + Proof. + order. + Qed. + + Hint Resolve gt_not_eq eq_not_lt. + + Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x. + Proof. + order. + Qed. + + Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x. + Proof. + order. + Qed. + + Hint Resolve eq_not_gt lt_antirefl lt_not_gt. + + Lemma elim_compare_eq : + forall x y : t, + eq x y -> exists H : eq x y, compare x y = EQ _ H. + Proof. + intros; case (compare x y); intros H'; try solve [false_order]. + exists H'; auto. + Qed. + + Lemma elim_compare_lt : + forall x y : t, + lt x y -> exists H : lt x y, compare x y = LT _ H. + Proof. + intros; case (compare x y); intros H'; try solve [false_order]. + exists H'; auto. + Qed. + + Lemma elim_compare_gt : + forall x y : t, + lt y x -> exists H : lt y x, compare x y = GT _ H. + Proof. + intros; case (compare x y); intros H'; try solve [false_order]. + exists H'; auto. + Qed. + + Ltac elim_comp := + match goal with + | |- ?e => match e with + | context ctx [ compare ?a ?b ] => + let H := fresh in + (destruct (compare a b) as [H|H|H]; + try solve [ intros; false_order]) + end + end. + + Ltac elim_comp_eq x y := + elim (elim_compare_eq (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_lt x y := + elim (elim_compare_lt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Ltac elim_comp_gt x y := + elim (elim_compare_gt (x:=x) (y:=y)); + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + + Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); [ right | left | right ]; auto. + Qed. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros; elim (compare x y); [ left | right | right ]; auto. + Qed. + + Definition eqb x y : bool := if eq_dec x y then true else false. + + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. + Proof. + unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. + Qed. + +(* Specialization of resuts about lists modulo. *) + +Notation In:=(InA eq). +Notation Inf:=(lelistA lt). +Notation Sort:=(sort lt). +Notation NoDup:=(NoDupA eq). + +Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. +Proof. exact (InA_eqA eq_sym eq_trans). Qed. + +Lemma ListIn_In : forall l x, List.In x l -> In x l. +Proof. exact (In_InA eq_refl). Qed. + +Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. +Proof. exact (InfA_ltA lt_trans). Qed. + +Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. +Proof. exact (InfA_eqA eq_lt). Qed. + +Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. +Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. + +Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. +Proof. exact (@In_InfA t lt). Qed. + +Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. +Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed. + +Lemma Inf_alt : + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). +Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. + +Lemma Sort_NoDup : forall l, Sort l -> NoDup l. +Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed. + +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. + +End OrderedTypeFacts. + +Module PairOrderedType(O:OrderedType). + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. + + Section Elt. + Variable elt : Set. + Notation key:=t. + + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + Definition ltk (p p':key*elt) := lt (fst p) (fst p'). + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* ltk ignore the second components *) + + Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). + Proof. auto. Qed. + + Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. + Proof. auto. Qed. + Hint Immediate ltk_right_r ltk_right_l. + + (* eqk, eqke are equalities, ltk is a strict order *) + + Lemma eqk_refl : forall e, eqk e e. + Proof. auto. Qed. + + Lemma eqke_refl : forall e, eqke e e. + Proof. auto. Qed. + + Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. + Proof. auto. Qed. + + Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. + Proof. unfold eqke; intuition. Qed. + + Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. + Proof. eauto. Qed. + + Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. + Proof. + unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. + Proof. eauto. Qed. + + Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Proof. unfold eqk, ltk; auto. Qed. + + Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Proof. + unfold eqke, ltk; intuition; simpl in *; subst. + exact (lt_not_eq H H1). + Qed. + + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. + Hint Immediate eqk_sym eqke_sym. + + (* Additionnal facts *) + + Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. + Proof. + unfold eqk, ltk; simpl; auto. + Qed. + + Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. + Proof. eauto. Qed. + + Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. + Proof. + intros (k,e) (k',e') (k'',e''). + unfold ltk, eqk; simpl; eauto. + Qed. + Hint Resolve eqk_not_ltk. + Hint Immediate ltk_eqk eqk_ltk. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + Hint Resolve InA_eqke_eqk. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + Notation Sort := (sort ltk). + Notation Inf := (lelistA ltk). + + Hint Unfold MapsTo In. + + (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + + Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. + Proof. + firstorder. + exists x; auto. + induction H. + destruct y. + exists e; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + Qed. + + Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. + Proof. exact (InfA_eqA eqk_ltk). Qed. + + Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. + Proof. exact (InfA_ltA ltk_trans). Qed. + + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + + Lemma Sort_Inf_In : + forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. + exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk). + Qed. + + Lemma Sort_Inf_NotIn : + forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + Proof. + intros; red; intros. + destruct H1 as [e' H2]. + elim (@ltk_not_eqk (k,e) (k,e')). + eapply Sort_Inf_In; eauto. + red; simpl; auto. + Qed. + + Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. + Proof. + exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk). + Qed. + + Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Proof. + inversion 1; intros; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> + ltk e e' \/ eqk e e'. + Proof. + inversion_clear 2; auto. + left; apply Sort_In_cons_1 with l; auto. + Qed. + + Lemma Sort_In_cons_3 : + forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. + Proof. + inversion_clear 1; red; intros. + destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + inversion 1. + inversion_clear H0; eauto. + destruct H1; simpl in *; intuition. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + inversion_clear 1; compute in H0; intuition. + Qed. + + End Elt. + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. + Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_not_ltk. + Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + Hint Resolve Sort_Inf_NotIn. + Hint Resolve In_inv_2 In_inv_3. + +End PairOrderedType. + + diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 6aeabe13..f71f58c6 100755..100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,19 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v,v 1.26.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Datatypes.v 8642 2006-03-17 10:09:02Z notin $ i*) + +Set Implicit Arguments. Require Import Notations. Require Import Logic. -Set Implicit Arguments. - (** [unit] is a singleton datatype with sole inhabitant [tt] *) Inductive unit : Set := tt : unit. -(** [bool] is the datatype of the booleans values [true] and [false] *) +(** [bool] is the datatype of the boolean values [true] and [false] *) Inductive bool : Set := | true : bool @@ -27,7 +27,9 @@ Inductive bool : Set := Add Printing If bool. (** [nat] is the datatype of natural numbers built from [O] and successor [S]; - note that zero is the letter O, not the numeral 0 *) + note that the constructor name is the letter O. + Numbers in [nat] can be denoted using a decimal notation; + e.g. [3%nat] abbreviates [S (S (S O))] *) Inductive nat : Set := | O : nat @@ -53,7 +55,7 @@ Implicit Arguments identity_ind [A]. Implicit Arguments identity_rec [A]. Implicit Arguments identity_rect [A]. -(** [option A] is the extension of A with a dummy element None *) +(** [option A] is the extension of [A] with an extra element [None] *) Inductive option (A:Set) : Set := | Some : A -> option A @@ -61,7 +63,13 @@ Inductive option (A:Set) : Set := Implicit Arguments None [A]. -(** [sum A B], equivalently [A + B], is the disjoint sum of [A] and [B] *) +Definition option_map (A B:Set) (f:A->B) o := + match o with + | Some a => Some (f a) + | None => None + end. + +(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *) (* Syntax defined in Specif.v *) Inductive sum (A B:Set) : Set := | inl : A -> sum A B diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index bae8d4a1..cbf8d7a7 100755..100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v,v 1.29.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Logic.v 8642 2006-03-17 10:09:02Z notin $ i*) Set Implicit Arguments. Require Import Notations. -(** * Propositional connectives *) +(** *** Propositional connectives *) (** [True] is the always true proposition *) Inductive True : Prop := @@ -28,13 +28,6 @@ Notation "~ x" := (not x) : type_scope. Hint Unfold not: core. -Inductive and (A B:Prop) : Prop := - conj : A -> B -> A /\ B - where "A /\ B" := (and A B) : type_scope. - - -Section Conjunction. - (** [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 @@ -42,6 +35,13 @@ Section Conjunction. [proj1] and [proj2] are first and second projections of a conjunction *) +Inductive and (A B:Prop) : Prop := + conj : A -> B -> A /\ B + +where "A /\ B" := (and A B) : type_scope. + +Section Conjunction. + Variables A B : Prop. Theorem proj1 : A /\ B -> A. @@ -61,7 +61,8 @@ End Conjunction. Inductive or (A B:Prop) : Prop := | or_introl : A -> A \/ B | or_intror : B -> A \/ B - where "A \/ B" := (or A B) : type_scope. + +where "A \/ B" := (or A B) : type_scope. (** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *) @@ -94,20 +95,28 @@ End Equivalence. Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R. Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) - (at level 200) : type_scope. - -(** * First-order quantifiers - - [ex A P], or simply [exists x, P x], expresses the existence of an - [x] of type [A] which satisfies the predicate [P] ([A] is of type - [Set]). This is existential quantification. - - [ex2 A P Q], or simply [exists2 x, P x & Q x], expresses the - existence of an [x] of type [A] which satisfies both the predicates - [P] and [Q]. - - Universal quantification (especially first-order one) is normally - written [forall x:A, P x]. For duality with existential quantification, - the construction [all P] is provided too. + (at level 200, right associativity) : type_scope. + +(** *** First-order quantifiers *) + +(** [ex P], or simply [exists x, P x], or also [exists x:A, P x], + 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 + [exists2 x:A, P x & Q x], expresses the existence of an [x] of + type [A] which satisfies both predicates [P] and [Q]. + + Universal quantification is primitively written [forall x:A, Q]. By + symmetry with existential quantification, the construction [all P] + is provided too. *) +(* Remark: [exists x, Q] denotes [ex (fun x => Q)] so that [exists x, + P x] is in fact equivalent to [ex (fun x => P x)] which may be not + convertible to [ex P] if [P] is not itself an abstraction *) + + Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. @@ -119,19 +128,19 @@ 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) : type_scope. + (at level 200, x ident, right associativity) : type_scope. Notation "'exists' x : t , p" := (ex (fun x:t => p)) - (at level 200, x ident, format "'exists' '/ ' x : t , '/ ' p") + (at level 200, x ident, right associativity, + format "'[' 'exists' '/ ' x : t , '/ ' p ']'") : type_scope. Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) - (at level 200, x ident, p at level 200) : type_scope. + (at level 200, x ident, p at level 200, right associativity) : type_scope. Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q)) - (at level 200, x ident, t at level 200, p at level 200, - format "'exists2' '/ ' x : t , '/ ' '[' p & '/' q ']'") + (at level 200, x ident, t at level 200, p at level 200, right associativity, + format "'[' 'exists2' '/ ' x : t , '/ ' '[' p & '/' q ']' ']'") : type_scope. - (** Derived rules for universal quantification *) Section universal_quantification. @@ -151,18 +160,21 @@ Section universal_quantification. End universal_quantification. -(** * Equality *) +(** *** Equality *) -(** [eq x y], or simply [x=y], expresses the (Leibniz') equality - of [x] and [y]. Both [x] and [y] must belong to the same type [A]. +(** [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 - equals) are proved below. The type of [x] and [y] can be made explicit - using the notation [x = y :> A] *) + 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 - where "x = y :> A" := (@eq A x y) : type_scope. + +where "x = y :> A" := (@eq A x y) : type_scope. Notation "x = y" := (x = y :>_) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. @@ -217,16 +229,6 @@ Section Logic_lemmas. End equality. -(* Is now a primitive principle - Theorem eq_rect: (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eq ? x y)->(P y). - Proof. - Intros. - Cut (identity A x y). - NewDestruct 1; Auto. - NewDestruct H; Auto. - Qed. -*) - Definition eq_ind_r : 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. @@ -277,3 +279,14 @@ Proof. Qed. Hint Immediate sym_eq sym_not_eq: core v62. + +(** Other notations *) + +Notation "'exists' ! x , P" := + (exists x', (fun x => P) x' /\ forall x'', (fun x => P) x'' -> x' = x'') + (at level 200, x ident, right associativity, + format "'[' 'exists' ! '/ ' x , '/ ' P ']'") : type_scope. +Notation "'exists' ! x : A , P" := + (exists x' : A, (fun x => P) x' /\ forall x'':A, (fun x => P) x'' -> x' = x'') + (at level 200, x ident, right associativity, + format "'[' 'exists' ! '/ ' x : A , '/ ' P ']'") : type_scope. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 0e62e842..857ffe94 100755..100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -6,18 +6,48 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic_Type.v,v 1.19.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Logic_Type.v 8642 2006-03-17 10:09:02Z notin $ i*) -Set Implicit Arguments. +(** This module defines type constructors for types in [Type] + ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *) -(** This module defines quantification on the world [Type] - ([Logic.v] was defining it on the world [Set]) *) +Set Implicit Arguments. Require Import Datatypes. Require Export Logic. +(** Negation of a type in [Type] *) + Definition notT (A:Type) := A -> False. +(** Conjunction of types in [Type] *) + +Inductive prodT (A B:Type) : Type := + pairT : A -> B -> prodT A B. + +Section prodT_proj. + + Variables A B : Type. + + Definition fstT (H:prodT A B) := match H with + | pairT x _ => x + end. + Definition sndT (H:prodT A B) := match H with + | pairT _ y => y + end. + +End prodT_proj. + +Definition prodT_uncurry (A B C:Type) (f:prodT A B -> C) + (x:A) (y:B) : C := f (pairT x y). + +Definition prodT_curry (A B C:Type) (f:A -> B -> C) + (p:prodT A B) : C := match p with + | pairT x y => f x y + end. + +(** Properties of [identity] *) + Section identity_is_a_congruence. Variables A B : Type. @@ -62,28 +92,4 @@ Definition identity_rect_r : intros A x P H y H0; case sym_id with (1 := H0); trivial. Defined. -Inductive prodT (A B:Type) : Type := - pairT : A -> B -> prodT A B. - -Section prodT_proj. - - Variables A B : Type. - - Definition fstT (H:prodT A B) := match H with - | pairT x _ => x - end. - Definition sndT (H:prodT A B) := match H with - | pairT _ y => y - end. - -End prodT_proj. - -Definition prodT_uncurry (A B C:Type) (f:prodT A B -> C) - (x:A) (y:B) : C := f (pairT x y). - -Definition prodT_curry (A B C:Type) (f:A -> B -> C) - (p:prodT A B) : C := match p with - | pairT x y => f x y - end. - Hint Immediate sym_id sym_not_id: core v62. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index e0a18747..3ca93067 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,v 1.24.2.2 2004/08/01 09:36:44 herbelin Exp $ i*) +(*i $Id: Notations.v 6410 2004-12-06 11:34:35Z herbelin $ i*) (** These are the notations whose level and associativity are imposed by Coq *) @@ -54,15 +54,12 @@ Reserved Notation "x ^ y" (at level 30, right associativity). Reserved Notation "( x , y , .. , z )" (at level 0). (** Notation "{ x }" is reserved and has a special status as component - of other notations; it is at level 0 to factor with {x:A|P} etc *) + of other notations such as "{ A } + { B }" and "A + { B }" (which + are at the same level than "x + y"); + "{ x }" is at level 0 to factor with "{ x : A | P }" *) Reserved Notation "{ x }" (at level 0, x at level 99). -(** Notations for sum-types *) - -Reserved Notation "{ A } + { B }" (at level 50, left associativity). -Reserved Notation "A + { B }" (at level 50, left associativity). - (** Notations for sigma-types or subsets *) Reserved Notation "{ x : A | P }" (at level 0, x at level 99). diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 789a020f..c0416b63 100755..100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,9 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v,v 1.23.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Peano.v 8642 2006-03-17 10:09:02Z notin $ i*) -(** Natural numbers [nat] built from [O] and [S] are defined in Datatypes.v *) +(** The type [nat] of Peano natural numbers (built from [O] and [S]) + is defined in [Datatypes.v] *) (** This module defines the following operations on natural numbers : - predecessor [pred] @@ -19,13 +20,15 @@ - greater or equal [ge] - greater [gt] - This module states various lemmas and theorems about natural numbers, - including Peano's axioms of arithmetic (in Coq, these are in fact provable) - Case analysis on [nat] and induction on [nat * nat] are provided too *) + It states various lemmas and theorems about natural numbers, + including Peano's axioms of arithmetic (in Coq, these are provable). + Case analysis on [nat] and induction on [nat * nat] are provided too + *) Require Import Notations. Require Import Datatypes. Require Import Logic. +Unset Boxed Definitions. Open Scope nat_scope. @@ -47,6 +50,8 @@ Proof. auto. Qed. +(** Injectivity of successor *) + Theorem eq_add_S : forall n m:nat, S n = S m -> n = m. Proof. intros n m H; change (pred (S n) = pred (S m)) in |- *; auto. @@ -54,21 +59,20 @@ Qed. Hint Immediate eq_add_S: core v62. -(** A consequence of the previous axioms *) - Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m. Proof. red in |- *; auto. Qed. Hint Resolve not_eq_S: core v62. +(** Zero is not the successor of a number *) + Definition IsSucc (n:nat) : Prop := match n with | O => False | S p => True end. - Theorem O_S : forall n:nat, 0 <> S n. Proof. red in |- *; intros n H. @@ -88,13 +92,14 @@ Hint Resolve n_Sn: core v62. Fixpoint plus (n m:nat) {struct n} : nat := match n with | O => m - | S p => S (plus p m) - end. + | S p => S (p + m) + end + +where "n + m" := (plus n m) : nat_scope. + Hint Resolve (f_equal2 plus): v62. Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core. -Infix "+" := plus : nat_scope. - Lemma plus_n_O : forall n:nat, n = n + 0. Proof. induction n; simpl in |- *; auto. @@ -122,11 +127,12 @@ Qed. Fixpoint mult (n m:nat) {struct n} : nat := match n with | O => 0 - | S p => m + mult p m - end. -Hint Resolve (f_equal2 mult): core v62. + | S p => m + p * m + end -Infix "*" := mult : nat_scope. +where "n * m" := (mult n m) : nat_scope. + +Hint Resolve (f_equal2 mult): core v62. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. @@ -142,27 +148,25 @@ Proof. Qed. Hint Resolve mult_n_Sm: core v62. -(** Definition of subtraction on [nat] : [m-n] is [0] if [n>=m] *) +(** 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 - | S k, S l => minus k l - end. + | S k, S l => k - l + end -Infix "-" := minus : nat_scope. +where "n - m" := (minus n m) : nat_scope. (** Definition of the usual orders, the basic properties of [le] and [lt] can be found in files Le and Lt *) -(** An inductive definition to define the order *) - Inductive le (n:nat) : nat -> Prop := - | le_n : le n n - | le_S : forall m:nat, le n m -> le n (S m). + | le_n : n <= n + | le_S : forall m:nat, n <= m -> n <= S m -Infix "<=" := le : nat_scope. +where "n <= m" := (le n m) : nat_scope. Hint Constructors le: core v62. (*i equivalent to : "Hints Resolve le_n le_S : core v62." i*) @@ -187,7 +191,7 @@ Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope. Notation "x < y < z" := (x < y /\ y < z) : nat_scope. Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope. -(** Pattern-Matching on natural numbers *) +(** Case analysis *) Theorem nat_case : forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 2fe520c4..5f6f1eab 100755..100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Prelude.v,v 1.11.2.1 2004/07/16 19:31:03 herbelin Exp $ i*) +(*i $Id: Prelude.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Notations. Require Export Logic. Require Export Datatypes. Require Export Specif. Require Export Peano. -Require Export Wf.
\ No newline at end of file +Require Export Wf. +Require Export Tactics. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 6855e689..e7fc1ac4 100755..100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -6,21 +6,21 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Specif.v,v 1.25.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Specif.v 8642 2006-03-17 10:09:02Z notin $ i*) -Set Implicit Arguments. +(** Basic specifications : sets that may contain logical information *) -(** Basic specifications : Sets containing logical information *) +Set Implicit Arguments. Require Import Notations. Require Import Datatypes. Require Import Logic. -(** Subsets *) +(** Subsets and Sigma-types *) -(** [(sig A P)], or more suggestively [{x:A | (P x)}], denotes the subset +(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset of elements of the Set [A] which satisfy the predicate [P]. - Similarly [(sig2 A P Q)], or [{x:A | (P x) & (Q x)}], denotes the subset + Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the Set [A] which satisfy both [P] and [Q]. *) Inductive sig (A:Set) (P:A -> Prop) : Set := @@ -29,8 +29,8 @@ Inductive sig (A:Set) (P:A -> Prop) : Set := Inductive sig2 (A:Set) (P Q:A -> Prop) : Set := exist2 : forall x:A, P x -> Q x -> sig2 (A:=A) P Q. -(** [(sigS A P)], or more suggestively [{x:A & (P x)}], is a subtle variant - of subset where [P] is now of type [Set]. +(** [(sigS A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. + It is a variant of subset where [P] is now of type [Set]. Similarly for [(sigS2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) Inductive sigS (A:Set) (P:A -> Set) : Set := @@ -57,7 +57,13 @@ Add Printing Let sigS. Add Printing Let sigS2. -(** Projections of sig *) +(** Projections of [sig] + + An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] + of type [A] and of a proof [h] that [a] satisfies [P]. Then + [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the + proof of [(P a)] *) + Section Subset_projections. @@ -76,18 +82,18 @@ Section Subset_projections. End Subset_projections. -(** Projections of sigS *) +(** Projections of [sigS] + + An element [x] of a sigma-type [{y:A & P y}] is a dependent pair + made of an [a] of type [A] and an [h] of type [P a]. Then, + [(projS1 x)] is the first projection and [(projS2 x)] is the + second projection, the type of which depends on the [projS1]. *) Section Projections. Variable A : Set. Variable P : A -> Set. - (** An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] of - type [A] and of a proof [h] that [a] satisfies [P]. - Then [(projS1 y)] is the witness [a] - and [(projS2 y)] is the proof of [(P a)] *) - Definition projS1 (x:sigS P) : A := match x with | existS a _ => a end. @@ -99,7 +105,8 @@ Section Projections. End Projections. -(** Extended_booleans *) +(** [sumbool] is a boolean type equipped with the justification of + their value *) Inductive sumbool (A B:Prop) : Set := | left : A -> {A} + {B} @@ -108,6 +115,9 @@ Inductive sumbool (A B:Prop) : Set := Add Printing If sumbool. +(** [sumor] is an option type equipped with the justification of why + it may not be a regular value *) + Inductive sumor (A:Set) (B:Prop) : Set := | inleft : A -> A + {B} | inright : B -> A + {B} @@ -115,12 +125,10 @@ Inductive sumor (A:Set) (B:Prop) : Set := Add Printing If sumor. -(** Choice *) +(** Various forms of the axiom of choice for specifications *) Section Choice_lemmas. - (** The following lemmas state various forms of the axiom of choice *) - Variables S S' : Set. Variable R : S -> S' -> Prop. Variable R' : S -> S' -> Set. @@ -167,8 +175,10 @@ End Choice_lemmas. (** A result of type [(Exc A)] is either a normal value of type [A] or an [error] : - [Inductive Exc [A:Set] : Set := value : A->(Exc A) | error : (Exc A)] - it is implemented using the option type. *) + + [Inductive Exc [A:Set] : Set := value : A->(Exc A) | error : (Exc A)]. + + It is implemented using the option type. *) Definition Exc := option. Definition value := Some. @@ -189,7 +199,7 @@ Qed. Hint Resolve left right inleft inright: core v62. -(** Sigma Type at Type level [sigT] *) +(** Sigma-type for types in [Type] *) Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT (A:=A) P. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v new file mode 100644 index 00000000..ce37715e --- /dev/null +++ b/theories/Init/Tactics.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: Tactics.v 8100 2006-02-27 12:10:03Z letouzey $ i*) + +Require Import Notations. +Require Import Logic. + +(** Useful tactics *) + +(* A shorter name for generalize + clear, can be seen as an anti-intro *) + +Ltac revert H := generalize H; clear H. + +(* to contradict an hypothesis without copying its type. *) + +Ltac absurd_hyp h := + let T := type of h in + absurd T. + +(* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*) + +Ltac swap H := intro; apply H; clear H. + +(* 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. *) + +Ltac rewrite_all Eq := match type of Eq with + ?a = ?b => + generalize Eq; clear Eq; + match goal with + | H : context [a] |- _ => intro Eq; rewrite Eq in H; rewrite_all Eq + | _ => intro Eq; try rewrite Eq + end + end. + +Ltac rewrite_all_rev Eq := match type of Eq with + ?a = ?b => + generalize Eq; clear Eq; + match goal with + | H : context [b] |- _ => intro Eq; rewrite <- Eq in H; rewrite_all_rev Eq + | _ => intro Eq; try rewrite <- Eq + end + end. + +Tactic Notation "rewrite_all" "<-" constr(H) := rewrite_all_rev H. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 7ab3723d..fde70225 100755..100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -6,61 +6,59 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Set Implicit Arguments. - -(*i $Id: Wf.v,v 1.17.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Wf.v 8642 2006-03-17 10:09:02Z notin $ i*) (** This module proves the validity of - well-founded recursion (also called course of values) - well-founded induction - from a well-founded ordering on a given set *) + from a well-founded ordering on a given set *) + +Set Implicit Arguments. Require Import Notations. Require Import Logic. Require Import Datatypes. -(** Well-founded induction principle on Prop *) +(** Well-founded induction principle on [Prop] *) Section Well_founded. - Variable A : Set. + Variable A : Type. Variable R : A -> A -> Prop. (** The accessibility predicate is defined to be non-informative *) - Inductive Acc : A -> Prop := - Acc_intro : forall x:A, (forall y:A, R y x -> Acc y) -> Acc x. + Inductive Acc (x: A) : Prop := + Acc_intro : (forall y:A, R y x -> Acc y) -> Acc x. Lemma Acc_inv : forall x:A, Acc x -> forall y:A, R y x -> Acc y. destruct 1; trivial. Defined. - (** the informative elimination : + (** Informative elimination : [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. + Variable F : forall x:A, + (forall y:A, R y x -> Acc y) -> (forall y:A, R y x -> P y) -> P x. Fixpoint Acc_rect (x:A) (a:Acc x) {struct a} : P x := - F (Acc_inv a) (fun (y:A) (h:R y x) => Acc_rect (x:=y) (Acc_inv a h)). + F (Acc_inv a) (fun (y:A) (h:R y x) => Acc_rect (Acc_inv a h)). End AccRecType. Definition Acc_rec (P:A -> Set) := Acc_rect P. - (** A simplified version of Acc_rec(t) *) + (** A simplified version of [Acc_rect] *) Section AccIter. - Variable P : A -> Type. + 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 (x:=y) (Acc_inv a h)). + F (fun (y:A) (h:R y x) => Acc_iter (Acc_inv a h)). End AccIter. @@ -68,7 +66,7 @@ Section Well_founded. Definition well_founded := forall a:A, Acc a. - (** well-founded induction on Set and Prop *) + (** Well-founded induction on [Set] and [Prop] *) Hypothesis Rwf : well_founded. @@ -95,47 +93,48 @@ Section Well_founded. (** Building fixpoints *) -Section FixPoint. + Section FixPoint. -Variable P : A -> Set. -Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x. - -Fixpoint Fix_F (x:A) (r:Acc x) {struct r} : P x := - F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)). + Variable P : A -> Type. + Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x. -Definition Fix (x:A) := Fix_F (Rwf x). + Notation Fix_F := (Acc_iter P F) (only parsing). (* alias *) -(** Proof that [well_founded_induction] satisfies the fixpoint equation. - It requires an extra property of the functional *) + Definition Fix (x:A) := Acc_iter P F (Rwf x). -Hypothesis - F_ext : - 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. + (** Proof that [well_founded_induction] satisfies the fixpoint equation. + It requires an extra property of the functional *) -Scheme Acc_inv_dep := Induction for Acc Sort Prop. + Hypothesis + F_ext : + 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. -Lemma Fix_F_eq : - forall (x:A) (r:Acc x), - F (fun (y:A) (p:R y x) => Fix_F (Acc_inv r p)) = Fix_F r. -destruct r using Acc_inv_dep; auto. -Qed. + Scheme Acc_inv_dep := Induction for Acc Sort Prop. -Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s. -intro x; induction (Rwf x); intros. -rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros. -apply F_ext; auto. -Qed. + 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. + Proof. + intro x; induction (Rwf x); intros. + rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros. + apply F_ext; auto. + Qed. -Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y). -intro x; unfold Fix in |- *. -rewrite <- (Fix_F_eq (x:=x)). -apply F_ext; intros. -apply Fix_F_inv. -Qed. + 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)). + apply F_ext; intros. + apply Fix_F_inv. + Qed. -End FixPoint. + End FixPoint. End Well_founded. @@ -169,3 +168,5 @@ Section Well_founded_2. Defined. End Well_founded_2. + +Notation Fix_F := Acc_iter (only parsing). (* compatibility *) diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v index 9fde8f5f..2136bfb5 100644 --- a/theories/IntMap/Adalloc.v +++ b/theories/IntMap/Adalloc.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Adalloc.v,v 1.10.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Adalloc.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v index 7dba9ef6..f1a937a3 100644 --- a/theories/IntMap/Addec.v +++ b/theories/IntMap/Addec.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Addec.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Addec.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Equality on adresses *) diff --git a/theories/IntMap/Addr.v b/theories/IntMap/Addr.v index 1370d72d..727117b3 100644 --- a/theories/IntMap/Addr.v +++ b/theories/IntMap/Addr.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Addr.v,v 1.8.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Addr.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Representation of adresses by the [positive] type of binary numbers *) diff --git a/theories/IntMap/Adist.v b/theories/IntMap/Adist.v index cdb4c885..790218ce 100644 --- a/theories/IntMap/Adist.v +++ b/theories/IntMap/Adist.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Adist.v,v 1.9.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Adist.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import ZArith. diff --git a/theories/IntMap/Allmaps.v b/theories/IntMap/Allmaps.v index 68744220..f9a0feac 100644 --- a/theories/IntMap/Allmaps.v +++ b/theories/IntMap/Allmaps.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Allmaps.v,v 1.3.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Allmaps.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Export Addr. Require Export Adist. diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v index 8d217be9..27f739c1 100644 --- a/theories/IntMap/Fset.v +++ b/theories/IntMap/Fset.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Fset.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Fset.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*s Sets operations on maps *) diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v index 48972872..d31d8133 100644 --- a/theories/IntMap/Lsort.v +++ b/theories/IntMap/Lsort.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lsort.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Lsort.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v index da1fa99e..5345f81b 100644 --- a/theories/IntMap/Map.v +++ b/theories/IntMap/Map.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Map.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Map.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Definition of finite sets as trees indexed by adresses *) diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v index 9d09f2a9..b6a2b134 100644 --- a/theories/IntMap/Mapaxioms.v +++ b/theories/IntMap/Mapaxioms.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapaxioms.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapaxioms.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v index 7a394abb..d7a779ff 100644 --- a/theories/IntMap/Mapc.v +++ b/theories/IntMap/Mapc.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapc.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapc.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v index 868fbe5e..23e0669e 100644 --- a/theories/IntMap/Mapcanon.v +++ b/theories/IntMap/Mapcanon.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapcanon.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapcanon.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v index 49f9fe91..35efac47 100644 --- a/theories/IntMap/Mapcard.v +++ b/theories/IntMap/Mapcard.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapcard.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapcard.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v index 641529ee..335a1384 100644 --- a/theories/IntMap/Mapfold.v +++ b/theories/IntMap/Mapfold.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapfold.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapfold.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v index f5d443cc..31e98c49 100644 --- a/theories/IntMap/Mapiter.v +++ b/theories/IntMap/Mapiter.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapiter.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Mapiter.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v index 645c3407..1d53e6e5 100644 --- a/theories/IntMap/Maplists.v +++ b/theories/IntMap/Maplists.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Maplists.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) +(*i $Id: Maplists.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Addr. Require Import Addec. diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v index 33b412e3..e27943fb 100644 --- a/theories/IntMap/Mapsubset.v +++ b/theories/IntMap/Mapsubset.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Mapsubset.v,v 1.4.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) +(*i $Id: Mapsubset.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Bool. Require Import Sumbool. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index c3f65d67..ad91a350 100755..100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -6,10 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: List.v,v 1.9.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) - -Require Import Le. +(*i $Id: List.v 8686 2006-04-06 13:25:10Z letouzey $ i*) +Require Import Le Minus Min Bool. Section Lists. @@ -25,6 +24,8 @@ Infix "::" := cons (at level 60, right associativity) : list_scope. Open Scope list_scope. +Ltac now_show c := change c in |- *. + (*************************) (** Discrimination *) (*************************) @@ -35,108 +36,6 @@ Proof. Qed. (*************************) -(** Concatenation *) -(*************************) - -Fixpoint app (l m:list) {struct l} : list := - match l with - | nil => m - | a :: l1 => a :: app l1 m - end. - -Infix "++" := app (right associativity, at level 60) : list_scope. - -Lemma app_nil_end : forall l:list, l = l ++ nil. -Proof. - induction l; simpl in |- *; auto. - rewrite <- IHl; auto. -Qed. -Hint Resolve app_nil_end. - -Ltac now_show c := change c in |- *. - -Lemma app_ass : forall l m n:list, (l ++ m) ++ n = l ++ m ++ n. -Proof. - intros. induction l; simpl in |- *; auto. - now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n). - rewrite <- IHl; auto. -Qed. -Hint Resolve app_ass. - -Lemma ass_app : forall l m n:list, l ++ m ++ n = (l ++ m) ++ n. -Proof. - auto. -Qed. -Hint Resolve ass_app. - -Lemma app_comm_cons : forall (x y:list) (a:A), a :: x ++ y = (a :: x) ++ y. -Proof. - auto. -Qed. - -Lemma app_eq_nil : forall x y:list, x ++ y = nil -> x = nil /\ y = nil. -Proof. - destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; - simpl in |- *; auto. - intros H; discriminate H. - intros; discriminate H. -Qed. - -Lemma app_cons_not_nil : forall (x y:list) (a:A), nil <> x ++ a :: y. -Proof. -unfold not in |- *. - destruct x as [| a l]; simpl in |- *; intros. - discriminate H. - discriminate H. -Qed. - -Lemma app_eq_unit : - forall (x y:list) (a:A), - x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil. - -Proof. - destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; - simpl in |- *. - intros a H; discriminate H. - left; split; auto. - right; split; auto. - generalize H. - generalize (app_nil_end l); intros E. - rewrite <- E; auto. - intros. - injection H. - intro. - cut (nil = l ++ a0 :: l0); auto. - intro. - generalize (app_cons_not_nil _ _ _ H1); intro. - elim H2. -Qed. - -Lemma app_inj_tail : - forall (x y:list) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b. -Proof. - induction x as [| x l IHl]; - [ destruct y as [| a l] | destruct y as [| a l0] ]; - simpl in |- *; auto. - intros a b H. - injection H. - auto. - intros a0 b H. - injection H; intros. - generalize (app_cons_not_nil _ _ _ H0); destruct 1. - intros a b H. - injection H; intros. - cut (nil = l ++ a :: nil); auto. - intro. - generalize (app_cons_not_nil _ _ _ H2); destruct 1. - intros a0 b H. - injection H; intros. - destruct (IHl l0 a0 b H0). - split; auto. - rewrite <- H1; rewrite <- H2; reflexivity. -Qed. - -(*************************) (** Head and tail *) (*************************) @@ -253,6 +152,189 @@ Proof. destruct (H a0 a); simpl in |- *; auto. destruct IHl; simpl in |- *; auto. right; unfold not in |- *; intros [Hc1| Hc2]; auto. +Defined. + +(**************************) +(** Nth element of a list *) +(**************************) + +Fixpoint nth (n:nat) (l:list) (default:A) {struct l} : A := + match n, l with + | O, x :: l' => x + | O, other => default + | S m, nil => default + | S m, x :: t => nth m t default + end. + +Fixpoint nth_ok (n:nat) (l:list) (default:A) {struct l} : bool := + match n, l with + | O, x :: l' => true + | O, other => false + | S m, nil => false + | S m, x :: t => nth_ok m t default + end. + +Lemma nth_in_or_default : + forall (n:nat) (l:list) (d:A), {In (nth n l d) l} + {nth n l d = d}. +(* Realizer nth_ok. Program_all. *) +Proof. + intros n l d; generalize n; induction l; intro n0. + right; case n0; trivial. + case n0; simpl in |- *. + auto. + intro n1; elim (IHl n1); auto. +Qed. + +Lemma nth_S_cons : + forall (n:nat) (l:list) (d a:A), + In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l). +Proof. + simpl in |- *; auto. +Qed. + +Fixpoint nth_error (l:list) (n:nat) {struct n} : Exc A := + match n, l with + | O, x :: _ => value x + | S n, _ :: l => nth_error l n + | _, _ => error + end. + +Definition nth_default (default:A) (l:list) (n:nat) : A := + match nth_error l n with + | Some x => x + | None => default + end. + +Lemma nth_In : + forall (n:nat) (l:list) (d:A), n < length l -> In (nth n l d) l. + +Proof. +unfold lt in |- *; induction n as [| n hn]; simpl in |- *. +destruct l; simpl in |- *; [ inversion 2 | auto ]. +destruct l as [| a l hl]; simpl in |- *. +inversion 2. +intros d ie; right; apply hn; auto with arith. +Qed. + +Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. +Proof. +induction l; destruct n; simpl; intros; auto. +inversion H. +apply IHl; auto with arith. +Qed. + +Lemma nth_indep : + forall l n d d', n < length l -> nth n l d = nth n l d'. +Proof. +induction l; simpl; intros; auto. +inversion H. +destruct n; simpl; auto with arith. +Qed. + + +(*************************) +(** Concatenation *) +(*************************) + +Fixpoint app (l m:list) {struct l} : list := + match l with + | nil => m + | a :: l1 => a :: app l1 m + end. + +Infix "++" := app (right associativity, at level 60) : list_scope. + +Lemma app_nil_end : forall l:list, l = l ++ nil. +Proof. + induction l; simpl in |- *; auto. + rewrite <- IHl; auto. +Qed. +Hint Resolve app_nil_end. + +Lemma app_ass : forall l m n:list, (l ++ m) ++ n = l ++ m ++ n. +Proof. + intros. induction l; simpl in |- *; auto. + now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n). + rewrite <- IHl; auto. +Qed. +Hint Resolve app_ass. + +Lemma ass_app : forall l m n:list, l ++ m ++ n = (l ++ m) ++ n. +Proof. + auto. +Qed. +Hint Resolve ass_app. + +Lemma app_comm_cons : forall (x y:list) (a:A), a :: x ++ y = (a :: x) ++ y. +Proof. + auto. +Qed. + +Lemma app_eq_nil : forall x y:list, x ++ y = nil -> x = nil /\ y = nil. +Proof. + destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; + simpl in |- *; auto. + intros H; discriminate H. + intros; discriminate H. +Qed. + +Lemma app_cons_not_nil : forall (x y:list) (a:A), nil <> x ++ a :: y. +Proof. +unfold not in |- *. + destruct x as [| a l]; simpl in |- *; intros. + discriminate H. + discriminate H. +Qed. + +Lemma app_eq_unit : + forall (x y:list) (a:A), + x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil. + +Proof. + destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; + simpl in |- *. + intros a H; discriminate H. + left; split; auto. + right; split; auto. + generalize H. + generalize (app_nil_end l); intros E. + rewrite <- E; auto. + intros. + injection H. + intro. + cut (nil = l ++ a0 :: l0); auto. + intro. + generalize (app_cons_not_nil _ _ _ H1); intro. + elim H2. +Qed. + +Lemma app_inj_tail : + forall (x y:list) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b. +Proof. + induction x as [| x l IHl]; + [ destruct y as [| a l] | destruct y as [| a l0] ]; + simpl in |- *; auto. + intros a b H. + injection H. + auto. + intros a0 b H. + injection H; intros. + generalize (app_cons_not_nil _ _ _ H0); destruct 1. + intros a b H. + injection H; intros. + cut (nil = l ++ a :: nil); auto. + intro. + generalize (app_cons_not_nil _ _ _ H2); destruct 1. + intros a0 b H. + injection H; intros. + destruct (IHl l0 a0 b H0). + split; auto. + rewrite <- H1; rewrite <- H2; reflexivity. +Qed. + +Lemma app_length : forall l l', length (l++l') = length l + length l'. +Proof. +induction l; simpl; auto. Qed. Lemma in_app_or : forall (l m:list) (a:A), In a (l ++ m) -> In a l \/ In a m. @@ -285,6 +367,33 @@ Proof. Qed. Hint Resolve in_or_app. +Lemma app_nth1 : + forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. +Proof. +induction l. +intros. +inversion H. +intros l' d n. +case n; simpl; auto. +intros; rewrite IHl; auto with arith. +Qed. + +Lemma app_nth2 : + forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. +Proof. +induction l. +intros. +simpl. +destruct n; auto. +intros l' d n. +case n; simpl; auto. +intros. +inversion H. +intros. +rewrite IHl; auto with arith. +Qed. + + (***************************) (** Set inclusion on list *) (***************************) @@ -344,67 +453,7 @@ Proof. Qed. Hint Resolve incl_app. -(**************************) -(** Nth element of a list *) -(**************************) - -Fixpoint nth (n:nat) (l:list) (default:A) {struct l} : A := - match n, l with - | O, x :: l' => x - | O, other => default - | S m, nil => default - | S m, x :: t => nth m t default - end. - -Fixpoint nth_ok (n:nat) (l:list) (default:A) {struct l} : bool := - match n, l with - | O, x :: l' => true - | O, other => false - | S m, nil => false - | S m, x :: t => nth_ok m t default - end. - -Lemma nth_in_or_default : - forall (n:nat) (l:list) (d:A), {In (nth n l d) l} + {nth n l d = d}. -(* Realizer nth_ok. Program_all. *) -Proof. - intros n l d; generalize n; induction l; intro n0. - right; case n0; trivial. - case n0; simpl in |- *. - auto. - intro n1; elim (IHl n1); auto. -Qed. - -Lemma nth_S_cons : - forall (n:nat) (l:list) (d a:A), - In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l). -Proof. - simpl in |- *; auto. -Qed. -Fixpoint nth_error (l:list) (n:nat) {struct n} : Exc A := - match n, l with - | O, x :: _ => value x - | S n, _ :: l => nth_error l n - | _, _ => error - end. - -Definition nth_default (default:A) (l:list) (n:nat) : A := - match nth_error l n with - | Some x => x - | None => default - end. - -Lemma nth_In : - forall (n:nat) (l:list) (d:A), n < length l -> In (nth n l d) l. - -Proof. -unfold lt in |- *; induction n as [| n hn]; simpl in |- *. -destruct l; simpl in |- *; [ inversion 2 | auto ]. -destruct l as [| a l hl]; simpl in |- *. -inversion 2. -intros d ie; right; apply hn; auto with arith. -Qed. (********************************) (** Decidable equality on lists *) @@ -466,6 +515,72 @@ Proof. rewrite IHl; auto. Qed. +Lemma In_rev : forall l x, In x l <-> In x (rev l). +Proof. +induction l. +simpl; intuition. +intros. +simpl. +intuition. +subst. +apply in_or_app; right; simpl; auto. +apply in_or_app; left; firstorder. +destruct (in_app_or _ _ _ H); firstorder. +Qed. + +Lemma rev_length : forall l, length (rev l) = length l. +Proof. +induction l;simpl; auto. +rewrite app_length. +rewrite IHl. +simpl. +elim (length l); simpl; auto. +Qed. + +Lemma rev_nth : forall l d n, n < length l -> + nth n (rev l) d = nth (length l - S n) l d. +Proof. +induction l. +intros; inversion H. +intros. +simpl in H. +simpl (rev (a :: l)). +simpl (length (a :: l) - S n). +inversion H. +rewrite <- minus_n_n; simpl. +rewrite <- rev_length. +rewrite app_nth2; auto. +rewrite <- minus_n_n; auto. +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 rev_length; auto. +Qed. + +(****************************************************) +(** An alternative tail-recursive definition for reverse *) +(****************************************************) + +Fixpoint rev_acc (l l': list) {struct l} : list := + match l with + | nil => l' + | a::l => rev_acc l (a::l') + end. + +Lemma rev_acc_rev : forall l l', rev_acc l l' = rev l ++ l'. +Proof. +induction l; simpl; auto; intros. +rewrite <- ass_app; firstorder. +Qed. + +Lemma rev_alt : forall l, rev l = rev_acc l nil. +Proof. +intros; rewrite rev_acc_rev. +apply app_nil_end. +Qed. + (*********************************************) (** Reverse Induction Principle on Lists *) (*********************************************) @@ -503,9 +618,119 @@ Qed. End Reverse_Induction. +(***************************) +(** Last elements of a list *) +(***************************) + +(** [last l d] returns the last elements of the list [l], + or the default value [d] if [l] is empty. *) + +Fixpoint last (l:list)(d:A) {struct l} : A := + match l with + | nil => d + | a :: nil => a + | a :: l => last l d + end. + +(** [removelast l] remove the last element of [l] *) + +Fixpoint removelast (l:list) {struct l} : list := + match l with + | nil => nil + | a :: nil => nil + | a :: l => a :: removelast l + end. + +Lemma app_removelast_last : + forall l d, l<>nil -> l = removelast l ++ (last l d :: nil). +Proof. +induction l. +destruct 1; auto. +intros d _. +destruct l; auto. +pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. +Qed. + +Lemma exists_last : + forall l, l<>nil -> { l' : list & { a : A | l = l'++a::nil}}. +Proof. +induction l. +destruct 1; auto. +intros _. +destruct l. +exists nil; exists a; auto. +destruct IHl as [l' (a',H)]; try discriminate. +rewrite H. +exists (a::l'); exists a'; auto. +Qed. + +(********************************) +(* Cutting a list at some position *) +(********************************) + +Fixpoint firstn (n:nat)(l:list) {struct n} : list := + match n with + | 0 => nil + | S n => match l with + | nil => nil + | a::l => a::(firstn n l) + end + end. + +Fixpoint skipn (n:nat)(l:list) { struct n } : list := + match n with + | 0 => l + | S n => match l with + | nil => nil + | a::l => skipn n l + end + end. + +Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. +Proof. +induction n. +simpl; auto. +destruct l; simpl; auto. +f_equal; auto. +Qed. + +(**************) +(** Remove *) +(**************) + +Section Remove. + +Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. + +Fixpoint remove (x : A) (l : list){struct l} : list := + match l with + | nil => nil + | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) + end. + +End Remove. + +(***************************) +(** List without redundancy *) +(***************************) + +Inductive NoDup : list -> Prop := + | NoDup_nil : NoDup nil + | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). + End Lists. +(** Exporting list notations and hints *) + Implicit Arguments nil [A]. +Infix "::" := cons (at level 60, right associativity) : list_scope. +Infix "++" := app (right associativity, at level 60) : list_scope. + +Open Scope list_scope. + +Delimit Scope list_scope with list. + +Bind Scope list_scope with list. Hint Resolve nil_cons app_nil_end ass_app app_ass: datatypes v62. Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62. @@ -523,40 +748,241 @@ Section Functions_on_lists. (** Some generic functions on lists and basic functions of them *) (****************************************************************) +(*********) +(** Map *) +(*********) + Section Map. Variables A B : Set. Variable f : A -> B. + Fixpoint map (l:list A) : list B := match l with | nil => nil | cons a t => cons (f a) (map t) end. -End Map. Lemma in_map : - forall (A B:Set) (f:A -> B) (l:list A) (x:A), In x l -> In (f x) (map f l). + forall (l:list A) (x:A), In x l -> In (f x) (map l). Proof. induction l as [| a l IHl]; simpl in |- *; [ auto | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ]. Qed. -Fixpoint flat_map (A B:Set) (f:A -> list B) (l:list A) {struct l} : +Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. +Proof. +induction l; firstorder (subst; auto). +Qed. + +Lemma map_length : forall l, length (map l) = length l. +Proof. +induction l; simpl; auto. +Qed. + +Lemma map_nth : forall l d n, + nth n (map l) (f d) = f (nth n l d). +Proof. +induction l; simpl map; destruct n; firstorder. +Qed. + +Lemma map_app : forall l l', + map (l++l') = (map l)++(map l'). +Proof. +induction l; simpl; auto. +intros; rewrite IHl; auto. +Qed. + +Lemma map_rev : forall l, map (rev l) = rev (map l). +Proof. +induction l; simpl; auto. +rewrite map_app. +rewrite IHl; auto. +Qed. + +End Map. + +Lemma map_map : forall (A B C:Set)(f:A->B)(g:B->C) l, + map g (map f l) = map (fun x => g (f x)) l. +Proof. +induction l; simpl; auto. +rewrite IHl; auto. +Qed. + +Lemma map_ext : + forall (A B : Set)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. +Proof. +induction l; simpl; auto. +rewrite H; rewrite IHl; auto. +Qed. + +(********************************************) +(** Operations on lists of pairs or lists of lists *) +(********************************************) + +Section ListPairs. +Variable A B : Set. + +(** [split] derives two lists from a list of pairs *) + +Fixpoint split (l:list (A*B)) { struct l }: list A * list B := + match l with + | nil => (nil, nil) + | (x,y) :: tl => let (g,d) := split tl in (x::g, y::d) + end. + +Lemma in_split_l : forall (l:list (A*B))(p:A*B), + In p l -> In (fst p) (fst (split l)). +Proof. +induction l; simpl; intros; auto. +destruct p; destruct a; destruct (split l); simpl in *. +destruct H. +injection H; auto. +right; apply (IHl (a0,b) H). +Qed. + +Lemma in_split_r : forall (l:list (A*B))(p:A*B), + In p l -> In (snd p) (snd (split l)). +Proof. +induction l; simpl; intros; auto. +destruct p; destruct a; destruct (split l); simpl in *. +destruct H. +injection H; auto. +right; apply (IHl (a0,b) H). +Qed. + +Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), + nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). +Proof. +induction l. +destruct n; destruct d; simpl; auto. +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. +Qed. + +Lemma split_lenght_l : forall (l:list (A*B)), + length (fst (split l)) = length l. +Proof. +induction l; simpl; auto. +destruct a; destruct (split l); simpl; auto. +Qed. + +Lemma split_lenght_r : forall (l:list (A*B)), + length (snd (split l)) = length l. +Proof. +induction l; simpl; auto. +destruct a; destruct (split l); simpl; auto. +Qed. + +(** [combine] is the opposite of [split]. + Lists given to [combine] are meant to be of same length. + If not, [combine] stops on the shorter list *) + +Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) := + match l,l' with + | x::tl, y::tl' => (x,y)::(combine tl tl') + | _, _ => nil + end. + +Lemma split_combine : forall (l: list (A*B)), + let (l1,l2) := split l in combine l1 l2 = l. +Proof. +induction l. +simpl; auto. +destruct a; simpl. +destruct (split l); simpl in *. +f_equal; auto. +Qed. + +Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> + split (combine l l') = (l,l'). +Proof. +induction l; destruct l'; simpl; intros; auto; try discriminate. +injection H; clear H; intros. +rewrite IHl; auto. +Qed. + +Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), + In (x,y) (combine l l') -> In x l. +Proof. +induction l. +simpl; auto. +destruct l'; simpl; auto; intros. +contradiction. +destruct H. +injection H; auto. +right; apply IHl with l' y; auto. +Qed. + +Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), + In (x,y) (combine l l') -> In y l'. +Proof. +induction l. +simpl; intros; contradiction. +destruct l'; simpl; auto; intros. +destruct H. +injection H; auto. +right; apply IHl with x; auto. +Qed. + +Lemma combine_length : forall (l:list A)(l':list B), + length (combine l l') = min (length l) (length l'). +Proof. +induction l. +simpl; auto. +destruct l'; simpl; auto. +Qed. + +Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), + length l = length l' -> + nth n (combine l l') (x,y) = (nth n l x, nth n l' y). +Proof. +induction l; destruct l'; intros; try discriminate. +destruct n; simpl; auto. +destruct n; simpl in *; auto. +Qed. + +(** [flat_map] *) + +Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : list B := match l with | nil => nil - | cons x t => app (f x) (flat_map f t) + | cons x t => (f x)++(flat_map f t) end. -Fixpoint list_prod (A B:Set) (l:list A) (l':list B) {struct l} : +Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), + In y (flat_map f l) <-> exists x, In x l /\ In y (f x). +Proof. +induction l; simpl; split; intros. +contradiction. +destruct H as (x,(H,_)); contradiction. +destruct (in_app_or _ _ _ H). +exists a; auto. +destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). +exists x; auto. +apply in_or_app. +destruct H as (x,(H0,H1)); destruct H0. +subst; auto. +right; destruct (IHl y) as (_,H2); apply H2. +exists x; auto. +Qed. + +(** [list_prod] has the same signature as [combine], but unlike + [combine], it adds every possible pairs, not only those at the + same position. *) + +Fixpoint list_prod (l:list A) (l':list B) {struct l} : list (A * B) := match l with | nil => nil - | cons x t => app (map (fun y:B => (x, y)) l') (list_prod t l') + | cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l') end. Lemma in_prod_aux : - forall (A B:Set) (x:A) (y:B) (l:list B), + forall (x:A) (y:B) (l:list B), In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). Proof. induction l; @@ -566,7 +992,7 @@ Proof. Qed. Lemma in_prod : - forall (A B:Set) (l:list A) (l':list B) (x:A) (y:B), + forall (l:list A) (l':list B) (x:A) (y:B), In x l -> In y l' -> In (x, y) (list_prod l l'). Proof. induction l; @@ -575,10 +1001,36 @@ Proof. [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. +Lemma in_prod_iff : + forall (l:list A)(l':list B)(x:A)(y:B), + In (x,y) (list_prod l l') <-> In x l /\ In y l'. +Proof. +split; [ | intros; apply in_prod; intuition ]. +induction l; simpl; intros. +intuition. +destruct (in_app_or _ _ _ H); clear H. +destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_). +destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. +injection H2; clear H2; intros; subst; intuition. +intuition. +Qed. + +Lemma prod_length : forall (l:list A)(l':list B), + length (list_prod l l') = (length l) * (length l'). +Proof. +induction l; simpl; auto. +intros. +rewrite app_length. +rewrite map_length. +auto. +Qed. + +End ListPairs. + (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y] indexed by elts of [x], sorted in lexicographic order. *) -Fixpoint list_power (A B:Set) (l:list A) (l':list B) {struct l} : +Fixpoint list_power (A B:Set)(l:list A) (l':list B) {struct l} : list (list (A * B)) := match l with | nil => cons nil nil @@ -594,13 +1046,37 @@ Fixpoint list_power (A B:Set) (l:list A) (l':list B) {struct l} : Section Fold_Left_Recursor. Variables A B : Set. Variable f : A -> B -> A. + Fixpoint fold_left (l:list B) (a0:A) {struct l} : A := match l with | nil => a0 | cons b t => fold_left t (f a0 b) end. + +Lemma fold_left_app : forall (l l':list B)(i:A), + fold_left (l++l') i = fold_left l' (fold_left l i). +Proof. +induction l. +simpl; auto. +intros. +simpl. +auto. +Qed. + End Fold_Left_Recursor. +Lemma fold_left_length : + forall (A:Set)(l:list A), fold_left (fun x _ => S x) l 0 = length l. +Proof. +intro A. +cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l). +intros. +exact (H l 0). +induction l; simpl; auto. +intros; rewrite IHl. +simpl; auto with arith. +Qed. + (************************************) (** Right-to-left iterator on lists *) (************************************) @@ -609,13 +1085,34 @@ Section Fold_Right_Recursor. Variables A B : Set. Variable f : B -> A -> A. Variable a0 : A. + Fixpoint fold_right (l:list B) : A := match l with | nil => a0 | cons b t => f b (fold_right t) end. + End Fold_Right_Recursor. +Lemma fold_right_app : forall (A B:Set)(f:A->B->B) l l' i, + fold_right f i (l++l') = fold_right f (fold_right f i l') l. +Proof. +induction l. +simpl; auto. +simpl; intros. +f_equal; auto. +Qed. + +Lemma fold_left_rev_right : forall (A B:Set)(f:A->B->B) l i, + fold_right f i (rev l) = fold_left (fun x y => f y x) l i. +Proof. +induction l. +simpl; auto. +intros. +simpl. +rewrite fold_right_app; simpl; auto. +Qed. + Theorem fold_symmetric : forall (A:Set) (f:A -> A -> A), (forall x y z:A, f x (f y z) = f (f x y) z) -> @@ -638,18 +1135,157 @@ rewrite IHl. reflexivity. Qed. -End Functions_on_lists. +(********************************) +(** Boolean operations over lists *) +(********************************) +Section Bool. +Variable A : Set. +Variable f : A -> bool. -(** Exporting list notations *) +(** find whether a boolean function can be satisfied by an + elements of the list. *) -Infix "::" := cons (at level 60, right associativity) : list_scope. +Fixpoint existsb (l:list A) {struct l}: bool := + match l with + | nil => false + | a::l => f a || existsb l + end. -Infix "++" := app (right associativity, at level 60) : list_scope. +Lemma existsb_exists : + forall l, existsb l = true <-> exists x, In x l /\ f x = true. +Proof. +induction l; simpl; intuition. +inversion H. +firstorder. +destruct (orb_prop _ _ H1); firstorder. +firstorder. +subst. +rewrite H2; auto. +Qed. -Open Scope list_scope. +Lemma existsb_nth : forall l n d, n < length l -> + existsb l = false -> f (nth n l d) = false. +Proof. +induction l. +inversion 1. +simpl; intros. +destruct (orb_false_elim _ _ H0); clear H0; auto. +destruct n ; auto. +rewrite IHl; auto with arith. +Qed. -(** Declare Scope list_scope with key list *) -Delimit Scope list_scope with list. +(** find whether a boolean function is satisfied by + all the elements of a list. *) -Bind Scope list_scope with list. +Fixpoint forallb (l:list A) {struct l} : bool := + match l with + | nil => true + | a::l => f a && forallb l + end. + +Lemma forallb_forall : + forall l, forallb l = true <-> (forall x, In x l -> f x = true). +Proof. +induction l; simpl; intuition. +destruct (andb_prop _ _ H1). +congruence. +destruct (andb_prop _ _ H1); auto. +assert (forallb l = true). +apply H0; intuition. +rewrite H1; auto. +Qed. + +(** [filter] *) + +Fixpoint filter (l:list A) : list A := + match l with + | nil => nil + | x :: l => if f x then x::(filter l) else filter l + end. + +Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. +Proof. +induction l; simpl. +intuition. +intros. +case_eq (f a); intros; simpl; intuition congruence. +Qed. + +(** [find] *) + +Fixpoint find (l:list A) : option A := + match l with + | nil => None + | x :: tl => if f x then Some x else find tl + end. + +(** [partition] *) + +Fixpoint partition (l:list A) {struct l} : list A * list A := + match l with + | nil => (nil, nil) + | x :: tl => let (g,d) := partition tl in + if f x then (x::g,d) else (g,x::d) + end. + +End Bool. + + +(*********************************) +(** Sequence of natural numbers *) +(*********************************) + +(** [seq] computes the sequence of [len] contiguous integers + that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *) + +Fixpoint seq (start len:nat) {struct len} : list nat := + match len with + | 0 => nil + | S len => start :: seq (S start) len + end. + +Lemma seq_length : forall len start, length (seq start len) = len. +Proof. +induction len; simpl; auto. +Qed. + +Lemma seq_nth : forall len start n d, + n < len -> nth n (seq start len) d = start+n. +Proof. +induction len; intros. +inversion H. +simpl seq. +destruct n; simpl. +auto with arith. +rewrite IHlen;simpl; auto with arith. +Qed. + +Lemma seq_shift : forall len start, + map S (seq start len) = seq (S start) len. +Proof. +induction len; simpl; auto. +intros. +rewrite IHlen. +auto with arith. +Qed. + +End Functions_on_lists. + + +Hint Rewrite + rev_involutive (* rev (rev l) = l *) + rev_unit (* rev (l ++ a :: nil) = a :: rev l *) + map_nth (* nth n (map f l) (f d) = f (nth n l d) *) + map_length (* length (map f l) = length l *) + seq_length (* length (seq start len) = len *) + app_length (* length (l ++ l') = length l + length l' *) + rev_length (* length (rev l) = length l *) + : list. + +Hint Rewrite <- + app_nil_end (* l = l ++ nil *) + : list. + +Ltac simpl_list := autorewrite with list. +Ltac ssimpl_list := autorewrite with list using simpl. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index d5ecad9c..4e009ed5 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -6,14 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ListSet.v,v 1.13.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) +(*i $Id: ListSet.v 6844 2005-03-16 13:09:55Z herbelin $ i*) -(** A Library for finite sets, implemented as lists - A Library with similar interface will soon be available under - the name TreeSet in the theories/Trees directory *) +(** A Library for finite sets, implemented as lists *) -(** PolyList is loaded, but not exported. - This allow to "hide" the definitions, functions and theorems of PolyList +(** List is loaded, but not exported. + This allow to "hide" the definitions, functions and theorems of List and to see only the ones of ListSet *) Require Import List. @@ -395,4 +393,4 @@ Section other_definitions. End other_definitions. -Unset Implicit Arguments.
\ No newline at end of file +Unset Implicit Arguments. diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v index d639a39d..aa2b74dd 100755..100644 --- a/theories/Lists/MonoList.v +++ b/theories/Lists/MonoList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: MonoList.v,v 1.2.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) +(*i $Id: MonoList.v 8642 2006-03-17 10:09:02Z notin $ i*) (** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***) diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v new file mode 100644 index 00000000..811dcab4 --- /dev/null +++ b/theories/Lists/SetoidList.v @@ -0,0 +1,300 @@ +(***********************************************************************) +(* 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: SetoidList.v 8686 2006-04-06 13:25:10Z letouzey $ *) + +Require Export List. +Require Export Sorting. +Require Export Setoid. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Logical relations over lists with respect to a setoid equality + or ordering. *) + +(** This can be seen as a complement of predicate [lelistA] and [sort] + found in [Sorting]. *) + +Section Type_with_equality. +Variable A : Set. +Variable eqA : A -> A -> Prop. + +(** Being in a list modulo an equality relation over type [A]. *) + +Inductive InA (x : A) : list A -> Prop := + | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) + | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). + +Hint Constructors InA. + +(** An alternative definition of [InA]. *) + +Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. +Proof. + induction l; intuition. + inversion H. + firstorder. + inversion H1; firstorder. + firstorder; subst; auto. +Qed. + +(** A list without redundancy modulo the equality over [A]. *) + +Inductive NoDupA : list A -> Prop := + | NoDupA_nil : NoDupA nil + | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). + +Hint Constructors NoDupA. + +(** lists with same elements modulo [eqA] *) + +Definition eqlistA l l' := forall x, InA x l <-> InA x l'. + +(** Results concerning lists modulo [eqA] *) + +Hypothesis eqA_refl : forall x, eqA x x. +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. + +Hint Resolve eqA_refl eqA_trans. +Hint Immediate eqA_sym. + +Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. +Proof. + intros s x y. + do 2 rewrite InA_alt. + intros H (z,(U,V)). + exists z; split; eauto. +Qed. +Hint Immediate InA_eqA. + +Lemma In_InA : forall l x, In x l -> InA x l. +Proof. + simple induction l; simpl in |- *; intuition. + subst; auto. +Qed. +Hint Resolve In_InA. + +(** Results concerning lists modulo [eqA] and [ltA] *) + +Variable ltA : A -> A -> Prop. + +Hypothesis ltA_trans : forall x y z, ltA x y -> ltA y z -> ltA x z. +Hypothesis ltA_not_eqA : forall x y, ltA x y -> ~ eqA x y. +Hypothesis ltA_eqA : forall x y z, ltA x y -> eqA y z -> ltA x z. +Hypothesis eqA_ltA : forall x y z, eqA x y -> ltA y z -> ltA x z. + +Hint Resolve ltA_trans. +Hint Immediate ltA_eqA eqA_ltA. + +Notation InfA:=(lelistA ltA). +Notation SortA:=(sort ltA). + +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. + eapply ltA_trans; eauto. +Qed. + +Lemma InfA_eqA : + forall l x y, eqA x y -> InfA y l -> InfA x l. +Proof. + intro s; case s; constructor; inversion_clear H0; eauto. +Qed. +Hint Immediate InfA_ltA InfA_eqA. + +Lemma SortA_InfA_InA : + forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. +Proof. + simple induction l. + intros; inversion H1. + intros. + inversion_clear H0; inversion_clear H1; inversion_clear H2. + eapply ltA_eqA; eauto. + eauto. +Qed. + +Lemma In_InfA : + forall l x, (forall y, In y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl in |- *; intros; constructor; auto. +Qed. + +Lemma InA_InfA : + forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl in |- *; intros; constructor; auto. +Qed. + +(* In fact, this may be used as an alternative definition for InfA: *) + +Lemma InfA_alt : + forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). +Proof. +split. +intros; eapply SortA_InfA_InA; eauto. +apply InA_InfA. +Qed. + +Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. +Proof. + simple induction l; auto. + intros x l' H H0. + inversion_clear H0. + constructor; auto. + intro. + assert (ltA x x) by eapply SortA_InfA_InA; eauto. + elim (ltA_not_eqA H3); auto. +Qed. + +Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> + (forall x, InA x l -> InA x l' -> False) -> + NoDupA (l++l'). +Proof. +induction l; simpl; auto; intros. +inversion_clear H. +constructor. +rewrite InA_alt; intros (y,(H4,H5)). +destruct (in_app_or _ _ _ H5). +elim H2. +rewrite InA_alt. +exists y; auto. +apply (H1 a). +auto. +rewrite InA_alt. +exists y; auto. +apply IHl; auto. +intros. +apply (H1 x); auto. +Qed. + + +Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). +Proof. +induction l. +simpl; auto. +simpl; intros. +inversion_clear H. +apply NoDupA_app; auto. +constructor; auto. +intro H2; inversion H2. +intros x. +rewrite InA_alt. +intros (x1,(H2,H3)). +inversion_clear 1. +destruct H0. +apply InA_eqA with x1; eauto. +apply In_InA. +rewrite In_rev; auto. +inversion H4. +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. + + Hint Constructors lelistA sort. + +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 Remove. + +Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. + +Fixpoint removeA (x : A) (l : list A){struct l} : list A := + match l with + | nil => nil + | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) + end. + +Lemma removeA_filter : forall x l, + removeA x l = filter (fun y => if eqA_dec x y then false else true) l. +Proof. +induction l; simpl; auto. +destruct (eqA_dec x a); auto. +rewrite IHl; auto. +Qed. + +Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. +Proof. +induction l; simpl; auto. +split. +inversion_clear 1. +destruct 1; inversion_clear H. +intros. +destruct (eqA_dec x a); simpl; auto. +rewrite IHl; split; destruct 1; split; auto. +inversion_clear H; auto. +destruct H0; apply eqA_trans with a; auto. +split. +inversion_clear 1. +split; auto. +swap n. +apply eqA_trans with y; auto. +rewrite (IHl x y) in H0; destruct H0; auto. +destruct 1; inversion_clear H; auto. +constructor 2; rewrite IHl; auto. +Qed. + +Lemma removeA_NoDupA : + forall s x, NoDupA s -> NoDupA (removeA x s). +Proof. +simple induction s; simpl; intros. +auto. +inversion_clear H0. +destruct (eqA_dec x a); simpl; auto. +constructor; auto. +rewrite removeA_InA. +intuition. +Qed. + +Lemma removeA_eqlistA : forall l l' x, + ~InA x l -> eqlistA (x :: l) l' -> eqlistA l (removeA x l'). +Proof. +unfold eqlistA; intros. +rewrite removeA_InA. +split; intros. +rewrite <- H0; split; auto. +swap H. +apply InA_eqA with x0; auto. +rewrite <- (H0 x0) in H1. +destruct H1. +inversion_clear H1; auto. +elim H2; auto. +Qed. + +End Remove. + +End Type_with_equality. + +Hint Constructors InA. +Hint Constructors NoDupA. +Hint Constructors sort. +Hint Constructors lelistA. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 3c433ba2..7bc6a09d 100755..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,v 1.15.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) +(*i $Id: Streams.v 8642 2006-03-17 10:09:02Z notin $ i*) Set Implicit Arguments. @@ -71,9 +71,8 @@ Qed. (** Extensional Equality between two streams *) -CoInductive EqSt : Stream -> Stream -> Prop := +CoInductive EqSt (s1 s2: Stream) : Prop := eqst : - forall s1 s2:Stream, hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. (** A coinduction principle *) @@ -140,12 +139,12 @@ Inductive Exists : Stream -> Prop := | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x. i*) -Inductive Exists : Stream -> Prop := - | Here : forall x:Stream, P x -> Exists x - | Further : forall x:Stream, Exists (tl x) -> Exists x. +Inductive Exists ( x: Stream ) : Prop := + | Here : P x -> Exists x + | Further : Exists (tl x) -> Exists x. -CoInductive ForAll : Stream -> Prop := - HereAndFurther : forall x:Stream, P x -> ForAll (tl x) -> ForAll x. +CoInductive ForAll (x: Stream) : Prop := + HereAndFurther : P x -> ForAll (tl x) -> ForAll x. Section Co_Induction_ForAll. diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v index fbeb97ce..19f97aec 100755..100644 --- a/theories/Lists/TheoryList.v +++ b/theories/Lists/TheoryList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: TheoryList.v,v 1.15.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: TheoryList.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Some programs and results about lists following CAML Manual *) diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex index 344bba59..c45f8803 100755 --- a/theories/Lists/intro.tex +++ b/theories/Lists/intro.tex @@ -4,21 +4,24 @@ This library includes the following files: \begin{itemize} -\item {\tt List.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY - WITH OLDER VERSIONS OF COQS. THE USER SHOULD USE POLYLIST INSTEAD. - -\item {\tt PolyList.v} contains definitions of (polymorphic) lists, +\item {\tt List.v} contains definitions of (polymorphic) lists, functions on lists such as head, tail, map, append and prove some properties of these functions. Implicit arguments are used in this - library, so you should read the Referance Manual about implicit + library, so you should read the Reference Manual about implicit arguments before using it. +\item {\tt ListSet.v} contains definitions and properties of finite + sets, implemented as lists. + \item {\tt TheoryList.v} contains complementary results on lists. Here - a more theoric point of view is assumed : one extracts functions + a more theoretic point of view is assumed : one extracts functions from propositions, rather than defining functions and then prove them. \item {\tt Streams.v} defines the type of infinite lists (streams). It is a coinductive type. Basic facts are stated and proved. The streams are also polymorphic. +\item {\tt MonoList.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY + WITH OLDER VERSIONS OF COQ. THE USER SHOULD USE {\tt List.v} INSTEAD. + \end{itemize} diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 0fe8a87d..9eaef07a 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Berardi.v,v 1.5.2.2 2004/08/03 17:42:43 herbelin Exp $ i*) +(*i $Id: Berardi.v 8122 2006-03-04 19:26:40Z herbelin $ i*) (** This file formalizes Berardi's paradox which says that in the calculus of constructions, excluded middle (EM) and axiom of @@ -92,14 +92,10 @@ End Retracts. Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). Proof. intros A B. -elim (EM (retract (pow A) (pow B))). -intros [f0 g0 e]. -exists f0 g0. -trivial. - -intros hf. -exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F). -intros; elim hf; auto. +destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. + exists f0 g0; trivial. + exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; + destruct hf; auto. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 87d8a70e..bc892ca9 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ChoiceFacts.v,v 1.7.2.2 2004/08/01 09:29:59 herbelin Exp $ i*) +(*i $Id: ChoiceFacts.v 8132 2006-03-05 10:59:47Z herbelin $ i*) (** We show that the functional formulation of the axiom of Choice (usual formulation in type theory) is equivalent to its relational @@ -17,29 +17,33 @@ relational formulation) without known inconsistency with classical logic, though definite description conflicts with classical logic *) +Section ChoiceEquivalences. + +Variables A B :Type. + Definition RelationalChoice := - forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists y : B, R x y) -> + forall (R:A -> B -> Prop), + (forall x:A, exists y : B, R x y) -> exists R' : A -> B -> Prop, (forall x:A, - exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')). + exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')). Definition FunctionalChoice := - forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists y : B, R x y) -> + forall (R:A -> B -> Prop), + (forall x:A, exists y : B, R x y) -> exists f : A -> B, (forall x:A, R x (f x)). Definition ParamDefiniteDescription := - forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) -> + forall (R:A -> B -> Prop), + (forall x:A, exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) -> exists f : A -> B, (forall x:A, R x (f x)). Lemma description_rel_choice_imp_funct_choice : ParamDefiniteDescription -> RelationalChoice -> FunctionalChoice. intros Descr RelCh. -red in |- *; intros A B R H. -destruct (RelCh A B R H) as [R' H0]. -destruct (Descr A B R') as [f H1]. +red in |- *; intros R H. +destruct (RelCh R H) as [R' H0]. +destruct (Descr R') as [f H1]. intro x. elim (H0 x); intros y [H2 [H3 H4]]; exists y; split; [ exact H3 | exact H4 ]. exists f; intro x. @@ -50,8 +54,8 @@ Qed. Lemma funct_choice_imp_rel_choice : FunctionalChoice -> RelationalChoice. intros FunCh. -red in |- *; intros A B R H. -destruct (FunCh A B R H) as [f H0]. +red in |- *; intros R H. +destruct (FunCh R H) as [f H0]. exists (fun x y => y = f x). intro x; exists (f x); split; [ apply H0 @@ -61,8 +65,8 @@ Qed. Lemma funct_choice_imp_description : FunctionalChoice -> ParamDefiniteDescription. intros FunCh. -red in |- *; intros A B R H. -destruct (FunCh A B R) as [f H0]. +red in |- *; intros R H. +destruct (FunCh R) as [f H0]. (* 1 *) intro x. elim (H x); intros y [H0 H1]. @@ -80,22 +84,25 @@ intro H; split; intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H). Qed. +End ChoiceEquivalences. + (** 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 *) -Definition GuardedRelationalChoice := - forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop), - (forall x:A, P x -> exists y : B, R x y) -> +Definition GuardedRelationalChoice (A B:Type) := + forall (P:A -> Prop) (R:A -> B -> Prop), + (forall x:A, P x -> exists y : B, R x y) -> exists R' : A -> B -> Prop, (forall x:A, P x -> - exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')). + exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')). Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice : - RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice. + (forall A B, RelationalChoice A B) + -> ProofIrrelevance -> (forall A B, GuardedRelationalChoice A B). Proof. intros rel_choice proof_irrel. red in |- *; intros A B P R H. @@ -103,7 +110,7 @@ destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as [R' H0]. intros [x HPx]. destruct (H x HPx) as [y HRxy]. exists y; exact HRxy. -set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y). +set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y). exists R''; intros x HPx. destruct (H0 (existT P x HPx)) as [y [HRxy [HR'xy Huniq]]]. exists y. split. @@ -118,16 +125,17 @@ exists y. split. exact HR'xy'. Qed. -Definition IndependenceOfPremises := +Definition IndependenceOfGeneralPremises := forall (A:Type) (P:A -> Prop) (Q:Prop), - (Q -> exists x : _, P x) -> exists x : _, Q -> P x. + (Q -> exists x, P x) -> exists x, Q -> P x. -Lemma rel_choice_indep_of_premises_imp_guarded_rel_choice : - RelationalChoice -> IndependenceOfPremises -> GuardedRelationalChoice. +Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : + forall A B, RelationalChoice A B -> + IndependenceOfGeneralPremises -> GuardedRelationalChoice A B. Proof. -intros RelCh IndPrem. -red in |- *; intros A B P R H. -destruct (RelCh A B (fun x y => P x -> R x y)) as [R' H0]. +intros A B RelCh IndPrem. +red in |- *; intros P R H. +destruct (RelCh (fun x y => P x -> R x y)) as [R' H0]. intro x. apply IndPrem. apply H. exists R'. @@ -137,3 +145,79 @@ destruct (RelCh A B (fun x y => P x -> R x y)) as [R' H0]. apply (H1 HPx). exact H2. Qed. + + +(** Countable codomains, such as [nat], can be equipped with a + well-order, which implies the existence of a least element on + inhabited decidable subsets. As a consequence, the relational form of + the axiom of choice is derivable on [nat] for decidable relations. + + We show instead that definite description and the functional form + of the axiom of choice are equivalent on decidable relation with [nat] + as codomain +*) + +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') + /\ forall x', P x' /\ (forall x'', P x'' -> R x' x'') -> 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 nat 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 (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)). + +Lemma classical_denumerable_description_imp_fun_choice : + forall A:Type, + ParamDefiniteDescription A nat -> + forall R, (forall x y, decidable (R x y)) -> FunctionalChoice_on A nat R. +Proof. +intros A Descr. +red in |- *; intros R Rdec H. +set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y'). +destruct (Descr R') as [f Hf]. + intro x. + apply (dec_inh_nat_subset_has_unique_least_element (R x)). + apply Rdec. + apply (H x). +exists f. +intros x. +destruct (Hf x) as [Hfx _]. +assumption. +Qed. diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 044cee17..523c9245 100755..100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -6,9 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Classical.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Classical Logic *) Require Export Classical_Prop. -Require Export Classical_Pred_Type.
\ No newline at end of file +Require Export Classical_Pred_Type. + diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index 51f758e2..5a633f84 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalChoice.v,v 1.4.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: ClassicalChoice.v 6401 2004-12-05 16:44:57Z herbelin $ i*) (** This file provides classical logic and functional choice *) @@ -23,10 +23,11 @@ Require Import ChoiceFacts. Theorem choice : forall (A B:Type) (R:A -> B -> Prop), - (forall x:A, exists y : B, 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. apply description_rel_choice_imp_funct_choice. -exact description. -exact relational_choice. -Qed.
\ No newline at end of file +exact (description A B). +exact (relational_choice A B). +Qed. diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index 6602cd73..ce3e279c 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalDescription.v,v 1.7.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: ClassicalDescription.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** This file provides classical logic and definite description *) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index cb14fb0e..91056250 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -6,24 +6,56 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: ClassicalFacts.v 8136 2006-03-05 21:57:47Z herbelin $ i*) -(** Some facts and definitions about classical logic *) +(** ** Some facts and definitions about classical logic -(** [prop_degeneracy] (also referred as propositional completeness) *) -(* asserts (up to consistency) that there are only two distinct formulas *) +Table of contents: + +A. Propositional degeneracy = excluded-middle + propositional extensionality + +B. Classical logic and proof-irrelevance + +B. 1. CC |- prop. ext. + A inhabited -> (A = A->A) -> A has fixpoint + +B. 2. CC |- prop. ext. + dep elim on bool -> proof-irrelevance + +B. 3. CIC |- prop. ext. -> proof-irrelevance + +B. 4. CC |- excluded-middle + dep elim on bool -> proof-irrelevance + +B. 5. CIC |- excluded-middle -> proof-irrelevance + +C. Weak classical axioms + +C. 1. Weak excluded middle + +C. 2. Gödel-Dummet axiom and right distributivity of implication over + disjunction + +C. 3. Independence of general premises and drinker's paradox + +*) + +(************************************************************************) +(** *** A. Prop degeneracy = excluded-middle + prop extensionality *) +(** + i.e. [(forall A, A=True \/ A=False) + <-> + (forall A, A\/~A) /\ (forall A B, (A<->B) -> A=B)] +*) + +(** [prop_degeneracy] (also referred to as propositional completeness) + asserts (up to consistency) that there are only two distinct formulas *) Definition prop_degeneracy := forall A:Prop, A = True \/ A = False. -(** [prop_extensionality] asserts equivalent formulas are equal *) +(** [prop_extensionality] asserts that equivalent formulas are equal *) Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B. -(** [excluded_middle] asserts we can reason by case on the truth *) -(* or falsity of any formula *) +(** [excluded_middle] asserts that we can reason by case on the truth + or falsity of any formula *) Definition excluded_middle := forall A:Prop, A \/ ~ A. -(** [proof_irrelevance] asserts equality of all proofs of a given formula *) -Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. - (** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *) Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality. @@ -58,6 +90,12 @@ destruct (EM A). right; apply (Ext A False); split; [ exact H | apply False_ind ]. Qed. +(************************************************************************) +(** *** B. Classical logic and proof-irrelevance *) + +(************************************************************************) +(** **** B. 1. CC |- prop ext + A inhabited -> (A = A->A) -> A has fixpoint *) + (** We successively show that: [prop_extensionality] @@ -104,13 +142,20 @@ rewrite (g1_o_g2 (fun x:A => f (g1 x x))). reflexivity. Qed. -(** Assume we have booleans with the property that there is at most 2 +(************************************************************************) +(** **** B. 2. CC |- prop_ext /\ dep elim on bool -> proof-irrelevance *) + +(** [proof_irrelevance] asserts equality of all proofs of a given formula *) +Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. + +(** Assume that we have booleans with the property that there is at most 2 booleans (which is equivalent to dependent case analysis). Consider the fixpoint of the negation function: it is either true or false by dependent case analysis, but also the opposite by fixpoint. Hence proof-irrelevance. - We then map bool proof-irrelevance to all propositions. + We then map equality of boolean proofs to proof irrelevance in all + propositions. *) Section Proof_irrelevance_gen. @@ -161,7 +206,7 @@ End Proof_irrelevance_gen. most 2 elements. *) -Section Proof_irrelevance_CC. +Section Proof_irrelevance_Prop_Ext_CC. Definition BoolP := forall C:Prop, C -> C -> C. Definition TrueP : BoolP := fun C c1 c2 => c1. @@ -181,7 +226,10 @@ Proof ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl BoolP_elim_redr. -End Proof_irrelevance_CC. +End Proof_irrelevance_Prop_Ext_CC. + +(************************************************************************) +(** **** B. 3. CIC |- prop. ext. -> proof-irrelevance *) (** In the Calculus of Inductive Constructions, inductively defined booleans enjoy dependent case analysis, hence directly proof-irrelevance from @@ -211,9 +259,286 @@ End Proof_irrelevance_CIC. (i.e. propositional extensionality + excluded middle) without dependent case analysis ? - Conjecture: it seems possible to build a model of CC interpreting - all non-empty types by the set of all lambda-terms. Such a model would - satisfy propositional degeneracy without satisfying proof-irrelevance - (nor dependent case analysis). This would imply that the previous - results cannot be refined. + Berardi [[Berardi90]] built a model of CC interpreting inhabited + types by the set of all untyped lambda-terms. This model satisfies + propositional degeneracy without satisfying proof-irrelevance (nor + dependent case analysis). This implies that the previous results + cannot be refined. + + [[Berardi90]] Stefano Berardi, "Type dependence and constructive + mathematics", Ph. D. thesis, Dipartimento Matematica, Università di + Torino, 1990. *) + +(************************************************************************) +(** **** B. 4. CC |- excluded-middle + dep elim on bool -> proof-irrelevance *) + +(** This is a proof in the pure Calculus of Construction that + classical logic in [Prop] + dependent elimination of disjunction entails + proof-irrelevance. + + Reference: + + [[Coquand90]] T. Coquand, "Metamathematical Investigations of a + Calculus of Constructions", Proceedings of Logic in Computer Science + (LICS'90), 1990. + + Proof skeleton: classical logic + dependent elimination of + disjunction + discrimination of proofs implies the existence of a + retract from [Prop] into [bool], hence inconsistency by encoding any + paradox of system U- (e.g. Hurkens' paradox). +*) + +Require Import Hurkens. + +Section Proof_irrelevance_EM_CC. + +Variable or : Prop -> Prop -> Prop. +Variable or_introl : forall A B:Prop, A -> or A B. +Variable or_intror : forall A B:Prop, B -> or A B. +Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C. +Hypothesis + or_elim_redl : + forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A), + f a = or_elim A B C f g (or_introl A B a). +Hypothesis + or_elim_redr : + forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B), + g b = or_elim A B C f g (or_intror A B b). +Hypothesis + or_dep_elim : + forall (A B:Prop) (P:or A B -> Prop), + (forall a:A, P (or_introl A B a)) -> + (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. + +Hypothesis em : forall A:Prop, or A (~ A). +Variable B : Prop. +Variables b1 b2 : B. + +(** [p2b] and [b2p] form a retract if [~b1=b2] *) + +Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A). +Definition b2p b := b1 = b. + +Lemma p2p1 : forall A:Prop, A -> b2p (p2b A). +Proof. + unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A); + unfold b2p in |- *; intros. + apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)). + destruct (b H). +Qed. +Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A. +Proof. + intro not_eq_b1_b2. + unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A); + unfold b2p in |- *; intros. + assumption. + destruct not_eq_b1_b2. + rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H. + assumption. +Qed. + +(** Using excluded-middle a second time, we get proof-irrelevance *) + +Theorem proof_irrelevance_cc : b1 = b2. +Proof. + refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H. + trivial. + apply (paradox B p2b b2p (p2p2 H) p2p1). +Qed. + +End Proof_irrelevance_EM_CC. + +(** Remark: Hurkens' paradox still holds with a retract from the + _negative_ fragment of [Prop] into [bool], hence weak classical + logic, i.e. [forall A, ~A\/~~A], is enough for deriving + proof-irrelevance. +*) + +(************************************************************************) +(** **** B. 5. CIC |- excluded-middle -> proof-irrelevance *) + +(** + Since, dependent elimination is derivable in the Calculus of + Inductive Constructions (CCI), we get proof-irrelevance from classical + logic in the CCI. +*) + +Section Proof_irrelevance_CCI. + +Hypothesis em : forall A:Prop, A \/ ~ A. + +Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) + (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a). +Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) + (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b). +Scheme or_indd := Induction for or Sort Prop. + +Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2. +Proof + proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl + or_elim_redr or_indd em. + +End Proof_irrelevance_CCI. + +(** Remark: in the Set-impredicative CCI, Hurkens' paradox still holds with + [bool] in [Set] and since [~true=false] for [true] and [false] + in [bool] from [Set], we get the inconsistency of + [em : forall A:Prop, {A}+{~A}] in the Set-impredicative CCI. +*) + +(** *** C. Weak classical axioms *) + +(** We show the following increasing in the strength of axioms: + - weak excluded-middle + - right distributivity of implication over disjunction and Gödel-Dummet axiom + - independence of general premises and drinker's paradox + - excluded-middle +*) + +(** **** C. 1. Weak excluded-middle *) + +(** The weak classical logic based on [~~A \/ ~A] is referred to with + name KC in {[ChagrovZakharyaschev97]] + + [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael + Zakharyaschev, "Modal Logic", Clarendon Press, 1997. +*) + +Definition weak_excluded_middle := + forall A:Prop, ~~A \/ ~A. + +(** The interest in the equivalent variant + [weak_generalized_excluded_middle] is that it holds even in logic + without a primitive [False] connective (like Gödel-Dummett axiom) *) + +Definition weak_generalized_excluded_middle := + forall A B:Prop, ((A -> B) -> B) \/ (A -> B). + +(** **** C. 2. Gödel-Dummett axiom *) + +(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]]. + + [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus + with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol + 24 No. 2(1959), pp 97-103. + + [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül", + Ergeb. Math. Koll. 4 (1933), pp. 34-38. + *) + +Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A). + +Lemma excluded_middle_Godel_Dummett : excluded_middle -> GodelDummett. +Proof. +intros EM A B. destruct (EM B) as [HB|HnotB]. + left; intros _; exact HB. + right; intros HB; destruct (HnotB HB). +Qed. + +(** [(A->B) \/ (B->A)] is equivalent to [(C -> A\/B) -> (C->A) \/ (C->B)] + (proof from [[Dummett59]]) *) + +Definition RightDistributivityImplicationOverDisjunction := + forall A B C:Prop, (C -> A\/B) -> (C->A) \/ (C->B). + +Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction : + GodelDummett <-> RightDistributivityImplicationOverDisjunction. +Proof. +split. + intros GD A B C HCAB. + destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; + destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption. + intros Distr A B. + destruct (Distr A B (A\/B)) as [HABA|HABB]. + intro HAB; exact HAB. + right; intro HB; apply HABA; right; assumption. + left; intro HA; apply HABB; left; assumption. +Qed. + +(** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *) + +Lemma Godel_Dummett_weak_excluded_middle : + GodelDummett -> weak_excluded_middle. +Proof. +intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA]. + left; intro HnotA; apply (HnotA (HnotAA HnotA)). + right; intro HA; apply (HAnotA HA HA). +Qed. + +(** **** C. 3. Independence of general premises and drinker's paradox *) + +(** Independence of general premises is the unconstrained, non + constructive, version of the Independence of Premises as + considered in [[Troelstra73]]. + + It is a generalization to predicate logic of the right + distributivity of implication over disjunction (hence of + Gödel-Dummett axiom) whose own constructive form (obtained by a + restricting the third formula to be negative) is called + Kreisel-Putnam principle [[KreiselPutnam57]]. + + [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine + Unableitsbarkeitsbeweismethode für den intuitionistischen + Aussagenkalkül". Archiv für Mathematische Logik und + Graundlagenforschung, 3:74- 78, 1957. + + [[Troelstra73]], Anne Troelstra, editor. Metamathematical + Investigation of Intuitionistic Arithmetic and Analysis, volume + 344 of Lecture Notes in Mathematics, Springer-Verlag, 1973. +*) + +Notation Local "'inhabited' A" := A (at level 10, only parsing). + +Definition IndependenceOfGeneralPremises := + forall (A:Type) (P:A -> Prop) (Q:Prop), + inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x. + +Lemma + independence_general_premises_right_distr_implication_over_disjunction : + IndependenceOfGeneralPremises -> RightDistributivityImplicationOverDisjunction. +Proof. +intros IP A B C HCAB. +destruct (IP bool (fun b => if b then A else B) C true) as ([|],H). + intro HC; destruct (HCAB HC); [exists true|exists false]; assumption. + left; assumption. + right; assumption. +Qed. + +Lemma independence_general_premises_Godel_Dummett : + IndependenceOfGeneralPremises -> GodelDummett. +Proof. +destruct Godel_Dummett_iff_right_distr_implication_over_disjunction. +auto using independence_general_premises_right_distr_implication_over_disjunction. +Qed. + +(** Independence of general premises is equivalent to the drinker's paradox *) + +Definition DrinkerParadox := + forall (A:Type) (P:A -> Prop), + inhabited A -> exists x, (exists x, P x) -> P x. + +Lemma independence_general_premises_drinker : + IndependenceOfGeneralPremises <-> DrinkerParadox. +Proof. +split. + intros IP A P InhA; apply (IP A P (exists x, P x) InhA); intro Hx; exact Hx. + intros Drinker A P Q InhA H; destruct (Drinker A P InhA) as (x,Hx). + exists x; intro HQ; apply (Hx (H HQ)). +Qed. + +(** Independence of general premises is weaker than (generalized) + excluded middle *) + +Definition generalized_excluded_middle := + forall A B:Prop, A \/ (A -> B). + +Lemma excluded_middle_independence_general_premises : + generalized_excluded_middle -> DrinkerParadox. +Proof. +intros GEM A P x0. +destruct (GEM (exists x, P x) (P x0)) as [(x,Hx)|Hnot]. + exists x; intro; exact Hx. + exists x0; exact Hnot. +Qed. + diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v index c8f87fe8..2a5f03ec 100755..100644 --- a/theories/Logic/Classical_Pred_Set.v +++ b/theories/Logic/Classical_Pred_Set.v @@ -6,11 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Set.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Classical_Pred_Set.v 8642 2006-03-17 10:09:02Z notin $ i*) + +(** This file is obsolete, use Classical_Pred_Type.v via Classical.v +instead *) (** Classical Predicate Logic on Set*) -Require Import Classical_Prop. +Require Import Classical_Pred_Type. Section Generic. Variable U : Set. @@ -19,52 +22,26 @@ Variable U : Set. Lemma not_all_ex_not : forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. -Proof. -unfold not in |- *; intros P notall. -apply NNPP; unfold not in |- *. -intro abs. -cut (forall n:U, P n); auto. -intro n; apply NNPP. -unfold not in |- *; intros. -apply abs; exists n; trivial. -Qed. +Proof (Classical_Pred_Type.not_all_ex_not U). Lemma not_all_not_ex : forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. -Proof. -intros P H. -elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n. -apply NNPP; trivial. -Qed. +Proof (Classical_Pred_Type.not_all_not_ex U). Lemma not_ex_all_not : forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. -Proof. -unfold not in |- *; intros P notex n abs. -apply notex. -exists n; trivial. -Qed. +Proof (Classical_Pred_Type.not_ex_all_not U). Lemma not_ex_not_all : forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. -Proof. -intros P H n. -apply NNPP. -red in |- *; intro K; apply H; exists n; trivial. -Qed. +Proof (Classical_Pred_Type.not_ex_not_all U). Lemma ex_not_not_all : forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). -Proof. -unfold not in |- *; intros P exnot allP. -elim exnot; auto. -Qed. +Proof (Classical_Pred_Type.ex_not_not_all U). Lemma all_not_not_ex : forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). -Proof. -unfold not in |- *; intros P allnot exP; elim exP; intros n p. -apply allnot with n; auto. -Qed. +Proof (Classical_Pred_Type.all_not_not_ex U). -End Generic.
\ No newline at end of file +End Generic. diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 804ff32d..56ebf967 100755..100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Pred_Type.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Classical_Pred_Type.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Classical Predicate Logic on Type *) @@ -17,29 +17,30 @@ Variable U : Type. (** de Morgan laws for quantifiers *) -Lemma not_all_ex_not : - forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. +Lemma not_all_not_ex : + forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. Proof. -unfold not in |- *; intros P notall. -apply NNPP; unfold not in |- *. +intros P notall. +apply NNPP. intro abs. -cut (forall n:U, P n); auto. -intro n; apply NNPP. -unfold not in |- *; intros. -apply abs; exists n; trivial. +apply notall. +intros n H. +apply abs; exists n; exact H. Qed. -Lemma not_all_not_ex : - forall P:U -> Prop, ~ (forall n:U, ~ P n) -> exists n : U, P n. +Lemma not_all_ex_not : + forall P:U -> Prop, ~ (forall n:U, P n) -> exists n : U, ~ P n. Proof. -intros P H. -elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n. -apply NNPP; trivial. +intros P notall. +apply not_all_not_ex with (P:=fun x => ~ P x). +intro all; apply notall. +intro n; apply NNPP. +apply all. Qed. Lemma not_ex_all_not : forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n. -Proof. +Proof. (* Intuitionistic *) unfold not in |- *; intros P notex n abs. apply notex. exists n; trivial. @@ -55,16 +56,16 @@ Qed. Lemma ex_not_not_all : forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n). -Proof. +Proof. (* Intuitionistic *) unfold not in |- *; intros P exnot allP. elim exnot; auto. Qed. Lemma all_not_not_ex : forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n). -Proof. +Proof. (* Intuitionistic *) unfold not in |- *; intros P allnot exP; elim exP; intros n p. apply allnot with n; auto. Qed. -End Generic.
\ No newline at end of file +End Generic. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index ccc26df1..f8b0e65b 100755..100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -6,11 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Prop.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Classical_Prop.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Classical Propositional Logic *) -Require Import ProofIrrelevance. +Require Import ClassicalFacts. Hint Unfold not: core. @@ -29,8 +29,8 @@ intro; apply H; intro; absurd P; trivial. Qed. Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q. -Proof. -intros; elim (classic Q); auto. +Proof. (* Intuitionistic *) +tauto. Qed. Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q. @@ -46,9 +46,8 @@ apply not_imply_elim2 with P; trivial. Qed. Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q. -Proof. -simple induction 1; auto. -intros H1 H2; elim (H1 H2). +Proof. (* Intuitionistic *) +tauto. Qed. Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q. @@ -62,24 +61,50 @@ simple induction 1; red in |- *; simple induction 2; auto. Qed. Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q. -Proof. -intros; elim (classic P); auto. +Proof. (* Intuitionistic *) +tauto. Qed. Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q). -Proof. -simple induction 1; red in |- *; simple induction 3; trivial. +Proof. (* Intuitionistic *) +tauto. Qed. Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q. -Proof. -simple induction 2; trivial. +Proof. (* Intuitionistic *) +tauto. Qed. Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R. -Proof. -simple induction 2; auto. +Proof. (* Intuitionistic *) +tauto. Qed. Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. -Proof proof_irrelevance_cci classic.
\ No newline at end of file +Proof proof_irrelevance_cci classic. + +(* classical_left transforms |- A \/ B into ~B |- A *) +(* classical_right transforms |- A \/ B into ~A |- B *) + +Ltac classical_right := match goal with + | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) +end. + +Ltac classical_left := match goal with +| _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) +end. + +Require Export EqdepFacts. + +Module Eq_rect_eq. + +Lemma eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. +Proof. +intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity. +Qed. + +End Eq_rect_eq. + +Module EqdepTheory := EqdepTheory(Eq_rect_eq). +Export EqdepTheory. diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v index 753b8590..9b1f4e19 100755..100644 --- a/theories/Logic/Classical_Type.v +++ b/theories/Logic/Classical_Type.v @@ -6,9 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Classical_Type.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Classical_Type.v 8642 2006-03-17 10:09:02Z notin $ i*) + +(** This file is obsolete, use Classical.v instead *) (** Classical Logic for Type *) Require Export Classical_Prop. -Require Export Classical_Pred_Type.
\ No newline at end of file +Require Export Classical_Pred_Type. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 08babda9..8317f6bb 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Decidable.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Decidable.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Properties of decidable propositions *) diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 2b982963..3e94deda 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Diaconescu.v,v 1.5.2.3 2004/08/01 09:36:44 herbelin Exp $ i*) +(*i $Id: Diaconescu.v 6401 2004-12-05 16:44:57Z herbelin $ i*) (** R. Diaconescu [Diaconescu] showed that the Axiom of Choice in Set Theory entails Excluded-Middle; S. Lacas and B. Werner [LacasWerner] @@ -59,18 +59,18 @@ Qed. Require Import ChoiceFacts. -Variable rel_choice : RelationalChoice. +Variable rel_choice : forall A B:Type, RelationalChoice A B. Lemma guarded_rel_choice : forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop), (forall x:A, P x -> exists y : B, R x y) -> - exists R' : A -> B -> Prop, + exists R' : A -> B -> Prop, (forall x:A, P x -> exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')). Proof. - exact - (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel). + apply + (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel). Qed. (** The form of choice we need: there is a functional relation which chooses diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index 24905039..2fe9d1a6 100755..100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -6,183 +6,29 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep.v,v 1.10.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Eqdep.v 8642 2006-03-17 10:09:02Z notin $ i*) -(** This file defines dependent equality and shows its equivalence with - equality on dependent pairs (inhabiting sigma-types). It axiomatizes - the invariance by substitution of reflexive equality proofs and - shows the equivalence between the 4 following statements +(** This file axiomatizes the invariance by substitution of reflexive + equality proofs [[Streicher93]] and exports its consequences, such + as the injectivity of the projection of the dependent pair. - - Invariance by Substitution of Reflexive Equality Proofs. - - Injectivity of Dependent Equality - - Uniqueness of Identity Proofs - - Uniqueness of Reflexive Identity Proofs - - Streicher's Axiom K - - These statements are independent of the calculus of constructions [2]. - - References: - - [1] T. Streicher, Semantical Investigations into Intensional Type Theory, - Habilitationsschrift, LMU München, 1993. - [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory, - Proceedings of the meeting Twenty-five years of constructive - type theory, Venice, Oxford University Press, 1998 + [[Streicher93]] T. Streicher, Semantical Investigations into + Intensional Type Theory, Habilitationsschrift, LMU München, 1993. *) -Section Dependent_Equality. - -Variable U : Type. -Variable P : U -> Type. - -(** Dependent equality *) - -Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := - eq_dep_intro : eq_dep p x p x. -Hint Constructors eq_dep: core v62. - -Lemma eq_dep_sym : - forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x. -Proof. -destruct 1; auto. -Qed. -Hint Immediate eq_dep_sym: core v62. +Require Export EqdepFacts. -Lemma eq_dep_trans : - forall (p q r:U) (x:P p) (y:P q) (z:P r), - eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z. -Proof. -destruct 1; auto. -Qed. - -Scheme eq_indd := Induction for eq Sort Prop. - -Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop := - eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y. - -Lemma eq_dep1_dep : - forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y. -Proof. -destruct 1 as (eq_qp, H). -destruct eq_qp using eq_indd. -rewrite H. -apply eq_dep_intro. -Qed. - -Lemma eq_dep_dep1 : - forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y. -Proof. -destruct 1. -apply eq_dep1_intro with (refl_equal p). -simpl in |- *; trivial. -Qed. - -(** Invariance by Substitution of Reflexive Equality Proofs *) +Module Eq_rect_eq. Axiom eq_rect_eq : - forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - -(** Injectivity of Dependent Equality is a consequence of *) -(** Invariance by Substitution of Reflexive Equality Proof *) - -Lemma eq_dep1_eq : forall (p:U) (x y:P p), eq_dep1 p x p y -> x = y. -Proof. -simple destruct 1; intro. -rewrite <- eq_rect_eq; auto. -Qed. - -Lemma eq_dep_eq : forall (p:U) (x y:P p), eq_dep p x p y -> x = y. -Proof. -intros; apply eq_dep1_eq; apply eq_dep_dep1; trivial. -Qed. - -End Dependent_Equality. - -(** Uniqueness of Identity Proofs (UIP) is a consequence of *) -(** Injectivity of Dependent Equality *) - -Lemma UIP : forall (U:Type) (x y:U) (p1 p2:x = y), p1 = p2. -Proof. -intros; apply eq_dep_eq with (P := fun y => x = y). -elim p2 using eq_indd. -elim p1 using eq_indd. -apply eq_dep_intro. -Qed. - -(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) - -Lemma UIP_refl : forall (U:Type) (x:U) (p:x = x), p = refl_equal x. -Proof. -intros; apply UIP. -Qed. - -(** Streicher axiom K is a direct consequence of Uniqueness of - Reflexive Identity Proofs *) - -Lemma Streicher_K : - forall (U:Type) (x:U) (P:x = x -> Prop), - P (refl_equal x) -> forall p:x = x, P p. -Proof. -intros; rewrite UIP_refl; assumption. -Qed. - -(** We finally recover eq_rec_eq (alternatively eq_rect_eq) from K *) - -Lemma eq_rec_eq : - forall (U:Type) (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h. -Proof. -intros. -apply Streicher_K with (p := h). -reflexivity. -Qed. - -(** Dependent equality is equivalent to equality on dependent pairs *) - -Lemma equiv_eqex_eqdep : - forall (U:Set) (P:U -> Set) (p q:U) (x:P p) (y:P q), - existS P p x = existS P q y <-> eq_dep U P p x q y. -Proof. -split. -(* -> *) -intro H. -change p with (projS1 (existS P p x)) in |- *. -change x at 2 with (projS2 (existS P p x)) in |- *. -rewrite H. -apply eq_dep_intro. -(* <- *) -destruct 1; reflexivity. -Qed. - -(** UIP implies the injectivity of equality on dependent pairs *) - -Lemma inj_pair2 : - forall (U:Set) (P:U -> Set) (p:U) (x y:P p), - existS P p x = existS P p y -> x = y. -Proof. -intros. -apply (eq_dep_eq U P). -generalize (equiv_eqex_eqdep U P p p x y). -simple induction 1. -intros. -auto. -Qed. + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. -(** UIP implies the injectivity of equality on dependent pairs *) +End Eq_rect_eq. -Lemma inj_pairT2 : - forall (U:Type) (P:U -> Type) (p:U) (x y:P p), - existT P p x = existT P p y -> x = y. -Proof. -intros. -apply (eq_dep_eq U P). -change p at 1 with (projT1 (existT P p x)) in |- *. -change x at 2 with (projT2 (existT P p x)) in |- *. -rewrite H. -apply eq_dep_intro. -Qed. +Module EqdepTheory := EqdepTheory(Eq_rect_eq). +Export EqdepTheory. -(** The main results to be exported *) +(** Exported hints *) -Hint Resolve eq_dep_intro eq_dep_eq: core v62. -Hint Immediate eq_dep_sym: core v62. +Hint Resolve eq_dep_eq: core v62. Hint Resolve inj_pair2 inj_pairT2: core. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v new file mode 100644 index 00000000..7963555a --- /dev/null +++ b/theories/Logic/EqdepFacts.v @@ -0,0 +1,351 @@ +(************************************************************************) +(* 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: EqdepFacts.v 8674 2006-03-30 06:56:50Z herbelin $ i*) + +(** This file defines dependent equality and shows its equivalence with + equality on dependent pairs (inhabiting sigma-types). It derives + the consequence of axiomatizing the invariance by substitution of + reflexive equality proofs and shows the equivalence between the 4 + following statements + + - Invariance by Substitution of Reflexive Equality Proofs. + - Injectivity of Dependent Equality + - Uniqueness of Identity Proofs + - Uniqueness of Reflexive Identity Proofs + - Streicher's Axiom K + + These statements are independent of the calculus of constructions [2]. + + References: + + [1] T. Streicher, Semantical Investigations into Intensional Type Theory, + Habilitationsschrift, LMU München, 1993. + [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory, + Proceedings of the meeting Twenty-five years of constructive + type theory, Venice, Oxford University Press, 1998 + +Table of contents: + +A. Definition of dependent equality and equivalence with equality + +B. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K + +C. Definition of the functor that builds properties of dependent + equalities assuming axiom eq_rect_eq + +*) + +(************************************************************************) +(** *** A. Definition of dependent equality and equivalence with equality of dependent pairs *) + +Section Dependent_Equality. + +Variable U : Type. +Variable P : U -> Type. + +(** Dependent equality *) + +Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := + eq_dep_intro : eq_dep p x p x. +Hint Constructors eq_dep: core v62. + +Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. +Proof eq_dep_intro. + +Lemma eq_dep_sym : + forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x. +Proof. + destruct 1; auto. +Qed. +Hint Immediate eq_dep_sym: core v62. + +Lemma eq_dep_trans : + forall (p q r:U) (x:P p) (y:P q) (z:P r), + eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z. +Proof. + destruct 1; auto. +Qed. + +Scheme eq_indd := Induction for eq Sort Prop. + +(** Equivalent definition of dependent equality expressed as a non + dependent inductive type *) + +Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop := + eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y. + +Lemma eq_dep1_dep : + forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y. +Proof. + destruct 1 as (eq_qp, H). + destruct eq_qp using eq_indd. + rewrite H. + apply eq_dep_intro. +Qed. + +Lemma eq_dep_dep1 : + forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y. +Proof. + destruct 1. + apply eq_dep1_intro with (refl_equal p). + simpl in |- *; trivial. +Qed. + +End Dependent_Equality. + +Implicit Arguments eq_dep [U P]. +Implicit Arguments eq_dep1 [U P]. + +(** Dependent equality is equivalent to equality on dependent pairs *) + +Lemma eq_sigS_eq_dep : + forall (U:Set) (P:U -> Set) (p q:U) (x:P p) (y:P q), + existS P p x = existS P q y -> eq_dep p x q y. +Proof. + intros. + dependent rewrite H. + apply eq_dep_intro. +Qed. + +Lemma equiv_eqex_eqdep : + forall (U:Set) (P:U -> Set) (p q:U) (x:P p) (y:P q), + existS P p x = existS P q y <-> eq_dep p x q y. +Proof. +split. + (* -> *) + apply eq_sigS_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. +Proof. + destruct 1; reflexivity. +Qed. + +(** Exported hints *) + +Hint Resolve eq_dep_intro: core v62. +Hint Immediate eq_dep_sym: core v62. + +(************************************************************************) +(** *** B. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) + +Section Equivalences. + +Variable U:Type. + +(** Invariance by Substitution of Reflexive Equality Proofs *) + +Definition Eq_rect_eq := + forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + +(** Injectivity of Dependent Equality *) + +Definition Eq_dep_eq := + forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. + +(** Uniqueness of Identity Proofs (UIP) *) + +Definition UIP_ := + forall (x y:U) (p1 p2:x = y), p1 = p2. + +(** Uniqueness of Reflexive Identity Proofs *) + +Definition UIP_refl_ := + forall (x:U) (p:x = x), p = refl_equal x. + +(** Streicher's axiom K *) + +Definition Streicher_K_ := + forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. + +(** Injectivity of Dependent Equality is a consequence of *) +(** Invariance by Substitution of Reflexive Equality Proof *) + +Lemma eq_rect_eq__eq_dep1_eq : + Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y. +Proof. + intro eq_rect_eq. + simple destruct 1; intro. + rewrite <- eq_rect_eq; auto. +Qed. + +Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq. +Proof. + intros eq_rect_eq; red; intros. + apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial. +Qed. + +(** Uniqueness of Identity Proofs (UIP) is a consequence of *) +(** Injectivity of Dependent Equality *) + +Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_. +Proof. + intro eq_dep_eq; red. + intros; apply eq_dep_eq with (P := fun y => x = y). + elim p2 using eq_indd. + elim p1 using eq_indd. + apply eq_dep_intro. +Qed. + +(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) + +Lemma UIP__UIP_refl : UIP_ -> UIP_refl_. +Proof. + intro UIP; red; intros; apply UIP. +Qed. + +(** Streicher's axiom K is a direct consequence of Uniqueness of + Reflexive Identity Proofs *) + +Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_. +Proof. + intro UIP_refl; red; intros; rewrite UIP_refl; assumption. +Qed. + +(** We finally recover from K the Invariance by Substitution of + Reflexive Equality Proofs *) + +Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq. +Proof. + intro Streicher_K; red; intros. + apply Streicher_K with (p := h). + reflexivity. +Qed. + +(** Remark: It is reasonable to think that [eq_rect_eq] is strictly + stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]): + + [Definition Eq_rec_eq := + forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.] + + Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what + does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP] + requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not + in [Set]. +*) + +End Equivalences. + +Section Corollaries. + +Variable U:Type. +Variable V:Set. + +(** UIP implies the injectivity of equality on dependent pairs in Type *) + +Definition Inj_dep_pairT := + forall (P:U -> Type) (p:U) (x y:P p), + existT P p x = existT P p y -> x = y. + +Lemma eq_dep_eq__inj_pairT2 : Eq_dep_eq U -> Inj_dep_pairT. + Proof. + intro eq_dep_eq; red; intros. + apply eq_dep_eq. + apply eq_sigT_eq_dep. + assumption. + Qed. + +(** UIP implies the injectivity of equality on dependent pairs in Set *) + +Definition Inj_dep_pairS := + forall (P:V -> Set) (p:V) (x y:P p), existS P p x = existS P p y -> x = y. + +Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq V -> Inj_dep_pairS. +Proof. + intro eq_dep_eq; red; intros. + apply eq_dep_eq. + apply eq_sigS_eq_dep. + assumption. +Qed. + +End Corollaries. + +(************************************************************************) +(** *** C. Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) + +Module Type EqdepElimination. + + Axiom eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), + x = eq_rect p Q x p h. + +End EqdepElimination. + +Module EqdepTheory (M:EqdepElimination). + +Section Axioms. + +Variable U:Type. + +(** Invariance by Substitution of Reflexive Equality Proofs *) + +Lemma eq_rect_eq : + forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. +Proof M.eq_rect_eq U. + +Lemma eq_rec_eq : + forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rect p Q x p h. +Proof (fun p Q => M.eq_rect_eq U p Q). + +(** Injectivity of Dependent Equality *) + +Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. +Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). + +(** Uniqueness of Identity Proofs (UIP) is a consequence of *) +(** Injectivity of Dependent Equality *) + +Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. +Proof (eq_dep_eq__UIP U eq_dep_eq). + +(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) + +Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x. +Proof (UIP__UIP_refl U UIP). + +(** Streicher's axiom K is a direct consequence of Uniqueness of + Reflexive Identity Proofs *) + +Lemma Streicher_K : + forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. +Proof (UIP_refl__Streicher_K U UIP_refl). + +End Axioms. + +(** UIP implies the injectivity of equality on dependent pairs in Type *) + +Lemma inj_pairT2 : + forall (U:Type) (P:U -> Type) (p:U) (x y:P p), + existT P p x = existT P p y -> x = y. +Proof (fun U => eq_dep_eq__inj_pairT2 U (eq_dep_eq U)). + +(** UIP implies the injectivity of equality on dependent pairs in Set *) + +Lemma inj_pair2 : + forall (U:Set) (P:U -> Set) (p:U) (x y:P p), + existS P p x = existS P p y -> x = y. +Proof (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)). + +End EqdepTheory. + +Implicit Arguments eq_dep []. +Implicit Arguments eq_dep1 []. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 7caf403c..7d71a1a6 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -6,56 +6,43 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Eqdep_dec.v,v 1.14.2.1 2004/07/16 19:31:06 herbelin Exp $ i*) +(*i $Id: Eqdep_dec.v 8136 2006-03-05 21:57:47Z herbelin $ 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. - A corollary of this theorem is the equality of the right projections - of two equal dependent pairs. +(** 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. + A corollary of this theorem is the equality of the right projections + of two equal dependent pairs. - Author: Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego - adapted to Coq by B. Barras + Author: Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego + adapted to Coq by B. Barras - Credit: Proofs up to [K_dec] follows an outline by Michael Hedberg -*) + Credit: Proofs up to [K_dec] follow an outline by Michael Hedberg +Table of contents: -(** We need some dependent elimination schemes *) +A. Streicher's K and injectivity of dependent pair hold on decidable types -Set Implicit Arguments. +B.1. Definition of the functor that builds properties of dependent equalities + from a proof of decidability of equality for a set in Type - (** Bijection between [eq] and [eqT] *) - Definition eq2eqT (A:Set) (x y:A) (eqxy:x = y) : - x = y := - match eqxy in (_ = y) return x = y with - | refl_equal => refl_equal x - end. - - Definition eqT2eq (A:Set) (x y:A) (eqTxy:x = y) : - x = y := - match eqTxy in (_ = y) return x = y with - | refl_equal => refl_equal x - end. +B.2. Definition of the functor that builds properties of dependent equalities + from a proof of decidability of equality for a set in Set - Lemma eq_eqT_bij : forall (A:Set) (x y:A) (p:x = y), p = eqT2eq (eq2eqT p). -intros. -case p; reflexivity. -Qed. +*) - Lemma eqT_eq_bij : forall (A:Set) (x y:A) (p:x = y), p = eq2eqT (eqT2eq p). -intros. -case p; reflexivity. -Qed. +(************************************************************************) +(** *** A. Streicher's K and injectivity of dependent pair hold on decidable types *) +Set Implicit Arguments. -Section DecidableEqDep. +Section EqdepDec. Variable A : Type. Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := eq_ind _ (fun a => a = y') eq2 _ eq1. - Remark trans_sym_eqT : forall (x y:A) (u:x = y), comp u u = refl_equal y. + Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y. intros. case u; trivial. Qed. @@ -89,7 +76,7 @@ Qed. Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u. intros. case u; unfold nu_inv in |- *. -apply trans_sym_eqT. +apply trans_sym_eq. Qed. @@ -108,7 +95,6 @@ elim eq_proofs_unicity with x (refl_equal x) p. trivial. Qed. - (** The corollary *) Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x := @@ -138,21 +124,173 @@ case H. reflexivity. Qed. -End DecidableEqDep. +End EqdepDec. + +Require Import EqdepFacts. + + (** We deduce axiom [K] for (decidable) types *) + Theorem K_dec_type : + forall A:Type, + (forall x y:A, {x = y} + {x <> y}) -> + forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. +intros A eq_dec x P H p. +elim p using K_dec; intros. +case (eq_dec x0 y); [left|right]; assumption. +trivial. +Qed. - (** We deduce the [K] axiom for (decidable) Set *) Theorem K_dec_set : forall A:Set, (forall x y:A, {x = y} + {x <> y}) -> forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. -intros. -rewrite eq_eqT_bij. -elim (eq2eqT p) using K_dec. -intros. -case (H x0 y); intros. -elim e; left; reflexivity. + Proof fun A => K_dec_type (A:=A). + + (** We deduce the [eq_rect_eq] axiom for (decidable) types *) + Theorem eq_rect_eq_dec : + forall A:Type, + (forall x y:A, {x = y} + {x <> y}) -> + forall (p:A) (Q:A -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. +intros A eq_dec. +apply (Streicher_K__eq_rect_eq A (K_dec_type eq_dec)). +Qed. -right; red in |- *; intro neq; apply n; elim neq; reflexivity. +Unset Implicit Arguments. -trivial. -Qed.
\ No newline at end of file +(************************************************************************) +(** *** B.1. Definition of the functor that builds properties of dependent equalities on decidable sets in Type *) + +(** The signature of decidable sets in [Type] *) + +Module Type DecidableType. + + Parameter U:Type. + Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. + +End DecidableType. + +(** The module [DecidableEqDep] collects equality properties for decidable + set in [Type] *) + +Module DecidableEqDep (M:DecidableType). + + Import M. + + (** Invariance by Substitution of Reflexive Equality Proofs *) + + Lemma eq_rect_eq : + forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + Proof eq_rect_eq_dec eq_dec. + + (** Injectivity of Dependent Equality *) + + Theorem eq_dep_eq : + forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. + Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq). + + (** Uniqueness of Identity Proofs (UIP) *) + + Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. + Proof (eq_dep_eq__UIP U eq_dep_eq). + + (** Uniqueness of Reflexive Identity Proofs *) + + Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x. + Proof (UIP__UIP_refl U UIP). + + (** Streicher's axiom K *) + + Lemma Streicher_K : + forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. + Proof (K_dec_type eq_dec). + + (** Injectivity of equality on dependent pairs in [Type] *) + + Lemma inj_pairT2 : + forall (P:U -> Type) (p:U) (x y:P p), + existT P p x = existT P p y -> x = y. + Proof eq_dep_eq__inj_pairT2 U eq_dep_eq. + + (** Proof-irrelevance on subsets of decidable sets *) + + Lemma inj_pairP2 : + forall (P:U -> Prop) (x:U) (p q:P x), + ex_intro P x p = ex_intro P x q -> p = q. + intros. + apply inj_right_pair with (A:=U). + intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. + assumption. + Qed. + +End DecidableEqDep. + +(************************************************************************) +(** *** B.2 Definition of the functor that builds properties of dependent equalities on decidable sets in Set *) + +(** The signature of decidable sets in [Set] *) + +Module Type DecidableSet. + + Parameter U:Set. + Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. + +End DecidableSet. + +(** The module [DecidableEqDepSet] collects equality properties for decidable + set in [Set] *) + +Module DecidableEqDepSet (M:DecidableSet). + + Import M. + Module N:=DecidableEqDep(M). + + (** Invariance by Substitution of Reflexive Equality Proofs *) + + Lemma eq_rect_eq : + forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. + Proof eq_rect_eq_dec eq_dec. + + (** Injectivity of Dependent Equality *) + + Theorem eq_dep_eq : + forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y. + Proof N.eq_dep_eq. + + (** Uniqueness of Identity Proofs (UIP) *) + + Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2. + Proof N.UIP. + + (** Uniqueness of Reflexive Identity Proofs *) + + Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x. + Proof N.UIP_refl. + + (** Streicher's axiom K *) + + Lemma Streicher_K : + forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p. + Proof N.Streicher_K. + + (** Injectivity of equality on dependent pairs with second component + in [Type] *) + + Lemma inj_pairT2 : + forall (P:U -> Type) (p:U) (x y:P p), + existT P p x = existT P p y -> x = y. + Proof N.inj_pairT2. + + (** Proof-irrelevance on subsets of decidable sets *) + + Lemma inj_pairP2 : + forall (P:U -> Prop) (x:U) (p q:P x), + ex_intro P x p = ex_intro P x q -> p = q. + Proof N.inj_pairP2. + + (** Injectivity of equality on dependent pairs in [Set] *) + + Lemma inj_pair2 : + forall (P:U -> Set) (p:U) (x y:P p), + existS P p x = existS P p y -> x = y. + Proof eq_dep_eq__inj_pair2 U N.eq_dep_eq. + +End DecidableEqDepSet. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 4666d9b4..4d365e32 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: JMeq.v,v 1.8.2.2 2004/08/03 17:42:32 herbelin Exp $ i*) +(*i $Id: JMeq.v 6009 2004-08-03 17:42:55Z herbelin $ i*) -(** John Major's Equality as proposed by C. Mc Bride +(** John Major's Equality as proposed by Conor McBride Reference: diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v index afdc0ffe..44ab9a2e 100644 --- a/theories/Logic/ProofIrrelevance.v +++ b/theories/Logic/ProofIrrelevance.v @@ -6,109 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** This is a proof in the pure Calculus of Construction that - classical logic in Prop + dependent elimination of disjunction entails - proof-irrelevance. +(** This file axiomatizes proof-irrelevance and derives some consequences *) - Since, dependent elimination is derivable in the Calculus of - Inductive Constructions (CCI), we get proof-irrelevance from classical - logic in the CCI. +Require Import ProofIrrelevanceFacts. - Reference: +Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. - - [Coquand] T. Coquand, "Metamathematical Investigations of a - Calculus of Constructions", Proceedings of Logic in Computer Science - (LICS'90), 1990. +Module PI. Definition proof_irrelevance := proof_irrelevance. End PI. - Proof skeleton: classical logic + dependent elimination of - disjunction + discrimination of proofs implies the existence of a - retract from [Prop] into [bool], hence inconsistency by encoding any - paradox of system U- (e.g. Hurkens' paradox). -*) - -Require Import Hurkens. - -Section Proof_irrelevance_CC. - -Variable or : Prop -> Prop -> Prop. -Variable or_introl : forall A B:Prop, A -> or A B. -Variable or_intror : forall A B:Prop, B -> or A B. -Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C. -Hypothesis - or_elim_redl : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A), - f a = or_elim A B C f g (or_introl A B a). -Hypothesis - or_elim_redr : - forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B), - g b = or_elim A B C f g (or_intror A B b). -Hypothesis - or_dep_elim : - forall (A B:Prop) (P:or A B -> Prop), - (forall a:A, P (or_introl A B a)) -> - (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. - -Hypothesis em : forall A:Prop, or A (~ A). -Variable B : Prop. -Variables b1 b2 : B. - -(** [p2b] and [b2p] form a retract if [~b1=b2] *) - -Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A). -Definition b2p b := b1 = b. - -Lemma p2p1 : forall A:Prop, A -> b2p (p2b A). -Proof. - unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A); - unfold b2p in |- *; intros. - apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)). - destruct (b H). -Qed. -Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A. -Proof. - intro not_eq_b1_b2. - unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A); - unfold b2p in |- *; intros. - assumption. - destruct not_eq_b1_b2. - rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H. - assumption. -Qed. - -(** Using excluded-middle a second time, we get proof-irrelevance *) - -Theorem proof_irrelevance_cc : b1 = b2. -Proof. - refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H. - trivial. - apply (paradox B p2b b2p (p2p2 H) p2p1). -Qed. - -End Proof_irrelevance_CC. - - -(** The Calculus of Inductive Constructions (CCI) enjoys dependent - elimination, hence classical logic in CCI entails proof-irrelevance. -*) - -Section Proof_irrelevance_CCI. - -Hypothesis em : forall A:Prop, A \/ ~ A. - -Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) - (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a). -Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) - (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b). -Scheme or_indd := Induction for or Sort Prop. - -Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2. -Proof - proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl - or_elim_redr or_indd em. - -End Proof_irrelevance_CCI. - -(** Remark: in CCI, [bool] can be taken in [Set] as well in the - paradox and since [~true=false] for [true] and [false] in - [bool], we get the inconsistency of [em : forall A:Prop, {A}+{~A}] in CCI -*) +Module ProofIrrelevanceTheory := ProofIrrelevanceTheory(PI). +Export ProofIrrelevanceTheory. diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v new file mode 100644 index 00000000..dd3178eb --- /dev/null +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -0,0 +1,62 @@ +(************************************************************************) +(* 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 defines the functor that build consequences of proof-irrelevance *) + +Require Export EqdepFacts. + +Module Type ProofIrrelevance. + + Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2. + +End ProofIrrelevance. + +Module ProofIrrelevanceTheory (M:ProofIrrelevance). + + (** Proof-irrelevance implies uniqueness of reflexivity proofs *) + + Module Eq_rect_eq. + Lemma eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), + x = eq_rect p Q x p h. + Proof. + intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p). + reflexivity. + Qed. + End Eq_rect_eq. + + (** Export the theory of injective dependent elimination *) + + Module EqdepTheory := EqdepTheory(Eq_rect_eq). + Export EqdepTheory. + + Scheme eq_indd := Induction for eq Sort Prop. + + (** We derive the irrelevance of the membership property for subsets *) + + Lemma subset_eq_compat : + forall (U:Set) (P:U->Prop) (x y:U) (p:P x) (q:P y), + x = y -> exist P x p = exist P y q. + Proof. + intros. + rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + elim H using eq_indd. + reflexivity. + Qed. + + Lemma subsetT_eq_compat : + forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), + x = y -> existT P x p = existT P y q. + Proof. + intros. + rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + elim H using eq_indd. + reflexivity. + Qed. + +End ProofIrrelevanceTheory. diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 08873aa5..11979057 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RelationalChoice.v,v 1.3.2.2 2004/08/01 09:29:59 herbelin Exp $ i*) +(*i $Id: RelationalChoice.v 6001 2004-08-01 09:27:26Z herbelin $ i*) (** This file axiomatizes the relational form of the axiom of choice *) diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index e6a14938..b4582d51 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -6,9 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinNat.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*) +(*i $Id: BinNat.v 8685 2006-04-06 13:22:02Z letouzey $ i*) Require Import BinPos. +Unset Boxed Definitions. (**********************************************************************) (** Binary natural numbers *) @@ -21,10 +22,10 @@ Inductive N : Set := Delimit Scope N_scope with N. -(** Automatically open scope N_scope for the constructors of N *) +(** Automatically open scope positive_scope for the constructors of N *) Bind Scope N_scope with N. -Arguments Scope Npos [N_scope]. +Arguments Scope Npos [positive_scope]. Open Local Scope N_scope. @@ -32,7 +33,7 @@ Open Local Scope N_scope. Definition Ndouble_plus_one x := match x with - | N0 => Npos 1%positive + | N0 => Npos 1 | Npos p => Npos (xI p) end. @@ -47,7 +48,7 @@ Definition Ndouble n := match n with Definition Nsucc n := match n with - | N0 => Npos 1%positive + | N0 => Npos 1 | Npos p => Npos (Psucc p) end. @@ -57,7 +58,7 @@ Definition Nplus n m := match n, m with | N0, _ => m | _, N0 => n - | Npos p, Npos q => Npos (p + q)%positive + | Npos p, Npos q => Npos (p + q) end. Infix "+" := Nplus : N_scope. @@ -68,7 +69,7 @@ Definition Nmult n m := match n, m with | N0, _ => N0 | _, N0 => N0 - | Npos p, Npos q => Npos (p * q)%positive + | Npos p, Npos q => Npos (p * q) end. Infix "*" := Nmult : N_scope. @@ -154,7 +155,7 @@ Qed. (** Properties of multiplication *) -Theorem Nmult_1_l : forall n:N, Npos 1%positive * n = n. +Theorem Nmult_1_l : forall n:N, Npos 1 * n = n. Proof. destruct n; reflexivity. Qed. diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v index fffb10c1..513a67c2 100644 --- a/theories/NArith/BinPos.v +++ b/theories/NArith/BinPos.v @@ -6,7 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinPos.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*) +(*i $Id: BinPos.v 6699 2005-02-07 14:30:08Z coq $ i*) + +Unset Boxed Definitions. (**********************************************************************) (** Binary positive numbers *) @@ -39,6 +41,8 @@ Fixpoint Psucc (x:positive) : positive := (** Addition *) +Set Boxed Definitions. + Fixpoint Pplus (x y:positive) {struct x} : positive := match x, y with | xI x', xI y' => xO (Pplus_carry x' y') @@ -65,6 +69,8 @@ Fixpoint Pplus (x y:positive) {struct x} : positive := | xH, xH => xI xH end. +Unset Boxed Definitions. + Infix "+" := Pplus : positive_scope. Open Local Scope positive_scope. diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index b1bdaaf0..2f066efa 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArith.v,v 1.2.2.1 2004/07/16 19:31:07 herbelin Exp $ *) +(* $Id: NArith.v 5920 2004-07-16 20:01:26Z herbelin $ *) (** Library for binary natural numbers *) diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v index f5bbb1c9..88abc700 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,v 1.3.2.1 2004/07/16 19:31:07 herbelin Exp $ i*) +(*i $Id: Pnat.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import BinPos. diff --git a/theories/NArith/intro.tex b/theories/NArith/intro.tex new file mode 100644 index 00000000..83eed970 --- /dev/null +++ b/theories/NArith/intro.tex @@ -0,0 +1,5 @@ +\section{Binary positive and non negative integers : NArith}\label{NArith} + +Here are defined various arithmetical notions and their properties, +similar to those of {\tt Arith}. + diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index a691b189..e6bc69b6 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,v 1.14.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Alembert.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -30,7 +30,7 @@ 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)). -intro; apply X. +intro X; apply X. apply completeness. unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2); [ intro | apply Rinv_0_lt_compat; prove_sup0 ]. @@ -107,7 +107,7 @@ red in |- *; intro; assert (H8 := H n); rewrite H7 in H8; replace (S x + 0)%nat with (S x); [ reflexivity | ring ]. symmetry in |- *; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity. -intro; elim X; intros. +intro X; elim X; intros. apply existT with x; apply tech10; [ unfold Un_growing in |- *; intro; rewrite tech5; pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r; @@ -418,7 +418,7 @@ 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)). -intro; apply X. +intro X; apply X. apply completeness. assert (H1 := tech13 _ _ Hyp H0). elim H1; intros. @@ -517,7 +517,7 @@ rewrite H10 in H11; elim (Rlt_irrefl _ H11). replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ]. symmetry in |- *; apply tech2; assumption. exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity. -intro; elim X; intros. +intro X; elim X; intros. apply existT with x; apply tech10; [ unfold Un_growing in |- *; intro; rewrite tech5; pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r; @@ -559,11 +559,11 @@ rewrite <- Rabs_mult. rewrite Rabs_Rabsolu. unfold Rdiv in H3; apply H3; assumption. apply H0. -intro. +intro X. elim X; intros. apply existT with x. assumption. -intro. +intro X. elim X; intros. apply existT with x. assumption. @@ -581,7 +581,7 @@ intros. cut (sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l)). -intro. +intro X. elim X; intros. apply existT with x0. apply tech12; assumption. @@ -723,4 +723,4 @@ unfold Rdiv in |- *; apply Rmult_lt_0_compat. assumption. apply Rinv_0_lt_compat; apply Rabs_pos_lt. red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r). -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 166a8a46..1ec8c664 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,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: AltSeries.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index ad535a9d..24d64c07 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,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: ArithProp.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rbasic_fun. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index e31b623c..940bd628 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Binomial.v,v 1.9.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Binomial.v 6295 2004-11-12 16:40:39Z gregoire $ i*) Require Import Rbase. Require Import Rfunctions. @@ -201,4 +201,4 @@ replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ]. replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | apply INR_fact_neq_0 ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index 41a6284f..7f3727c7 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cauchy_prod.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Cauchy_prod.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 422eb4a4..558632c5 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Cos_plus.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Cos_plus.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 9f76a5ad..8320382c 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,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Cos_rel.v 6245 2004-10-20 13:50:08Z barras $ i*) Require Import Rbase. Require Import Rfunctions. @@ -417,4 +417,4 @@ unfold sin_in in s. assert (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). rewrite H1; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index f897e258..1c663288 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: DiscrR.v,v 1.21.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: DiscrR.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import RIneq. Require Import Omega. Open Local Scope R_scope. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index fcaeb11e..90ea93ef 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,v 1.16.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Exp_prop.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -895,7 +895,7 @@ cut Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l)). -intro. +intro X. elim X; intros. exists x; intros. split. @@ -1008,4 +1008,4 @@ rewrite Rmult_minus_distr_l. rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rmult_minus_distr_l. rewrite Rmult_1_r; rewrite exp_plus; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index c3c3d9bb..d4f3a8ec 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Integration.v,v 1.1.6.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: Integration.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Export NewtonInt. Require Export RiemannInt_SF. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index baa61304..241313a0 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: MVT.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: MVT.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -27,7 +27,7 @@ Theorem MVT : intros; assert (H2 := Rlt_le _ _ H). set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y). cut (forall c:R, a < c < b -> derivable_pt h c). -intro; cut (forall c:R, a <= c <= b -> continuity_pt h c). +intro X; cut (forall c:R, a <= c <= b -> continuity_pt h c). intro; assert (H4 := continuity_ab_maj h a b H2 H3). assert (H5 := continuity_ab_min h a b H2 H3). elim H4; intros Mx H6. @@ -142,9 +142,9 @@ Lemma MVT_cor1 : a < b -> exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b. intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c); - [ intro | intros; apply pr ]. + [ intro X | intros; apply pr ]. cut (forall c:R, a < c < b -> derivable_pt id c); - [ intro | intros; apply derivable_pt_id ]. + [ intro X0 | intros; apply derivable_pt_id ]. cut (forall c:R, a <= c <= b -> continuity_pt f c); [ intro | intros; apply derivable_continuous_pt; apply pr ]. cut (forall c:R, a <= c <= b -> continuity_pt id c); @@ -166,11 +166,11 @@ Theorem MVT_cor2 : (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) -> exists c : R, f b - f a = f' c * (b - a) /\ a < c < b. intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c). -intro; cut (forall c:R, a < c < b -> derivable_pt f c). -intro; cut (forall c:R, a <= c <= b -> continuity_pt f c). +intro X; cut (forall c:R, a < c < b -> derivable_pt f c). +intro X0; cut (forall c:R, a <= c <= b -> continuity_pt f c). intro; cut (forall c:R, a <= c <= b -> derivable_pt id c). -intro; cut (forall c:R, a < c < b -> derivable_pt id c). -intro; cut (forall c:R, a <= c <= b -> continuity_pt id c). +intro X1; cut (forall c:R, a < c < b -> derivable_pt id c). +intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c). intro; elim (MVT f id a b X0 X2 H H1 H2); intros; elim H3; clear H3; intros; exists x; split. cut (derive_pt id x (X2 x x0) = 1). @@ -595,7 +595,7 @@ Lemma IAF_var : g b - g a <= f b - f a. intros. cut (derivable (g - f)). -intro. +intro X. cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0). intro. assert (H2 := IAF (g - f)%F a b 0 X H H1). diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 97cd4b94..62c53e6d 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: NewtonInt.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: NewtonInt.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -128,7 +128,8 @@ Lemma NewtonInt_P5 : Newton_integrable f a b -> Newton_integrable g a b -> Newton_integrable (fun x:R => l * f x + g x) a b. -unfold Newton_integrable in |- *; intros; elim X; intros; elim X0; intros; +unfold Newton_integrable in |- *; intros f g l a b X X0; + elim X; intros; elim X0; intros; exists (fun y:R => l * x y + x0 y). elim p; intro. elim p0; intro. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 0c19c8da..d6dc352c 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: PSeries_reg.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*) +(*i $Id: PSeries_reg.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index 6087d3f2..bace7b9d 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,v 1.11.2.2 2005/07/13 22:28:30 herbelin Exp $ i*) +(*i $Id: PartSum.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -430,7 +430,7 @@ Lemma cv_cauchy_1 : forall An:nat -> R, sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) -> Cauchy_crit_series An. -intros. +intros An X. elim X; intros. unfold Un_cv in p. unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 5da14193..3e1dbccf 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RIneq.v,v 1.23.2.2 2005/03/29 15:35:13 herbelin Exp $ i*) +(*i $Id: RIneq.v 6897 2005-03-29 15:39:12Z herbelin $ i*) (***************************************************************************) (** Basic lemmas for the classical reals numbers *) diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 3b58c02f..551aec98 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: RList.v,v 1.10.2.1 2004/07/16 19:31:11 herbelin Exp $ i*) +(*i $Id: RList.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 289b1921..97355238 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_Ifp.v,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: R_Ifp.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (**********************************************************) (** Complements for the reals.Integer and fractional part *) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 0abf9064..d87adc24 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqr.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: R_sqr.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rbasic_fun. Open Local Scope R_scope. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 660b0527..cb372840 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: R_sqrt.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: R_sqrt.v 6295 2004-11-12 16:40:39Z gregoire $ i*) Require Import Rbase. Require Import Rfunctions. @@ -396,4 +396,4 @@ unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse. rewrite Ropp_minus_distr. reflexivity. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 88af8b20..b885e4ce 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,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Ranalysis.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 918ebfc0..6d30e291 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis1.v,v 1.21.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Ranalysis1.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -453,7 +453,7 @@ Qed. Theorem derivable_continuous_pt : forall f (x:R), derivable_pt f x -> continuity_pt f x. -intros. +intros f x X. generalize (derivable_derive f x X); intro. elim H; intros l H1. cut (l = fct_cte l x). @@ -468,7 +468,7 @@ unfold fct_cte in |- *; reflexivity. Qed. Theorem derivable_continuous : forall f, derivable f -> continuity f. -unfold derivable, continuity in |- *; intros. +unfold derivable, continuity in |- *; intros f X x. apply (derivable_continuous_pt f x (X x)). Qed. @@ -661,7 +661,7 @@ Qed. Lemma derivable_pt_plus : forall f1 f2 (x:R), derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x. -unfold derivable_pt in |- *; intros. +unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. apply existT with (x0 + x1). @@ -670,7 +670,7 @@ Qed. Lemma derivable_pt_opp : forall f (x:R), derivable_pt f x -> derivable_pt (- f) x. -unfold derivable_pt in |- *; intros. +unfold derivable_pt in |- *; intros f x X. elim X; intros. apply existT with (- x0). apply derivable_pt_lim_opp; assumption. @@ -679,7 +679,7 @@ Qed. Lemma derivable_pt_minus : forall f1 f2 (x:R), derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x. -unfold derivable_pt in |- *; intros. +unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. apply existT with (x0 - x1). @@ -689,7 +689,7 @@ Qed. Lemma derivable_pt_mult : forall f1 f2 (x:R), derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x. -unfold derivable_pt in |- *; intros. +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). @@ -704,7 +704,7 @@ Qed. Lemma derivable_pt_scal : forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x. -unfold derivable_pt in |- *; intros. +unfold derivable_pt in |- *; intros f1 a x X. elim X; intros. apply existT with (a * x0). apply derivable_pt_lim_scal; assumption. @@ -724,7 +724,7 @@ Qed. Lemma derivable_pt_comp : forall f1 f2 (x:R), derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x. -unfold derivable_pt in |- *; intros. +unfold derivable_pt in |- *; intros f1 f2 x X X0. elim X; intros. elim X0; intros. apply existT with (x1 * x0). @@ -733,24 +733,24 @@ Qed. Lemma derivable_plus : forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f1 f2 X X0 x. apply (derivable_pt_plus _ _ x (X _) (X0 _)). Qed. Lemma derivable_opp : forall f, derivable f -> derivable (- f). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f X x. apply (derivable_pt_opp _ x (X _)). Qed. Lemma derivable_minus : forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f1 f2 X X0 x. apply (derivable_pt_minus _ _ x (X _) (X0 _)). Qed. Lemma derivable_mult : forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f1 f2 X X0 x. apply (derivable_pt_mult _ _ x (X _) (X0 _)). Qed. @@ -761,7 +761,7 @@ Qed. Lemma derivable_scal : forall f (a:R), derivable f -> derivable (mult_real_fct a f). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f a X x. apply (derivable_pt_scal _ a x (X _)). Qed. @@ -775,7 +775,7 @@ Qed. Lemma derivable_comp : forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f1 f2 X X0 x. apply (derivable_pt_comp _ _ x (X _) (X0 _)). Qed. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 35f7eab8..0627e22c 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis2.v,v 1.11.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Ranalysis2.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 9f85b00a..663ccb07 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis3.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Ranalysis3.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -20,9 +20,9 @@ Theorem derivable_pt_lim_div : derivable_pt_lim f2 x l2 -> f2 x <> 0 -> derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)). -intros. +intros f1 f2 x l1 l2 H H0 H1. cut (derivable_pt f2 x); - [ intro | unfold derivable_pt in |- *; apply existT with l2; exact H0 ]. + [ intro X | unfold derivable_pt in |- *; apply existT with 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 |- *. @@ -756,7 +756,7 @@ Lemma derivable_pt_div : derivable_pt f1 x -> derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x. unfold derivable_pt in |- *. -intros. +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)). @@ -767,7 +767,7 @@ Lemma derivable_div : forall f1 f2:R -> R, derivable f1 -> derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2). -unfold derivable in |- *; intros. +unfold derivable in |- *; intros f1 f2 X X0 H x. apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)). Qed. @@ -790,4 +790,4 @@ unfold derive_pt in H; rewrite H in H3. assert (H4 := projT2 pr2). unfold derive_pt in H0; rewrite H0 in H4. apply derivable_pt_lim_div; assumption. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index 86f49cd4..40bb2429 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,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Ranalysis4.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -20,13 +20,13 @@ Require Import Exp_prop. Open Local Scope R_scope. Lemma derivable_pt_inv : forall (f:R -> R) (x:R), f x <> 0 -> derivable_pt f x -> derivable_pt (/ f) x. -intros; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x). -intro; apply X0. +intros f x H X; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x). +intro X0; apply X0. apply derivable_pt_div. apply derivable_pt_const. assumption. assumption. -unfold div_fct, inv_fct, fct_cte in |- *; intro; elim X0; intros; +unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros; unfold derivable_pt in |- *; apply existT with x0; unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *; unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; @@ -76,8 +76,8 @@ Qed. (**********) Lemma derivable_inv : forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f). -intros. -unfold derivable in |- *; intro. +intros f H X. +unfold derivable in |- *; intro x. apply derivable_pt_inv. apply (H x). apply (X x). @@ -381,4 +381,4 @@ Lemma derive_pt_sinh : forall x:R, derive_pt sinh x (derivable_pt_sinh x) = cosh x. intro; apply derive_pt_eq_0. apply derivable_pt_lim_sinh. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index bef9f89c..61902568 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,v 1.20.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Raxioms.v 6338 2004-11-22 09:10:51Z gregoire $ i*) (*********************************************************) (** Axiomatisation of the classical reals *) @@ -107,7 +107,7 @@ Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. (**********************************************************) (**********) -Fixpoint INR (n:nat) : R := +Boxed Fixpoint INR (n:nat) : R := match n with | O => 0 | S O => 1 diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index 773819a2..5bfb692a 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rbase.v,v 1.39.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rbase.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Export Rdefinitions. Require Export Raxioms. diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 49ba48f7..436a8011 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,v 1.22.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rbasic_fun.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*********************************************************) (** Complements for the real numbers *) diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index dd8379cb..2f11a404 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,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rcomplete.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 33f494df..62aec6bc 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,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rdefinitions.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*********************************************************) diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index 81db80ab..42663de6 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,v 1.15.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rderiv.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*********************************************************) (** Definition of the derivative,continuity *) diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 5e4b3e7b..c9cd189d 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Reals.v,v 1.24.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Reals.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (* The library REALS is divided in 6 parts : - Rbase: basic lemmas on R diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index cdff9fcb..0ab93229 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,v 1.31.2.1 2004/07/16 19:31:12 herbelin Exp $ i*) +(*i $Id: Rfunctions.v 6338 2004-11-22 09:10:51Z gregoire $ 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*) @@ -63,7 +63,7 @@ Qed. (* Power *) (*******************************) (*********) -Fixpoint pow (r:R) (n:nat) {struct n} : R := +Boxed Fixpoint pow (r:R) (n:nat) {struct n} : R := match n with | O => 1 | S n => r * pow r n @@ -670,7 +670,7 @@ Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z). (** Sum of n first naturals *) (*******************************) (*********) -Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat := +Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat := match n with | O => f 0%nat | S n' => (sum_nat_f_O f n' + f (S n'))%nat diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index a01e7b52..9ce20839 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rgeom.v,v 1.13.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rgeom.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index ce33afdb..79cb7797 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,v 1.18.2.2 2005/07/13 23:18:52 herbelin Exp $ i*) +(*i $Id: RiemannInt.v 7223 2005-07-13 23:43:54Z herbelin $ i*) Require Import Rfunctions. Require Import SeqSeries. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 0ae8f9f2..71ab0b4c 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,v 1.16.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: RiemannInt_SF.v 6338 2004-11-22 09:10:51Z gregoire $ i*) Require Import Rbase. Require Import Rfunctions. @@ -147,7 +147,7 @@ Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := | existT a b => a end. -Fixpoint Int_SF (l k:Rlist) {struct l} : R := +Boxed Fixpoint Int_SF (l k:Rlist) {struct l} : R := match l with | nil => 0 | cons a l' => diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 0fbb17c6..b8d304b1 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,v 1.23.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rlimit.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*********************************************************) (* Definition of the limit *) diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 7575d929..aa9e9887 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,v 1.17.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rpower.v 6295 2004-11-12 16:40:39Z gregoire $ i*) (*i Due to L.Thery i*) (************************************************************) @@ -658,4 +658,4 @@ apply derivable_pt_lim_const with (a := y). apply derivable_pt_lim_id. ring. apply derivable_pt_lim_exp. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 6577146f..ec738996 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,v 1.10.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rprod.v 6338 2004-11-22 09:10:51Z gregoire $ i*) Require Import Compare. Require Import Rbase. @@ -17,7 +17,7 @@ Require Import Binomial. Open Local Scope R_scope. (* TT Ak; 1<=k<=N *) -Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R := +Boxed Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R := match N with | O => 1 | S p => prod_f_SO An p * An (S p) @@ -188,4 +188,4 @@ rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0. apply prod_neq_R0; apply INR_fact_neq_0. apply INR_eq; rewrite minus_INR; [ rewrite mult_INR; do 2 rewrite S_INR; ring | apply le_n_2n ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index cbf93278..aa3a0316 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,v 1.11.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rseries.v 6338 2004-11-22 09:10:51Z gregoire $ i*) Require Import Rbase. Require Import Rfunctions. @@ -28,7 +28,7 @@ Section sequence. Variable Un : nat -> R. (*********) -Fixpoint Rmax_N (N:nat) : R := +Boxed Fixpoint Rmax_N (N:nat) : R := match N with | O => Un 0 | S n => Rmax (Un (S n)) (Rmax_N n) diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index e54c3675..1e69a8f5 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,v 1.12.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rsigma.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index 459f2716..de3422e8 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,v 1.14.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rsqrt_def.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Sumbool. Require Import Rbase. @@ -15,7 +15,7 @@ Require Import SeqSeries. Require Import Ranalysis1. Open Local Scope R_scope. -Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := +Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := match N with | O => x | S n => @@ -455,7 +455,7 @@ cut (x <= y). intro. generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). -intros. +intros X X0. elim X; intros. elim X0; intros. assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p). @@ -759,4 +759,4 @@ apply Rsqr_inj. assumption. assumption. rewrite <- H0; rewrite <- H2; reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 1c112bf1..84f3b081 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtopology.v,v 1.19.2.1 2004/07/16 19:31:13 herbelin Exp $ i*) +(*i $Id: Rtopology.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index e4cae6c6..060070c4 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,v 1.40.2.1 2004/07/16 19:31:14 herbelin Exp $ i*) +(*i $Id: Rtrigo.v 6245 2004-10-20 13:50:08Z barras $ i*) Require Import Rbase. Require Import Rfunctions. @@ -1704,4 +1704,4 @@ Lemma cos_eq_0_2PI_1 : intros x H1 H2 H3; elim H3; intro H4; [ rewrite H4; rewrite cos_PI2; reflexivity | rewrite H4; rewrite cos_3PI2; reflexivity ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index 3cda9290..fc465bc4 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,v 1.16.2.1 2004/07/16 19:31:14 herbelin Exp $ i*) +(*i $Id: Rtrigo_alt.v 6245 2004-10-20 13:50:08Z barras $ i*) Require Import Rbase. Require Import Rfunctions. @@ -423,4 +423,4 @@ intros; unfold cos_approx in |- *; apply sum_eq; intros; unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg; unfold Rdiv in |- *; reflexivity. apply Ropp_0_gt_lt_contravar; assumption. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 0ef87322..f8c15667 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Rtrigo_calc.v,v 1.15.2.1 2004/07/16 19:31:14 herbelin Exp $ i*) +(*i $Id: Rtrigo_calc.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 92ec68ce..94f5ec97 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,v 1.17.2.1 2004/07/16 19:31:14 herbelin Exp $ i*) +(*i $Id: Rtrigo_def.v 6295 2004-11-12 16:40:39Z gregoire $ i*) Require Import Rbase. Require Import Rfunctions. @@ -409,4 +409,4 @@ apply H. exact (projT2 exist_cos0). assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *; pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index b0f29e5c..eaf2121e 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,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: Rtrigo_fun.v 8691 2006-04-10 09:23:37Z msozeau $ i*) Require Import Rbase. Require Import Rfunctions. @@ -61,10 +61,10 @@ intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros; rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0). intro; rewrite (Rabs_pos_eq (/ INR (S n))). cut (/ eps - 1 < INR x). -intro; +intro ; generalize (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4 - (le_INR x n ((fun (n m:nat) (H:(m >= n)%nat) => H) x n H2))); + (le_INR x n H2)); clear H4; intro; unfold Rminus in H4; generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4); replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ]. diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 9d3b60c6..1c9a9445 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,v 1.15.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: Rtrigo_reg.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -32,7 +32,7 @@ cut (fun n:nat => sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k))) n) l)). -intro; elim X; intros. +intro X; elim X; intros. apply existT with x. split. apply p. @@ -206,7 +206,7 @@ cut sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n) l)). -intro; elim X; intros. +intro X; elim X; intros. apply existT with x. split. apply p. @@ -605,4 +605,4 @@ Lemma derive_pt_cos : forall x:R, derive_pt cos x (derivable_pt_cos _) = - sin x. intros; apply derive_pt_eq_0. apply derivable_pt_lim_cos. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 34f9fd72..2e851b13 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -5,8 +5,8 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(*i $Id: SeqProp.v,v 1.13.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) + +(*i $Id: SeqProp.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -48,7 +48,7 @@ cut (~ (forall N:nat, Un N <= x - eps)). intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)). intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7. intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8; - unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); + unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); apply Rlt_not_le; apply tech_Rgt_minus; exact H1. Qed. @@ -66,12 +66,12 @@ Lemma decreasing_cv : Un_decreasing Un -> has_lb Un -> sigT (fun l:R => Un_cv Un l). intros. cut (sigT (fun l:R => Un_cv (opp_seq Un) l) -> sigT (fun l:R => Un_cv Un l)). -intro. +intro X. apply X. apply growing_cv. apply decreasing_growing; assumption. exact H0. -intro. +intro X. elim X; intros. apply existT with (- x). unfold Un_cv in p. @@ -155,14 +155,14 @@ elim H1; intros. exists (k + x1)%nat; assumption. Qed. -Definition sequence_majorant (Un:nat -> R) (pr:has_ub Un) +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_minorant (Un:nat -> R) (pr:has_lb Un) +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). 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_majorant Un pr). intros. unfold Un_decreasing in |- *. intro. @@ -289,14 +289,14 @@ 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. + 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. intros. split. unfold sequence_minorant in |- *. cut (sigT (fun l:R => is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l)). -intro. +intro X. elim X; intros. replace (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x). unfold is_lub in p. @@ -329,7 +329,7 @@ apply min_inf. apply min_ss; assumption. unfold sequence_majorant in |- *. cut (sigT (fun l:R => is_lub (EUn (fun i:nat => Un (n + i)%nat)) l)). -intro. +intro X. elim X; intros. replace (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x. unfold is_lub in p. @@ -379,7 +379,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_majorant Un pr1). intros. assert (H := Vn_Un_Wn_order Un pr1 pr2). unfold has_lb in |- *. @@ -486,7 +486,7 @@ Qed. Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2. intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *. tauto. -Qed. +Qed. (**********) Lemma approx_maj : @@ -628,234 +628,234 @@ assert (H2 := H1 n). apply not_Rlt; assumption. Qed. -(* Unicity of limit for convergent sequences *) +(* Unicity of limit for convergent sequences *) Lemma UL_sequence : - forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2. -intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros. -apply cond_eq. + forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2. +intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros. +apply cond_eq. intros; cut (0 < eps / 2); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. -elim (H (eps / 2) H2); intros. -elim (H0 (eps / 2) H2); intros. -set (N := max x x0). -apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)). + [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. +elim (H (eps / 2) H2); intros. +elim (H0 (eps / 2) H2); intros. +set (N := max x x0). +apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)). replace (l1 - l2) with (l1 - Un N + (Un N - l2)); - [ apply Rabs_triang | ring ]. -rewrite (double_var eps); apply Rplus_lt_compat. + [ apply Rabs_triang | ring ]. +rewrite (double_var eps); apply Rplus_lt_compat. rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3; - unfold ge, N in |- *; apply le_max_l. -apply H4; unfold ge, N in |- *; apply le_max_r. + unfold ge, N in |- *; apply le_max_l. +apply H4; unfold ge, N in |- *; apply le_max_r. Qed. -(**********) +(**********) Lemma CV_plus : forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2). -unfold Un_cv in |- *; unfold R_dist in |- *; intros. + Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2). +unfold Un_cv in |- *; unfold R_dist in |- *; intros. cut (0 < eps / 2); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. -elim (H (eps / 2) H2); intros. -elim (H0 (eps / 2) H2); intros. -set (N := max x x0). -exists N; intros. + [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. +elim (H (eps / 2) H2); intros. +elim (H0 (eps / 2) H2); intros. +set (N := max x x0). +exists N; intros. replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2)); - [ idtac | ring ]. -apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)). -apply Rabs_triang. -rewrite (double_var eps); apply Rplus_lt_compat. + [ idtac | ring ]. +apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)). +apply Rabs_triang. +rewrite (double_var eps); apply Rplus_lt_compat. apply H3; unfold ge in |- *; apply le_trans with N; - [ unfold N in |- *; apply le_max_l | assumption ]. + [ unfold N in |- *; apply le_max_l | assumption ]. apply H4; unfold ge in |- *; apply le_trans with N; - [ unfold N in |- *; apply le_max_r | assumption ]. + [ unfold N in |- *; apply le_max_r | assumption ]. Qed. -(**********) +(**********) Lemma cv_cvabs : forall (Un:nat -> R) (l:R), - Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l). -unfold Un_cv in |- *; unfold R_dist in |- *; intros. -elim (H eps H0); intros. -exists x; intros. -apply Rle_lt_trans with (Rabs (Un n - l)). -apply Rabs_triang_inv2. -apply H1; assumption. -Qed. + Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l). +unfold Un_cv in |- *; unfold R_dist in |- *; intros. +elim (H eps H0); intros. +exists x; intros. +apply Rle_lt_trans with (Rabs (Un n - l)). +apply Rabs_triang_inv2. +apply H1; assumption. +Qed. -(**********) +(**********) Lemma CV_Cauchy : - forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un. -intros; elim X; intros. -unfold Cauchy_crit in |- *; intros. -unfold Un_cv in p; unfold R_dist in p. + forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un. +intros Un X; elim X; intros. +unfold Cauchy_crit in |- *; intros. +unfold Un_cv in p; unfold R_dist in p. cut (0 < eps / 2); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. -elim (p (eps / 2) H0); intros. -exists x0; intros. + [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. +elim (p (eps / 2) H0); intros. +exists x0; intros. unfold R_dist in |- *; - apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)). + apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)). replace (Un n - Un m) with (Un n - x + (x - Un m)); - [ apply Rabs_triang | ring ]. -rewrite (double_var eps); apply Rplus_lt_compat. -apply H1; assumption. -rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption. -Qed. + [ apply Rabs_triang | ring ]. +rewrite (double_var eps); apply Rplus_lt_compat. +apply H1; assumption. +rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption. +Qed. (**********) Lemma maj_by_pos : forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> - exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). -intros; elim X; intros. -cut (sigT (fun l:R => Un_cv (fun k:nat => Rabs (Un k)) l)). -intro. -assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0). -assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H). -elim H0; intros. -exists (x0 + 1). -cut (0 <= x0). -intro. -split. -apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ]. -intros. -apply Rle_trans with x0. -unfold is_upper_bound in H1. -apply H1. -exists n; reflexivity. + exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). +intros Un X; elim X; intros. +cut (sigT (fun 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). +elim H0; intros. +exists (x0 + 1). +cut (0 <= x0). +intro. +split. +apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ]. +intros. +apply Rle_trans with x0. +unfold is_upper_bound in H1. +apply H1. +exists n; reflexivity. pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; - apply Rlt_0_1. -apply Rle_trans with (Rabs (Un 0%nat)). -apply Rabs_pos. -unfold is_upper_bound in H1. -apply H1. -exists 0%nat; reflexivity. -apply existT with (Rabs x). -apply cv_cvabs; assumption. -Qed. - -(**********) + apply Rlt_0_1. +apply Rle_trans with (Rabs (Un 0%nat)). +apply Rabs_pos. +unfold is_upper_bound in H1. +apply H1. +exists 0%nat; reflexivity. +apply existT with (Rabs x). +apply cv_cvabs; assumption. +Qed. + +(**********) Lemma CV_mult : forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). -intros. -cut (sigT (fun l:R => Un_cv An l)). -intro. -assert (H1 := maj_by_pos An X). -elim H1; intros M H2. -elim H2; intros. -unfold Un_cv in |- *; unfold R_dist in |- *; intros. -cut (0 < eps / (2 * M)). -intro. -case (Req_dec l2 0); intro. -unfold Un_cv in H0; unfold R_dist in H0. -elim (H0 (eps / (2 * M)) H6); intros. -exists x; intros. + Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). +intros. +cut (sigT (fun l:R => Un_cv An l)). +intro X. +assert (H1 := maj_by_pos An X). +elim H1; intros M H2. +elim H2; intros. +unfold Un_cv in |- *; unfold R_dist in |- *; intros. +cut (0 < eps / (2 * M)). +intro. +case (Req_dec l2 0); intro. +unfold Un_cv in H0; unfold R_dist in H0. +elim (H0 (eps / (2 * M)) H6); intros. +exists x; intros. apply Rle_lt_trans with - (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). + (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). replace (An n * Bn n - l1 * l2) with (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2)); - [ apply Rabs_triang | ring ]. + [ apply Rabs_triang | ring ]. replace (Rabs (An n * Bn n - An n * l2)) with - (Rabs (An n) * Rabs (Bn n - l2)). -replace (Rabs (An n * l2 - l1 * l2)) with 0. -rewrite Rplus_0_r. -apply Rle_lt_trans with (M * Rabs (Bn n - l2)). -do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). -apply Rmult_le_compat_l. -apply Rabs_pos. -apply H4. -apply Rmult_lt_reg_l with (/ M). -apply Rinv_0_lt_compat; apply H3. -rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. -rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). -apply Rlt_trans with (eps / (2 * M)). -apply H8; assumption. -unfold Rdiv in |- *; rewrite Rinv_mult_distr. -apply Rmult_lt_reg_l with 2. + (Rabs (An n) * Rabs (Bn n - l2)). +replace (Rabs (An n * l2 - l1 * l2)) with 0. +rewrite Rplus_0_r. +apply Rle_lt_trans with (M * Rabs (Bn n - l2)). +do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). +apply Rmult_le_compat_l. +apply Rabs_pos. +apply H4. +apply Rmult_lt_reg_l with (/ M). +apply Rinv_0_lt_compat; apply H3. +rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. +rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). +apply Rlt_trans with (eps / (2 * M)). +apply H8; assumption. +unfold Rdiv in |- *; rewrite Rinv_mult_distr. +apply Rmult_lt_reg_l with 2. prove_sup0. replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M)); - [ idtac | ring ]. -rewrite <- Rinv_r_sym. -rewrite Rmult_1_l; rewrite double. -pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r. + [ idtac | ring ]. +rewrite <- Rinv_r_sym. +rewrite Rmult_1_l; rewrite double. +pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; assumption ]. -discrR. -discrR. -red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). -red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). + [ assumption | apply Rinv_0_lt_compat; assumption ]. +discrR. +discrR. +red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). +red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *; - rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity. -replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ]. -symmetry in |- *; apply Rabs_mult. -cut (0 < eps / (2 * Rabs l2)). -intro. + rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity. +replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ]. +symmetry in |- *; apply Rabs_mult. +cut (0 < eps / (2 * Rabs l2)). +intro. unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0; - unfold R_dist in H0. -elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9. -elim (H0 (eps / (2 * M)) H6); intros N2 H10. -set (N := max N1 N2). -exists N; intros. + unfold R_dist in H0. +elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9. +elim (H0 (eps / (2 * M)) H6); intros N2 H10. +set (N := max N1 N2). +exists N; intros. apply Rle_lt_trans with - (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). + (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). replace (An n * Bn n - l1 * l2) with (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2)); - [ apply Rabs_triang | ring ]. + [ apply Rabs_triang | ring ]. replace (Rabs (An n * Bn n - An n * l2)) with - (Rabs (An n) * Rabs (Bn n - l2)). -replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)). -rewrite (double_var eps); apply Rplus_lt_compat. -apply Rle_lt_trans with (M * Rabs (Bn n - l2)). -do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). -apply Rmult_le_compat_l. -apply Rabs_pos. -apply H4. -apply Rmult_lt_reg_l with (/ M). -apply Rinv_0_lt_compat; apply H3. -rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. -rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). -apply Rlt_le_trans with (eps / (2 * M)). -apply H10. -unfold ge in |- *; apply le_trans with N. -unfold N in |- *; apply le_max_r. -assumption. -unfold Rdiv in |- *; rewrite Rinv_mult_distr. -right; ring. -discrR. -red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). -red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). -apply Rmult_lt_reg_l with (/ Rabs l2). -apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. -rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. -rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)). -apply H9. -unfold ge in |- *; apply le_trans with N. -unfold N in |- *; apply le_max_l. -assumption. -unfold Rdiv in |- *; right; rewrite Rinv_mult_distr. -ring. -discrR. -apply Rabs_no_R0; assumption. -apply Rabs_no_R0; assumption. + (Rabs (An n) * Rabs (Bn n - l2)). +replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)). +rewrite (double_var eps); apply Rplus_lt_compat. +apply Rle_lt_trans with (M * Rabs (Bn n - l2)). +do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). +apply Rmult_le_compat_l. +apply Rabs_pos. +apply H4. +apply Rmult_lt_reg_l with (/ M). +apply Rinv_0_lt_compat; apply H3. +rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. +rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). +apply Rlt_le_trans with (eps / (2 * M)). +apply H10. +unfold ge in |- *; apply le_trans with N. +unfold N in |- *; apply le_max_r. +assumption. +unfold Rdiv in |- *; rewrite Rinv_mult_distr. +right; ring. +discrR. +red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). +red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). +apply Rmult_lt_reg_l with (/ Rabs l2). +apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. +rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. +rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)). +apply H9. +unfold ge in |- *; apply le_trans with N. +unfold N in |- *; apply le_max_l. +assumption. +unfold Rdiv in |- *; right; rewrite Rinv_mult_distr. +ring. +discrR. +apply Rabs_no_R0; assumption. +apply Rabs_no_R0; assumption. replace (An n * l2 - l1 * l2) with (l2 * (An n - l1)); - [ symmetry in |- *; apply Rabs_mult | ring ]. + [ symmetry in |- *; apply Rabs_mult | ring ]. replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); - [ symmetry in |- *; apply Rabs_mult | ring ]. -unfold Rdiv in |- *; apply Rmult_lt_0_compat. -assumption. + [ symmetry in |- *; apply Rabs_mult | ring ]. +unfold Rdiv in |- *; apply Rmult_lt_0_compat. +assumption. apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | apply Rabs_pos_lt; assumption ]. + [ prove_sup0 | apply Rabs_pos_lt; assumption ]. unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; - [ prove_sup0 | assumption ] ]. -apply existT with l1; assumption. -Qed. + [ prove_sup0 | assumption ] ]. +apply existT with l1; assumption. +Qed. Lemma tech9 : forall Un:nat -> R, @@ -905,13 +905,13 @@ rewrite b; assumption. cut (forall n:nat, Un n <= x0). intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros. cut (forall y:R, EUn Un y -> y <= x0). -intro; assert (H8 := H6 _ H7). +intro; assert (H8 := H6 _ H7). elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)). unfold EUn in |- *; intros; elim H7; intros. rewrite H8; apply H4. intro; case (Rle_dec (Un n) x0); intro. assumption. -cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0). +cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0). intro; unfold Un_cv in H3; cut (0 < Un n - x0). intro; elim (H3 (Un n - x0) H5); intros. cut (max n x1 >= x1)%nat. @@ -931,7 +931,7 @@ left; assumption. unfold ge in |- *; apply le_max_r. apply Rplus_lt_reg_r with x0. rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply H4; apply le_n. intros; apply Rlt_le_trans with (Un n). case (Rlt_le_dec x0 (Un n)); intro. @@ -977,7 +977,7 @@ unfold R_dist in H4; rewrite <- Rabs_Rabsolu; apply Rabs_triang. rewrite (Rabs_right k). apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k); - repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; repeat rewrite Rplus_0_l; apply H4. apply Rle_ge; elim H; intros; assumption. unfold Rdiv in |- *; apply Rmult_lt_0_compat. @@ -989,7 +989,7 @@ Qed. (**********) Lemma growing_ineq : forall (Un:nat -> R) (l:R), - Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. + Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. intros; case (total_order_T (Un n) l); intro. elim s; intro. left; assumption. @@ -1042,14 +1042,14 @@ Qed. (**********) Lemma CV_minus : forall (An Bn:nat -> R) (l1 l2:R), - Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2). -intros. -replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i). -unfold Rminus in |- *; apply CV_plus. -assumption. -apply CV_opp; assumption. -unfold Rminus, opp_seq in |- *; reflexivity. -Qed. + Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2). +intros. +replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i). +unfold Rminus in |- *; apply CV_plus. +assumption. +apply CV_opp; assumption. +unfold Rminus, opp_seq in |- *; reflexivity. +Qed. (* Un -> +oo *) Definition cv_infty (Un:nat -> R) : Prop := @@ -1265,7 +1265,7 @@ apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8). clear Un Vn; apply INR_le; simpl in |- *. induction M_nat as [| M_nat HrecM_nat]. -assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. +assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7. simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)). replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S; diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index deb98492..6cab2486 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,v 1.14.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: SeqSeries.v 8670 2006-03-28 22:16:14Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -36,12 +36,12 @@ intros; (sigT (fun l:R => Un_cv (fun n:nat => sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) l)). -intro; +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)). -intro; elim X; intros l1N H2. +intro X0; elim X; intros l1N H2. elim X0; intros l2N H3. cut (l1 - SP fn N x = l1N). intro; cut (l2 - sum_f_R0 An N = l2N). @@ -217,7 +217,7 @@ Lemma Rseries_CV_comp : (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). -intros; apply cv_cauchy_2. +intros An Bn H X; apply cv_cauchy_2. assert (H0 := cv_cauchy_1 _ X). unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *. intros; elim (H0 eps H1); intros. diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index b4026e67..11b9d57b 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitAbsolu.v,v 1.6.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: SplitAbsolu.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbasic_fun. diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index 19df2afa..31d49b76 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: SplitRmult.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: SplitRmult.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index b11e51f0..3e2b6b9f 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sqrt_reg.v,v 1.9.2.1 2004/07/16 19:31:15 herbelin Exp $ i*) +(*i $Id: Sqrt_reg.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v index 3cf604d8..ae914933 100755..100644 --- a/theories/Relations/Newman.v +++ b/theories/Relations/Newman.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Newman.v,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Newman.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Rstar. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 5e0e9ec8..22a08a27 100755..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,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Operators_Properties.v 8642 2006-03-17 10:09:02Z notin $ i*) (****************************************************************************) (* Bruno Barras *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index e115b0b0..22ba7413 100755..100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Definitions.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Relation_Definitions.v 8642 2006-03-17 10:09:02Z notin $ i*) Section Relation_Definition. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index b6359ada..edc112e5 100755..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,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Relation_Operators.v 8642 2006-03-17 10:09:02Z notin $ i*) (****************************************************************************) (* Bruno Barras, Cristina Cornes *) @@ -22,31 +22,31 @@ Require Import List. (** Some operators to build relations *) Section Transitive_Closure. - Variable A : Set. + Variable A : Type. Variable R : relation A. - Inductive clos_trans : A -> A -> Prop := - | t_step : forall x y:A, R x y -> clos_trans x y + Inductive clos_trans (x: A) : A -> Prop := + | t_step : forall y:A, R x y -> clos_trans x y | t_trans : - forall x y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z. + forall y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z. End Transitive_Closure. Section Reflexive_Transitive_Closure. - Variable A : Set. + Variable A : Type. Variable R : relation A. - Inductive clos_refl_trans : relation A := - | rt_step : forall x y:A, R x y -> clos_refl_trans x y - | rt_refl : forall x:A, clos_refl_trans x x + Inductive clos_refl_trans (x:A) : A -> Prop:= + | rt_step : forall y:A, R x y -> clos_refl_trans x y + | rt_refl : clos_refl_trans x x | rt_trans : - forall x y z:A, + forall y z:A, clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. End Reflexive_Transitive_Closure. Section Reflexive_Symetric_Transitive_Closure. - Variable A : Set. + Variable A : Type. Variable R : relation A. Inductive clos_refl_sym_trans : relation A := @@ -62,7 +62,7 @@ End Reflexive_Symetric_Transitive_Closure. Section Transposee. - Variable A : Set. + Variable A : Type. Variable R : relation A. Definition transp (x y:A) := R y x. @@ -70,7 +70,7 @@ End Transposee. Section Union. - Variable A : Set. + Variable A : Type. Variables R1 R2 : relation A. Definition union (x y:A) := R1 x y \/ R2 x y. @@ -164,4 +164,4 @@ End Lexicographic_Exponentiation. Hint Unfold transp union: sets v62. Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62. -Hint Immediate rst_sym: sets v62.
\ No newline at end of file +Hint Immediate rst_sym: sets v62. diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 6c96f14d..2df0317b 100755..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,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Relations.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relation_Definitions. Require Export Relation_Operators. diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v index 7bb3ee93..4e62d73a 100755..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,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*) +(*i $Id: Rstar.v 8642 2006-03-17 10:09:02Z notin $ i*) (** Properties of a binary relation [R] on type [A] *) diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 63f21fed..6ff73438 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -1,3 +1,4 @@ + (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -6,66 +7,658 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $: i*) +(*i $Id: Setoid.v 6306 2004-11-16 16:11:10Z sacerdot $: 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 + | cons : 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}. + +Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments. + induction 1. + exact (singl (Leibniz _ a)). + exact (cons (Leibniz _ a) IHX). +Defined. + +(* every function is a morphism from Leibniz+ to Leibniz *) +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. + +(* 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. + hnf; unfold impl; tauto. +Qed. + +Definition Impl_Relation_Class : Relation_Class. + eapply (@AsymmetricReflexive unit tt _ impl). + exact impl_refl. +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 (cons 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 (cons 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 (cons 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 (cons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). + intros. + exists Aeq. + unfold make_compatibility_goal; simpl; unfold impl; eauto. +Defined. + +(* 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. + +(* every predicate is 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. + +(* impl AS A RELATION *) + +Theorem impl_trans: transitive _ impl. + hnf; unfold impl; tauto. +Qed. + +Add Relation Prop impl + reflexivity proved by impl_refl + transitivity proved by impl_trans + as impl_relation. + +(* THE CIC PART OF THE REFLEXIVE TACTIC (SETOID REWRITE) *) -Section Setoid. +Inductive rewrite_direction : Type := + Left2Right + | Right2Left. -Variable A : Type. -Variable Aeq : A -> A -> Prop. +Implicit Type dir: rewrite_direction. -Record Setoid_Theory : Prop := +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. + 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'' (cons 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 (prodT (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). + 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)). + 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. + +(* BEGIN OF UTILITY/BACKWARD COMPATIBILITY PART *) + +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}. -End Setoid. +(* END OF UTILITY/BACKWARD COMPATIBILITY PART *) + +(* A FEW EXAMPLES ON iff *) -Definition Prop_S : Setoid_Theory Prop iff. -split; [ exact iff_refl | exact iff_sym | exact iff_trans ]. +(* impl IS A MORPHISM *) + +Add Morphism impl with signature iff ==> iff ==> iff as Impl_Morphism. +unfold impl; tauto. Qed. -Add Setoid Prop iff Prop_S. +(* and IS A MORPHISM *) -Hint Resolve (Seq_refl Prop iff Prop_S): setoid. -Hint Resolve (Seq_sym Prop iff Prop_S): setoid. -Hint Resolve (Seq_trans Prop iff Prop_S): setoid. +Add Morphism and with signature iff ==> iff ==> iff as And_Morphism. + tauto. +Qed. -Add Morphism or : or_ext. -intros. -inversion H1. -left. -inversion H. -apply (H3 H2). +(* or IS A MORPHISM *) -right. -inversion H0. -apply (H3 H2). +Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism. + tauto. Qed. -Add Morphism and : and_ext. -intros. -inversion H1. -split. -inversion H. -apply (H4 H2). +(* not IS A MORPHISM *) -inversion H0. -apply (H4 H3). +Add Morphism not with signature iff ==> iff as Not_Morphism. + tauto. Qed. -Add Morphism not : not_ext. -red in |- *; intros. -apply H0. -inversion H. -apply (H3 H1). +(* THE SAME EXAMPLES ON impl *) + +Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2. + unfold impl; tauto. Qed. -Definition fleche (A B:Prop) := A -> B. +Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2. + unfold impl; tauto. +Qed. -Add Morphism fleche : fleche_ext. -unfold fleche in |- *. -intros. -inversion H0. -inversion H. -apply (H3 (H1 (H6 H2))). +Add Morphism not with signature impl --> impl as Not_Morphism2. + unfold impl; tauto. Qed. + +(* FOR BACKWARD COMPATIBILITY *) +Implicit Arguments Setoid_Theory []. +Implicit Arguments Seq_refl []. +Implicit Arguments Seq_sym []. +Implicit Arguments Seq_trans []. diff --git a/theories/Setoids/intro.tex b/theories/Setoids/intro.tex new file mode 100644 index 00000000..50cd025d --- /dev/null +++ b/theories/Setoids/intro.tex @@ -0,0 +1 @@ +\section{Setoids}\label{Setoids} diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 98cb14e4..382b5d72 100755..100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Classical_sets.v,v 1.4.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Classical_sets.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index a2bc781d..7e4471a0 100755..100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Constructive_sets.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Constructive_sets.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index 9fae12f5..0b2cf3e3 100755..100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Cpo.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Cpo.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index 05afc298..d71c96b0 100755..100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Ensembles.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Ensembles.v 8642 2006-03-17 10:09:02Z notin $ i*) Section Ensembles. Variable U : Type. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index 5a2e4397..47b41ec3 100755..100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Finite_sets.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Import Ensembles. diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index 952965e8..ddbf62e4 100755..100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Finite_sets_facts.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Finite_sets_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index f58f2f81..c97aa127 100755..100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Image.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Image.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index c357e26c..806e9dde 100755..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,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Infinite_sets.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index 26f29c96..cfadd81c 100755..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,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Integers.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Finite_sets. Require Export Constructive_sets. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index a308282b..cdc8520c 100755..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,v 1.9.2.1 2004/07/16 19:31:17 herbelin Exp $ i*) +(*i $Id: Multiset.v 8642 2006-03-17 10:09:02Z notin $ i*) (* G. Huet 1-9-95 *) diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index b3e59886..9924ba66 100755..100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Partial_Order.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Partial_Order.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index af6151bf..2b6c899f 100755..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,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Permut.v 8642 2006-03-17 10:09:02Z notin $ i*) (* G. Huet 1-9-95 *) diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index a7f5e9f4..c9a52ac2 100755..100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset.v,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Powerset.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Relations_1. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 05c60def..210017d4 100755..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,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Powerset_Classical_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 2c71f529..47ef2ea7 100755..100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Powerset_facts.v,v 1.8.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Powerset_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Ensembles. Require Export Constructive_sets. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index e33746a9..64c4c654 100755..100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_1.v 8642 2006-03-17 10:09:02Z notin $ i*) Section Relations_1. Variable U : Type. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 62688895..6ee7f5e2 100755..100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_1_facts.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_1_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relations_1. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index 15d3ee2d..a74102fd 100755..100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_2.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_2.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relations_1. @@ -32,18 +32,18 @@ Section Relations_2. Variable U : Type. Variable R : Relation U. -Inductive Rstar : Relation U := - | Rstar_0 : forall x:U, Rstar x x - | Rstar_n : forall x y z:U, R x y -> Rstar y z -> Rstar x z. +Inductive Rstar (x:U) : U -> Prop := + | Rstar_0 : Rstar x x + | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z. -Inductive Rstar1 : Relation U := - | Rstar1_0 : forall x:U, Rstar1 x x - | Rstar1_1 : forall x y:U, R x y -> Rstar1 x y - | Rstar1_n : forall x y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. +Inductive Rstar1 (x:U) : U -> Prop := + | Rstar1_0 : Rstar1 x x + | Rstar1_1 : forall y:U, R x y -> Rstar1 x y + | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z. -Inductive Rplus : Relation U := - | Rplus_0 : forall x y:U, R x y -> Rplus x y - | Rplus_n : forall x y z:U, R x y -> Rplus y z -> Rplus x z. +Inductive Rplus (x:U) : U -> Prop := + | Rplus_0 : forall y:U, R x y -> Rplus x y + | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z. Definition Strongly_confluent : Prop := forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z). diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index 4c729fe7..3291f3ee 100755..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,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_2_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relations_1. Require Export Relations_1_facts. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 6a254819..b8c65148 100755..100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_3.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relations_1. Require Export Relations_2. @@ -46,9 +46,9 @@ Section Relations_3. Definition Confluent : Prop := forall x:U, confluent x. - Inductive noetherian : U -> Prop := + Inductive noetherian (x: U) : Prop := definition_of_noetherian : - forall x:U, (forall y:U, R x y -> noetherian y) -> noetherian x. + (forall y:U, R x y -> noetherian y) -> noetherian x. Definition Noetherian : Prop := forall x:U, noetherian x. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 34322dc7..38ff9eae 100755..100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -24,7 +24,7 @@ (* in Summer 1995. Several developments by E. Ledinot were an inspiration. *) (****************************************************************************) -(*i $Id: Relations_3_facts.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Relations_3_facts.v 8642 2006-03-17 10:09:02Z notin $ i*) Require Export Relations_1. Require Export Relations_1_facts. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 10d26f22..42c96191 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Uniset.v,v 1.9.2.1 2004/07/16 19:31:18 herbelin Exp $ i*) +(*i $Id: Uniset.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Sets as characteristic functions *) diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 41594749..346ae95a 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Heap.v,v 1.3.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Heap.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** A development of Treesort on Heap trees *) diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 43a0f0bc..b3287cd1 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Permutation.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Permutation.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Relations. Require Import List. diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index aa829fea..0e0bfe8f 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Sorting.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Sorting.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import List. Require Import Multiset. diff --git a/theories/Sorting/intro.tex b/theories/Sorting/intro.tex new file mode 100644 index 00000000..64ae4c88 --- /dev/null +++ b/theories/Sorting/intro.tex @@ -0,0 +1 @@ +\section{Sorting}\label{Sorting} diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v new file mode 100644 index 00000000..919989fd --- /dev/null +++ b/theories/Strings/Ascii.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 *) +(************************************************************************) + +(* $Id: Ascii.v 8026 2006-02-11 19:40:49Z herbelin $ *) + +(* Contributed by Laurent Théry (INRIA); + Adapted to Coq V8 by the Coq Development Team *) + +Require Import Bool. +Require Import BinPos. + +(** *** Definition of ascii characters *) + +(* Definition of ascii character as a 8 bits constructor *) + +Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). + +Delimit Scope char_scope with char. +Bind Scope char_scope with ascii. + +Definition zero := Ascii false false false false false false false false. + +Definition one := Ascii true false false false false false false false. + +Definition app1 (f : bool -> bool) (a : ascii) := + match a with + | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => + Ascii (f a1) (f a2) (f a3) (f a4) (f a5) (f a6) (f a7) (f a8) + end. + +Definition app2 (f : bool -> bool -> bool) (a b : ascii) := + match a, b with + | Ascii a1 a2 a3 a4 a5 a6 a7 a8, Ascii b1 b2 b3 b4 b5 b6 b7 b8 => + Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) + (f a5 b5) (f a6 b6) (f a7 b7) (f a8 b8) + end. + +Definition shift (c : bool) (a : ascii) := + match a with + | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii c a1 a2 a3 a4 a5 a6 a7 + end. + +(* Definition of a decidable function that is effective *) + +Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}. + decide equality; apply bool_dec. +Defined. + +(** *** Conversion between natural numbers modulo 256 and ascii characters *) + +(* Auxillary function that turns a positive into an ascii by + looking at the last n bits, ie z mod 2^n *) + +Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) + (n : nat) {struct n} : ascii := + match n with + | O => res + | S n1 => + match z with + | xH => app2 orb res acc + | xI z' => ascii_of_pos_aux (app2 orb res acc) (shift false acc) z' n1 + | xO z' => ascii_of_pos_aux res (shift false acc) z' n1 + end + end. + + +(* Function that turns a positive into an ascii by + looking at the last 8 bits, ie a mod 8 *) + +Definition ascii_of_pos (a : positive) := ascii_of_pos_aux zero one a 8. + +(* Function that turns a Peano number into an ascii by converting it + to positive *) + +Definition ascii_of_nat (a : nat) := + match a with + | O => zero + | S a' => ascii_of_pos (P_of_succ_nat a') + end. + +(* The opposite function *) + +Definition nat_of_ascii (a : ascii) : nat := + let (a1, a2, a3, a4, a5, a6, a7, a8) := a in + 2 * + (2 * + (2 * + (2 * + (2 * + (2 * + (2 * (if a8 then 1 else 0) + + (if a7 then 1 else 0)) + + (if a6 then 1 else 0)) + + (if a5 then 1 else 0)) + + (if a4 then 1 else 0)) + + (if a3 then 1 else 0)) + + (if a2 then 1 else 0)) + + (if a1 then 1 else 0). + +Theorem ascii_nat_embedding : + forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. +Proof. + destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. +Abort. + +(** *** Concrete syntax *) + +(** + Ascii characters can be represented in scope char_scope as follows: + - ["c"] represents itself if c is a character of code < 128, + - [""""] is an exception: it represents the ascii character 34 + (double quote), + - ["nnn"] represents the ascii character of decimal code nnn. + + For instance, both ["065"] and ["A"] denote the character `uppercase + A', and both ["034"] and [""""] denote the character `double quote'. + + Notice that the ascii characters of code >= 128 do not denote + stand-alone utf8 characters so that only the notation "nnn" is + available for them (unless your terminal is able to represent them, + which is typically not the case in coqide). +*) + +Open Local Scope char_scope. + +Example Space := " ". +Example DoubleQuote := """". +Example Beep := "007". diff --git a/theories/Strings/String.v b/theories/Strings/String.v new file mode 100644 index 00000000..f2c58364 --- /dev/null +++ b/theories/Strings/String.v @@ -0,0 +1,392 @@ +(************************************************************************) +(* 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: String.v 8026 2006-02-11 19:40:49Z herbelin $ *) + +(** Contributed by Laurent Théry (INRIA); + Adapted to Coq V8 by the Coq Development Team *) + +Require Import Arith. +Require Import Ascii. + +(** *** Definition of strings *) + +(** Implementation of string as list of ascii characters *) + +Inductive string : Set := + | EmptyString : string + | String : ascii -> string -> string. + +Delimit Scope string_scope with string. +Bind Scope string_scope with string. +Open Local Scope string_scope. + +(** Equality is decidable *) + +Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. + decide equality; apply ascii_dec. +Defined. + +(** *** Concatenation of strings *) + +Reserved Notation "x ++ y" (right associativity, at level 60). + +Fixpoint append (s1 s2 : string) {struct s1} : string := + match s1 with + | EmptyString => s2 + | String c s1' => String c (s1' ++ s2) + end + +where "s1 ++ s2" := (append s1 s2) : string_scope. + +(******************************) +(** Length *) +(******************************) + +Fixpoint length (s : string) : nat := + match s with + | EmptyString => 0 + | String c s' => S (length s') + end. + +(******************************) +(** Nth character of a string *) +(******************************) + +Fixpoint get (n : nat) (s : string) {struct s} : option ascii := + match s with + | EmptyString => None + | String c s' => match n with + | O => Some c + | S n' => get n' s' + end + end. + +(** Two lists that are identical through get are syntactically equal *) + +Theorem get_correct : + forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. +Proof. +intros s1; elim s1; simpl in |- *. +intros s2; case s2; simpl in |- *; split; auto. +intros H; generalize (H 0); intros H1; inversion H1. +intros; discriminate. +intros a s1' Rec s2; case s2; simpl in |- *; split; auto. +intros H; generalize (H 0); intros H1; inversion H1. +intros; discriminate. +intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1. +case (Rec s). +intros H0; rewrite H0; auto. +intros n; exact (H (S n)). +intros H; injection H; intros H1 H2 n; case n; auto. +rewrite H2; trivial. +rewrite H1; auto. +Qed. + +(** The first elements of [s1 ++ s2] are the ones of [s1] *) + +Theorem append_correct1 : + forall (s1 s2 : string) (n : nat), + n < length s1 -> get n s1 = get n (s1 ++ s2). +Proof. +intros s1; elim s1; simpl in |- *; auto. +intros s2 n H; inversion H. +intros a s1' Rec s2 n; case n; simpl in |- *; auto. +intros n0 H; apply Rec; auto. +apply lt_S_n; auto. +Qed. + +(** The last elements of [s1 ++ s2] are the ones of [s2] *) + +Theorem append_correct2 : + forall (s1 s2 : string) (n : nat), + get n s2 = get (n + length s1) (s1 ++ s2). +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. +Qed. + +(** *** Substrings *) + +(** [substring n m s] returns the substring of [s] that starts + at position [n] and of length [m]; + if this does not make sense it returns [""] *) + +Fixpoint substring (n m : nat) (s : string) {struct s} : string := + match n, m, s with + | 0, 0, _ => EmptyString + | 0, S m', EmptyString => s + | 0, S m', String c s' => String c (substring 0 m' s') + | S n', _, EmptyString => s + | S n', _, String c s' => substring n' m s' + end. + +(** The substring is included in the initial string *) + +Theorem substring_correct1 : + forall (s : string) (n m p : nat), + p < m -> get p (substring n m s) = get (p + n) s. +Proof. +intros s; elim s; simpl in |- *; auto. +intros n; case n; simpl in |- *; auto. +intros m; case m; simpl in |- *; auto. +intros a s' Rec; intros n; case n; simpl in |- *; auto. +intros m; case m; simpl in |- *; auto. +intros p H; inversion H. +intros m' p; case p; simpl in |- *; auto. +intros n0 H; apply Rec; simpl in |- *; auto. +apply Lt.lt_S_n; auto. +intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto. +Qed. + +(** The substring has at most [m] elements *) + +Theorem substring_correct2 : + forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. +Proof. +intros s; elim s; simpl in |- *; auto. +intros n; case n; simpl in |- *; auto. +intros m; case m; simpl in |- *; auto. +intros a s' Rec; intros n; case n; simpl in |- *; auto. +intros m; case m; simpl in |- *; auto. +intros m' p; case p; simpl in |- *; auto. +intros H; inversion H. +intros n0 H; apply Rec; simpl in |- *; auto. +apply Le.le_S_n; auto. +Qed. + +(** *** Test functions *) + +(** Test if [s1] is a prefix of [s2] *) + +Fixpoint prefix (s1 s2 : string) {struct s2} : bool := + match s1 with + | EmptyString => true + | String a s1' => + match s2 with + | EmptyString => false + | String b s2' => + match ascii_dec a b with + | left _ => prefix s1' s2' + | right _ => false + end + end + end. + +(** If [s1] is a prefix of [s2], it is the [substring] of length + [length s1] starting at position [O] of [s2] *) + +Theorem prefix_correct : + forall s1 s2 : string, + prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. +Proof. +intros s1; elim s1; simpl in |- *; auto. +intros s2; case s2; simpl in |- *; split; auto. +intros a s1' Rec s2; case s2; simpl in |- *; auto. +split; intros; discriminate. +intros b s2'; case (ascii_dec a b); simpl in |- *; auto. +intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. +rewrite e; rewrite H1; auto. +apply H2; injection H3; auto. +intros n; split; intros; try discriminate. +case n; injection H; auto. +Qed. + +(** Test if, starting at position [n], [s1] occurs in [s2]; if + so it returns the position *) + +Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := + match s2, n with + | EmptyString, 0 => + match s1 with + | EmptyString => Some 0 + | String a s1' => None + end + | EmptyString, S n' => None + | String b s2', 0 => + if prefix s1 s2 then Some 0 + else + match index 0 s1 s2' with + | Some n => Some (S n) + | None => None + end + | String b s2', S n' => + match index n' s1 s2' with + | Some n => Some (S n) + | None => None + end + end. + +(* Dirty trick to evaluate locally that prefix reduces itself *) +Opaque prefix. + +(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *) + +Theorem index_correct1 : + forall (n m : nat) (s1 s2 : string), + index n s1 s2 = Some m -> substring m (length s1) s2 = s1. +Proof. +intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *; + auto. +intros n; case n; simpl in |- *; auto. +intros m s1; case s1; simpl in |- *; auto. +intros H; injection H; intros H1; rewrite <- H1; auto. +intros; discriminate. +intros; discriminate. +intros b s2' Rec n m s1. +case n; simpl in |- *; auto. +generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). +intros H0 H; injection H; intros H1; rewrite <- H1; auto. +case H0; simpl in |- *; auto. +case m; simpl in |- *; auto. +case (index 0 s1 s2'); intros; discriminate. +intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto. +intros; discriminate. +intros n'; case m; simpl in |- *; auto. +case (index n' s1 s2'); intros; discriminate. +intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. +intros x H H1; apply H; injection H1; intros H2; injection H2; auto. +intros; discriminate. +Qed. + +(** If the result of [index] is [Some m], + [s1] does not occur in [s2] before [m] *) + +Theorem index_correct2 : + forall (n m : nat) (s1 s2 : string), + index n s1 s2 = Some m -> + forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1. +Proof. +intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *; + auto. +intros n; case n; simpl in |- *; auto. +intros m s1; case s1; simpl in |- *; auto. +intros H; injection H; intros H1; rewrite <- H1. +intros p H0 H2; inversion H2. +intros; discriminate. +intros; discriminate. +intros b s2' Rec n m s1. +case n; simpl in |- *; auto. +generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). +intros H0 H; injection H; intros H1; rewrite <- H1; auto. +intros p H2 H3; inversion H3. +case m; simpl in |- *; auto. +case (index 0 s1 s2'); intros; discriminate. +intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto. +intros x H H0 H1 p; try case p; simpl in |- *; auto. +intros H2 H3; red in |- *; intros H4; case H0. +intros H5 H6; absurd (false = true); auto with bool. +intros n0 H2 H3; apply H; auto. +injection H1; intros H4; injection H4; auto. +apply Le.le_O_n. +apply Lt.lt_S_n; auto. +intros; discriminate. +intros n'; case m; simpl in |- *; auto. +case (index n' s1 s2'); intros; discriminate. +intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto. +intros x H H0 p; case p; simpl in |- *; auto. +intros H1; inversion H1; auto. +intros n0 H1 H2; apply H; auto. +injection H0; intros H3; injection H3; auto. +apply Le.le_S_n; auto. +apply Lt.lt_S_n; auto. +intros; discriminate. +Qed. + +(** If the result of [index] is [None], [s1] does not occur in [s2] + after [n] *) + +Theorem index_correct3 : + forall (n m : nat) (s1 s2 : string), + index n s1 s2 = None -> + s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1. +Proof. +intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *; + auto. +intros n; case n; simpl in |- *; auto. +intros m s1; case s1; simpl in |- *; auto. +case m; intros; red in |- *; intros; discriminate. +intros n' m; case m; auto. +intros s1; case s1; simpl in |- *; auto. +intros b s2' Rec n m s1. +case n; simpl in |- *; auto. +generalize (prefix_correct s1 (String b s2')); + case (prefix s1 (String b s2')). +intros; discriminate. +case m; simpl in |- *; auto with bool. +case s1; simpl in |- *; auto. +intros a s H H0 H1 H2; red in |- *; intros H3; case H. +intros H4 H5; absurd (false = true); auto with bool. +case s1; simpl in |- *; auto. +intros a s n0 H H0 H1 H2; + change (substring n0 (length (String a s)) s2' <> String a s) in |- *; + apply (Rec 0); auto. +generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros; + discriminate. +apply Le.le_O_n. +intros n'; case m; simpl in |- *; auto. +intros H H0 H1; inversion H1. +intros n0 H H0 H1; apply (Rec n'); auto. +generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros; + discriminate. +apply Le.le_S_n; auto. +Qed. + +(* Back to normal for prefix *) +Transparent prefix. + +(** If we are searching for the [Empty] string and the answer is no + this means that [n] is greater than the size of [s] *) + +Theorem index_correct4 : + forall (n : nat) (s : string), + index n EmptyString s = None -> length s < n. +Proof. +intros n s; generalize n; clear n; elim s; simpl in |- *; auto. +intros n; case n; simpl in |- *; auto. +intros; discriminate. +intros; apply Lt.lt_O_Sn. +intros a s' H n; case n; simpl in |- *; auto. +intros; discriminate. +intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *; + auto. +intros; discriminate. +intros H0 H1; apply Lt.lt_n_S; auto. +Qed. + +(** Same as [index] but with no optional type, we return [0] when it + does not occur *) + +Definition findex n s1 s2 := + match index n s1 s2 with + | Some n => n + | None => 0 + end. + +(** *** Concrete syntax *) + +(** + The concrete syntax for strings in scope string_scope follows the + Coq convention for strings: all ascii characters of code less than + 128 are litteral to the exception of the character `double quote' + which must be doubled. + + Strings that involve ascii characters of code >= 128 which are not + part of a valid utf8 sequence of characters are not representable + using the Coq string notation (use explicitly the String constructor + with the ascii codes of the characters). +*) + +Example HelloWorld := " ""Hello world!"" +". diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index a3f16888..940569bd 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,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Disjoint_Union.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Cristina Cornes From : Constructing Recursion Operators in Type Theory diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index 1677659c..f596640d 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inclusion.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Inclusion.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index f2cf1d2e..3323590e 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Inverse_Image.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Inverse_Image.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index d8a4d37c..988d2475 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Lexicographic_Exponentiation.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Lexicographic_Exponentiation.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Cristina Cornes diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 8ac178fc..035c1e65 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,v 1.12.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Lexicographic_Product.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Authors: Bruno Barras, Cristina Cornes *) diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 2e9d497b..5bf82ffb 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,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Transitive_Closure.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index 8f31ce9f..269cfd9d 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,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Union.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Bruno Barras *) diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index 4a20c518..e9a18e74 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,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Well_Ordering.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Author: Cristina Cornes. From: Constructing Recursion Operators in Type Theory diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v index 87c00b47..d5dfd072 100644 --- a/theories/Wellfounded/Wellfounded.v +++ b/theories/Wellfounded/Wellfounded.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wellfounded.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*) +(*i $Id: Wellfounded.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Export Disjoint_Union. Require Export Inclusion. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 11fa3872..02cf5f2d 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinInt.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ i*) +(*i $Id: BinInt.v 6295 2004-11-12 16:40:39Z gregoire $ i*) (***********************************************************) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) @@ -17,6 +17,8 @@ Require Export Pnat. Require Import BinNat. Require Import Plus. Require Import Mult. + +Unset Boxed Definitions. (**********************************************************************) (** Binary integer numbers *) @@ -1035,4 +1037,4 @@ Definition Zabs_N (z:Z) := Definition Z_of_N (x:N) := match x with | N0 => Z0 | Npos p => Zpos p - end.
\ No newline at end of file + end. diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 069ddd42..af1fdd0b 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf_Z.v,v 1.20.2.1 2004/07/16 19:31:20 herbelin Exp $ i*) +(*i $Id: Wf_Z.v 6984 2005-05-02 10:50:15Z herbelin $ i*) Require Import BinInt. Require Import Zcompare. @@ -176,11 +176,11 @@ apply X; auto; unfold R in |- *; intuition; apply Zlt_pred. intros; elim H; simpl in |- *; trivial. Qed. -(** A more general induction principal using [Zlt]. *) +(** A more general induction principle on non-negative numbers using [Zlt]. *) -Lemma Z_lt_rec : +Lemma Zlt_0_rec : forall P:Z -> Type, - (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> + (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. Proof. intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf). @@ -189,10 +189,29 @@ apply Hrec; intros. assert (H2 : 0 < 0). apply Zle_lt_trans with y; intuition. inversion H2. +assumption. firstorder. unfold Zle, Zcompare in H; elim H; auto. Defined. +Lemma Zlt_0_ind : + forall P:Z -> Prop, + (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> + forall x:Z, 0 <= x -> P x. +Proof. +exact Zlt_0_rec. +Qed. + +(** Obsolete version of [Zlt] induction principle on non-negative numbers *) + +Lemma Z_lt_rec : + forall P:Z -> Type, + (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> + forall x:Z, 0 <= x -> P x. +Proof. +intros P Hrec; apply Zlt_0_rec; auto. +Qed. + Lemma Z_lt_induction : forall P:Z -> Prop, (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) -> @@ -201,4 +220,37 @@ Proof. exact Z_lt_rec. Qed. +(** An even more general induction principle using [Zlt]. *) + +Lemma Zlt_lower_bound_rec : + forall P:Z -> Type, forall z:Z, + (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> + forall x:Z, z <= x -> P x. +Proof. +intros P z Hrec x. +assert (Hexpand : forall x, x = x - z + z). + intro; unfold Zminus; rewrite <- Zplus_assoc; rewrite Zplus_opp_l; + rewrite Zplus_0_r; trivial. +intro Hz. +rewrite (Hexpand x); pattern (x - z) in |- *; apply Zlt_0_rec. +2: apply Zplus_le_reg_r with z; rewrite <- Hexpand; assumption. +intros x0 Hlt_x0 H. +apply Hrec. + 2: change z with (0+z); apply Zplus_le_compat_r; assumption. + intro y; rewrite (Hexpand y); intros. +destruct H0. +apply Hlt_x0. +split. + apply Zplus_le_reg_r with z; assumption. + apply Zplus_lt_reg_r with z; assumption. +Qed. + +Lemma Zlt_lower_bound_ind : + forall P:Z -> Prop, forall z:Z, + (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> + forall x:Z, z <= x -> P x. +Proof. +exact Zlt_lower_bound_rec. +Qed. + End Efficient_Rec. diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index 7e361621..45749fa3 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZArith.v,v 1.5.2.2 2004/08/03 17:56:30 herbelin Exp $ i*) +(*i $Id: ZArith.v 6013 2004-08-03 17:56:19Z herbelin $ i*) (** Library for manipulating integers based on binary encoding *) diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 694e071e..20fd6b5f 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZArith_base.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ *) +(* $Id: ZArith_base.v 8032 2006-02-12 21:20:48Z herbelin $ *) (** Library for manipulating integers based on binary encoding. These are the basic modules, required by [Omega] and [Ring] for instance. @@ -19,6 +19,8 @@ Require Export Zcompare. Require Export Zorder. Require Export Zeven. Require Export Zmin. +Require Export Zmax. +Require Export Zminmax. Require Export Zabs. Require Export Znat. Require Export auxiliary. @@ -31,4 +33,4 @@ Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l Zmult_plus_distr_r: zarith. -Require Export Zhints.
\ No newline at end of file +Require Export Zhints. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index dbd0df6c..40c5860c 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,v 1.11.2.1 2004/07/16 19:31:20 herbelin Exp $ i*) +(*i $Id: ZArith_dec.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import Sumbool. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 90e4c2a4..fed6ad76 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zabs.v,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zabs.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v index fa5f00dc..353f0d5d 100644 --- a/theories/ZArith/Zbinary.v +++ b/theories/ZArith/Zbinary.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zbinary.v,v 1.6.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zbinary.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Bit vectors interpreted as integers. Contribution by Jean Duprat (ENS Lyon). *) diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index bb8abef4..a195b951 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,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ *) +(* $Id: Zbool.v 6295 2004-11-12 16:40:39Z gregoire $ *) Require Import BinInt. Require Import Zeven. @@ -15,6 +15,8 @@ Require Import Zcompare. Require Import ZArith_dec. Require Import Sumbool. +Unset Boxed Definitions. + (** The decidability of equality and order relations over type [Z] give some boolean functions with the adequate specification. *) diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index b60cd37c..817fbc1b 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zcomplements.v,v 1.26.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zcomplements.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import ZArithRing. Require Import ZArith_base. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 84eb2259..e391d087 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zdiv.v,v 1.21.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zdiv.v 6295 2004-11-12 16:40:39Z gregoire $ i*) (* Contribution by Claude Marché and Xavier Urbain *) @@ -36,7 +36,7 @@ Open Local Scope Z_scope. *) -Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : +Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : Z * Z := match a with | xH => if Zge_bool b 2 then (0, 1) else (1, 0) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index a4a9abde..72d2d828 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zeven.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zeven.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import BinInt. diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index a9ee2c87..d0a2d2a0 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zhints.v,v 1.8.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zhints.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** This file centralizes the lemmas about [Z], classifying them according to the way they can be used in automatic search *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index b575de88..653ee951 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zlogarithm.v,v 1.14.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zlogarithm.v 6295 2004-11-12 16:40:39Z gregoire $ i*) (**********************************************************************) (** The integer logarithms with base 2. @@ -36,6 +36,7 @@ Fixpoint log_inf (p:positive) : Z := | xO q => Zsucc (log_inf q) (* 2n *) | xI q => Zsucc (log_inf q) (* 2n+1 *) end. + Fixpoint log_sup (p:positive) : Z := match p with | xH => 0 (* 1 *) diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v new file mode 100644 index 00000000..ae3bbf41 --- /dev/null +++ b/theories/ZArith/Zmax.v @@ -0,0 +1,108 @@ +(************************************************************************) +(* 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: Zmax.v 8032 2006-02-12 21:20:48Z herbelin $ i*) + +Require Import Arith. +Require Import BinInt. +Require Import Zcompare. +Require Import Zorder. + +Open Local Scope Z_scope. + +(**********************************************************************) +(** *** Maximum of two binary integer numbers *) + +Definition Zmax m n := + match m ?= n with + | Eq | Gt => m + | Lt => n + end. + +(** Characterization of maximum on binary integer numbers *) + +Lemma Zmax_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmax n m). +Proof. +intros n m P H1 H2; unfold Zmax in |- *; case (n ?= m); auto with arith. +Qed. + +Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), + (m<=n -> P n) -> (n<=m -> P m) -> P (Zmax n m). +Proof. +intros n m P H1 H2; unfold Zmax, Zle, Zge in *. +rewrite <- (Zcompare_antisym n m) in H1. +destruct (n ?= m); (apply H1|| apply H2); discriminate. +Qed. + +(** Least upper bound properties of max *) + +Lemma Zle_max_l : forall n m:Z, n <= Zmax n m. +Proof. +intros; apply Zmax_case_strong; auto with zarith. +Qed. + +Notation Zmax1 := Zle_max_l (only parsing). + +Lemma Zle_max_r : forall n m:Z, m <= Zmax n m. +Proof. +intros; apply Zmax_case_strong; auto with zarith. +Qed. + +Notation Zmax2 := Zle_max_r (only parsing). + +Lemma Zmax_lub : forall n m p:Z, n <= p -> m <= p -> Zmax n m <= p. +Proof. +intros; apply Zmax_case; assumption. +Qed. + +(** Semi-lattice properties of max *) + +Lemma Zmax_idempotent : forall n:Z, Zmax n n = n. +Proof. +intros; apply Zmax_case; auto. +Qed. + +Lemma Zmax_comm : forall n m:Z, Zmax n m = Zmax m n. +Proof. +intros; do 2 apply Zmax_case_strong; intros; + apply Zle_antisym; auto with zarith. +Qed. + +Lemma Zmax_assoc : forall n m p:Z, Zmax n (Zmax m p) = Zmax (Zmax n m) p. +Proof. +intros n m p; repeat apply Zmax_case_strong; intros; + reflexivity || (try apply Zle_antisym); eauto with zarith. +Qed. + +(** Additional properties of max *) + +Lemma Zmax_irreducible_inf : forall n m:Z, Zmax n m = n \/ Zmax n m = m. +Proof. +intros; apply Zmax_case; auto. +Qed. + +Lemma Zmax_le_prime_inf : forall n m p:Z, p <= Zmax n m -> p <= n \/ p <= m. +Proof. +intros n m p; apply Zmax_case; auto. +Qed. + +(** Operations preserving max *) + +Lemma Zsucc_max_distr : + forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m). +Proof. +intros n m; unfold Zmax in |- *; rewrite (Zcompare_succ_compat n m); + elim_compare n m; intros E; rewrite E; auto with arith. +Qed. + +Lemma Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p. +Proof. +intros x y n; unfold Zmax in |- *. +rewrite (Zplus_comm x n); rewrite (Zplus_comm y n); + rewrite (Zcompare_plus_compat x y n). +case (x ?= y); apply Zplus_comm. +Qed. diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index d48e62c5..d79ebe98 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -5,9 +5,12 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmin.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*) +(*i $Id: Zmin.v 8032 2006-02-12 21:20:48Z herbelin $ i*) -(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) +(** 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). + *) Require Import Arith. Require Import BinInt. @@ -17,23 +20,31 @@ Require Import Zorder. Open Local Scope Z_scope. (**********************************************************************) -(** Minimum on binary integer numbers *) +(** *** Minimum on binary integer numbers *) -Definition Zmin (n m:Z) := - match n ?= m return Z with - | Eq => n - | Lt => n +Unboxed Definition Zmin (n m:Z) := + match n ?= m with + | Eq | Lt => n | Gt => m end. -(** Properties of minimum on binary integer numbers *) +(** Characterization of the minimum on binary integer numbers *) -Lemma Zmin_SS : forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). +Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), + (n<=m -> P n) -> (m<=n -> P m) -> P (Zmin n m). Proof. -intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m); - elim_compare n m; intros E; rewrite E; auto with arith. +intros n m P H1 H2; unfold Zmin, Zle, Zge in *. +rewrite <- (Zcompare_antisym n m) in H2. +destruct (n ?= m); (apply H1|| apply H2); discriminate. Qed. +Lemma Zmin_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmin n m). +Proof. +intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith. +Qed. + +(** Greatest lower bound properties of min *) + Lemma Zle_min_l : forall n m:Z, Zmin n m <= n. Proof. intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E; @@ -50,57 +61,70 @@ intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E; | apply Zle_refl ]. Qed. -Lemma Zmin_case : forall (n m:Z) (P:Z -> Set), P n -> P m -> P (Zmin n m). +Lemma Zmin_glb : forall n m p:Z, p <= n -> p <= m -> p <= Zmin n m. Proof. -intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith. +intros; apply Zmin_case; assumption. Qed. -Lemma Zmin_or : forall n m:Z, Zmin n m = n \/ Zmin n m = m. +(** Semi-lattice properties of min *) + +Lemma Zmin_idempotent : forall n:Z, Zmin n n = n. Proof. -unfold Zmin in |- *; intros; elim (n ?= m); auto. +unfold Zmin in |- *; intros; elim (n ?= n); auto. Qed. -Lemma Zmin_n_n : forall n:Z, Zmin n n = n. +Notation Zmin_n_n := Zmin_idempotent (only parsing). + +Lemma Zmin_comm : forall n m:Z, Zmin n m = Zmin m n. Proof. -unfold Zmin in |- *; intros; elim (n ?= n); auto. +intros n m; unfold Zmin. +rewrite <- (Zcompare_antisym n m). +assert (H:=Zcompare_Eq_eq n m). +destruct (n ?= m); simpl; auto. Qed. -Lemma Zmin_plus : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p. +Lemma Zmin_assoc : forall n m p:Z, Zmin n (Zmin m p) = Zmin (Zmin n m) p. Proof. -intros x y n; unfold Zmin in |- *. -rewrite (Zplus_comm x n); rewrite (Zplus_comm y n); - rewrite (Zcompare_plus_compat x y n). -case (x ?= y); apply Zplus_comm. +intros n m p; repeat apply Zmin_case_strong; intros; + reflexivity || (try apply Zle_antisym); eauto with zarith. Qed. -(**********************************************************************) -(** Maximum of two binary integer numbers *) +(** Additional properties of min *) -Definition Zmax a b := match a ?= b with - | Lt => b - | _ => a - end. +Lemma Zmin_irreducible_inf : forall n m:Z, {Zmin n m = n} + {Zmin n m = m}. +Proof. +unfold Zmin in |- *; intros; elim (n ?= m); auto. +Qed. -(** Properties of maximum on binary integer numbers *) +Lemma Zmin_irreducible : forall n m:Z, Zmin n m = n \/ Zmin n m = m. +Proof. +intros n m; destruct (Zmin_irreducible_inf n m); [left|right]; trivial. +Qed. -Ltac CaseEq name := - generalize (refl_equal name); pattern name at -1 in |- *; case name. +Notation Zmin_or := Zmin_irreducible (only parsing). -Theorem Zmax1 : forall a b, a <= Zmax a b. +Lemma Zmin_le_prime_inf : forall n m p:Z, Zmin n m <= p -> {n <= p} + {m <= p}. Proof. -intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *; - auto with zarith. -unfold Zle in |- *; intros H; rewrite H; red in |- *; intros; discriminate. +intros n m p; apply Zmin_case; auto. Qed. -Theorem Zmax2 : forall a b, b <= Zmax a b. +(** Operations preserving min *) + +Lemma Zsucc_min_distr : + forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). Proof. -intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *; - auto with zarith. -intros H; - (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros; - discriminate). -intros H; - (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros; - discriminate). +intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m); + elim_compare n m; intros E; rewrite E; auto with arith. Qed. + +Notation Zmin_SS := Zsucc_min_distr (only parsing). + +Lemma Zplus_min_distr_r : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p. +Proof. +intros x y n; unfold Zmin in |- *. +rewrite (Zplus_comm x n); rewrite (Zplus_comm y n); + rewrite (Zcompare_plus_compat x y n). +case (x ?= y); apply Zplus_comm. +Qed. + +Notation Zmin_plus := Zplus_min_distr_r (only parsing). diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v new file mode 100644 index 00000000..ebe9318e --- /dev/null +++ b/theories/ZArith/Zminmax.v @@ -0,0 +1,82 @@ +(************************************************************************) +(* 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: Zminmax.v 8034 2006-02-12 22:08:04Z herbelin $ i*) + +Require Import Zmin Zmax. +Require Import BinInt Zorder. + +Open Local Scope Z_scope. + +(** *** Lattice properties of min and max on Z *) + +(** Absorption *) + +Lemma Zmin_max_absorption_r_r : forall n m, Zmax n (Zmin n m) = n. +Proof. +intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; + reflexivity || apply Zle_antisym; trivial. +Qed. + +Lemma Zmax_min_absorption_r_r : forall n m, Zmin n (Zmax n m) = n. +Proof. +intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; + reflexivity || apply Zle_antisym; trivial. +Qed. + +(** Distributivity *) + +Lemma Zmax_min_distr_r : + forall n m p, Zmax n (Zmin m p) = Zmin (Zmax n m) (Zmax n p). +Proof. +intros. +repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + reflexivity || + apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). +Qed. + +Lemma Zmin_max_distr_r : + forall n m p, Zmin n (Zmax m p) = Zmax (Zmin n m) (Zmin n p). +Proof. +intros. +repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + reflexivity || + apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). +Qed. + +(** Modularity *) + +Lemma Zmax_min_modular_r : + forall n m p, Zmax n (Zmin m (Zmax n p)) = Zmin (Zmax n m) (Zmax n p). +Proof. +intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + reflexivity || + apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). +Qed. + +Lemma Zmin_max_modular_r : + forall n m p, Zmin n (Zmax m (Zmin n p)) = Zmax (Zmin n m) (Zmin n p). +Proof. +intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + reflexivity || + apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). +Qed. + +(** Disassociativity *) + +Lemma max_min_disassoc : forall n m p, Zmin n (Zmax m p) <= Zmax (Zmin n m) p. +Proof. +intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + apply Zle_refl || (assumption || eapply Zle_trans; eassumption). +Qed. + + + + + + + diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index adcaf0ba..8246e324 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zmisc.v,v 1.20.2.1 2004/07/16 19:31:22 herbelin Exp $ i*) +(*i $Id: Zmisc.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import BinInt. Require Import Zcompare. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index d051ed74..3e27878c 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znat.v,v 1.3.2.1 2004/07/16 19:31:22 herbelin Exp $ i*) +(*i $Id: Znat.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 715cdc7d..a1963446 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znumtheory.v,v 1.5.2.1 2004/07/16 19:31:22 herbelin Exp $ i*) +(*i $Id: Znumtheory.v 6984 2005-05-02 10:50:15Z herbelin $ i*) Require Import ZArith_base. Require Import ZArithRing. @@ -278,12 +278,12 @@ Lemma euclid_rec : (forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid. Proof. intros v3 Hv3; generalize Hv3; pattern v3 in |- *. -apply Z_lt_rec. +apply Zlt_0_rec. clear v3 Hv3; intros. elim (Z_zerop x); intro. apply Euclid_intro with (u := u1) (v := u2) (d := u3). assumption. -apply H2. +apply H3. rewrite a0; auto with zarith. set (q := u3 / x) in *. assert (Hq : 0 <= u3 - q * x < x). @@ -297,9 +297,9 @@ apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)). tauto. replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with (u1 * a + u2 * b - q * (v1 * a + v2 * b)). -rewrite H0; rewrite H1; trivial. +rewrite H1; rewrite H2; trivial. ring. -intros; apply H2. +intros; apply H3. apply Zis_gcd_for_euclid with q; assumption. assumption. Qed. @@ -377,11 +377,11 @@ Definition Zgcd_pos : Proof. intros a Ha. apply - (Z_lt_rec + (Zlt_0_rec (fun a:Z => forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0})); try assumption. intro x; case x. -intros _ b; exists (Zabs b). +intros _ _ b; exists (Zabs b). elim (Z_le_lt_eq_dec _ _ (Zabs_pos b)). intros H0; split. apply Zabs_ind. @@ -393,7 +393,7 @@ intros _ b; exists (Zabs b). rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *. split; [ apply Zis_gcd_0 | idtac ]; auto with zarith. -intros p Hrec b. +intros p Hrec _ b. generalize (Z_div_mod b (Zpos p)). case (Zdiv_eucl b (Zpos p)); intros q r Hqr. elim Hqr; clear Hqr; intros; auto with zarith. @@ -405,8 +405,7 @@ split; auto. rewrite H. apply Zis_gcd_for_euclid2; auto. -intros p Hrec b. -exists 0; intros. +intros p _ H b. elim H; auto. Defined. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 27eb02cd..b81cc580 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zorder.v,v 1.6.2.3 2005/03/29 15:35:12 herbelin Exp $ i*) +(*i $Id: Zorder.v 6983 2005-05-02 10:47:51Z herbelin $ i*) (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *) @@ -905,23 +905,23 @@ Qed. (** Simplification of square wrt order *) Lemma Zgt_square_simpl : - forall n m:Z, n >= 0 -> m >= 0 -> n * n > m * m -> n > m. + forall n m:Z, n >= 0 -> n * n > m * m -> n > m. Proof. -intros x y H0 H1 H2. -case (dec_Zlt y x). +intros n m H0 H1. +case (dec_Zlt m n). intro; apply Zlt_gt; trivial. -intros H3; cut (y >= x). +intros H2; cut (m >= n). intros H. -elim Zgt_not_le with (1 := H2). +elim Zgt_not_le with (1 := H1). apply Zge_le. apply Zmult_ge_compat; auto. apply Znot_lt_ge; trivial. Qed. Lemma Zlt_square_simpl : - forall n m:Z, 0 <= n -> 0 <= m -> m * m < n * n -> m < n. + forall n m:Z, 0 <= n -> m * m < n * n -> m < n. Proof. -intros x y H0 H1 H2. +intros x y H0 H1. apply Zgt_lt. apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption. Qed. @@ -967,5 +967,17 @@ intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l; rewrite Zplus_comm; exact H. Qed. +Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n. +Proof. +intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l; + rewrite Zplus_comm; exact H. +Qed. + +Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m. +Proof. +intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); +rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. +Qed. + (* For compatibility *) Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing). diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index e5bf8b04..70a2bd45 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Zpower.v,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ i*) +(*i $Id: Zpower.v 5920 2004-07-16 20:01:26Z herbelin $ i*) Require Import ZArith_base. Require Import Omega. diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v index 583c5828..cf4acb5f 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,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ *) +(* $Id: Zsqrt.v 6199 2004-10-11 11:39:18Z herbelin $ *) Require Import Omega. Require Export ZArith_base. @@ -22,12 +22,12 @@ Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => match constr:X1 with - | context [1%positive] => fail + | context [1%positive] => fail 1 | _ => rewrite (BinInt.Zpos_xI X1) end | |- context [(Zpos (xO ?X1))] => match constr:X1 with - | context [1%positive] => fail + | context [1%positive] => fail 1 | _ => rewrite (BinInt.Zpos_xO X1) end end. diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 8633986b..4ff663fb 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Zwf.v,v 1.7.2.1 2004/07/16 19:31:22 herbelin Exp $ *) +(* $Id: Zwf.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Import ZArith_base. Require Export Wf_nat. diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index ecd2daab..28cbd1e4 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: auxiliary.v,v 1.12.2.1 2004/07/16 19:31:22 herbelin Exp $ i*) +(*i $Id: auxiliary.v 5920 2004-07-16 20:01:26Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) |