diff options
| author |  Stephane Glondu <steph@glondu.net> | 2009-02-01 00:54:40 +0100 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2009-02-01 00:54:40 +0100 |
| commit | cfbfe13f5b515ae2e3c6cdd97e2ccee03bc26e56 (patch) | |
| tree | b7832bd5d412a5a5d69cb36ae2ded62c71124c22 /theories | |
| parent | 113b703a695acbe31ac6dd6a8c4aa94f6fda7545 (diff) | |
Imported Upstream version 8.2~rc2+dfsgupstream/8.2.rc2+dfsg
Diffstat (limited to 'theories')
80 files changed, 3481 insertions, 2532 deletions
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 1216a545..7cab976f 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 10625 2008-03-06 11:21:01Z notin $ i*) +(*i $Id: Div2.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Lt. Require Import Plus. @@ -60,45 +60,38 @@ Hint Resolve lt_div2: arith. (** Properties related to the parity *) -Lemma even_odd_div2 : - forall n, - (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)). +Lemma even_div2 : forall n, even n -> div2 n = div2 (S n) +with odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n). Proof. - intro n. pattern n in |- *. apply ind_0_1_SS. - (* n = 0 *) - split. split; auto with arith. - split. intro H. inversion H. - intro H. absurd (S (div2 0) = div2 1); auto with arith. - (* n = 1 *) - split. split. intro. inversion H. inversion H1. - intro H. absurd (div2 1 = div2 2). - simpl in |- *. discriminate. assumption. - split; auto with arith. - (* n = (S (S n')) *) - intros. decompose [and] H. unfold iff in H0, H1. - decompose [and] H0. decompose [and] H1. clear H H0 H1. - split; split; auto with arith. - intro H. inversion H. inversion H1. - change (S (div2 n0) = S (div2 (S n0))) in |- *. auto with arith. - intro H. inversion H. inversion H1. - change (S (S (div2 n0)) = S (div2 (S n0))) in |- *. auto with arith. + destruct n; intro H. + (* 0 *) trivial. + (* S n *) inversion_clear H. apply odd_div2 in H0 as <-. trivial. + destruct n; intro. + (* 0 *) inversion H. + (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial. Qed. -(** Specializations *) - -Lemma even_div2 : forall n, even n -> div2 n = div2 (S n). -Proof fun n => proj1 (proj1 (even_odd_div2 n)). +Lemma div2_even : forall n, div2 n = div2 (S n) -> even n +with div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n. +Proof. + destruct n; intro H. + (* 0 *) constructor. + (* S n *) constructor. apply div2_odd. rewrite H. trivial. + destruct n; intro H. + (* 0 *) discriminate. + (* S n *) constructor. apply div2_even. injection H as <-. trivial. +Qed. -Lemma div2_even : forall n, div2 n = div2 (S n) -> even n. -Proof fun n => proj2 (proj1 (even_odd_div2 n)). +Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. -Lemma odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n). -Proof fun n => proj1 (proj2 (even_odd_div2 n)). +Lemma even_odd_div2 : + forall n, + (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)). +Proof. + auto decomp using div2_odd, div2_even, odd_div2, even_div2. +Qed. -Lemma div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n. -Proof fun n => proj2 (proj2 (even_odd_div2 n)). -Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. (** Properties related to the double ([2n]) *) @@ -132,8 +125,7 @@ Proof. split; split; auto with arith. intro H. inversion H. inversion H1. (* n = (S (S n')) *) - intros. decompose [and] H. unfold iff in H0, H1. - decompose [and] H0. decompose [and] H1. clear H H0 H1. + intros. destruct H as ((IH1,IH2),(IH3,IH4)). split; split. intro H. inversion H. inversion H1. simpl in |- *. rewrite (double_S (div2 n0)). auto with arith. @@ -142,8 +134,6 @@ Proof. simpl in |- *. rewrite (double_S (div2 n0)). auto with arith. simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith. Qed. - - (** Specializations *) Lemma even_double : forall n, even n -> n = double (div2 n). diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 1484666b..59209370 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 10410 2007-12-31 13:11:55Z msozeau $ i*) +(*i $Id: Even.v 11512 2008-10-27 12:28:36Z herbelin $ i*) (** Here we define the predicates [even] and [odd] by mutual induction and we prove the decidability and the exclusion of those predicates. @@ -52,153 +52,91 @@ Qed. (** * Facts about [even] & [odd] wrt. [plus] *) -Lemma even_plus_aux : - forall n m, - (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\ - (even (n + m) <-> even n /\ even m \/ odd n /\ odd m). +Lemma even_plus_split : forall n m, + (even (n + m) -> even n /\ even m \/ odd n /\ odd m) +with odd_plus_split : forall n m, + odd (n + m) -> odd n /\ even m \/ even n /\ odd m. Proof. - intros n; elim n; simpl in |- *; auto with arith. - intros m; split; auto. - split. - intros H; right; split; auto with arith. - intros H'; case H'; auto with arith. - intros H'0; elim H'0; intros H'1 H'2; inversion H'1. - intros H; elim H; auto. - split; auto with arith. - intros H'; elim H'; auto with arith. - intros H; elim H; auto. - intros H'0; elim H'0; intros H'1 H'2; inversion H'1. - intros n0 H' m; elim (H' m); intros H'1 H'2; elim H'1; intros E1 E2; elim H'2; - intros E3 E4; clear H'1 H'2. - split; split. - intros H'0; case E3. - inversion H'0; auto. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H'0; case H'0; intros C0; case C0; intros C1 C2. - apply odd_S. - apply E4; left; split; auto with arith. - inversion C1; auto. - apply odd_S. - apply E4; right; split; auto with arith. - inversion C1; auto. - intros H'0. - case E1. - inversion H'0; auto. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H; elim H; intros H0 H1; clear H; auto with arith. - intros H'0; case H'0; intros C0; case C0; intros C1 C2. - apply even_S. - apply E2; left; split; auto with arith. - inversion C1; auto. - apply even_S. - apply E2; right; split; auto with arith. - inversion C1; auto. +intros. clear even_plus_split. destruct n; simpl in *. + auto with arith. + inversion_clear H; + apply odd_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. +intros. clear odd_plus_split. destruct n; simpl in *. + auto with arith. + inversion_clear H; + apply even_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith. Qed. - -Lemma even_even_plus : forall n m, even n -> even m -> even (n + m). + +Lemma even_even_plus : forall n m, even n -> even m -> even (n + m) +with odd_plus_l : forall n m, odd n -> even m -> odd (n + m). Proof. - intros n m; case (even_plus_aux n m). - intros H H0; case H0; auto. +intros n m [|] ?. trivial. apply even_S, odd_plus_l; trivial. +intros n m [] ?. apply odd_S, even_even_plus; trivial. Qed. - -Lemma odd_even_plus : forall n m, odd n -> odd m -> even (n + m). + +Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m) +with odd_even_plus : forall n m, odd n -> odd m -> even (n + m). Proof. - intros n m; case (even_plus_aux n m). - intros H H0; case H0; auto. +intros n m [|] ?. trivial. apply odd_S, odd_even_plus; trivial. +intros n m [] ?. apply even_S, odd_plus_r; trivial. +Qed. + +Lemma even_plus_aux : forall n m, + (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\ + (even (n + m) <-> even n /\ even m \/ odd n /\ odd m). +Proof. +split; split; auto using odd_plus_split, even_plus_split. +intros [[]|[]]; auto using odd_plus_r, odd_plus_l. +intros [[]|[]]; auto using even_even_plus, odd_even_plus. Qed. Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0; elim H0; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0; elim H0; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'0. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Hint Resolve even_even_plus odd_even_plus: arith. -Lemma odd_plus_l : forall n m, odd n -> even m -> odd (n + m). -Proof. - intros n m; case (even_plus_aux n m). - intros H; case H; auto. -Qed. - -Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m). -Proof. - intros n m; case (even_plus_aux n m). - intros H; case H; auto. -Qed. - Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0; case H0; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0; case H0; auto. - intros H0 H1 H2; case (not_even_and_odd m); auto. - case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd m); auto. Qed. Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m. Proof. - intros n m H; case (even_plus_aux n m). - intros H' H'0; elim H'. - intros H'1; case H'1; auto. - intros H0 H1 H2; case (not_even_and_odd n); auto. - case H0; auto. - intros H0; case H0; auto. + intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. + intro; destruct (not_even_and_odd n); auto. Qed. Hint Resolve odd_plus_l odd_plus_r: arith. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 95af67f8..5de2298d 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 9883 2007-06-07 18:44:59Z letouzey $ i*) +(*i $Id: Max.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Le. @@ -74,13 +74,13 @@ Lemma max_dec : forall n m, {max n m = n} + {max n m = m}. Proof. induction n; induction m; simpl in |- *; auto with arith. elim (IHn m); intro H; elim H; auto. -Qed. +Defined. 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. +Defined. Notation max_case2 := max_case (only parsing). diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 1e58d05d..157217ae 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -10,13 +9,12 @@ (* Decidable equivalences. * * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud + * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud * 91405 Orsay, France *) -(* $Id: EquivDec.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: EquivDec.v 11800 2009-01-18 18:34:15Z msozeau $ *) -Set Implicit Arguments. -Unset Strict Implicit. +Set Manual Implicit Arguments. (** Export notations. *) @@ -29,12 +27,12 @@ Require Import Coq.Logic.Decidable. Open Scope equiv_scope. -Class [ equiv : Equivalence A ] => DecidableEquivalence := +Class DecidableEquivalence `(equiv : Equivalence A) := setoid_decidable : forall x y : A, decidable (x === y). (** The [EqDec] class gives a decision procedure for a particular setoid equality. *) -Class [ equiv : Equivalence A ] => EqDec := +Class EqDec A R {equiv : Equivalence R} := equiv_dec : forall x y : A, { x === y } + { x =/= y }. (** We define the [==] overloaded notation for deciding equality. It does not take precedence @@ -54,7 +52,7 @@ Open Local Scope program_scope. (** Invert the branches. *) -Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). +Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) @@ -62,10 +60,10 @@ Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope. (** Define boolean versions, losing the logical information. *) -Definition equiv_decb [ EqDec A ] (x y : A) : bool := +Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. -Definition nequiv_decb [ EqDec A ] (x y : A) : bool := +Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). @@ -77,16 +75,13 @@ Require Import Coq.Arith.Peano_dec. (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) -Program Instance nat_eq_eqdec : ! EqDec nat eq := - equiv_dec := eq_nat_dec. +Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. Require Import Coq.Bool.Bool. -Program Instance bool_eqdec : ! EqDec bool eq := - equiv_dec := bool_dec. +Program Instance bool_eqdec : EqDec bool eq := bool_dec. -Program Instance unit_eqdec : ! EqDec unit eq := - equiv_dec x y := in_left. +Program Instance unit_eqdec : EqDec unit eq := λ x y, in_left. Next Obligation. Proof. @@ -94,39 +89,38 @@ Program Instance unit_eqdec : ! EqDec unit eq := reflexivity. Qed. -Program Instance prod_eqdec [ EqDec A eq, EqDec B eq ] : +Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : ! EqDec (prod A B) eq := - equiv_dec x y := + { equiv_dec x y := let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then if x2 == y2 then in_left else in_right - else in_right. + else in_right }. Solve Obligations using unfold complement, equiv ; program_simpl. -Program Instance sum_eqdec [ EqDec A eq, EqDec B eq ] : - ! EqDec (sum A B) eq := +Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : + EqDec (sum A B) eq := { equiv_dec x y := match x, y with | inl a, inl b => if a == b then in_left else in_right | inr a, inr b => if a == b then in_left else in_right | inl _, inr _ | inr _, inl _ => in_right - end. + end }. Solve Obligations using unfold complement, equiv ; program_simpl. -(** Objects of function spaces with countable domains like bool have decidable equality. *) - -Require Import Coq.Program.FunctionalExtensionality. +(** Objects of function spaces with countable domains like bool have decidable equality. + Proving the reflection requires functional extensionality though. *) -Program Instance bool_function_eqdec [ EqDec A eq ] : ! EqDec (bool -> A) eq := - equiv_dec f g := +Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := + { equiv_dec f g := if f true == g true then if f false == g false then in_left else in_right - else in_right. + else in_right }. Solve Obligations using try red ; unfold equiv, complement ; program_simpl. @@ -138,8 +132,8 @@ Program Instance bool_function_eqdec [ EqDec A eq ] : ! EqDec (bool -> A) eq := Require Import List. -Program Instance list_eqdec [ eqa : EqDec A eq ] : ! EqDec (list A) eq := - equiv_dec := +Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := + { equiv_dec := fix aux (x : list A) y { struct x } := match x, y with | nil, nil => in_left @@ -148,7 +142,7 @@ Program Instance list_eqdec [ eqa : EqDec A eq ] : ! EqDec (list A) eq := if aux tl tl' then in_left else in_right else in_right | _, _ => in_right - end. + end }. Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index d52eed47..5e5895ab 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -13,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Equivalence.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Equivalence.v 11709 2008-12-20 11:42:15Z msozeau $ *) Require Export Coq.Program.Basics. Require Import Coq.Program.Tactics. @@ -28,9 +27,7 @@ Unset Strict Implicit. Open Local Scope signature_scope. -Definition equiv [ Equivalence A R ] : relation A := R. - -Typeclasses unfold equiv. +Definition equiv `{Equivalence A R} : relation A := R. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) @@ -42,9 +39,7 @@ Open Local Scope equiv_scope. (** Overloading for [PER]. *) -Definition pequiv [ PER A R ] : relation A := R. - -Typeclasses unfold pequiv. +Definition pequiv `{PER A R} : relation A := R. (** Overloaded notation for partial equivalence. *) @@ -52,16 +47,11 @@ Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope. (** Shortcuts to make proof search easier. *) -Program Instance equiv_reflexive [ sa : Equivalence A ] : Reflexive equiv. - -Program Instance equiv_symmetric [ sa : Equivalence A ] : Symmetric equiv. +Program Instance equiv_reflexive `(sa : Equivalence A) : Reflexive equiv. - Next Obligation. - Proof. - symmetry ; auto. - Qed. +Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv. -Program Instance equiv_transitive [ sa : Equivalence A ] : Transitive equiv. +Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. Next Obligation. Proof. @@ -113,13 +103,12 @@ Section Respecting. (** Here we build an equivalence instance for functions which relates respectful ones only, we do not export it. *) - Definition respecting [ Equivalence A (R : relation A), Equivalence B (R' : relation B) ] : Type := + Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := { morph : A -> B | respectful R R' morph morph }. - Program Instance respecting_equiv [ eqa : Equivalence A R, eqb : Equivalence B R' ] : - Equivalence respecting - (fun (f g : respecting) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). - + Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : + Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). + Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. @@ -131,13 +120,10 @@ End Respecting. (** The default equivalence on function spaces, with higher-priority than [eq]. *) -Program Instance pointwise_equivalence [ eqb : Equivalence B eqB ] : - Equivalence (A -> B) (pointwise_relation eqB) | 9. - - Solve Obligations using simpl_relation ; first [ reflexivity | (symmetry ; auto) ]. +Program Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) : + Equivalence (pointwise_relation A eqB) | 9. Next Obligation. Proof. - transitivity (y x0) ; auto. + transitivity (y a) ; auto. Qed. - diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v index 4c844911..998f8cb7 100644 --- a/theories/Classes/Functions.v +++ b/theories/Classes/Functions.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -13,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Functions.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Functions.v 11709 2008-12-20 11:42:15Z msozeau $ *) Require Import Coq.Classes.RelationClasses. Require Import Coq.Classes.Morphisms. @@ -21,22 +20,22 @@ Require Import Coq.Classes.Morphisms. Set Implicit Arguments. Unset Strict Implicit. -Class Injective ((m : Morphism (A -> B) (RA ++> RB) f)) : Prop := +Class Injective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop := injective : forall x y : A, RB (f x) (f y) -> RA x y. -Class ((m : Morphism (A -> B) (RA ++> RB) f)) => Surjective : Prop := +Class Surjective `(m : Morphism (A -> B) (RA ++> RB) f) : Prop := surjective : forall y, exists x : A, RB y (f x). -Definition Bijective ((m : Morphism (A -> B) (RA ++> RB) (f : A -> B))) := +Definition Bijective `(m : Morphism (A -> B) (RA ++> RB) (f : A -> B)) := Injective m /\ Surjective m. -Class MonoMorphism (( m : Morphism (A -> B) (eqA ++> eqB) )) := +Class MonoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := monic :> Injective m. -Class EpiMorphism ((m : Morphism (A -> B) (eqA ++> eqB))) := +Class EpiMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := epic :> Surjective m. -Class IsoMorphism ((m : Morphism (A -> B) (eqA ++> eqB))) := - monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m. +Class IsoMorphism `(m : Morphism (A -> B) (eqA ++> eqB)) := + { monomorphism :> MonoMorphism m ; epimorphism :> EpiMorphism m }. -Class ((m : Morphism (A -> A) (eqA ++> eqA))) [ ! IsoMorphism m ] => AutoMorphism. +Class AutoMorphism `(m : Morphism (A -> A) (eqA ++> eqA)) {I : IsoMorphism m}. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index e5f951d0..5df7a4ed 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -13,12 +13,18 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Init.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Init.v 11709 2008-12-20 11:42:15Z msozeau $ *) (* Ltac typeclass_instantiation := typeclasses eauto || eauto. *) Tactic Notation "clapply" ident(c) := - eapply @c ; eauto with typeclass_instances. + eapply @c ; typeclasses eauto. + +(** Hints for the proof search: these combinators should be considered rigid. *) + +Require Import Coq.Program.Basics. + +Typeclasses Opaque id const flip compose arrow impl iff. (** The unconvertible typeclass, to test that two objects of the same type are actually different. *) @@ -27,8 +33,8 @@ Class Unconvertible (A : Type) (a b : A). Ltac unconvertible := match goal with - | |- @Unconvertible _ ?x ?y => conv x y ; fail 1 "Convertible" - | |- _ => apply Build_Unconvertible + | |- @Unconvertible _ ?x ?y => unify x y with typeclass_instances ; fail 1 "Convertible" + | |- _ => eapply Build_Unconvertible end. Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances.
\ No newline at end of file diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index c2ae026d..86097a56 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -13,16 +13,15 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: Morphisms.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: Morphisms.v 11709 2008-12-20 11:42:15Z msozeau $ *) + +Set Manual Implicit Arguments. Require Import Coq.Program.Basics. Require Import Coq.Program.Tactics. Require Import Coq.Relations.Relation_Definitions. Require Export Coq.Classes.RelationClasses. -Set Implicit Arguments. -Unset Strict Implicit. - (** * Morphisms. We now turn to the definition of [Morphism] and declare standard instances. @@ -32,13 +31,9 @@ Unset Strict Implicit. The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) -Class Morphism A (R : relation A) (m : A) : Prop := +Class Morphism {A} (R : relation A) (m : A) : Prop := respect : R m m. -(** We make the type implicit, it can be infered from the relations. *) - -Implicit Arguments Morphism [A]. - (** Respectful morphisms. *) (** The fully dependent version, not used yet. *) @@ -53,7 +48,7 @@ Definition respectful_hetero (** The non-dependent version is an instance where we forget dependencies. *) -Definition respectful (A B : Type) +Definition respectful {A B : Type} (R : relation A) (R' : relation B) : relation (A -> B) := Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). @@ -75,13 +70,20 @@ Arguments Scope respectful [type_scope type_scope signature_scope signature_scop Open Local Scope signature_scope. -(** Pointwise lifting is just respect with leibniz equality on the left. *) +(** Dependent pointwise lifting of a relation on the range. *) + +Definition forall_relation {A : Type} {B : A -> Type} (sig : Î a : A, relation (B a)) : relation (Î x : A, B x) := + λ f g, Î a : A, sig a (f a) (g a). + +Arguments Scope forall_relation [type_scope type_scope signature_scope]. -Definition pointwise_relation {A B : Type} (R : relation B) : relation (A -> B) := - fun f g => forall x : A, R (f x) (g x). +(** Non-dependent pointwise lifting *) + +Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := + Eval compute in forall_relation (B:=λ _, B) (λ _, R). Lemma pointwise_pointwise A B (R : relation B) : - relation_equivalence (pointwise_relation R) (@eq A ==> R). + relation_equivalence (pointwise_relation A R) (@eq A ==> R). Proof. intros. split. simpl_relation. firstorder. Qed. (** We can build a PER on the Coq function space if we have PERs on the domain and @@ -91,24 +93,26 @@ Hint Unfold Reflexive : core. Hint Unfold Symmetric : core. Hint Unfold Transitive : core. -Program Instance respectful_per [ PER A (R : relation A), PER B (R' : relation B) ] : - PER (A -> B) (R ==> R'). +Typeclasses Opaque respectful pointwise_relation forall_relation. + +Program Instance respectful_per `(PER A (R : relation A), PER B (R' : relation B)) : + PER (R ==> R'). Next Obligation. Proof with auto. - assert(R x0 x0). + assert(R x0 x0). transitivity y0... symmetry... transitivity (y x0)... Qed. (** Subrelations induce a morphism on the identity. *) -Instance subrelation_id_morphism [ subrelation A Râ Râ ] : Morphism (Râ ==> Râ) id. +Instance subrelation_id_morphism `(subrelation A Râ Râ) : Morphism (Râ ==> Râ) id. Proof. firstorder. Qed. (** The subrelation property goes through products as usual. *) -Instance morphisms_subrelation_respectful [ subl : subrelation A Râ Râ, subr : subrelation B Sâ Sâ ] : +Instance morphisms_subrelation_respectful `(subl : subrelation A Râ Râ, subr : subrelation B Sâ Sâ) : subrelation (Râ ==> Sâ) (Râ ==> Sâ). Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. @@ -119,8 +123,8 @@ Proof. simpl_relation. Qed. (** [Morphism] is itself a covariant morphism for [subrelation]. *) -Lemma subrelation_morphism [ mor : Morphism A Râ m, unc : Unconvertible (relation A) Râ Râ, - sub : subrelation A Râ Râ ] : Morphism Râ m. +Lemma subrelation_morphism `(mor : Morphism A Râ m, unc : Unconvertible (relation A) Râ Râ, + sub : subrelation A Râ Râ) : Morphism Râ m. Proof. intros. apply sub. apply mor. Qed. @@ -153,14 +157,14 @@ Proof. firstorder. Qed. Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl). Proof. firstorder. Qed. -Instance pointwise_subrelation [ sub : subrelation A R R' ] : - subrelation (pointwise_relation (A:=B) R) (pointwise_relation R') | 4. +Instance pointwise_subrelation {A} `(sub : subrelation B R R') : + subrelation (pointwise_relation A R) (pointwise_relation A R') | 4. Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. (** The complement of a relation conserves its morphisms. *) Program Instance complement_morphism - [ mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R ] : + `(mR : Morphism (A -> A -> Prop) (RA ==> RA ==> iff) R) : Morphism (RA ==> RA ==> iff) (complement R). Next Obligation. @@ -173,7 +177,7 @@ Program Instance complement_morphism (** The [inverse] too, actually the [flip] instance is a bit more general. *) Program Instance flip_morphism - [ mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f ] : + `(mor : Morphism (A -> B -> C) (RA ==> RB ==> RC) f) : Morphism (RB ==> RA ==> RC) (flip f). Next Obligation. @@ -185,7 +189,7 @@ Program Instance flip_morphism contravariant in the first argument, covariant in the second. *) Program Instance trans_contra_co_morphism - [ Transitive A R ] : Morphism (R --> R ++> impl) R. + `(Transitive A R) : Morphism (R --> R ++> impl) R. Next Obligation. Proof with auto. @@ -196,7 +200,7 @@ Program Instance trans_contra_co_morphism (** Morphism declarations for partial applications. *) Program Instance trans_contra_inv_impl_morphism - [ Transitive A R ] : Morphism (R --> inverse impl) (R x) | 3. + `(Transitive A R) : Morphism (R --> inverse impl) (R x) | 3. Next Obligation. Proof with auto. @@ -204,7 +208,7 @@ Program Instance trans_contra_inv_impl_morphism Qed. Program Instance trans_co_impl_morphism - [ Transitive A R ] : Morphism (R ==> impl) (R x) | 3. + `(Transitive A R) : Morphism (R ==> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -212,7 +216,7 @@ Program Instance trans_co_impl_morphism Qed. Program Instance trans_sym_co_inv_impl_morphism - [ PER A R ] : Morphism (R ==> inverse impl) (R x) | 2. + `(PER A R) : Morphism (R ==> inverse impl) (R x) | 2. Next Obligation. Proof with auto. @@ -220,7 +224,7 @@ Program Instance trans_sym_co_inv_impl_morphism Qed. Program Instance trans_sym_contra_impl_morphism - [ PER A R ] : Morphism (R --> impl) (R x) | 2. + `(PER A R) : Morphism (R --> impl) (R x) | 2. Next Obligation. Proof with auto. @@ -228,7 +232,7 @@ Program Instance trans_sym_contra_impl_morphism Qed. Program Instance per_partial_app_morphism - [ PER A R ] : Morphism (R ==> iff) (R x) | 1. + `(PER A R) : Morphism (R ==> iff) (R x) | 1. Next Obligation. Proof with auto. @@ -242,7 +246,7 @@ Program Instance per_partial_app_morphism to get an [R y z] goal. *) Program Instance trans_co_eq_inv_impl_morphism - [ Transitive A R ] : Morphism (R ==> (@eq A) ==> inverse impl) R | 2. + `(Transitive A R) : Morphism (R ==> (@eq A) ==> inverse impl) R | 2. Next Obligation. Proof with auto. @@ -251,7 +255,7 @@ Program Instance trans_co_eq_inv_impl_morphism (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *) -Program Instance PER_morphism [ PER A R ] : Morphism (R ==> R ==> iff) R | 1. +Program Instance PER_morphism `(PER A R) : Morphism (R ==> R ==> iff) R | 1. Next Obligation. Proof with auto. @@ -261,7 +265,7 @@ Program Instance PER_morphism [ PER A R ] : Morphism (R ==> R ==> iff) R | 1. transitivity y... transitivity y0... symmetry... Qed. -Lemma symmetric_equiv_inverse [ Symmetric A R ] : relation_equivalence R (flip R). +Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. Program Instance compose_morphism A B C Râ Râ Râ : @@ -276,7 +280,7 @@ Program Instance compose_morphism A B C Râ Râ Râ : (** Coq functions are morphisms for leibniz equality, applied only if really needed. *) -Instance reflexive_eq_dom_reflexive (A : Type) [ Reflexive B R' ] : +Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : Reflexive (@Logic.eq A ==> R'). Proof. simpl_relation. Qed. @@ -307,20 +311,20 @@ Qed. to set different priorities in different hint bases and select a particular hint database for resolution of a type class constraint.*) -Class MorphismProxy A (R : relation A) (m : A) : Prop := +Class MorphismProxy {A} (R : relation A) (m : A) : Prop := respect_proxy : R m m. Instance reflexive_morphism_proxy - [ Reflexive A R ] (x : A) : MorphismProxy R x | 1. + `(Reflexive A R) (x : A) : MorphismProxy R x | 1. Proof. firstorder. Qed. Instance morphism_morphism_proxy - [ Morphism A R x ] : MorphismProxy R x | 2. + `(Morphism A R x) : MorphismProxy R x | 2. Proof. firstorder. Qed. (** [R] is Reflexive, hence we can build the needed proof. *) -Lemma Reflexive_partial_app_morphism [ Morphism (A -> B) (R ==> R') m, MorphismProxy A R x ] : +Lemma Reflexive_partial_app_morphism `(Morphism (A -> B) (R ==> R') m, MorphismProxy A R x) : Morphism R' (m x). Proof. simpl_relation. Qed. @@ -399,38 +403,48 @@ Qed. (** Special-purpose class to do normalization of signatures w.r.t. inverse. *) -Class (A : Type) => Normalizes (m : relation A) (m' : relation A) : Prop := +Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := normalizes : relation_equivalence m m'. -Instance inverse_respectful_norm : - ! Normalizes (A -> B) (inverse R ==> inverse R') (inverse (R ==> R')) . -Proof. firstorder. Qed. +(** Current strategy: add [inverse] everywhere and reduce using [subrelation] + afterwards. *) + +Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)). +Proof. + firstorder. +Qed. -(* If not an inverse on the left, do a double inverse. *) +Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) : + Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature). +Proof. unfold Normalizes. intros. + rewrite NA, NB. firstorder. +Qed. + +Ltac inverse := + match goal with + | [ |- Normalizes _ (respectful _ _) _ ] => eapply @inverse_arrow + | _ => eapply @inverse_atom + end. + +Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. + +(** Treating inverse: can't make them direct instances as we + need at least a [flip] present in the goal. *) -Instance not_inverse_respectful_norm : - ! Normalizes (A -> B) (R ==> inverse R') (inverse (inverse R ==> R')) | 4. +Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. Proof. firstorder. Qed. -Instance inverse_respectful_rec_norm [ Normalizes B R' (inverse R'') ] : - ! Normalizes (A -> B) (inverse R ==> R') (inverse (R ==> R'')). -Proof. red ; intros. - assert(r:=normalizes). - setoid_rewrite r. - setoid_rewrite inverse_respectful. - reflexivity. -Qed. +Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')). +Proof. firstorder. Qed. -(** Once we have normalized, we will apply this instance to simplify the problem. *) +Hint Extern 1 (subrelation (flip _) _) => eapply @inverse1 : typeclass_instances. +Hint Extern 1 (subrelation _ (flip _)) => eapply @inverse2 : typeclass_instances. -Definition morphism_inverse_morphism [ mor : Morphism A R m ] : Morphism (inverse R) m := mor. +(** Once we have normalized, we will apply this instance to simplify the problem. *) -Ltac morphism_inverse := - match goal with - [ |- @Morphism _ (flip _) _ ] => eapply @morphism_inverse_morphism - end. +Definition morphism_inverse_morphism `(mor : Morphism A R m) : Morphism (inverse R) m := mor. -Hint Extern 2 (@Morphism _ _ _) => morphism_inverse : typeclass_instances. +Hint Extern 2 (@Morphism _ (flip _) _) => eapply @morphism_inverse_morphism : typeclass_instances. (** Bootstrap !!! *) @@ -445,7 +459,7 @@ Proof. apply H0. Qed. -Lemma morphism_releq_morphism [ Normalizes A R R', Morphism _ R' m ] : Morphism R m. +Lemma morphism_releq_morphism `(Normalizes A R R', Morphism _ R' m) : Morphism R m. Proof. intros. @@ -467,7 +481,7 @@ Hint Extern 6 (@Morphism _ _ _) => morphism_normalization : typeclass_instances. (** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *) -Lemma reflexive_morphism [ Reflexive A R ] (x : A) +Lemma reflexive_morphism `{Reflexive A R} (x : A) : Morphism R x. Proof. firstorder. Qed. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index ec62e12e..3bbd56cf 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -32,18 +31,6 @@ Program Instance not_iff_morphism : Program Instance and_impl_morphism : Morphism (impl ==> impl ==> impl) and. -(* Program Instance and_impl_iff_morphism : *) -(* Morphism (impl ==> iff ==> impl) and. *) - -(* Program Instance and_iff_impl_morphism : *) -(* Morphism (iff ==> impl ==> impl) and. *) - -(* Program Instance and_inverse_impl_iff_morphism : *) -(* Morphism (inverse impl ==> iff ==> inverse impl) and. *) - -(* Program Instance and_iff_inverse_impl_morphism : *) -(* Morphism (iff ==> inverse impl ==> inverse impl) and. *) - Program Instance and_iff_morphism : Morphism (iff ==> iff ==> iff) and. @@ -52,18 +39,6 @@ Program Instance and_iff_morphism : Program Instance or_impl_morphism : Morphism (impl ==> impl ==> impl) or. -(* Program Instance or_impl_iff_morphism : *) -(* Morphism (impl ==> iff ==> impl) or. *) - -(* Program Instance or_iff_impl_morphism : *) -(* Morphism (iff ==> impl ==> impl) or. *) - -(* Program Instance or_inverse_impl_iff_morphism : *) -(* Morphism (inverse impl ==> iff ==> inverse impl) or. *) - -(* Program Instance or_iff_inverse_impl_morphism : *) -(* Morphism (iff ==> inverse impl ==> inverse impl) or. *) - Program Instance or_iff_morphism : Morphism (iff ==> iff ==> iff) or. @@ -73,7 +48,7 @@ Program Instance iff_iff_iff_impl_morphism : Morphism (iff ==> iff ==> iff) impl (** Morphisms for quantifiers *) -Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation iff ==> iff) (@ex A). +Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation A iff ==> iff) (@ex A). Next Obligation. Proof. @@ -87,7 +62,7 @@ Program Instance ex_iff_morphism {A : Type} : Morphism (pointwise_relation iff = Qed. Program Instance ex_impl_morphism {A : Type} : - Morphism (pointwise_relation impl ==> impl) (@ex A). + Morphism (pointwise_relation A impl ==> impl) (@ex A). Next Obligation. Proof. @@ -96,7 +71,7 @@ Program Instance ex_impl_morphism {A : Type} : Qed. Program Instance ex_inverse_impl_morphism {A : Type} : - Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@ex A). + Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A). Next Obligation. Proof. @@ -105,7 +80,7 @@ Program Instance ex_inverse_impl_morphism {A : Type} : Qed. Program Instance all_iff_morphism {A : Type} : - Morphism (pointwise_relation iff ==> iff) (@all A). + Morphism (pointwise_relation A iff ==> iff) (@all A). Next Obligation. Proof. @@ -114,7 +89,7 @@ Program Instance all_iff_morphism {A : Type} : Qed. Program Instance all_impl_morphism {A : Type} : - Morphism (pointwise_relation impl ==> impl) (@all A). + Morphism (pointwise_relation A impl ==> impl) (@all A). Next Obligation. Proof. @@ -123,7 +98,7 @@ Program Instance all_impl_morphism {A : Type} : Qed. Program Instance all_inverse_impl_morphism {A : Type} : - Morphism (pointwise_relation (inverse impl) ==> inverse impl) (@all A). + Morphism (pointwise_relation A (inverse impl) ==> inverse impl) (@all A). Next Obligation. Proof. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index 1b389667..24b8d636 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.Morphisms") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -42,17 +41,14 @@ Proof. do 2 red. unfold predicate_implication. auto. Qed. (* when [R] and [R'] are in [relation_equivalence]. *) Instance relation_equivalence_pointwise : - Morphism (relation_equivalence ==> pointwise_relation (A:=A) (pointwise_relation (A:=A) iff)) id. + Morphism (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. Proof. intro. apply (predicate_equivalence_pointwise (cons A (cons A nil))). Qed. Instance subrelation_pointwise : - Morphism (subrelation ==> pointwise_relation (A:=A) (pointwise_relation (A:=A) impl)) id. + Morphism (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. Lemma inverse_pointwise_relation A (R : relation A) : - relation_equivalence (pointwise_relation (inverse R)) (inverse (pointwise_relation (A:=A) R)). + relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. - - - diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 9a43a1ba..f95894be 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-name: "coqtop.byte"; coq-prog-args: ("-emacs-U" "-top" "Coq.Classes.RelationClasses") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -14,7 +13,7 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: RelationClasses.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: RelationClasses.v 11800 2009-01-18 18:34:15Z msozeau $ *) Require Export Coq.Classes.Init. Require Import Coq.Program.Basics. @@ -23,12 +22,13 @@ Require Export Coq.Relations.Relation_Definitions. (** We allow to unfold the [relation] definition while doing morphism search. *) -Typeclasses unfold relation. - Notation inverse R := (flip (R:relation _) : relation _). Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False. +(** Opaque for proof-search. *) +Typeclasses Opaque complement. + (** These are convertible. *) Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R). @@ -39,64 +39,65 @@ Proof. reflexivity. Qed. Set Implicit Arguments. Unset Strict Implicit. -Class Reflexive A (R : relation A) := +Class Reflexive {A} (R : relation A) := reflexivity : forall x, R x x. -Class Irreflexive A (R : relation A) := +Class Irreflexive {A} (R : relation A) := irreflexivity :> Reflexive (complement R). -Class Symmetric A (R : relation A) := +Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. -Class Asymmetric A (R : relation A) := +Class Asymmetric {A} (R : relation A) := asymmetry : forall x y, R x y -> R y x -> False. -Class Transitive A (R : relation A) := +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. Hint Resolve @irreflexivity : ord. Unset Implicit Arguments. +(** A HintDb for relations. *) + +Ltac solve_relation := + match goal with + | [ |- ?R ?x ?x ] => reflexivity + | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H + end. + +Hint Extern 4 => solve_relation : relations. + (** We can already dualize all these properties. *) -Program Instance flip_Reflexive [ Reflexive A R ] : Reflexive (flip R) := - reflexivity := reflexivity (R:=R). +Program Instance flip_Reflexive `(Reflexive A R) : Reflexive (flip R) := + reflexivity (R:=R). -Program Instance flip_Irreflexive [ Irreflexive A R ] : Irreflexive (flip R) := - irreflexivity := irreflexivity (R:=R). +Program Instance flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) := + irreflexivity (R:=R). -Program Instance flip_Symmetric [ Symmetric A R ] : Symmetric (flip R). +Program Instance flip_Symmetric `(Symmetric A R) : Symmetric (flip R). - Solve Obligations using unfold flip ; program_simpl ; clapply Symmetric. + Solve Obligations using unfold flip ; intros ; tcapp symmetry ; assumption. -Program Instance flip_Asymmetric [ Asymmetric A R ] : Asymmetric (flip R). +Program Instance flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R). - Solve Obligations using program_simpl ; unfold flip in * ; intros ; clapply asymmetry. + Solve Obligations using program_simpl ; unfold flip in * ; intros ; typeclass_app asymmetry ; eauto. -Program Instance flip_Transitive [ Transitive A R ] : Transitive (flip R). +Program Instance flip_Transitive `(Transitive A R) : Transitive (flip R). - Solve Obligations using unfold flip ; program_simpl ; clapply transitivity. + Solve Obligations using unfold flip ; program_simpl ; typeclass_app transitivity ; eauto. -Program Instance Reflexive_complement_Irreflexive [ Reflexive A (R : relation A) ] +Program Instance Reflexive_complement_Irreflexive `(Reflexive A (R : relation A)) : Irreflexive (complement R). Next Obligation. - Proof. - unfold complement. - red. intros H. - intros H' ; apply H'. - apply reflexivity. - Qed. - + Proof. firstorder. Qed. -Program Instance complement_Symmetric [ Symmetric A (R : relation A) ] : Symmetric (complement R). +Program Instance complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R). Next Obligation. - Proof. - red ; intros H'. - apply (H (symmetry H')). - Qed. + Proof. firstorder. Qed. (** * Standard instances. *) @@ -147,52 +148,52 @@ Program Instance eq_Transitive : Transitive (@eq A). (** A [PreOrder] is both Reflexive and Transitive. *) -Class PreOrder A (R : relation A) : Prop := +Class PreOrder {A} (R : relation A) : Prop := { PreOrder_Reflexive :> Reflexive R ; - PreOrder_Transitive :> Transitive R. + PreOrder_Transitive :> Transitive R }. (** A partial equivalence relation is Symmetric and Transitive. *) -Class PER (carrier : Type) (pequiv : relation carrier) : Prop := - PER_Symmetric :> Symmetric pequiv ; - PER_Transitive :> Transitive pequiv. +Class PER {A} (R : relation A) : Prop := { + PER_Symmetric :> Symmetric R ; + PER_Transitive :> Transitive R }. (** Equivalence relations. *) -Class Equivalence (carrier : Type) (equiv : relation carrier) : Prop := - Equivalence_Reflexive :> Reflexive equiv ; - Equivalence_Symmetric :> Symmetric equiv ; - Equivalence_Transitive :> Transitive equiv. +Class Equivalence {A} (R : relation A) : Prop := { + Equivalence_Reflexive :> Reflexive R ; + Equivalence_Symmetric :> Symmetric R ; + Equivalence_Transitive :> Transitive R }. (** An Equivalence is a PER plus reflexivity. *) -Instance Equivalence_PER [ Equivalence A R ] : PER A R | 10 := - PER_Symmetric := Equivalence_Symmetric ; - PER_Transitive := Equivalence_Transitive. +Instance Equivalence_PER `(Equivalence A R) : PER R | 10 := + { PER_Symmetric := Equivalence_Symmetric ; + PER_Transitive := Equivalence_Transitive }. (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) -Class Antisymmetric ((equ : Equivalence A eqA)) (R : relation A) := +Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) := antisymmetry : forall x y, R x y -> R y x -> eqA x y. -Program Instance flip_antiSymmetric {{Antisymmetric A eqA R}} : +Program Instance flip_antiSymmetric `(Antisymmetric A eqA R) : ! Antisymmetric A eqA (flip R). (** Leibinz equality [eq] is an equivalence relation. The instance has low priority as it is always applicable if only the type is constrained. *) -Program Instance eq_equivalence : Equivalence A (@eq A) | 10. +Program Instance eq_equivalence : Equivalence (@eq A) | 10. (** Logical equivalence [iff] is an equivalence relation. *) -Program Instance iff_equivalence : Equivalence Prop iff. +Program Instance iff_equivalence : Equivalence iff. (** We now develop a generalization of results on relations for arbitrary predicates. The resulting theory can be applied to homogeneous binary relations but also to arbitrary n-ary predicates. *) -Require Import List. +Require Import Coq.Lists.List. (* Notation " [ ] " := nil : list_scope. *) (* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *) @@ -273,7 +274,7 @@ Definition predicate_implication {l : list Type} := (** Notations for pointwise equivalence and implication of predicates. *) Infix "<â>" := predicate_equivalence (at level 95, no associativity) : predicate_scope. -Infix "-â>" := predicate_implication (at level 70) : predicate_scope. +Infix "-â>" := predicate_implication (at level 70, right associativity) : predicate_scope. Open Local Scope predicate_scope. @@ -306,7 +307,7 @@ Notation "ââ„â" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) Program Instance predicate_equivalence_equivalence : - Equivalence (predicate l) predicate_equivalence. + Equivalence (@predicate_equivalence l). Next Obligation. induction l ; firstorder. @@ -324,7 +325,7 @@ Program Instance predicate_equivalence_equivalence : Qed. Program Instance predicate_implication_preorder : - PreOrder (predicate l) predicate_implication. + PreOrder (@predicate_implication l). Next Obligation. induction l ; firstorder. @@ -356,10 +357,10 @@ Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relatio (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) Instance relation_equivalence_equivalence (A : Type) : - Equivalence (relation A) relation_equivalence. + Equivalence (@relation_equivalence A). Proof. intro A. exact (@predicate_equivalence_equivalence (cons A (cons A nil))). Qed. -Instance relation_implication_preorder : PreOrder (relation A) subrelation. +Instance relation_implication_preorder : PreOrder (@subrelation A). Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Qed. (** *** Partial Order. @@ -367,14 +368,14 @@ Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Q We give an equivalent definition, up-to an equivalence relation on the carrier. *) -Class [ equ : Equivalence A eqA, preo : PreOrder A R ] => PartialOrder := +Class PartialOrder A eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). (** The equivalence proof is sufficient for proving that [R] must be a morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) -Instance partial_order_antisym [ PartialOrder A eqA R ] : ! Antisymmetric A eqA R. +Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. Proof with auto. reduce_goal. pose proof partial_order_equivalence as poe. do 3 red in poe. apply <- poe. firstorder. @@ -389,3 +390,6 @@ Program Instance subrelation_partial_order : Proof. unfold relation_equivalence in *. firstorder. Qed. + +Typeclasses Opaque arrows predicate_implication predicate_equivalence + relation_equivalence pointwise_lifting. diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v index 9264b6d2..305168ec 100644 --- a/theories/Classes/SetoidAxioms.v +++ b/theories/Classes/SetoidAxioms.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -13,7 +12,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud * 91405 Orsay, France *) -(* $Id: SetoidAxioms.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: SetoidAxioms.v 11709 2008-12-20 11:42:15Z msozeau $ *) Require Import Coq.Program.Program. @@ -22,10 +21,10 @@ Unset Strict Implicit. Require Export Coq.Classes.SetoidClass. -(* Application of the extensionality axiom to turn a goal on leibinz equality to - a setoid equivalence. *) +(* Application of the extensionality axiom to turn a goal on + Leibinz equality to a setoid equivalence (use with care!). *) -Axiom setoideq_eq : forall [ sa : Setoid a ] (x y : a), x == y -> x = y. +Axiom setoideq_eq : forall `{sa : Setoid a} (x y : a), x == y -> x = y. (** Application of the extensionality principle for setoids. *) diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 178d5333..47f92ada 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -13,7 +12,7 @@ Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud 91405 Orsay, France *) -(* $Id: SetoidClass.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: SetoidClass.v 11800 2009-01-18 18:34:15Z msozeau $ *) Set Implicit Arguments. Unset Strict Implicit. @@ -27,11 +26,9 @@ Require Import Coq.Classes.Functions. (** A setoid wraps an equivalence. *) -Class Setoid A := +Class Setoid A := { equiv : relation A ; - setoid_equiv :> Equivalence A equiv. - -Typeclasses unfold equiv. + setoid_equiv :> Equivalence equiv }. (* Too dangerous instance *) (* Program Instance [ eqa : Equivalence A eqA ] => *) @@ -40,13 +37,13 @@ Typeclasses unfold equiv. (** Shortcuts to make proof search easier. *) -Definition setoid_refl [ sa : Setoid A ] : Reflexive equiv. +Definition setoid_refl `(sa : Setoid A) : Reflexive equiv. Proof. typeclasses eauto. Qed. -Definition setoid_sym [ sa : Setoid A ] : Symmetric equiv. +Definition setoid_sym `(sa : Setoid A) : Symmetric equiv. Proof. typeclasses eauto. Qed. -Definition setoid_trans [ sa : Setoid A ] : Transitive equiv. +Definition setoid_trans `(sa : Setoid A) : Transitive equiv. Proof. typeclasses eauto. Qed. Existing Instance setoid_refl. @@ -58,8 +55,8 @@ Existing Instance setoid_trans. (* Program Instance eq_setoid : Setoid A := *) (* equiv := eq ; setoid_equiv := eq_equivalence. *) -Program Instance iff_setoid : Setoid Prop := - equiv := iff ; setoid_equiv := iff_equivalence. +Program Instance iff_setoid : Setoid Prop := + { equiv := iff ; setoid_equiv := iff_equivalence }. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) @@ -87,7 +84,7 @@ Ltac clsubst_nofail := Tactic Notation "clsubst" "*" := clsubst_nofail. -Lemma nequiv_equiv_trans : forall [ Setoid A ] (x y z : A), x =/= y -> y == z -> x =/= z. +Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. intros; intro. assert(z == y) by (symmetry ; auto). @@ -95,7 +92,7 @@ Proof with auto. contradiction. Qed. -Lemma equiv_nequiv_trans : forall [ Setoid A ] (x y z : A), x == y -> y =/= z -> x =/= z. +Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. intros; intro. assert(y == x) by (symmetry ; auto). @@ -122,23 +119,11 @@ Ltac setoidify := repeat setoidify_tac. (** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *) -Program Definition setoid_morphism [ sa : Setoid A ] : Morphism (equiv ++> equiv ++> iff) equiv := - PER_morphism. - -(** Add this very useful instance in the database. *) - -Implicit Arguments setoid_morphism [[!sa]]. -Existing Instance setoid_morphism. - -Program Definition setoid_partial_app_morphism [ sa : Setoid A ] (x : A) : Morphism (equiv ++> iff) (equiv x) := - Reflexive_partial_app_morphism. - -Existing Instance setoid_partial_app_morphism. +Program Instance setoid_morphism `(sa : Setoid A) : Morphism (equiv ++> equiv ++> iff) equiv := + respect. -Definition type_eq : relation Type := - fun x y => x = y. - -Program Instance type_equivalence : Equivalence Type type_eq. +Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Morphism (equiv ++> iff) (equiv x) := + respect. Ltac morphism_tac := try red ; unfold arrow ; intros ; program_simpl ; try tauto. @@ -148,29 +133,12 @@ Ltac obligation_tactic ::= morphism_tac. using [iff_impl_id_morphism] if the proof is in [Prop] and [eq_arrow_id_morphism] if it is in Type. *) -Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) Basics.id. - -(* Program Instance eq_arrow_id_morphism : ? Morphism (eq +++> arrow) id. *) - -(* Definition compose_respect (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) -(* (x y : A -> C) : Prop := forall (f : A -> B) (g : B -> C), R f f -> R' g g. *) - -(* Program Instance (A B C : Type) (R : relation (A -> B)) (R' : relation (B -> C)) *) -(* [ mg : ? Morphism R' g ] [ mf : ? Morphism R f ] => *) -(* compose_morphism : ? Morphism (compose_respect R R') (g o f). *) - -(* Next Obligation. *) -(* Proof. *) -(* apply (respect (m0:=mg)). *) -(* apply (respect (m0:=mf)). *) -(* assumption. *) -(* Qed. *) +Program Instance iff_impl_id_morphism : Morphism (iff ++> impl) id. (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) -Class PartialSetoid (carrier : Type) := - pequiv : relation carrier ; - pequiv_prf :> PER carrier pequiv. +Class PartialSetoid (A : Type) := + { pequiv : relation A ; pequiv_prf :> PER pequiv }. (** Overloaded notation for partial setoid equivalence. *) diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 8a069343..bac64724 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -10,10 +9,10 @@ (* Decidable setoid equality theory. * * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud + * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud * 91405 Orsay, France *) -(* $Id: SetoidDec.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: SetoidDec.v 11800 2009-01-18 18:34:15Z msozeau $ *) Set Implicit Arguments. Unset Strict Implicit. @@ -27,12 +26,12 @@ Require Export Coq.Classes.SetoidClass. Require Import Coq.Logic.Decidable. -Class DecidableSetoid A [ Setoid A ] := +Class DecidableSetoid `(S : Setoid A) := setoid_decidable : forall x y : A, decidable (x == y). (** The [EqDec] class gives a decision procedure for a particular setoid equality. *) -Class (( s : Setoid A )) => EqDec := +Class EqDec `(S : Setoid A) := equiv_dec : forall x y : A, { x == y } + { x =/= y }. (** We define the [==] overloaded notation for deciding equality. It does not take precedence @@ -52,7 +51,7 @@ Open Local Scope program_scope. (** Invert the branches. *) -Program Definition nequiv_dec [ EqDec A ] (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). +Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x == y } := swap_sumbool (x == y). (** Overloaded notation for inequality. *) @@ -60,10 +59,10 @@ Infix "=/=" := nequiv_dec (no associativity, at level 70). (** Define boolean versions, losing the logical information. *) -Definition equiv_decb [ EqDec A ] (x y : A) : bool := +Definition equiv_decb `{EqDec A} (x y : A) : bool := if x == y then true else false. -Definition nequiv_decb [ EqDec A ] (x y : A) : bool := +Definition nequiv_decb `{EqDec A} (x y : A) : bool := negb (equiv_decb x y). Infix "==b" := equiv_decb (no associativity, at level 70). @@ -75,19 +74,19 @@ Require Import Coq.Arith.Arith. (** The equiv is burried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) -Program Instance eq_setoid A : Setoid A := - equiv := eq ; setoid_equiv := eq_equivalence. +Program Instance eq_setoid A : Setoid A | 10 := + { equiv := eq ; setoid_equiv := eq_equivalence }. Program Instance nat_eq_eqdec : EqDec (eq_setoid nat) := - equiv_dec := eq_nat_dec. + eq_nat_dec. Require Import Coq.Bool.Bool. Program Instance bool_eqdec : EqDec (eq_setoid bool) := - equiv_dec := bool_dec. + bool_dec. Program Instance unit_eqdec : EqDec (eq_setoid unit) := - equiv_dec x y := in_left. + λ x y, in_left. Next Obligation. Proof. @@ -95,8 +94,8 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := reflexivity. Qed. -Program Instance prod_eqdec [ ! EqDec (eq_setoid A), ! EqDec (eq_setoid B) ] : EqDec (eq_setoid (prod A B)) := - equiv_dec x y := +Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := + λ x y, let '(x1, x2) := x in let '(y1, y2) := y in if x1 == y1 then @@ -108,10 +107,8 @@ Program Instance prod_eqdec [ ! EqDec (eq_setoid A), ! EqDec (eq_setoid B) ] : E (** Objects of function spaces with countable domains like bool have decidable equality. *) -Require Import Coq.Program.FunctionalExtensionality. - -Program Instance bool_function_eqdec [ ! EqDec (eq_setoid A) ] : EqDec (eq_setoid (bool -> A)) := - equiv_dec f g := +Program Instance bool_function_eqdec `(! EqDec (eq_setoid A)) : EqDec (eq_setoid (bool -> A)) := + λ f g, if f true == g true then if f false == g false then in_left else in_right diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 6398b125..caacc9ec 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -13,7 +13,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud * 91405 Orsay, France *) -(* $Id: SetoidTactics.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: SetoidTactics.v 11709 2008-12-20 11:42:15Z msozeau $ *) Require Export Coq.Classes.RelationClasses. Require Export Coq.Classes.Morphisms. @@ -45,11 +45,11 @@ Class DefaultRelation A (R : relation A). (** To search for the default relation, just call [default_relation]. *) -Definition default_relation [ DefaultRelation A R ] := R. +Definition default_relation `{DefaultRelation A R} := R. (** Every [Equivalence] gives a default relation, if no other is given (lowest priority). *) -Instance equivalence_default [ Equivalence A R ] : DefaultRelation R | 4. +Instance equivalence_default `(Equivalence A R) : DefaultRelation R | 4. (** The setoid_replace tactics in Ltac, defined in terms of default relations and the setoid_rewrite tactic. *) @@ -178,7 +178,7 @@ Ltac reverse_arrows x := end. Ltac default_add_morphism_tactic := - intros ; + unfold flip ; intros ; (try destruct_morphism) ; match goal with | [ |- (?x ==> ?y) _ _ ] => red_subst_eq_morphism (x ==> y) ; reverse_arrows (x ==> y) diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 05cd1892..df12166e 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 11359 2008-09-04 09:43:36Z notin $ *) +(* $Id: FMapFacts.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite maps library *) @@ -20,9 +20,14 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. +Hint Extern 1 (Equivalence _) => constructor; congruence. + +Notation Leibniz := (@eq _) (only parsing). + + (** * Facts about weak maps *) -Module WFacts (E:DecidableType)(Import M:WSfun E). +Module WFacts_fun (E:DecidableType)(Import M:WSfun E). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -32,6 +37,15 @@ Proof. destruct b; destruct b'; intuition. Qed. +Lemma eq_option_alt : forall (elt:Type)(o o':option elt), + o=o' <-> (forall e, o=Some e <-> o'=Some e). +Proof. +split; intros. +subst; split; auto. +destruct o; destruct o'; try rewrite H; auto. +symmetry; rewrite <- H; auto. +Qed. + Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. @@ -85,14 +99,10 @@ Qed. Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. -intros. -generalize (find_mapsto_iff m x); destruct (find x m). -split; intros; try discriminate. -destruct H0. -exists e; rewrite H; auto. -split; auto. -intros; intros (e,H1). -rewrite H in H1; discriminate. +split; intros. +rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. +split; intro H'; try discriminate. elim H; exists e; auto. +intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. Qed. Lemma in_find_iff : forall m x, In x m <-> find x m <> None. @@ -334,21 +344,14 @@ Qed. Lemma find_o : forall m x y, E.eq x y -> find x m = find y m. Proof. -intros. -generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H). -destruct (find x m); destruct (find y m); intros. -rewrite <- H0; rewrite H2; rewrite H1; auto. -symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto. -rewrite <- H0; rewrite H2; rewrite H1; auto. -auto. +intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff. +apply MapsTo_iff; auto. Qed. Lemma empty_o : forall x, find x (empty elt) = None. Proof. -intros. -case_eq (find x (empty elt)); intros; auto. -generalize (find_2 H). -rewrite empty_mapsto_iff; intuition. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition. Qed. Lemma empty_a : forall x, mem x (empty elt) = false. @@ -368,15 +371,12 @@ Qed. Lemma add_neq_o : forall m x y e, ~ E.eq x y -> find y (add x e m) = find y m. Proof. -intros. -case_eq (find y m); intros; auto with map. -case_eq (find y (add x e m)); intros; auto with map. -rewrite <- H0; symmetry. -apply find_1; apply add_3 with x e; auto with map. +intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. +apply add_neq_mapsto_iff; auto. Qed. Hint Resolve add_neq_o : map. -Lemma add_o : forall m x y e, +Lemma add_o : forall m x y e, find y (add x e m) = if eq_dec x y then Some e else find y m. Proof. intros; destruct (eq_dec x y); auto with map. @@ -404,45 +404,38 @@ Qed. Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. -intros. -generalize (remove_1 (m:=m) H). -generalize (find_mapsto_iff (remove x m) y). -destruct (find y (remove x m)); auto. -destruct 2. -exists e; rewrite H0; auto. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. Qed. Hint Resolve remove_eq_o : map. -Lemma remove_neq_o : forall m x y, - ~ E.eq x y -> find y (remove x m) = find y m. +Lemma remove_neq_o : forall m x y, + ~ E.eq x y -> find y (remove x m) = find y m. Proof. -intros. -case_eq (find y m); intros; auto with map. -case_eq (find y (remove x m)); intros; auto with map. -rewrite <- H0; symmetry. -apply find_1; apply remove_3 with x; auto with map. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. Qed. Hint Resolve remove_neq_o : map. -Lemma remove_o : forall m x y, +Lemma remove_o : forall m x y, find y (remove x m) = if eq_dec x y then None else find y m. Proof. intros; destruct (eq_dec x y); auto with map. Qed. -Lemma remove_eq_b : forall m x y, +Lemma remove_eq_b : forall m x y, E.eq x y -> mem y (remove x m) = false. Proof. intros; rewrite mem_find_b; rewrite remove_eq_o; auto. Qed. -Lemma remove_neq_b : forall m x y, +Lemma remove_neq_b : forall m x y, ~ E.eq x y -> mem y (remove x m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto. Qed. -Lemma remove_b : forall m x y, +Lemma remove_b : forall m x y, mem y (remove x m) = negb (eqb x y) && mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. @@ -506,7 +499,7 @@ Qed. Lemma map2_1bis : forall (m: t elt)(m': t elt') x (f:option elt->option elt'->option elt''), f None None = None -> - find x (map2 f m m') = f (find x m) (find x m'). + find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. case_eq (find x m); intros. @@ -525,23 +518,16 @@ rewrite (find_1 H4) in H0; discriminate. rewrite (find_1 H4) in H1; discriminate. Qed. -Lemma elements_o : forall m x, +Lemma elements_o : forall m x, find x m = findA (eqb x) (elements m). Proof. -intros. -assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)). - intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff. -assert (H0:=elements_3w m). -generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans eq_dec (elements m) x e H0). -fold (eqb x). -destruct (find x m); destruct (findA (eqb x) (elements m)); - simpl; auto; intros. -symmetry; rewrite <- H1; rewrite <- H; auto. -symmetry; rewrite <- H1; rewrite <- H; auto. -rewrite H; rewrite H1; auto. -Qed. - -Lemma elements_b : forall m x, +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, elements_mapsto_iff. +unfold eqb. +rewrite <- findA_NoDupA; intuition; try apply elements_3w; eauto. +Qed. + +Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m). Proof. intros. @@ -568,30 +554,41 @@ Qed. End BoolSpec. -Section Equalities. +Section Equalities. Variable elt:Type. + (** Another characterisation of [Equal] *) + +Lemma Equal_mapsto_iff : forall m1 m2 : t elt, + Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). +Proof. +intros m1 m2. split; [intros Heq k e|intros Hiff]. +rewrite 2 find_mapsto_iff, Heq. split; auto. +intro k. rewrite eq_option_alt. intro e. +rewrite <- 2 find_mapsto_iff; auto. +Qed. + (** * Relations between [Equal], [Equiv] and [Equivb]. *) (** First, [Equal] is [Equiv] with Leibniz on elements. *) -Lemma Equal_Equiv : forall (m m' : t elt), +Lemma Equal_Equiv : forall (m m' : t elt), Equal m m' <-> Equiv (@Logic.eq elt) m m'. Proof. - unfold Equal, Equiv; split; intros. - split; intros. - rewrite in_find_iff, in_find_iff, H; intuition. - rewrite find_mapsto_iff in H0,H1; congruence. - destruct H. - specialize (H y). - specialize (H0 y). - do 2 rewrite in_find_iff in H. - generalize (find_mapsto_iff m y)(find_mapsto_iff m' y). - do 2 destruct find; auto; intros. - f_equal; apply H0; [rewrite H1|rewrite H2]; auto. - destruct H as [H _]; now elim H. - destruct H as [_ H]; now elim H. +intros. rewrite Equal_mapsto_iff. split; intros. +split. +split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. +intros; apply MapsTo_fun with m k; auto; rewrite H; auto. +split; intros H'. +destruct H. +assert (Hin : In k m') by (rewrite <- H; exists e; auto). +destruct Hin as (e',He'). +rewrite (H0 k e e'); auto. +destruct H. +assert (Hin : In k m) by (rewrite H; exists e; auto). +destruct Hin as (e',He'). +rewrite <- (H0 k e' e); auto. Qed. (** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] @@ -649,8 +646,8 @@ Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. -Definition Equal_ST : forall elt:Type, Setoid_Theory (t elt) (@Equal _). -Proof. +Definition Equal_ST : forall elt:Type, Equivalence (@Equal elt). +Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. @@ -660,8 +657,6 @@ Add Relation key E.eq transitivity proved by E.eq_trans as KeySetoid. -Typeclasses unfold key. - Implicit Arguments Equal [[elt]]. Add Parametric Relation (elt : Type) : (t elt) Equal @@ -670,52 +665,52 @@ Add Parametric Relation (elt : Type) : (t elt) Equal transitivity proved by (@Equal_trans elt) as EqualSetoid. -Add Parametric Morphism elt : (@In elt) with signature E.eq ==> Equal ==> iff as In_m. +Add Parametric Morphism elt : (@In elt) + with signature E.eq ==> Equal ==> iff as In_m. Proof. unfold Equal; intros k k' Hk m m' Hm. rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> @Logic.eq _ ==> Equal ==> iff as MapsTo_m. + with signature E.eq ==> Leibniz ==> Equal ==> iff as MapsTo_m. Proof. unfold Equal; intros k k' Hk e m m' Hm. -rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; +rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; intuition. Qed. -Add Parametric Morphism elt : (@Empty elt) with signature Equal ==> iff as Empty_m. +Add Parametric Morphism elt : (@Empty elt) + with signature Equal ==> iff as Empty_m. Proof. unfold Empty; intros m m' Hm; intuition. rewrite <-Hm in H0; eauto. rewrite Hm in H0; eauto. Qed. -Add Parametric Morphism elt : (@is_empty elt) with signature Equal ==> @Logic.eq _ as is_empty_m. +Add Parametric Morphism elt : (@is_empty elt) + with signature Equal ==> Leibniz as is_empty_m. Proof. intros m m' Hm. rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. -Add Parametric Morphism elt : (@mem elt) with signature E.eq ==> Equal ==> @Logic.eq _ as mem_m. +Add Parametric Morphism elt : (@mem elt) + with signature E.eq ==> Equal ==> Leibniz as mem_m. Proof. intros k k' Hk m m' Hm. rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. -Add Parametric Morphism elt : (@find elt) with signature E.eq ==> Equal ==> @Logic.eq _ as find_m. +Add Parametric Morphism elt : (@find elt) + with signature E.eq ==> Equal ==> Leibniz as find_m. Proof. -intros k k' Hk m m' Hm. -generalize (find_mapsto_iff m k)(find_mapsto_iff m' k') - (not_find_in_iff m k)(not_find_in_iff m' k'); -do 2 destruct find; auto; intros. -rewrite <- H, Hk, Hm, H0; auto. -rewrite <- H1, Hk, Hm, H2; auto. -symmetry; rewrite <- H2, <-Hk, <-Hm, H1; auto. +intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. +rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. -Add Parametric Morphism elt : (@add elt) with signature - E.eq ==> @Logic.eq _ ==> Equal ==> Equal as add_m. +Add Parametric Morphism elt : (@add elt) + with signature E.eq ==> Leibniz ==> Equal ==> Equal as add_m. Proof. intros k k' Hk e m m' Hm y. rewrite add_o, add_o; do 2 destruct eq_dec; auto. @@ -723,8 +718,8 @@ elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. -Add Parametric Morphism elt : (@remove elt) with signature - E.eq ==> Equal ==> Equal as remove_m. +Add Parametric Morphism elt : (@remove elt) + with signature E.eq ==> Equal ==> Equal as remove_m. Proof. intros k k' Hk m m' Hm y. rewrite remove_o, remove_o; do 2 destruct eq_dec; auto. @@ -732,7 +727,8 @@ elim n; rewrite <-Hk; auto. elim n; rewrite Hk; auto. Qed. -Add Parametric Morphism elt elt' : (@map elt elt') with signature @Logic.eq _ ==> Equal ==> Equal as map_m. +Add Parametric Morphism elt elt' : (@map elt elt') + with signature Leibniz ==> Equal ==> Equal as map_m. Proof. intros f m m' Hm y. rewrite map_o, map_o, Hm; auto. @@ -743,25 +739,23 @@ Qed. (* old name: *) Notation not_find_mapsto_iff := not_find_in_iff. -End WFacts. +End WFacts_fun. -(** * Same facts for full maps *) +(** * Same facts for self-contained weak sets and for full maps *) -Module Facts (M:S). - Module D := OT_as_DT M.E. - Include WFacts D M. -End Facts. +Module WFacts (M:S) := WFacts_fun M.E M. +Module Facts := WFacts. + +(** * Additional Properties for weak maps -(** * Additional Properties for weak maps - Results about [fold], [elements], induction principles... *) -Module WProperties (E:DecidableType)(M:WSfun E). - Module Import F:=WFacts E M. +Module WProperties_fun (E:DecidableType)(M:WSfun E). + Module Import F:=WFacts_fun E M. Import M. - Section Elt. + Section Elt. Variable elt:Type. Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m). @@ -769,6 +763,44 @@ Module WProperties (E:DecidableType)(M:WSfun E). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). + (** Complements about InA, NoDupA and findA *) + + Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, + E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l. + Proof. + intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt. + intros ((k',e') & (Hk',He') & H); simpl in *. + exists (k',e'); split; auto. + red; simpl; eauto. + Qed. + + Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + Proof. + induction 1; auto. + constructor; auto. + destruct x as (k,e). + eauto using InA_eqke_eqk. + Qed. + + Lemma findA_rev : forall l k, NoDupA eqk l -> + findA (eqb k) l = findA (eqb k) (rev l). + Proof. + intros. + case_eq (findA (eqb k) l). + intros. symmetry. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by eauto using NoDupA_rev; eauto. + case_eq (findA (eqb k) (rev l)); auto. + intros e. + unfold eqb. + rewrite <- findA_NoDupA, InA_rev, findA_NoDupA + by eauto using NoDupA_rev. + intro Eq; rewrite Eq; auto. + Qed. + + (** * Elements *) + Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil. Proof. intros. @@ -793,29 +825,268 @@ Module WProperties (E:DecidableType)(M:WSfun E). rewrite <-elements_Empty; apply empty_1. Qed. - Lemma fold_Empty : forall m (A:Type)(f:key->elt->A->A)(i:A), - Empty m -> fold f m i = i. + (** * Conversions between maps and association lists. *) + + Definition of_list (l : list (key*elt)) := + List.fold_right (fun p => add (fst p) (snd p)) (empty _) l. + + Definition to_list := elements. + + Lemma of_list_1 : forall l k e, + NoDupA eqk l -> + (MapsTo k e (of_list l) <-> InA eqke (k,e) l). + Proof. + induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. + rewrite empty_mapsto_iff, InA_nil; intuition. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k e Hnodup'); clear Hnodup'. + rewrite add_mapsto_iff, InA_cons, <- IH. + unfold eq_key_elt at 1; simpl. + split; destruct 1 as [H|H]; try (intuition;fail). + destruct (eq_dec k k'); [left|right]; split; auto. + contradict Hnotin. + apply InA_eqke_eqk with k e; intuition. + Qed. + + Lemma of_list_1b : forall l k, + NoDupA eqk l -> + find k (of_list l) = findA (eqb k) l. + Proof. + induction l as [|(k',e') l IH]; simpl; intros k Hnodup. + apply empty_o. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k Hnodup'); clear Hnodup'. + rewrite add_o, IH. + unfold eqb; do 2 destruct eq_dec; auto; elim n; eauto. + Qed. + + Lemma of_list_2 : forall l, NoDupA eqk l -> + equivlistA eqke l (to_list (of_list l)). + Proof. + intros l Hnodup (k,e). + rewrite <- elements_mapsto_iff, of_list_1; intuition. + Qed. + + Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. + Proof. + intros s k. + rewrite of_list_1b, elements_o; auto. + apply elements_3w. + Qed. + + (** * Fold *) + + (** ** Induction principles about fold contributed by S. Lescuyer *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise map m we are considering. *) + + Lemma fold_rec : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m, Empty m -> P m i) -> + (forall k e a m' m'', MapsTo k e m -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Hempty Hstep. + rewrite fold_1, <- fold_left_rev_right. + set (F:=fun (y : key * elt) (x : A) => f (fst y) (snd y) x). + set (l:=rev (elements m)). + assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). + intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto. + assert (Hdup : NoDupA eqk l). + unfold l. apply NoDupA_rev; try red; eauto. apply elements_3w. + assert (Hsame : forall k, find k m = findA (eqb k) l). + intros k. unfold l. rewrite elements_o, findA_rev; auto. + apply elements_3w. + clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. + (* empty *) + intros m Hsame; simpl. + apply Hempty. intros k e. + rewrite find_mapsto_iff, Hsame; simpl; discriminate. + (* step *) + intros m Hsame; destruct a as (k,e); simpl. + apply Hstep' with (of_list l); auto. + rewrite InA_cons; left; red; auto. + inversion_clear Hdup. contradict H. destruct H as (e',He'). + apply InA_eqke_eqk with k e'; auto. + rewrite <- of_list_1; auto. + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. + unfold eqb. do 2 destruct eq_dec; auto; elim n; eauto. + inversion_clear Hdup; auto. + apply IHl. + intros; eapply Hstep'; eauto. + inversion_clear Hdup; auto. + intros; apply of_list_1b. inversion_clear Hdup; auto. + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + (P (empty _) i) -> + (forall k e a m', MapsTo k e m -> ~In k m' -> + P m' a -> P (add k e m') (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with (empty _); auto. intro k. rewrite empty_o. + case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. + intro H'; elim (H k e'); auto. + apply Pmorphism with (add k e m'); try intro; auto. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), + P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> + P (fold f m i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable anywhere. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + P (empty _) i -> + (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> + forall m, P m (fold f m i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) + (m : t elt), + R i j -> + (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> + R (fold f m i) (fold g m j). + Proof. + intros A B R f g i j m Rempty Rstep. + do 2 rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements m)). + assert (Rstep' : forall k e a b, InA eqke (k,e) l -> + R a b -> R (f k e a) (g k e b)) by + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto). + clearbody l; clear Rstep m. + induction l; simpl; auto. + apply Rstep'; auto. + destruct a; simpl; rewrite InA_cons; left; red; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on maps. *) + + Lemma map_induction : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + Lemma map_induction_bis : + forall P : t elt -> Type, + (forall m m', Equal m m' -> P m -> P m') -> + P (empty _) -> + (forall x e m, ~In x m -> P m -> P (add x e m)) -> + forall m, P m. Proof. intros. - rewrite fold_1. - rewrite elements_Empty in H; rewrite H; simpl; auto. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. Qed. - Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l. + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m. Proof. - induction 1; auto. - constructor; auto. - contradict H. - destruct x as (x,y). - rewrite InA_alt in *; destruct H as ((a,b),((H1,H2),H3)); simpl in *. - exists (a,b); auto. + intros. + apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. + intros m' Heq k'. + rewrite empty_o. + case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. + intro; elim (Heq k' e'); auto. + intros k e a m' m'' _ _ Hadd Heq k'. + rewrite Hadd, 2 add_o, Heq; auto. + Qed. + + Section Fold_More. + + (** ** Additional properties of fold *) + + (** When a function [f] is compatible and allows transpositions, we can + compute [fold f] in any order. *) + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A). + + (** This is more convenient than a [compat_op eqke ...]. + In fact, every [compat_op], [compat_bool], etc, should + become a [Morphism] someday. *) + Hypothesis Comp : Morphism (E.eq==>Leibniz==>eqA==>eqA) f. + + Lemma fold_init : + forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros. apply Comp; auto. + Qed. + + Lemma fold_Empty : + forall m i, Empty m -> eqA (fold f m i) i. + Proof. + intros. apply fold_rec_nodep with (P:=fun a => eqA a i). + reflexivity. + intros. elim (H k e); auto. Qed. - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y => f (fst y) (snd y)) -> - Equal m1 m2 -> + (** As noticed by P. Casteran, asking for the general [SetoidList.transpose] + here is too restrictive. Think for instance of [f] being [M.add] : + in general, [M.add k e (M.add k e' m)] is not equivalent to + [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this + situation during a real [fold], since the keys received by this [fold] + are unique. Hence we can ask the transposition property to hold only + for non-equal keys. + + This idea could be push slightly further, by asking the transposition + property to hold only for (non-equal) keys living in the map given to + [fold]. Please contact us if you need such a version. + + FSets could also benefit from a restricted [transpose], but for this + case the gain is unclear. *) + + Definition transpose_neqkey := + forall k k' e e' a, ~E.eq k k' -> + eqA (f k e (f k' e' a)) (f k' e' (f k e a)). + + Hypothesis Tra : transpose_neqkey. + + Lemma fold_commutes : forall i m k e, ~In k m -> + eqA (fold f m (f k e i)) (f k e (fold f m i)). + Proof. + intros i m k e Hnotin. + apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. + reflexivity. + intros. + transitivity (f k0 e0 (f k e b)). + apply Comp; auto. + apply Tra; auto. + contradict Hnotin; rewrite <- Hnotin; exists e0; auto. + Qed. + + Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. assert (eqke_refl : forall p, eqke p p). @@ -826,22 +1097,26 @@ Module WProperties (E:DecidableType)(M:WSfun E). intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - apply fold_right_equivlistA with (eqA:=eqke) (eqB:=eqA); auto. + apply fold_right_equivlistA_restr with + (R:=fun p p' => ~eqk p p') (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; simpl in *; apply Comp; auto. + unfold eq_key; auto. + intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. + intuition eauto. + intros (k,e) (k',e'); unfold eq_key; simpl; auto. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. + apply NoDupA_rev; try red; eauto. apply elements_3w. red; intros. do 2 rewrite InA_rev. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff. - rewrite H1; split; auto. + rewrite H; split; auto. Qed. - Lemma fold_Add : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y =>f (fst y) (snd y)) -> - ~In x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). + Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> + eqA (fold f m2 i) (f k e (fold f m1 i)). Proof. assert (eqke_refl : forall p, eqke p p). red; auto. @@ -852,52 +1127,68 @@ Module WProperties (E:DecidableType)(M:WSfun E). intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - change (f x e (fold_right f' i (rev (elements m1)))) - with (f' (x,e) (fold_right f' i (rev (elements m1)))). - apply fold_right_add with (eqA:=eqke)(eqB:=eqA); auto. + change (f k e (fold_right f' i (rev (elements m1)))) + with (f' (k,e) (fold_right f' i (rev (elements m1)))). + apply fold_right_add_restr with + (R:=fun p p'=>~eqk p p')(eqA:=eqke)(eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *. apply Comp; auto. + + unfold eq_key; auto. + intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. + intuition eauto. + unfold f'; intros (k1,e1) (k2,e2); unfold eq_key; simpl; auto. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. + apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. + apply NoDupA_rev; try red; eauto. apply elements_3w. rewrite InA_rev. - contradict H1. + contradict H. exists e. rewrite elements_mapsto_iff; auto. intros a. - rewrite InA_cons; do 2 rewrite InA_rev; + rewrite InA_cons; do 2 rewrite InA_rev; destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl. - rewrite H2. + rewrite H0. rewrite add_o. - destruct (eq_dec x a); intuition. - inversion H3; auto. + destruct (eq_dec k a); intuition. + inversion H1; auto. f_equal; auto. - elim H1. + elim H. exists b; apply MapsTo_1 with a; auto with map. elim n; auto. Qed. - Lemma cardinal_fold : forall m : t elt, + Lemma fold_add : forall m k e i, ~In k m -> + eqA (fold f (add k e m) i) (f k e (fold f m i)). + Proof. + intros. apply fold_Add; try red; auto. + Qed. + + End Fold_More. + + (** * Cardinal *) + + Lemma cardinal_fold : forall m : t elt, cardinal m = fold (fun _ _ => S) m 0. Proof. intros; rewrite cardinal_1, fold_1. symmetry; apply fold_left_length; auto. Qed. - Lemma cardinal_Empty : forall m : t elt, + Lemma cardinal_Empty : forall m : t elt, Empty m <-> cardinal m = 0. Proof. intros. rewrite cardinal_1, elements_Empty. destruct (elements m); intuition; discriminate. Qed. - - Lemma Equal_cardinal : forall m m' : t elt, + + Lemma Equal_cardinal : forall m m' : t elt, Equal m m' -> cardinal m = cardinal m'. Proof. intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=@eq _); auto. - constructor; auto; congruence. - red; auto. - red; auto. + apply fold_Equal with (eqA:=Leibniz); compute; auto. Qed. Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. @@ -910,10 +1201,7 @@ Module WProperties (E:DecidableType)(M:WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ _ => S) x e). - apply fold_Add; auto. - constructor; intros; auto; congruence. - red; simpl; auto. - red; simpl; auto. + apply fold_Add with (eqA:=Leibniz); compute; auto. Qed. Lemma cardinal_inv_1 : forall m : t elt, @@ -943,27 +1231,16 @@ Module WProperties (E:DecidableType)(M:WSfun E). eauto. Qed. - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. + (** * Additional notions over maps *) - destruct (cardinal_inv_2 (sym_eq Heqn)) as ((x,e),H0); simpl in *. - assert (Add x e (remove x m) m). - red; intros. - rewrite add_o; rewrite remove_o; destruct (eq_dec x y); eauto with map. - apply X0 with (remove x m) x e; auto with map. - apply IHn; auto with map. - assert (S n = S (cardinal (remove x m))). - rewrite Heqn; eapply cardinal_2; eauto with map. - inversion H1; auto with map. - Qed. + Definition Disjoint (m m' : t elt) := + forall k, ~(In k m /\ In k m'). + + Definition Partition (m m1 m2 : t elt) := + Disjoint m1 m2 /\ + (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - (** * Let's emulate some functions not present in the interface *) + (** * Emulation of some functions lacking in the interface *) Definition filter (f : key -> elt -> bool)(m : t elt) := fold (fun k e m => if f k e then add k e m else m) m (empty _). @@ -977,122 +1254,411 @@ Module WProperties (E:DecidableType)(M:WSfun E). Definition partition (f : key -> elt -> bool)(m : t elt) := (filter f m, filter (fun k e => negb (f k e)) m). + (** [update] adds to [m1] all the bindings of [m2]. It can be seen as + an [union] operator which gives priority to its 2nd argument + in case of binding conflit. *) + + Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. + + (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. + It can be seen as an [inter] operator, with priority to its 1st argument + in case of binding conflit. *) + + Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. + + (** [diff] erases from [m1] all bindings whose key is in [m2]. *) + + Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. + Section Specs. Variable f : key -> elt -> bool. - Hypothesis Hf : forall e, compat_bool E.eq (fun k => f k e). + Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. - Lemma filter_iff : forall m k e, + Lemma filter_iff : forall m k e, MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. Proof. - unfold filter; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - rewrite (elements_mapsto_iff m). - rewrite <- (InA_rev eqke (k,e) (elements m)). - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - rewrite empty_mapsto_iff. - intuition. - inversion H1. - - destruct a as (k',e'); simpl. - inversion_clear H. - case_eq (f k' e'); intros; simpl; - try rewrite add_mapsto_iff; rewrite IHl; clear IHl; intuition. - constructor; red; auto. - rewrite (Hf e' H2),H4 in H; auto. - inversion_clear H3. - compute in H2; destruct H2; auto. - destruct (E.eq_dec k' k); auto. - elim H0. - rewrite InA_alt in *; destruct H2 as (w,Hw); exists w; intuition. - red in H2; red; simpl in *; intuition. - rewrite e0; auto. - inversion_clear H3; auto. - compute in H2; destruct H2. - rewrite (Hf e H2),H3,H in H4; discriminate. + unfold filter. + set (f':=fun k e m => if f k e then add k e m else m). + intro m. pattern m, (fold f' m (empty _)). apply fold_rec. + + intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. + elim (Hm' k e); auto. + + intros k e acc m1 m2 Hke Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. + unfold f'; simpl. + case_eq (f k e); intros Hfke; simpl; + rewrite !add_mapsto_iff, IH; clear IH; intuition. + rewrite <- Hfke; apply Hf; auto. + destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto. + elim Hn; exists e'; rewrite Hk; auto. + assert (f k e = f k' e') by (apply Hf; auto). congruence. Qed. - + Lemma for_all_iff : forall m, for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true). Proof. - cut (forall m : t elt, - for_all f m = true <-> - (forall k e, InA eqke (k,e) (rev (elements m)) -> f k e = true)). - intros; rewrite H; split; intros. - apply H0; rewrite InA_rev, <- elements_mapsto_iff; auto. - apply H0; rewrite InA_rev, <- elements_mapsto_iff in H1; auto. - - unfold for_all; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - intuition. - inversion H1. - - destruct a as (k,e); simpl. - inversion_clear H. - case_eq (f k e); intros; simpl; - try rewrite IHl; clear IHl; intuition. - inversion_clear H3; auto. - compute in H4; destruct H4. - rewrite (Hf e0 H3), H4; auto. - rewrite <-H, <-(H2 k e); auto. - constructor; red; auto. + unfold for_all. + set (f':=fun k e b => if f k e then b else false). + intro m. pattern m, (fold f' m true). apply fold_rec. + + intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto. + + intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'. + rewrite Hadd, add_mapsto_iff in Hke'. + destruct Hke' as [(?,?)|(?,?)]; auto. + rewrite <- Hfke; apply Hf; auto. + apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn; exists e'; rewrite Hn; auto. + (* f k e = false *) + split; intros H; try discriminate. + rewrite <- Hfke. apply H. + rewrite Hadd, add_mapsto_iff; auto. Qed. - + Lemma exists_iff : forall m, - exists_ f m = true <-> + exists_ f m = true <-> (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true). Proof. - cut (forall m : t elt, - exists_ f m = true <-> - (exists p, InA eqke p (rev (elements m)) - /\ f (fst p) (snd p) = true)). - intros; rewrite H; split; intros. - destruct H0 as ((k,e),Hke); exists (k,e). - rewrite InA_rev, <-elements_mapsto_iff in Hke; auto. - destruct H0 as ((k,e),Hke); exists (k,e). - rewrite InA_rev, <-elements_mapsto_iff; auto. - unfold exists_; intros. - rewrite fold_1. - rewrite <- fold_left_rev_right. - assert (NoDupA eqk (rev (elements m))). - apply NoDupA_rev; auto; try apply elements_3w; auto. - intros (k1,e1); compute; auto. - intros (k1,e1)(k2,e2); compute; auto. - intros (k1,e1)(k2,e2)(k3,e3); compute; eauto. - induction (rev (elements m)); simpl; auto. - - intuition; try discriminate. - destruct H0 as ((k,e),(Hke,_)); inversion Hke. - - destruct a as (k,e); simpl. - inversion_clear H. - case_eq (f k e); intros; simpl; - try rewrite IHl; clear IHl; intuition. + unfold exists_. + set (f':=fun k e b => if f k e then true else b). + intro m. pattern m, (fold f' m false). apply fold_rec. + + intros m' Hm'. split; try (intros; discriminate). + intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. + + intros k e b m1 m2 _ Hn Hadd IH. clear m. + change (Equal m2 (add k e m1)) in Hadd. + unfold f'; simpl. case_eq (f k e); intros Hfke. + (* f k e = true *) + split; [intros _|auto]. exists (k,e); simpl; split; auto. - constructor; red; auto. - destruct H2 as ((k',e'),(Hke',Hf')); exists (k',e'); simpl; auto. - destruct H2 as ((k',e'),(Hke',Hf')); simpl in *. - inversion_clear Hke'. - compute in H2; destruct H2. - rewrite (Hf e' H2), H3,H in Hf'; discriminate. + rewrite Hadd, add_mapsto_iff; auto. + (* f k e = false *) + rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *. + exists (k',e'); simpl; split; auto. + rewrite Hadd, add_mapsto_iff; right; split; auto. + contradict Hn. exists e'; rewrite Hn; auto. + rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)]. + assert (f k' e' = f k e) by (apply Hf; auto). congruence. exists (k',e'); auto. Qed. + End Specs. + Lemma Disjoint_alt : forall m m', + Disjoint m m' <-> + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). + Proof. + unfold Disjoint; split. + intros H k v v' H1 H2. + apply H with k; split. + exists v; trivial. + exists v'; trivial. + intros H k ((v,Hv),(v',Hv')). + eapply H; eauto. + Qed. + + Section Partition. + Variable f : key -> elt -> bool. + Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + + Lemma partition_iff_1 : forall m m1 k e, + m1 = fst (partition f m) -> + (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). + Proof. + unfold partition; simpl; intros. subst m1. + apply filter_iff; auto. + Qed. + + Lemma partition_iff_2 : forall m m2 k e, + m2 = snd (partition f m) -> + (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). + Proof. + unfold partition; simpl; intros. subst m2. + rewrite filter_iff. + split; intros (H,H'); split; auto. + destruct (f k e); simpl in *; auto. + rewrite H'; auto. + repeat red; intros. f_equal. apply Hf; auto. + Qed. + + Lemma partition_Partition : forall m m1 m2, + partition f m = (m1,m2) -> Partition m m1 m2. + Proof. + intros. split. + rewrite Disjoint_alt. intros k e e'. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence. + intros k e. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + destruct (f k e); intuition. + Qed. + + End Partition. + + Lemma Partition_In : forall m m1 m2 k, + Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. + Proof. + intros m m1 m2 k Hm Hk. + destruct (In_dec m1 k) as [H|H]; [left|right]; auto. + destruct Hm as (Hm,Hm'). + destruct Hk as (e,He); rewrite Hm' in He; destruct He. + elim H; exists e; auto. + exists e; auto. + Defined. + + Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. + Proof. + intros m1 m2 H k (H1,H2). elim (H k); auto. + Qed. + + Lemma Partition_sym : forall m m1 m2, + Partition m m1 m2 -> Partition m m2 m1. + Proof. + intros m m1 m2 (H,H'); split. + apply Disjoint_sym; auto. + intros; rewrite H'; intuition. + Qed. + + Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> + (Empty m <-> (Empty m1 /\ Empty m2)). + Proof. + intros m m1 m2 (Hdisj,Heq). split. + intro He. + split; intros k e Hke; elim (He k e); rewrite Heq; auto. + intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. + elim (He1 k e); auto. + elim (He2 k e); auto. + Qed. + + Lemma Partition_Add : + forall m m' x e , ~In x m -> Add x e m m' -> + forall m1 m2, Partition m' m1 m2 -> + exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ + Add x e m3 m2 /\ Partition m m1 m3). + Proof. + unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). + assert (Heq : Equal m (remove x m')). + change (Equal m' (add x e m)) in Hadd. rewrite Hadd. + intro k. rewrite remove_o, add_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He, <- not_find_in_iff; auto. + assert (H : MapsTo x e m'). + change (Equal m' (add x e m)) in Hadd; rewrite Hadd. + apply add_1; auto. + rewrite Hor in H; destruct H. + + (* first case : x in m1 *) + exists (remove x m1); left. split; [|split]. + (* add *) + change (Equal m1 (add x e (remove x m1))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H1; destruct H1; auto. + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e|exists e']; auto. + apply MapsTo_1 with k'; auto. + + (* second case : x in m2 *) + exists (remove x m2); right. split; [|split]. + (* add *) + change (Equal m2 (add x e (remove x m2))). + intro k. + rewrite add_o, remove_o. + destruct eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H2; destruct H2; auto. + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e'|exists e]; auto. + apply MapsTo_1 with k'; auto. + Qed. + + Lemma Partition_fold : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + transpose_neqkey eqA f -> + forall m m1 m2 i, + Partition m m1 m2 -> + eqA (fold f m i) (fold f m1 (fold f m2 i)). + Proof. + intros A eqA st f Comp Tra. + induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. + + intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. + rewrite (Partition_Empty Hp) in Hm. destruct Hm. + rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. + + intros m1 m2 i Hp. + destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). + (* fst case: m3 is (k,e)::m1 *) + assert (~In k m3). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + symmetry. + transitivity (f k e (fold f m3 (fold f m2 i))). + apply fold_Add with (eqA:=eqA); auto. + apply Comp; auto. + symmetry; apply IH; auto. + (* snd case: m3 is (k,e)::m2 *) + assert (~In k m3). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + assert (~In k m1). + contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + transitivity (f k e (fold f m1 (fold f m3 i))). + apply Comp; auto using IH. + transitivity (fold f m1 (f k e (fold f m3 i))). + symmetry. + apply fold_commutes with (eqA:=eqA); auto. + apply fold_init with (eqA:=eqA); auto. + symmetry. + apply fold_Add with (eqA:=eqA); auto. + Qed. + + Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> + cardinal m = cardinal m1 + cardinal m2. + Proof. + intros. + rewrite (cardinal_fold m), (cardinal_fold m1). + set (f:=fun (_:key)(_:elt)=>S). + setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). + rewrite <- cardinal_fold. + intros. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + apply Partition_fold with (eqA:=@Logic.eq _); try red; auto. + compute; auto. + Qed. + + Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> + let f := fun k (_:elt) => mem k m1 in + Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). + Proof. + intros m m1 m2 Hm f. + assert (Hf : Morphism (E.eq==>Leibniz==>Leibniz) f). + intros k k' Hk e e' _; unfold f; rewrite Hk; auto. + set (m1':= fst (partition f m)). + set (m2':= snd (partition f m)). + split; rewrite Equal_mapsto_iff; intros k e. + rewrite (@partition_iff_1 f Hf m m1') by auto. + unfold f. + rewrite <- mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + exists e; auto. + elim (Hm k); split; auto; exists e; auto. + rewrite (@partition_iff_2 f Hf m m2') by auto. + unfold f. + rewrite <- not_mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + elim (Hm k); split; auto; exists e; auto. + elim H1; exists e; auto. + Qed. + + Lemma update_mapsto_iff : forall m m' k e, + MapsTo k e (update m m') <-> + (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). + Proof. + unfold update. + intros m m'. + pattern m', (fold (@add _) m' m). apply fold_rec. + + intros m0 Hm0 k e. + assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). + intuition. + elim (Hm0 k e); auto. + + intros k e m0 m1 m2 _ Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd. + rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. + Qed. + + Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> + { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. + Proof. + intros m m' k e H. rewrite update_mapsto_iff in H. + destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. + elim H'; exists e; auto. + Defined. + + Lemma update_in_iff : forall m m' k, + In k (update m m') <-> In k m \/ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite update_mapsto_iff in H. + destruct H; [right|left]; exists e; intuition. + destruct (In_dec m' k) as [H|H]. + destruct H as (e,H). intros _; exists e. + rewrite update_mapsto_iff; left; auto. + destruct 1 as [H'|H']; [|elim H; auto]. + destruct H' as (e,H'). exists e. + rewrite update_mapsto_iff; right; auto. + Qed. + + Lemma diff_mapsto_iff : forall m m' k e, + MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. + Proof. + intros m m' k e. + unfold diff. + rewrite filter_iff. + intuition. + rewrite mem_1 in *; auto; discriminate. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma diff_in_iff : forall m m' k, + In k (diff m m') <-> In k m /\ ~In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite diff_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. + Qed. + + Lemma restrict_mapsto_iff : forall m m' k e, + MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. + Proof. + intros m m' k e. + unfold restrict. + rewrite filter_iff. + intuition. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma restrict_in_iff : forall m m' k, + In k (restrict m m') <-> In k m /\ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite restrict_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. + Qed. + (** specialized versions analyzing only keys (resp. elements) *) Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). @@ -1106,17 +1672,85 @@ Module WProperties (E:DecidableType)(M:WSfun E). End Elt. - Add Parametric Morphism elt : (@cardinal elt) with signature Equal ==> @Logic.eq _ as cardinal_m. + Add Parametric Morphism elt : (@cardinal elt) + with signature Equal ==> Leibniz as cardinal_m. Proof. intros; apply Equal_cardinal; auto. Qed. -End WProperties. - -(** * Same Properties for full maps *) - -Module Properties (M:S). - Module D := OT_as_DT M.E. - Include WProperties D M. -End Properties. + Add Parametric Morphism elt : (@Disjoint elt) + with signature Equal ==> Equal ==> iff as Disjoint_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. + rewrite <- Hm1, <- Hm2; auto. + rewrite Hm1, Hm2; auto. + Qed. + + Add Parametric Morphism elt : (@Partition elt) + with signature Equal ==> Equal ==> Equal ==> iff as Partition_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. + rewrite <- Hm2, <- Hm3. + split; intros (H,H'); split; auto; intros. + rewrite <- Hm1, <- Hm2, <- Hm3; auto. + rewrite Hm1, Hm2, Hm3; auto. + Qed. + + Add Parametric Morphism elt : (@update elt) + with signature Equal ==> Equal ==> Equal as update_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (update m1 m2) with (update m1' m2); unfold update. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + intros k k' e e' i Hneq x. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + apply fold_init with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto. + Qed. + + Add Parametric Morphism elt : (@restrict elt) + with signature Equal ==> Equal ==> Equal as restrict_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (restrict m1 m2) with (restrict m1' m2); + unfold restrict, filter. + apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *) + destruct mem; rewrite Hii'; auto. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; rewrite ?Hk,?He,Hm; red; auto. + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + Qed. + + Add Parametric Morphism elt : (@diff elt) + with signature Equal ==> Equal ==> Equal as diff_m. + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + setoid_replace (diff m1 m2) with (diff m1' m2); + unfold diff, filter. + apply fold_rel with (R:=Equal); try red; auto. + intros k e i i' H Hii' x. + pattern (mem k m2); rewrite Hm2. (* idem *) + destruct mem; simpl; rewrite Hii'; auto. + apply fold_Equal with (eqA:=Equal); auto. + intros k k' Hk e e' He m m' Hm; simpl in *. + pattern (mem k m2); rewrite Hk. (* idem *) + destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto. + intros k k' e e' i Hneq x. + case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto. + rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto. + Qed. + +End WProperties_fun. + +(** * Same Properties for self-contained weak maps and for full maps *) + +Module WProperties (M:WS) := WProperties_fun M.E M. +Module Properties := WProperties. (** * Properties specific to maps with ordered keys *) @@ -1151,7 +1785,8 @@ Module OrdProperties (M:S). Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. - Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. + Definition gtb (p p':key*elt) := + match E.compare (fst p) (fst p') with GT _ => true | _ => false end. Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). @@ -1275,7 +1910,7 @@ Module OrdProperties (M:S). rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. rewrite add_mapsto_iff; unfold O.eqke; simpl. intuition. - destruct (ME.eq_dec x t0); auto. + destruct (E.eq_dec x t0); auto. elimtype False. assert (In t0 m). exists e0; auto. @@ -1305,7 +1940,7 @@ Module OrdProperties (M:S). rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. rewrite add_mapsto_iff; unfold O.eqke; simpl. intuition. - destruct (ME.eq_dec x t0); auto. + destruct (E.eq_dec x t0); auto. elimtype False. assert (In t0 m). exists e0; auto. @@ -1361,7 +1996,7 @@ Module OrdProperties (M:S). inversion_clear H1; [ | inversion_clear H2; eauto ]. red in H3; simpl in H3; destruct H3. destruct p as (p1,p2). - destruct (ME.eq_dec p1 x). + destruct (E.eq_dec p1 x). apply ME.lt_eq with p1; auto. inversion_clear H2. inversion_clear H5. @@ -1513,74 +2148,53 @@ Module OrdProperties (M:S). (** The following lemma has already been proved on Weak Maps, but with one additionnal hypothesis (some [transpose] fact). *) - Lemma fold_Equal : forall s1 s2 (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Equal s1 s2 -> - eqA (fold f s1 i) (fold f s2 i). + Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). Proof. - intros. + intros m1 m2 A eqA st f i Hf Heq. do 2 rewrite fold_1. do 2 rewrite <- fold_left_rev_right. apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - apply eqlistA_rev. - apply elements_Equal_eqlistA; auto. + intros (k,e) (k',e') a a' (Hk,He) Ha; simpl in *; apply Hf; auto. + apply eqlistA_rev. apply elements_Equal_eqlistA. auto. Qed. - Lemma fold_Add : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - transpose eqA (fun y =>f (fst y) (snd y)) -> - ~In x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (f x e (fold f s1 i)). - Proof. - intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - change (f x e (fold_right f' i (rev (elements s1)))) - with (f' (x,e) (fold_right f' i (rev (elements s1)))). - trans_st (fold_right f' i - (rev (elements_lt (x, e) s1 ++ (x,e) :: elements_ge (x, e) s1))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - apply eqlistA_rev. - apply elements_Add; auto. - rewrite distr_rev; simpl. - rewrite app_ass; simpl. - rewrite (elements_split (x,e) s1). - rewrite distr_rev; simpl. - apply fold_right_commutes with (eqA:=eqke) (eqB:=eqA); auto. - Qed. - - Lemma fold_Add_Above : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Above x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (f x e (fold f s1 i)). + Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Above x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (f x e (fold f m1 i)). Proof. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - trans_st (fold_right f' i (rev (elements s1 ++ (x,e)::nil))). + transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. apply eqlistA_rev. apply elements_Add_Above; auto. rewrite distr_rev; simpl. - refl_st. + reflexivity. Qed. - Lemma fold_Add_Below : forall s1 s2 x e (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory A eqA) - (f:key->elt->A->A)(i:A), - compat_op eqke eqA (fun y =>f (fst y) (snd y)) -> - Below x s1 -> Add x e s1 s2 -> - eqA (fold f s2 i) (fold f s1 (f x e i)). + Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Below x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (fold f m1 (f x e i)). Proof. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. - trans_st (fold_right f' i (rev (((x,e)::nil)++elements s1))). + transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. apply eqlistA_rev. simpl; apply elements_Add_Below; auto. rewrite distr_rev; simpl. rewrite fold_right_app. - refl_st. + reflexivity. Qed. End Fold_properties. @@ -1589,7 +2203,3 @@ Module OrdProperties (M:S). End OrdProperties. - - - - diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 1e475887..ebdc9c57 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FMapInterface.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite map library *) @@ -55,11 +55,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) -Module Type WSfun (E : EqualityType). - - (** The module E of base objects is meant to be a [DecidableType] - (and used to be so). But requiring only an [EqualityType] here - allows subtyping between weak and ordered maps. *) +Module Type WSfun (E : DecidableType). Definition key := E.t. @@ -261,7 +257,7 @@ End WSfun. Similar to [WSfun] but expressed in a self-contained way. *) Module Type WS. - Declare Module E : EqualityType. + Declare Module E : DecidableType. Include Type WSfun E. End WS. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 23bf8196..0ec5ef36 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FMapList.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite map library *) @@ -402,7 +402,7 @@ Proof. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. - apply H1 with k; destruct (eq_dec x k); auto. + apply H1 with k; destruct (X.eq_dec x k); auto. destruct (X.compare x x'); try contradiction; clear y. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 9bc2a599..7fbc3d47 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: FMapPositive.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FMapPositive.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import Bool. Require Import ZArith. @@ -111,17 +111,17 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. apply EQ; red; auto. Qed. -End PositiveOrderedTypeBits. - -(** Other positive stuff *) - -Lemma peq_dec (x y: positive): {x = y} + {x <> y}. -Proof. + Lemma eq_dec (x y: positive): {x = y} + {x <> y}. + Proof. intros. case_eq ((x ?= y) Eq); intros. left. apply Pcompare_Eq_eq; auto. right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. -Qed. + Qed. + +End PositiveOrderedTypeBits. + +(** Other positive stuff *) Fixpoint append (i j : positive) {struct i} : positive := match i with @@ -717,7 +717,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. Proof. unfold MapsTo. - destruct (peq_dec x y). + destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. @@ -820,16 +820,21 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Variable B : Type. - Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive) - {struct m} : t B := - match m with - | Leaf => @Leaf B - | Node l o r => Node (xmapi f l (append i (xO xH))) - (option_map (f i) o) - (xmapi f r (append i (xI xH))) - end. + Section Mapi. + + Variable f : positive -> A -> B. - Definition mapi (f : positive -> A -> B) m := xmapi f m xH. + Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B := + match m with + | Leaf => @Leaf B + | Node l o r => Node (xmapi l (append i (xO xH))) + (option_map (f i) o) + (xmapi r (append i (xI xH))) + end. + + Definition mapi m := xmapi m xH. + + End Mapi. Definition map (f : A -> B) m := mapi (fun _ => f) m. @@ -983,14 +988,47 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. - Definition fold (A : Type)(B : Type) (f: positive -> A -> B -> B) (tr: t A) (v: B) := - List.fold_left (fun a p => f (fst p) (snd p) a) (elements tr) v. - + Section Fold. + + Variables A B : Type. + Variable f : positive -> A -> B -> B. + + Fixpoint xfoldi (m : t A) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l (Some x) r => + xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3) + | Node l None r => + xfoldi r (xfoldi l v (append i 2)) (append i 3) + end. + + Lemma xfoldi_1 : + forall m v i, + xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v. + Proof. + set (F := fun a p => f (fst p) (snd p) a). + induction m; intros; simpl; auto. + destruct o. + rewrite fold_left_app; simpl. + rewrite <- IHm1. + rewrite <- IHm2. + unfold F; simpl; reflexivity. + rewrite fold_left_app; simpl. + rewrite <- IHm1. + rewrite <- IHm2. + reflexivity. + Qed. + + Definition fold m i := xfoldi m i 1. + + End Fold. + Lemma fold_1 : forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. - intros; unfold fold; auto. + intros; unfold fold, elements. + rewrite xfoldi_1; reflexivity. Qed. Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := @@ -1128,10 +1166,10 @@ Module PositiveMapAdditionalFacts. (* Derivable from the Map interface *) Theorem gsspec: forall (A:Type)(i j: positive) (x: A) (m: t A), - find i (add j x m) = if peq_dec i j then Some x else find i m. + find i (add j x m) = if E.eq_dec i j then Some x else find i m. Proof. intros. - destruct (peq_dec i j); [ rewrite e; apply gss | apply gso; auto ]. + destruct (E.eq_dec i j); [ rewrite e; apply gss | apply gso; auto ]. Qed. (* Not derivable from the Map interface *) diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index faa705f6..cc1c0a76 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: FSetAVL.v 10811 2008-04-17 16:29:49Z letouzey $ *) +(* $Id: FSetAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * FSetAVL *) @@ -1881,6 +1881,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. + Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. + Proof. + intros (s,b) (s',b'); unfold eq; simpl. + case_eq (Raw.equal s s'); intro H; [left|right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + (* specs *) Section Specs. Variable s s' s'': t. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 0622451f..c03fb92e 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 10601 2008-02-28 00:20:33Z letouzey $ *) +(* $Id: FSetBridge.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * Finite sets library *) @@ -20,11 +20,8 @@ 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 DepOfNodep (Import M: S) <: Sdep with Module E := M.E. - Module ME := OrderedTypeFacts E. - Definition empty : {s : t | Empty s}. Proof. exists empty; auto with set. @@ -50,7 +47,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. Proof. intros; exists (add x s); auto. unfold Add in |- *; intuition. - elim (ME.eq_dec x y); auto. + elim (E.eq_dec x y); auto. intros; right. eapply add_3; eauto. Qed. @@ -68,7 +65,7 @@ Module DepOfNodep (M: S) <: Sdep with Module E := M.E. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. - elim (ME.eq_dec x y); intros; auto. + elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. apply In_1 with y; auto. eauto with set. @@ -396,6 +393,8 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intros; discriminate H. Qed. + Definition eq_dec := equal. + Definition equal (s s' : t) : bool := if equal s s' then true else false. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 0639c1f1..06b4e028 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetDecide.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetDecide.v 11699 2008-12-18 11:49:08Z letouzey $ *) (**************************************************************) (* FSetDecide.v *) @@ -19,10 +19,10 @@ Require Import Decidable DecidableTypeEx FSetFacts. -(** First, a version for Weak Sets *) +(** First, a version for Weak Sets in functorial presentation *) -Module WDecide (E : DecidableType)(Import M : WSfun E). - Module F := FSetFacts.WFacts E M. +Module WDecide_fun (E : DecidableType)(Import M : WSfun E). + Module F := FSetFacts.WFacts_fun E M. (** * Overview This functor defines the tactic [fsetdec], which will @@ -509,7 +509,14 @@ the above form: | J : _ |- _ => progress (change T with E.t in J) | |- _ => progress (change T with E.t) end ) - end). + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). (** These two tactics take us from Coq's built-in equality to [E.eq] (and vice versa) when possible. *) @@ -747,6 +754,12 @@ the above form: In x (singleton x). Proof. fsetdec. Qed. + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + Lemma test_Subset_add_remove : forall x s, s [<=] (add x (remove x s)). Proof. fsetdec. Qed. @@ -825,17 +838,27 @@ the above form: intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. Qed. + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + End FSetDecideTestCases. -End WDecide. +End WDecide_fun. Require Import FSetInterface. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Decide] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WDecide]. *) -Module Decide (M : S). - Module D:=OT_as_DT M.E. - Module WD := WDecide D M. - Ltac fsetdec := WD.fsetdec. -End Decide.
\ No newline at end of file +Module WDecide (M:WS) := WDecide_fun M.E M. +Module Decide := WDecide. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index a397cc28..80ab2b2c 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetEqProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -19,8 +19,8 @@ Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. -Module WEqProperties (Import E:DecidableType)(M:WSfun E). -Module Import MP := WProperties E M. +Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E). +Module Import MP := WProperties_fun E M. Import FM Dec.F. Import M. @@ -73,7 +73,7 @@ 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. +auto with set. rewrite <- is_empty_iff; auto with set. Qed. @@ -281,7 +281,7 @@ Qed. Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. Proof. intros; rewrite singleton_b. -unfold eqb; destruct (eq_dec x y); intuition. +unfold eqb; destruct (E.eq_dec x y); intuition. Qed. Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. @@ -494,7 +494,7 @@ destruct (mem x s); destruct (mem x s'); intuition. Qed. Section Fold. -Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). +Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). @@ -852,7 +852,7 @@ assert (gc : compat_opL (fun x:elt => plus (g x))). auto. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. -assert (st := gen_st nat). +assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. intros. rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). @@ -867,7 +867,7 @@ 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 (st : Equivalence (@Logic.eq nat)) by (split; congruence). assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). red; intros. rewrite (Hf x x' H); auto. @@ -892,7 +892,7 @@ rewrite filter_iff; auto; set_iff; tauto. Qed. Lemma fold_compat : - forall (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA) + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), (compat_op E.eq eqA f) -> (transpose eqA f) -> (compat_op E.eq eqA g) -> (transpose eqA g) -> @@ -901,19 +901,19 @@ Lemma fold_compat : 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). +transitivity (fold f s0 i). apply fold_equal with (eqA:=eqA); auto. rewrite equal_sym; auto. -trans_st (fold g s0 i). +transitivity (fold g s0 i). apply H0; intros; apply H1; auto with set. elim (equal_2 H x); auto with set; intros. apply fold_equal with (eqA:=eqA); auto with set. -trans_st (f x (fold f s0 i)). +transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. -trans_st (g x (fold f s0 i)); auto with set. -trans_st (g x (fold g s0 i)); auto with set. -sym_st; apply fold_add with (eqA:=eqA); auto. -do 2 rewrite fold_empty; refl_st. +transitivity (g x (fold f s0 i)); auto with set. +transitivity (g x (fold g s0 i)); auto with set. +symmetry; apply fold_add with (eqA:=eqA); auto. +do 2 rewrite fold_empty; reflexivity. Qed. Lemma sum_compat : @@ -927,13 +927,12 @@ Qed. End Sum. -End WEqProperties. - +End WEqProperties_fun. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [EqProperties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) -Module EqProperties (M:S). - Module D := OT_as_DT M.E. - Include WEqProperties D M. -End EqProperties. +Module WEqProperties (M:WS) := WEqProperties_fun M.E M. +Module EqProperties := WEqProperties. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index d77d9c60..1e15d3a1 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 11282 2008-07-28 11:51:53Z msozeau $ *) +(* $Id: FSetFacts.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -21,11 +21,9 @@ Require Export FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** First, a functor for Weak Sets. Since the signature [WS] includes - an EqualityType and not a stronger DecidableType, this functor - should take two arguments in order to compensate this. *) +(** First, a functor for Weak Sets in functorial version. *) -Module WFacts (Import E : DecidableType)(Import M : WSfun E). +Module WFacts_fun (Import E : DecidableType)(Import M : WSfun E). Notation eq_dec := E.eq_dec. Definition eqb x y := if eq_dec x y then true else false. @@ -293,12 +291,12 @@ End BoolSpec. (** * [E.eq] and [Equal] are setoid equalities *) -Definition E_ST : Setoid_Theory elt E.eq. +Definition E_ST : Equivalence E.eq. Proof. constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. -Definition Equal_ST : Setoid_Theory t Equal. +Definition Equal_ST : Equivalence Equal. Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. @@ -309,8 +307,6 @@ Add Relation elt E.eq transitivity proved by E.eq_trans as EltSetoid. -Typeclasses unfold elt. - Add Relation t Equal reflexivity proved by eq_refl symmetry proved by eq_sym @@ -418,18 +414,15 @@ Qed. (* [Subset] is a setoid order *) Lemma Subset_refl : forall s, s[<=]s. -Proof. red; auto. Defined. +Proof. red; auto. Qed. Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''. -Proof. unfold Subset; eauto. Defined. +Proof. unfold Subset; eauto. Qed. -Add Relation t Subset +Add Relation t Subset reflexivity proved by Subset_refl transitivity proved by Subset_trans as SubsetSetoid. -(* NB: for the moment, it is important to use Defined and not Qed in - the two previous lemmas, in order to allow conversion of - SubsetSetoid coming from separate Facts modules. See bug #1738. *) Instance In_s_m : Morphism (E.eq ==> Subset ++> impl) In | 1. Proof. @@ -480,28 +473,35 @@ Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. Qed. +Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. +Proof. +intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). +rewrite Hff', Hss'; intuition. +red; intros; rewrite <- 2 Hff'; auto. +Qed. + Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. Qed. -(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid +(* 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 WFacts. - +End WFacts_fun. -(** Now comes a special version dedicated to full sets. For this - one, only one argument [(M:S)] is necessary. *) +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Facts] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WFacts]. *) -Module Facts (Import M:S). - Module D:=OT_as_DT M.E. - Include WFacts D M. +Module WFacts (M:WS) := WFacts_fun M.E M. +Module Facts := WFacts. -End Facts. diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v index 1fc109f3..a2d8e681 100644 --- a/theories/FSets/FSetFullAVL.v +++ b/theories/FSets/FSetFullAVL.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: FSetFullAVL.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FSetFullAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) (** * FSetFullAVL @@ -913,6 +913,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. change (Raw.Equal s s'); auto. Defined. + Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. + Proof. + intros (s,b,a) (s',b',a'); unfold eq; simpl. + case_eq (Raw.equal s s'); intro H; [left|right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + (* specs *) Section Specs. Variable s s' s'': t. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 1255fcc8..79eea34e 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FSetInterface.v 11701 2008-12-18 11:49:12Z letouzey $ *) (** * Finite set library *) @@ -44,11 +44,7 @@ Unset Strict Implicit. Weak sets are sets without ordering on base elements, only a decidable equality. *) -Module Type WSfun (E : EqualityType). - - (** The module E of base objects is meant to be a [DecidableType] - (and used to be so). But requiring only an [EqualityType] here - allows subtyping between weak and ordered sets *) +Module Type WSfun (E : DecidableType). Definition elt := E.t. @@ -62,8 +58,8 @@ Module Type WSfun (E : EqualityType). 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). + 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. *) @@ -95,12 +91,8 @@ Module Type WSfun (E : EqualityType). (** Set difference. *) Definition eq : t -> t -> Prop := Equal. - (** In order to have the subtyping WS < S between weak and ordered - sets, we do not require here an [eq_dec]. This interface is hence - not compatible with [DecidableType], but only with [EqualityType], - so in general it may not possible to form weak sets of weak sets. - Some particular implementations may allow this nonetheless, in - particular [FSetWeakList.Make]. *) + + Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. Parameter equal : t -> t -> bool. (** [equal s1 s2] tests whether the sets [s1] and [s2] are @@ -282,7 +274,7 @@ End WSfun. module [E] of base elements is incorporated in the signature. *) Module Type WS. - Declare Module E : EqualityType. + Declare Module E : DecidableType. Include Type WSfun E. End WS. @@ -367,17 +359,16 @@ WSfun ---> WS | | | | V V -Sfun ---> S - +Sfun ---> S -Module S_WS (M : S) <: SW := M. +Module S_WS (M : S) <: WS := M. Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M. -Module S_Sfun (E:OrderedType)(M : S with Module E:=E) <: Sfun E := M. -Module WS_WSfun (E:EqualityType)(M : WS with Module E:=E) <: WSfun E := M. +Module S_Sfun (M : S) <: Sfun M.E := M. +Module WS_WSfun (M : WS) <: WSfun M.E := M. >> *) -(** * Dependent signature +(** * Dependent signature Signature [Sdep] presents ordered sets using dependent types *) @@ -402,7 +393,7 @@ Module Type Sdep. 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_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''. diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index a205d5b0..b009e109 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: FSetList.v 11866 2009-01-28 19:10:15Z letouzey $ *) (** * Finite sets library *) @@ -1263,6 +1263,14 @@ Module Make (X: OrderedType) <: S with Module E := X. auto. Defined. + Definition eq_dec : { eq s s' } + { ~ eq s s' }. + Proof. + change eq with Equal. + case_eq (equal s s'); intro H; [left | right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. + End Spec. End Make. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 7413b06b..8dc7fbd9 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 11064 2008-06-06 17:00:52Z letouzey $ *) +(* $Id: FSetProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) (** * Finite sets library *) @@ -22,15 +22,13 @@ Set Implicit Arguments. Unset Strict Implicit. Hint Unfold transpose compat_op. -Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. +Hint Extern 1 (Equivalence _) => constructor; congruence. -(** First, a functor for Weak Sets. Since the signature [WS] includes - an EqualityType and not a stronger DecidableType, this functor - should take two arguments in order to compensate this. *) +(** First, a functor for Weak Sets in functorial version. *) -Module WProperties (Import E : DecidableType)(M : WSfun E). - Module Import Dec := WDecide E M. - Module Import FM := Dec.F (* FSetFacts.WFacts E M *). +Module WProperties_fun (Import E : DecidableType)(M : WSfun E). + Module Import Dec := WDecide_fun E M. + Module Import FM := Dec.F (* FSetFacts.WFacts_fun E M *). Import M. Lemma In_dec : forall x s, {In x s} + {~ In x s}. @@ -126,6 +124,10 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). Lemma singleton_equal_add : singleton x [=] add x empty. Proof. fsetdec. Qed. + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. + Lemma union_sym : union s s' [=] union s' s. Proof. fsetdec. Qed. @@ -306,21 +308,176 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). rewrite <-elements_Empty; auto with set. Qed. - (** * Alternative (weaker) specifications for [fold] *) + (** * Conversions between lists and sets *) + + Definition of_list (l : list elt) := List.fold_right add empty l. - Section Old_Spec_Now_Properties. + Definition to_list := elements. + + Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. + Proof. + induction l; simpl; intro x. + rewrite empty_iff, InA_nil. intuition. + rewrite add_iff, InA_cons, IHl. intuition. + Qed. + + Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. + Proof. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. + Qed. + + Lemma of_list_3 : forall s, of_list (to_list s) [=] s. + Proof. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. + Qed. + + (** * Fold *) + + Section Fold. Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). + + (** ** Induction principles for fold (contributed by S. Lescuyer) *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise set s we are considering. *) + + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto. + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto. + inversion_clear Hdup; rewrite of_list_1; auto. + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + apply IHl. + intros; eapply Pstep'; eauto. + inversion_clear Hdup; auto. + exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with empty; auto with set. + rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable to any [x]. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + do 2 rewrite fold_1, <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). + clearbody l; clear Rstep s. + induction l; simpl; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on sets. *) + + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] - takes the set elements was unspecified. This specification reflects this fact: + takes the set elements was unspecified. This specification reflects + this fact: *) - Lemma fold_0 : + Lemma fold_0 : forall s (A : Type) (i : A) (f : elt -> A -> A), exists l : list elt, NoDup l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ + (forall x : elt, In x s <-> InA x l) /\ fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. @@ -333,26 +490,26 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). 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 + (** An alternate (and previous) specification for [fold] was based on + the recursive structure of a set. It is now lemmas [fold_1] and [fold_2]. *) Lemma fold_1 : - forall s (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + forall s (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), Empty s -> eqA (fold f s i) i. Proof. unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). rewrite H3; clear H3. generalize H H2; clear H H2; case l; simpl; intros. - refl_st. + reflexivity. elim (H e). elim (H2 e); intuition. Qed. Lemma fold_2 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). @@ -379,283 +536,238 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). rewrite elements_Empty in H; rewrite H; simpl; auto. Qed. - (** Similar specifications for [cardinal]. *) + Section Fold_More. - 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 *) + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. - rewrite elements_Empty, M.cardinal_1. - destruct (elements s); intuition; discriminate. - Qed. - - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - Hint Resolve cardinal_inv_1. - - Lemma cardinal_inv_2 : - forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. - intros; rewrite M.cardinal_1 in H. - generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. - exists e; auto. - Qed. - - Lemma cardinal_inv_2b : - forall s, cardinal s <> 0 -> { x : elt | In x s }. - Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; - [intuition|eauto]. - Qed. - - Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. - symmetry. - remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. - induction n; intros. - apply cardinal_1; rewrite <- H; auto. - destruct (cardinal_inv_2 Heqn) as (x,H2). - revert Heqn. - rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. - rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. - Qed. - - Add Morphism cardinal : cardinal_m. - Proof. - exact Equal_cardinal. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + reflexivity. + transitivity (f x0 (f x b)); auto. Qed. - Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + (** ** Fold is a morphism *) - 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. + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). Proof. - intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. - destruct (cardinal_inv_2 (sym_eq Heqn)) as (x,H0). - apply X0 with (remove x s) x; auto with set. - apply IHn; auto. - assert (S n = S (cardinal (remove x s))). - rewrite Heqn; apply cardinal_2 with x; auto with set. - inversion H; auto. - Qed. - - (** Other properties of [fold]. *) - - Section Fold. - Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). - Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - - Section Fold_1. - Variable i i':A. - - Lemma fold_empty : (fold f empty i) = i. - Proof. - apply fold_1b; auto with set. + intros. apply fold_rel with (R:=eqA); auto. Qed. Lemma fold_equal : - forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + forall i 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. + intros i s; pattern s; apply set_induction; clear s; intros. + transitivity i. apply fold_1; auto. - sym_st; apply fold_1; auto. + symmetry; apply fold_1; auto. rewrite <- H0; auto. - trans_st (f x (fold f s i)). + transitivity (f x (fold f s i)). apply fold_2 with (eqA := eqA); auto. - sym_st; apply fold_2 with (eqA := eqA); auto. + symmetry; apply fold_2 with (eqA := eqA); auto. unfold Add in *; intros. rewrite <- H2; auto. Qed. - - Lemma fold_add : forall s x, ~In x s -> + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). Proof. - intros; apply fold_2 with (eqA := eqA); auto. + intros; apply fold_2 with (eqA := eqA); auto with set. Qed. - Lemma add_fold : forall s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_1: forall s x, In x s -> + Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. - sym_st. + symmetry. apply fold_2 with (eqA:=eqA); auto with set. Qed. - Lemma remove_fold_2: forall s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. apply fold_equal; auto with set. Qed. - Lemma fold_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', + Lemma fold_union_inter : forall i s s', eqA (fold f (union s s') (fold f (inter s s') i)) (fold f s (fold f s' i)). Proof. intros; pattern s; apply set_induction; clear s; intros. - trans_st (fold f s' (fold f (inter s s') i)). + transitivity (fold f s' (fold f (inter s s') i)). apply fold_equal; auto with set. - trans_st (fold f s' i). + transitivity (fold f s' i). apply fold_init; auto. apply fold_1; auto with set. - sym_st; apply fold_1; auto. + symmetry; 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. + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. rewrite inter_iff; intuition. - 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))). + transitivity (f x (fold f s (fold f s' i))). + transitivity (fold f (union s s') (f x (fold f (inter s s') i))). apply fold_equal; auto. apply equal_sym; apply union_Equal with x; auto with set. - trans_st (f x (fold f (union s s') (fold f (inter s s') i))). + transitivity (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. + apply Comp; auto. + symmetry; 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))). + transitivity (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))). + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). apply Comp;auto. apply fold_init;auto. apply fold_equal;auto. apply equal_sym; apply inter_Add_2 with x; auto with set. - trans_st (f x (fold f s (fold f s' i))). - sym_st; apply fold_2 with (eqA:=eqA); auto. + transitivity (f x (fold f s (fold f s' i))). + apply Comp; auto. + symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. - End Fold_2. - Section Fold_3. - Variable i:A. - - Lemma fold_diff_inter : forall s s', + Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. - 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)). + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + symmetry; apply fold_union_inter; auto. + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). apply fold_equal; auto with set. apply fold_init; auto. apply fold_1; auto with set. Qed. - Lemma fold_union: forall s s', + Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros. - trans_st (fold f (union s s') (fold f (inter s s') i)). + transitivity (fold f (union s s') (fold f (inter s s') i)). apply fold_init; auto. - sym_st; apply fold_1; auto with set. + symmetry; apply fold_1; auto with set. unfold Empty; intro a; generalize (H a); set_iff; tauto. apply fold_union_inter; auto. Qed. - End Fold_3. - End Fold. + End Fold_More. 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 (@Logic.eq _) (fun _ => S)) by (unfold compat_op; auto). - assert (fp : transpose (@Logic.eq _) (fun _:elt => S)) by (unfold transpose; auto). - intros s p; pattern s; apply set_induction; clear s; intros. - rewrite (fold_1 st p (fun _ => S) H). - rewrite (fold_1 st 0 (fun _ => S) H); trivial. - 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. - - (** more properties of [cardinal] *) + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. + + End Fold. + + (** * Cardinal *) + + (** ** Characterization of cardinal in terms of fold *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite M.fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + (** ** Old specifications for [cardinal]. *) + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition; 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. + + (** ** Cardinal and (non-)emptiness *) + + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, M.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite M.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. + Qed. + + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. + Proof. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. + Qed. + + (** ** Cardinal is a morphism *) + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + apply cardinal_1; rewrite <- H; auto. + destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. + Qed. + + Add Morphism cardinal : cardinal_m. + Proof. + exact Equal_cardinal. + Qed. + + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + + (** ** Cardinal and set operators *) Lemma empty_cardinal : cardinal empty = 0. Proof. @@ -773,18 +885,18 @@ Module WProperties (Import E : DecidableType)(M : WSfun E). Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. -End WProperties. +End WProperties_fun. +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Properties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WProperties]. *) -(** A clone of [WProperties] working on full sets. *) +Module WProperties (M:WS) := WProperties_fun M.E M. +Module Properties := WProperties. -Module Properties (M:S). - Module D := OT_as_DT M.E. - Include WProperties D M. -End Properties. - -(** Now comes some properties specific to the element ordering, +(** Now comes some properties specific to the element ordering, invalid for Weak Sets. *) Module OrdProperties (M:S). @@ -973,7 +1085,7 @@ Module OrdProperties (M:S). Lemma fold_3 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. @@ -990,7 +1102,7 @@ Module OrdProperties (M:S). Lemma fold_4 : forall s s' x (A : Type) (eqA : A -> A -> Prop) - (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), compat_op E.eq eqA f -> Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). Proof. @@ -1010,7 +1122,7 @@ Module OrdProperties (M:S). no need for [(transpose eqA f)]. *) Section FoldOpt. - Variables (A:Type)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). Lemma fold_equal : @@ -1024,14 +1136,6 @@ Module OrdProperties (M:S). red; intro a; do 2 rewrite <- elements_iff; auto. Qed. - Lemma fold_init : forall i i' s, eqA i i' -> - eqA (fold f s i) (fold f s i'). - Proof. - intros; do 2 rewrite M.fold_1. - do 2 rewrite <- fold_left_rev_right. - induction (rev (elements s)); simpl; auto. - Qed. - Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index ae51d905..56a66261 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: FSetToFiniteSet.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: FSetToFiniteSet.v 11735 2009-01-02 17:22:31Z herbelin $ *) Require Import Ensembles Finite_sets. Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. @@ -20,7 +20,7 @@ Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). - Module MP:= WProperties U M. + Module MP:= WProperties_fun U M. Import M MP FM Ensembles Finite_sets. Definition mkEns : M.t -> Ensemble M.elt := @@ -30,7 +30,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. Proof. - unfold In; compute; auto. + unfold In; compute; auto with extcore. Qed. Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). @@ -155,9 +155,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). End WS_to_Finite_set. -Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U). - Module D := OT_as_DT U. - Include WS_to_Finite_set D M. -End S_to_Finite_set. +Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) := + WS_to_Finite_set U M. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 71a0d584..309016ce 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 10631 2008-03-06 18:17:24Z msozeau $ *) +(* $Id: FSetWeakList.v 11866 2009-01-28 19:10:15Z letouzey $ *) (** * Finite sets library *) @@ -746,53 +746,12 @@ Module Raw (X: DecidableType). Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), { eq s s' }+{ ~eq s s' }. Proof. - unfold eq. - induction s; intros s'. - (* nil *) - destruct s'; [left|right]. - firstorder. - unfold not, Equal. - intros H; generalize (H e); clear H. - rewrite InA_nil, InA_cons; intuition. - (* cons *) - intros. - case_eq (mem a s'); intros H; - [ destruct (IHs (remove a s')) as [H'|H']; - [ | | left|right]|right]; - clear IHs. - inversion_clear Hs; auto. - apply remove_unique; auto. - (* In a s' /\ s [=] remove a s' *) - generalize (mem_2 H); clear H; intro H. - unfold Equal in *; intros b. - rewrite InA_cons; split. - destruct 1. - apply In_eq with a; auto. - rewrite H' in H0. - apply remove_3 with a; auto. - destruct (X.eq_dec b a); [left|right]; auto. - rewrite H'. - apply remove_2; auto. - (* In a s' /\ ~ s [=] remove a s' *) - generalize (mem_2 H); clear H; intro H. - contradict H'. - unfold Equal in *; intros b. - split; intros. - apply remove_2; auto. - inversion_clear Hs. - contradict H1; apply In_eq with b; auto. - rewrite <- H'; rewrite InA_cons; auto. - assert (In b s') by (apply remove_3 with a; auto). - rewrite <- H', InA_cons in H1; destruct H1; auto. - elim (remove_1 Hs' (X.eq_sym H1) H0). - (* ~ In a s' *) - assert (~In a s'). - red; intro H'; rewrite (mem_1 H') in H; discriminate. - contradict H0. - unfold Equal in *. - rewrite <- H0. - rewrite InA_cons; auto. - Qed. + intros. + change eq with Equal. + case_eq (equal s s'); intro H; [left | right]. + apply equal_2; auto. + intro H'; rewrite equal_1 in H; auto; discriminate. + Defined. End ForNotations. End Raw. @@ -993,6 +952,6 @@ Module Make (X: DecidableType) <: WS with Module E := X. { eq s s' }+{ ~eq s s' }. Proof. intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). - Qed. + Defined. End Make. diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v index c56a24cf..fadd27dd 100644 --- a/theories/FSets/OrderedType.v +++ b/theories/FSets/OrderedType.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: OrderedType.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: OrderedType.v 11700 2008-12-18 11:49:10Z letouzey $ *) Require Export SetoidList. Set Implicit Arguments. @@ -19,7 +19,7 @@ Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := | EQ : eq x y -> Compare lt eq x y | GT : lt y x -> Compare lt eq x y. -Module Type OrderedType. +Module Type MiniOrderedType. Parameter Inline t : Type. @@ -29,7 +29,7 @@ Module Type OrderedType. 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. @@ -38,15 +38,34 @@ Module Type OrderedType. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. +End MiniOrderedType. + +Module Type OrderedType. + Include Type MiniOrderedType. + + (** A [eq_dec] can be deduced from [compare] below. But adding this + redundant field allows to see an OrderedType as a DecidableType. *) + Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. + End OrderedType. +Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. + Include O. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + assert (~ eq y x); auto. + Defined. + +End MOT_to_OT. + (** * Ordered types properties *) (** Additional properties that can be derived from signature [OrderedType]. *) -Module OrderedTypeFacts (O: OrderedType). - Import O. +Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. @@ -293,10 +312,8 @@ Ltac false_order := elimtype False; order. 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. - Defined. + (** For compatibility reasons *) + Definition eq_dec := eq_dec. Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v index 516df0f0..9d179995 100644 --- a/theories/FSets/OrderedTypeAlt.v +++ b/theories/FSets/OrderedTypeAlt.v @@ -11,11 +11,12 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeAlt.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: OrderedTypeAlt.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import OrderedType. -(** * An alternative (but equivalent) presentation for an Ordered Type inferface. *) +(** * An alternative (but equivalent) presentation for an Ordered Type + inferface. *) (** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt] whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] @@ -81,6 +82,12 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. rewrite compare_sym; rewrite H; auto. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. + End OrderedType_from_Alt. (** From the original presentation to this alternative one. *) diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v index 03171396..03e3ab83 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/FSets/OrderedTypeEx.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: OrderedTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import OrderedType. Require Import ZArith. @@ -34,6 +34,7 @@ Module Type UsualOrderedType. Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. Parameter compare : forall x y : t, Compare lt eq x y. + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. End UsualOrderedType. (** a [UsualOrderedType] is in particular an [OrderedType]. *) @@ -68,6 +69,8 @@ Module Nat_as_OT <: UsualOrderedType. intro; constructor 3; auto. Defined. + Definition eq_dec := eq_nat_dec. + End Nat_as_OT. @@ -99,6 +102,8 @@ Module Z_as_OT <: UsualOrderedType. apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto. Defined. + Definition eq_dec := Z_eq_dec. + End Z_as_OT. (** [positive] is an ordered type with respect to the usual order on natural numbers. *) @@ -140,6 +145,11 @@ Module Positive_as_OT <: UsualOrderedType. rewrite <- Pcompare_antisym; rewrite H; auto. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq; decide equality. + Defined. + End Positive_as_OT. @@ -183,6 +193,11 @@ Module N_as_OT <: UsualOrderedType. destruct (Nleb x y); intuition. Defined. + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. + Defined. + End N_as_OT. @@ -243,5 +258,12 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. apply GT; unfold lt; auto. Defined. + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); intro H; [ right | left | right ]; auto. + auto using lt_not_eq. + assert (~ eq y x); auto using lt_not_eq, eq_sym. + Defined. + End PairOrderedType. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index e5e6fd23..0163c01c 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Datatypes.v 11073 2008-06-08 20:24:51Z herbelin $ i*) +(*i $Id: Datatypes.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Set Implicit Arguments. @@ -59,19 +59,39 @@ Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. Proof. destruct a; destruct b; intros; split; try (reflexivity || discriminate). Qed. -Hint Resolve andb_prop: bool v62. +Hint Resolve andb_prop: bool. Lemma andb_true_intro : forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. Proof. destruct b1; destruct b2; simpl in |- *; tauto || auto with bool. Qed. -Hint Resolve andb_true_intro: bool v62. +Hint Resolve andb_true_intro: bool. (** Interpretation of booleans as propositions *) Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. +(** Additional rewriting lemmas about [eq_true] *) + +Lemma eq_true_ind_r : + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + +Lemma eq_true_rec_r : + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + +Lemma eq_true_rect_r : + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true. +Proof. + intros P b H H0; destruct H0 in H; assumption. +Defined. + (** [nat] is the datatype of natural numbers built from [O] and successor [S]; note that the constructor name is the letter O. Numbers in [nat] can be denoted using a decimal notation; @@ -95,7 +115,7 @@ Inductive Empty_set : Set :=. Inductive identity (A:Type) (a:A) : A -> Type := refl_identity : identity (A:=A) a a. -Hint Resolve refl_identity: core v62. +Hint Resolve refl_identity: core. Implicit Arguments identity_ind [A]. Implicit Arguments identity_rec [A]. @@ -144,7 +164,7 @@ Section projections. end. End projections. -Hint Resolve pair inl inr: core v62. +Hint Resolve pair inl inr: core. Lemma surjective_pairing : forall (A B:Type) (p:A * B), p = pair (fst p) (snd p). diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 6a636ccc..ae79744f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Logic.v 10304 2007-11-08 17:06:32Z emakarov $ i*) +(*i $Id: Logic.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Set Implicit Arguments. @@ -150,6 +150,16 @@ Proof. intros; tauto. Qed. +Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A). +Proof. +intros A B []; split; trivial. +Qed. + +Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A). +Proof. +intros; tauto. +Qed. + (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes either [P] and [Q], or [~P] and [Q] *) @@ -245,8 +255,8 @@ Implicit Arguments eq_ind [A]. Implicit Arguments eq_rec [A]. Implicit Arguments eq_rect [A]. -Hint Resolve I conj or_introl or_intror refl_equal: core v62. -Hint Resolve ex_intro ex_intro2: core v62. +Hint Resolve I conj or_introl or_intror refl_equal: core. +Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -339,7 +349,7 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. -Hint Immediate sym_eq sym_not_eq: core v62. +Hint Immediate sym_eq sym_not_eq: core. (** Basic definitions about relations and properties *) diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 9ef63cc8..43b1f634 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano.v 11115 2008-06-12 16:03:32Z werner $ i*) +(*i $Id: Peano.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** The type [nat] of Peano natural numbers (built from [O] and [S]) is defined in [Datatypes.v] *) @@ -47,7 +47,7 @@ Hint Resolve (f_equal pred): v62. Theorem pred_Sn : forall n:nat, n = pred (S n). Proof. - simpl; reflexivity. + simpl; reflexivity. Qed. (** Injectivity of successor *) @@ -59,13 +59,13 @@ Proof. rewrite Sn_eq_Sm; trivial. Qed. -Hint Immediate eq_add_S: core v62. +Hint Immediate eq_add_S: core. 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. +Hint Resolve not_eq_S: core. Definition IsSucc (n:nat) : Prop := match n with @@ -80,13 +80,13 @@ Proof. unfold not; intros n H. inversion H. Qed. -Hint Resolve O_S: core v62. +Hint Resolve O_S: core. Theorem n_Sn : forall n:nat, n <> S n. Proof. induction n; auto. Qed. -Hint Resolve n_Sn: core v62. +Hint Resolve n_Sn: core. (** Addition *) @@ -105,7 +105,7 @@ Lemma plus_n_O : forall n:nat, n = n + 0. Proof. induction n; simpl in |- *; auto. Qed. -Hint Resolve plus_n_O: core v62. +Hint Resolve plus_n_O: core. Lemma plus_O_n : forall n:nat, 0 + n = n. Proof. @@ -116,7 +116,7 @@ Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m. Proof. intros n m; induction n; simpl in |- *; auto. Qed. -Hint Resolve plus_n_Sm: core v62. +Hint Resolve plus_n_Sm: core. Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m). Proof. @@ -138,13 +138,13 @@ Fixpoint mult (n m:nat) {struct n} : nat := where "n * m" := (mult n m) : nat_scope. -Hint Resolve (f_equal2 mult): core v62. +Hint Resolve (f_equal2 mult): core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. induction n; simpl in |- *; auto. Qed. -Hint Resolve mult_n_O: core v62. +Hint Resolve mult_n_O: core. Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m. Proof. @@ -152,7 +152,7 @@ Proof. destruct H; rewrite <- plus_n_Sm; apply (f_equal S). pattern m at 1 3 in |- *; elim m; simpl in |- *; auto. Qed. -Hint Resolve mult_n_Sm: core v62. +Hint Resolve mult_n_Sm: core. (** Standard associated names *) @@ -165,16 +165,12 @@ Fixpoint minus (n m:nat) {struct n} : nat := match n, m with | O, _ => n | S k, O => n -(*======= - - | O, _ => n - | S k, O => S k *) | S k, S l => k - l end where "n - m" := (minus n m) : nat_scope. -(** Definition of the usual orders, the basic properties of [le] and [lt] +(** Definition of the usual orders, the basic properties of [le] and [lt] can be found in files Le and Lt *) Inductive le (n:nat) : nat -> Prop := @@ -183,21 +179,21 @@ Inductive le (n:nat) : nat -> Prop := 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*) +Hint Constructors le: core. +(*i equivalent to : "Hints Resolve le_n le_S : core." i*) Definition lt (n m:nat) := S n <= m. -Hint Unfold lt: core v62. +Hint Unfold lt: core. Infix "<" := lt : nat_scope. Definition ge (n m:nat) := m <= n. -Hint Unfold ge: core v62. +Hint Unfold ge: core. Infix ">=" := ge : nat_scope. Definition gt (n m:nat) := m < n. -Hint Unfold gt: core v62. +Hint Unfold gt: core. Infix ">" := gt : nat_scope. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 10555fc0..2d7e2159 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: Tactics.v 11741 2009-01-03 14:34:39Z herbelin $ i*) Require Import Notations. Require Import Logic. @@ -72,6 +72,17 @@ Ltac false_hyp H G := Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. +(* Similar variants of destruct *) + +Tactic Notation "destruct_with_eqn" constr(x) := + destruct x as []_eqn. +Tactic Notation "destruct_with_eqn" ident(n) := + try intros until n; destruct n as []_eqn. +Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) := + destruct x as []_eqn:H. +Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := + try intros until n; destruct n as []_eqn:H. + (* Rewriting in all hypothesis several times everywhere *) Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *. @@ -135,14 +146,31 @@ bapply lemma ltac:(fun H => destruct H as [H _]; apply H in J). Tactic Notation "apply" "<-" constr(lemma) "in" ident(J) := bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J). -(** A tactic simpler than auto that is useful for ending proofs "in one step" *) -Tactic Notation "now" tactic(t) := -t; -match goal with -| H : _ |- _ => solve [inversion H] -| _ => solve [trivial | reflexivity | symmetry; trivial | discriminate | split] -| _ => fail 1 "Cannot solve this goal." -end. +(** An experimental tactic simpler than auto that is useful for ending + proofs "in one step" *) + +Ltac easy := + let rec use_hyp H := + match type of H with + | _ /\ _ => exact H || destruct_hyp H + | _ => try solve [inversion H] + end + with do_intro := let H := fresh in intro H; use_hyp H + with destruct_hyp H := case H; clear H; do_intro; do_intro in + let rec use_hyps := + match goal with + | H : _ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps) + | H : _ |- _ => solve [inversion H] + | _ => idtac + end in + let rec do_atom := + solve [reflexivity | symmetry; trivial] || + contradiction || + (split; do_atom) + with do_ccl := trivial; repeat do_intro; do_atom in + (use_hyps; do_ccl) || fail "Cannot solve this goal". + +Tactic Notation "now" tactic(t) := t; easy. (** A tactic to document or check what is proved at some point of a script *) Ltac now_show c := change c. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 4edc1581..2592abb5 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: SetoidList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id: SetoidList.v 11800 2009-01-18 18:34:15Z msozeau $ *) Require Export List. Require Export Sorting. @@ -69,10 +69,10 @@ Definition equivlistA l l' := forall x, InA x l <-> InA x l'. (** lists with same elements modulo [eqA] at the same place *) -Inductive eqlistA : list A -> list A -> Prop := - | eqlistA_nil : eqlistA nil nil - | eqlistA_cons : forall x x' l l', - eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). +Inductive eqlistA : list A -> list A -> Prop := + | eqlistA_nil : eqlistA nil nil + | eqlistA_cons : forall x x' l l', + eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). Hint Constructors eqlistA. @@ -445,7 +445,11 @@ Definition compat_op (f : A -> B -> B) := Definition transpose (f : A -> B -> B) := forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). -Variable st:Setoid_Theory _ eqB. +(** A version of transpose with restriction on where it should hold *) +Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). + +Variable st:Equivalence eqB. Variable f:A->B->B. Variable i:B. Variable Comp:compat_op f. @@ -455,17 +459,7 @@ Lemma fold_right_eqlistA : eqB (fold_right f i s) (fold_right f i s'). Proof. induction 1; simpl; auto. -refl_st. -Qed. - -Variable Ass:transpose f. - -Lemma fold_right_commutes : forall s1 s2 x, - eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). -Proof. -induction s1; simpl; auto; intros. -refl_st. -trans_st (f a (f x (fold_right f i (s1++s2)))). +reflexivity. Qed. Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> @@ -490,38 +484,193 @@ Proof. destruct H8; auto. elim H0. destruct H7; [left|right]; eapply InA_eqA; eauto. -Qed. +Qed. -Lemma fold_right_equivlistA : - forall s s', NoDupA s -> NoDupA s' -> +(** [ForallList2] : specifies that a certain binary predicate should + always hold when inspecting two different elements of the list. *) + +Inductive ForallList2 (R : A -> A -> Prop) : list A -> Prop := + | ForallNil : ForallList2 R nil + | ForallCons : forall a l, + (forall b, In b l -> R a b) -> + ForallList2 R l -> ForallList2 R (a::l). +Hint Constructors ForallList2. + +(** [NoDupA] can be written in terms of [ForallList2] *) + +Lemma ForallList2_NoDupA : forall l, + ForallList2 (fun a b => ~eqA a b) l <-> NoDupA l. +Proof. + induction l; split; intros; auto. + inversion_clear H. constructor; [ | rewrite <- IHl; auto ]. + rewrite InA_alt; intros (a',(Haa',Ha')). + exact (H0 a' Ha' Haa'). + inversion_clear H. constructor; [ | rewrite IHl; auto ]. + intros b Hb. + contradict H0. + rewrite InA_alt; exists b; auto. +Qed. + +Lemma ForallList2_impl : forall (R R':A->A->Prop), + (forall a b, R a b -> R' a b) -> + forall l, ForallList2 R l -> ForallList2 R' l. +Proof. + induction 2; auto. +Qed. + +(** The following definition is easier to use than [ForallList2]. *) + +Definition ForallList2_alt (R:A->A->Prop) l := + forall a b, InA a l -> InA b l -> ~eqA a b -> R a b. + +Section Restriction. +Variable R : A -> A -> Prop. + +(** [ForallList2] and [ForallList2_alt] are related, but no completely + equivalent. For proving one implication, we need to know that the + list has no duplicated elements... *) + +Lemma ForallList2_equiv1 : forall l, NoDupA l -> + ForallList2_alt R l -> ForallList2 R l. +Proof. + induction l; auto. + constructor. intros b Hb. + inversion_clear H. + apply H0; auto. + contradict H1. + apply InA_eqA with b; auto. + apply IHl. + inversion_clear H; auto. + intros b c Hb Hc Hneq. + apply H0; auto. +Qed. + +(** ... and for proving the other implication, we need to be able + to reverse and adapt relation [R] modulo [eqA]. *) + +Hypothesis R_sym : forall a b, R a b -> R b a. +Hypothesis R_compat : forall a, compat_P (R a). + +Lemma ForallList2_equiv2 : forall l, + ForallList2 R l -> ForallList2_alt R l. +Proof. + induction l. + intros _. red. intros a b Ha. inversion Ha. + inversion_clear 1 as [|? ? H_R Hl]. + intros b c Hb Hc Hneq. + inversion_clear Hb; inversion_clear Hc. + (* b,c = a : impossible *) + elim Hneq; eauto. + (* b = a, c in l *) + rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)). + apply R_compat with d; auto. + apply R_sym; apply R_compat with a; auto. + (* b in l, c = a *) + rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)). + apply R_compat with a; auto. + apply R_sym; apply R_compat with d; auto. + (* b,c in l *) + apply (IHl Hl); auto. +Qed. + +Lemma ForallList2_equiv : forall l, NoDupA l -> + (ForallList2 R l <-> ForallList2_alt R l). +Proof. +split; [apply ForallList2_equiv2|apply ForallList2_equiv1]; auto. +Qed. + +Lemma ForallList2_equivlistA : forall l l', NoDupA l' -> + equivlistA l l' -> ForallList2 R l -> ForallList2 R l'. +Proof. +intros. +apply ForallList2_equiv1; auto. +intros a b Ha Hb Hneq. +red in H0; rewrite <- H0 in Ha,Hb. +revert a b Ha Hb Hneq. +change (ForallList2_alt R l). +apply ForallList2_equiv2; auto. +Qed. + +Variable TraR :transpose_restr R f. + +Lemma fold_right_commutes_restr : + forall s1 s2 x, ForallList2 R (s1++x::s2) -> + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))). +apply Comp; auto. +apply IHs1. +inversion_clear H; auto. +apply TraR. +inversion_clear H. +apply H0. +apply in_or_app; simpl; auto. +Qed. + +Lemma fold_right_equivlistA_restr : + forall s s', NoDupA s -> NoDupA s' -> ForallList2 R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. simple induction s. destruct s'; simpl. - intros; refl_st; auto. + intros; reflexivity. unfold equivlistA; intros. - destruct (H1 a). + destruct (H2 a). assert (X : InA a nil); auto; inversion X. - intros x l Hrec s' N N' E; simpl in *. + intros x l Hrec s' N N' F E; simpl in *. assert (InA x s'). rewrite <- (E x); auto. destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. - trans_st (f x (fold_right f i (s1++s2))). + transitivity (f x (fold_right f i (s1++s2))). apply Comp; auto. apply Hrec; auto. inversion_clear N; auto. eapply NoDupA_split; eauto. + inversion_clear F; auto. eapply equivlistA_NoDupA_split; eauto. - trans_st (f y (fold_right f i (s1++s2))). - apply Comp; auto; refl_st. - sym_st; apply fold_right_commutes. + transitivity (f y (fold_right f i (s1++s2))). + apply Comp; auto. reflexivity. + symmetry; apply fold_right_commutes_restr. + apply ForallList2_equivlistA with (x::l); auto. +Qed. + +Lemma fold_right_add_restr : + forall s' s x, NoDupA s -> NoDupA s' -> ForallList2 R s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). +Proof. + intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. +Qed. + +End Restriction. + +(** we know state similar results, but without restriction on transpose. *) + +Variable Tra :transpose f. + +Lemma fold_right_commutes : forall s1 s2 x, + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))); auto. +Qed. + +Lemma fold_right_equivlistA : + forall s s', NoDupA s -> NoDupA s' -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). +Proof. +intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); + try red; auto. +apply ForallList2_equiv1; try red; auto. Qed. Lemma fold_right_add : forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). -Proof. +Proof. intros; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. @@ -538,7 +687,7 @@ destruct (eqA_dec x a). left; auto. destruct IHl. left; auto. -right; red; inversion_clear 1; tauto. +right; red; inversion_clear 1; contradiction. Qed. Fixpoint removeA (x : A) (l : list A){struct l} : list A := @@ -547,7 +696,7 @@ Fixpoint removeA (x : A) (l : list A){struct l} : list A := | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) end. -Lemma removeA_filter : forall x l, +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. diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index d15e2c96..31c41120 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 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: ClassicalDescription.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** This file provides classical logic and definite description, which is equivalent to providing classical logic and Church's iota operator *) @@ -21,7 +21,7 @@ Set Implicit Arguments. Require Export Classical. Require Import ChoiceFacts. -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Axiom constructive_definite_description : forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 8a045ec8..db92696b 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalFacts.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: ClassicalFacts.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** Some facts and definitions about classical logic @@ -119,7 +119,7 @@ Qed. *) -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Lemma prop_ext_A_eq_A_imp_A : prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index a7c098e8..00d63252 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 10500 2008-02-02 15:51:00Z letouzey $ i*) +(*i $Id: Decidable.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** Properties of decidable propositions *) @@ -80,6 +80,13 @@ Proof. unfold decidable; tauto. Qed. +Theorem not_iff : + forall A B:Prop, decidable A -> decidable B -> + ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). +Proof. +unfold decidable; tauto. +Qed. + (** Results formulated with iff, used in FSetDecide. Negation are expanded since it is unclear whether setoid rewrite will always perform conversion. *) diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v index 9c928598..9c59c519 100644 --- a/theories/Logic/DecidableTypeEx.v +++ b/theories/Logic/DecidableTypeEx.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: DecidableTypeEx.v 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id: DecidableTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *) Require Import DecidableType OrderedType OrderedTypeEx. Set Implicit Arguments. @@ -46,24 +46,16 @@ Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. Definition eq_dec := M.eq_dec. End Make_UDT. -(** An OrderedType can be seen as a DecidableType *) +(** An OrderedType can now directly be seen as a DecidableType *) -Module OT_as_DT (O:OrderedType) <: DecidableType. - Module OF := OrderedTypeFacts O. - Definition t := O.t. - Definition eq := O.eq. - Definition eq_refl := O.eq_refl. - Definition eq_sym := O.eq_sym. - Definition eq_trans := O.eq_trans. - Definition eq_dec := OF.eq_dec. -End OT_as_DT. +Module OT_as_DT (O:OrderedType) <: DecidableType := O. (** (Usual) Decidable Type for [nat], [positive], [N], [Z] *) -Module Nat_as_DT <: UsualDecidableType := OT_as_DT (Nat_as_OT). -Module Positive_as_DT <: UsualDecidableType := OT_as_DT (Positive_as_OT). -Module N_as_DT <: UsualDecidableType := OT_as_DT (N_as_OT). -Module Z_as_DT <: UsualDecidableType := OT_as_DT (Z_as_OT). +Module Nat_as_DT <: UsualDecidableType := Nat_as_OT. +Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. +Module N_as_DT <: UsualDecidableType := N_as_OT. +Module Z_as_DT <: UsualDecidableType := Z_as_OT. (** From two decidable types, we can build a new DecidableType over their cartesian product. *) @@ -99,7 +91,7 @@ End PairDecidableType. (** Similarly for pairs of UsualDecidableType *) -Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: DecidableType. +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Definition t := prod D1.t D2.t. Definition eq := @eq t. Definition eq_refl := @refl_equal t. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 880ef7e2..b935a676 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Diaconescu.v 11238 2008-07-19 09:34:03Z herbelin $ i*) +(*i $Id: Diaconescu.v 11481 2008-10-20 19:23:51Z herbelin $ i*) (** Diaconescu showed that the Axiom of Choice entails Excluded-Middle in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show @@ -267,7 +267,7 @@ End ProofIrrel_RelChoice_imp_EqEM. (** Proof sketch from Bell [Bell93] (with thanks to P. CastĂ©ran) *) -Notation Local inhabited A := A. +Notation Local inhabited A := A (only parsing). Section ExtensionalEpsilon_imp_EM. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 844bff88..d5738c82 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: EqdepFacts.v 11095 2008-06-10 19:36:10Z herbelin $ i*) +(*i $Id: EqdepFacts.v 11735 2009-01-02 17:22:31Z herbelin $ i*) (** This file defines dependent equality and shows its equivalence with equality on dependent pairs (inhabiting sigma-types). It derives @@ -53,7 +53,7 @@ Section 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. + Hint Constructors eq_dep: core. Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. Proof eq_dep_intro. @@ -63,7 +63,7 @@ Section Dependent_Equality. Proof. destruct 1; auto. Qed. - Hint Immediate eq_dep_sym: core v62. + Hint Immediate eq_dep_sym: core. Lemma eq_dep_trans : forall (p q r:U) (x:P p) (y:P q) (z:P r), @@ -135,8 +135,8 @@ Qed. (** Exported hints *) -Hint Resolve eq_dep_intro: core v62. -Hint Immediate eq_dep_sym: core v62. +Hint Resolve eq_dep_intro: core. +Hint Immediate eq_dep_sym: core. (************************************************************************) (** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v new file mode 100644 index 00000000..4445b0e1 --- /dev/null +++ b/theories/Logic/FunctionalExtensionality.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: FunctionalExtensionality.v 11686 2008-12-16 12:57:26Z msozeau $ i*) + +(** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion. + It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *) + +Set Manual Implicit Arguments. + +(** The converse of functional extensionality. *) + +Lemma equal_f : forall {A B : Type} {f g : A -> B}, + f = g -> forall x, f x = g x. +Proof. + intros. + rewrite H. + auto. +Qed. + +(** Statements of functional extensionality for simple and dependent functions. *) + +Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, + forall (f g : forall x : A, B x), + (forall x, f x = g x) -> f = g. + +Lemma functional_extensionality {A B} (f g : A -> B) : + (forall x, f x = g x) -> f = g. +Proof. + intros ; eauto using @functional_extensionality_dep. +Qed. + +(** Apply [functional_extensionality], introducing variable x. *) + +Tactic Notation "extensionality" ident(x) := + match goal with + [ |- ?X = ?Y ] => + (apply (@functional_extensionality _ _ X Y) || + apply (@functional_extensionality_dep _ _ X Y)) ; intro x + end. + +(** Eta expansion follows from extensionality. *) + +Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : + f = fun x => f x. +Proof. + intros. + extensionality x. + reflexivity. +Qed. + +Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x. +Proof. + intros A B f. apply (eta_expansion_dep f). +Qed. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 20dabed2..3752abcc 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BinNat.v 10806 2008-04-16 23:51:06Z letouzey $ i*) +(*i $Id: BinNat.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import BinPos. Unset Boxed Definitions. @@ -393,10 +393,10 @@ Theorem Ncompare_n_Sm : Proof. intros n m; split; destruct n as [| p]; destruct m as [| q]; simpl; auto. destruct p; simpl; intros; discriminate. -pose proof (proj1 (Pcompare_p_Sq p q)); +pose proof (Pcompare_p_Sq p q) as (?,_). assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. intros H; destruct H; discriminate. -pose proof (proj2 (Pcompare_p_Sq p q)); +pose proof (Pcompare_p_Sq p q) as (_,?); assert (p = q <-> Npos p = Npos q); [split; congruence | tauto]. Qed. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index dcdb5f92..fb32274e 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ndigits.v 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id: Ndigits.v 11735 2009-01-02 17:22:31Z herbelin $ i*) Require Import Bool. Require Import Bvector. @@ -52,8 +52,8 @@ Proof. destruct n; destruct n'; simpl; auto. generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl; auto. - destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial. - destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial. + destruct p0; trivial; rewrite Hrecp; trivial. + destruct p0; trivial; rewrite Hrecp; trivial. destruct p0 as [p| p| ]; simpl; auto. Qed. @@ -115,7 +115,7 @@ Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n). Lemma xorf_eq : forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'. Proof. - unfold eqf, xorf. intros. apply xorb_eq. apply H. + unfold eqf, xorf. intros. apply xorb_eq, H. Qed. Lemma xorf_assoc : @@ -166,14 +166,12 @@ Lemma Nbit_faithful_3 : (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a. Proof. - destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))). + destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))). intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity. unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity. - case p. intros. absurd (false = true). discriminate. - exact (H0 0). - intros. rewrite (H p0 (fun n => H0 (S n))). reflexivity. - intros. absurd (false = true). discriminate. - exact (H0 0). + destruct p. discriminate (H0 O). + rewrite (H p (fun n => H0 (S n))). reflexivity. + discriminate (H0 0). Qed. Lemma Nbit_faithful_4 : @@ -181,27 +179,26 @@ Lemma Nbit_faithful_4 : (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') -> eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a. Proof. - destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))). + destruct a; intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))). intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity. - unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity. - case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity. - intros. absurd (true = false). discriminate. - exact (H0 0). - intros. absurd (N0 = Npos p0). discriminate. + intro. rewrite H0. reflexivity. + destruct p. rewrite (H p (fun n:nat => H0 (S n))). reflexivity. + discriminate (H0 0). cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))). - intro. exact (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))). - unfold eqf in *. intro. rewrite H0. reflexivity. + intro. discriminate (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))). + intro. rewrite H0. reflexivity. Qed. Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'. Proof. destruct a. exact Nbit_faithful_1. - induction p. intros a' H. apply Nbit_faithful_4. intros. cut (Npos p = Npos p'). - intro. inversion H1. reflexivity. - exact (IHp (Npos p') H0). + induction p. intros a' H. apply Nbit_faithful_4. intros. + assert (Npos p = Npos p') by exact (IHp (Npos p') H0). + inversion H1. reflexivity. assumption. - intros. apply Nbit_faithful_3. intros. cut (Npos p = Npos p'). intro. inversion H1. reflexivity. - exact (IHp (Npos p') H0). + intros. apply Nbit_faithful_3. intros. + assert (Npos p = Npos p') by exact (IHp (Npos p') H0). + inversion H1. reflexivity. assumption. exact Nbit_faithful_2. Qed. @@ -216,40 +213,37 @@ Qed. Lemma Nxor_sem_2 : forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0). Proof. - intro. case a'. trivial. - simpl. intro. - case p; trivial. + intro. destruct a'. trivial. + destruct p; trivial. Qed. Lemma Nxor_sem_3 : forall (p:positive) (a':N), Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0. Proof. - intros. case a'. trivial. - simpl. intro. - case p0; trivial. intro. - case (Pxor p p1); trivial. - intro. case (Pxor p p1); trivial. + intros. destruct a'. trivial. + simpl. destruct p0; trivial. + destruct (Pxor p p0); trivial. + destruct (Pxor p p0); trivial. Qed. Lemma Nxor_sem_4 : forall (p:positive) (a':N), Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0). Proof. - intros. case a'. trivial. - simpl. intro. case p0; trivial. intro. - case (Pxor p p1); trivial. - intro. - case (Pxor p p1); trivial. + intros. destruct a'. trivial. + simpl. destruct p0; trivial. + destruct (Pxor p p0); trivial. + destruct (Pxor p p0); trivial. Qed. Lemma Nxor_sem_5 : forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0. Proof. - destruct a. intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial. - case p. exact Nxor_sem_4. - intros. change (Nbit (Nxor (Npos (xO p0)) a') 0 = xorb false (Nbit a' 0)). - rewrite false_xorb. apply Nxor_sem_3. exact Nxor_sem_2. + destruct a; intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial. + destruct p. apply Nxor_sem_4. + change (Nbit (Nxor (Npos (xO p)) a') 0 = xorb false (Nbit a' 0)). + rewrite false_xorb. apply Nxor_sem_3. apply Nxor_sem_2. Qed. Lemma Nxor_sem_6 : @@ -258,28 +252,29 @@ Lemma Nxor_sem_6 : forall a a':N, Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n). Proof. - intros. + intros. +(* pose proof (fun p1 p2 => H (Npos p1) (Npos p2)) as H'. clear H. rename H' into H.*) generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H. unfold xorf in *. - case a. simpl Nbit; rewrite false_xorb. reflexivity. - case a'; intros. + destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity. + destruct a' as [|p0]. simpl Nbit; rewrite xorb_false. reflexivity. - case p0. case p; intros; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. + destruct p. destruct p0; simpl Nbit in *. + rewrite <- H; simpl; case (Pxor p p0); trivial. + rewrite <- H; simpl; case (Pxor p p0); trivial. rewrite xorb_false. reflexivity. - case p; intros; simpl Nbit in *. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. - rewrite <- H; simpl; case (Pxor p2 p1); trivial. + destruct p0; simpl Nbit in *. + rewrite <- H; simpl; case (Pxor p p0); trivial. + rewrite <- H; simpl; case (Pxor p p0); trivial. rewrite xorb_false. reflexivity. - simpl Nbit. rewrite false_xorb. simpl. case p; trivial. + simpl Nbit. rewrite false_xorb. destruct p0; trivial. Qed. Lemma Nxor_semantics : forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')). Proof. - unfold eqf. intros. generalize a a'. elim n. exact Nxor_sem_5. - exact Nxor_sem_6. + unfold eqf. intros; generalize a, a'. induction n. + apply Nxor_sem_5. apply Nxor_sem_6; assumption. Qed. (** Consequences: @@ -289,8 +284,8 @@ Qed. Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'. Proof. - intros. apply Nbit_faithful. apply xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')). - apply eqf_sym. apply Nxor_semantics. + intros. apply Nbit_faithful, xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')). + apply eqf_sym, Nxor_semantics. rewrite H. unfold eqf. trivial. Qed. @@ -298,19 +293,17 @@ Lemma Nxor_assoc : forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a''). Proof. intros. apply Nbit_faithful. - apply eqf_trans with - (f' := xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')). - apply eqf_trans with (f' := xorf (Nbit (Nxor a a')) (Nbit a'')). + apply eqf_trans with (xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')). + apply eqf_trans with (xorf (Nbit (Nxor a a')) (Nbit a'')). apply Nxor_semantics. apply eqf_xorf. apply Nxor_semantics. apply eqf_refl. - apply eqf_trans with - (f' := xorf (Nbit a) (xorf (Nbit a') (Nbit a''))). + apply eqf_trans with (xorf (Nbit a) (xorf (Nbit a') (Nbit a''))). apply xorf_assoc. - apply eqf_trans with (f' := xorf (Nbit a) (Nbit (Nxor a' a''))). + apply eqf_trans with (xorf (Nbit a) (Nbit (Nxor a' a''))). apply eqf_xorf. apply eqf_refl. - apply eqf_sym. apply Nxor_semantics. - apply eqf_sym. apply Nxor_semantics. + apply eqf_sym, Nxor_semantics. + apply eqf_sym, Nxor_semantics. Qed. (** Checking whether a number is odd, i.e. @@ -370,18 +363,16 @@ Qed. Lemma Nxor_bit0 : forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a'). Proof. - intros. rewrite <- Nbit0_correct. rewrite (Nxor_semantics a a' 0). - unfold xorf. rewrite Nbit0_correct. rewrite Nbit0_correct. reflexivity. + intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' 0). + unfold xorf. rewrite Nbit0_correct, Nbit0_correct. reflexivity. Qed. Lemma Nxor_div2 : forall a a':N, Ndiv2 (Nxor a a') = Nxor (Ndiv2 a) (Ndiv2 a'). Proof. intros. apply Nbit_faithful. unfold eqf. intro. - rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n). - rewrite Ndiv2_correct. - rewrite (Nxor_semantics a a' (S n)). - unfold xorf. rewrite Ndiv2_correct. rewrite Ndiv2_correct. + rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)). + unfold xorf. rewrite 2! Ndiv2_correct. reflexivity. Qed. @@ -389,8 +380,9 @@ Lemma Nneg_bit0 : forall a a':N, Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a'). Proof. - intros. rewrite <- true_xorb. rewrite <- H. rewrite Nxor_bit0. - rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity. + intros. + rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. + reflexivity. Qed. Lemma Nneg_bit0_1 : @@ -410,10 +402,9 @@ Lemma Nsame_bit0 : forall (a a':N) (p:positive), Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'. Proof. - intros. rewrite <- (xorb_false (Nbit0 a)). cut (Nbit0 (Npos (xO p)) = false). - intro. rewrite <- H0. rewrite <- H. rewrite Nxor_bit0. rewrite <- xorb_assoc. - rewrite xorb_nilpotent. rewrite false_xorb. reflexivity. - reflexivity. + intros. rewrite <- (xorb_false (Nbit0 a)). + assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity. + rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. Qed. (** a lexicographic order on bits, starting from the lowest bit *) @@ -434,42 +425,40 @@ Lemma Nbit0_less : forall a a', Nbit0 a = false -> Nbit0 a' = true -> Nless a a' = true. Proof. - intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *. - rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5. - rewrite H in H5. rewrite H0 in H5. discriminate H5. - rewrite H4. reflexivity. - intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intro H1. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H2. - rewrite H in H2. rewrite H0 in H2. discriminate H2. - rewrite H1. reflexivity. + intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless. + rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. + assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. + simpl. rewrite H, H0. reflexivity. + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. Lemma Nbit0_gt : forall a a', Nbit0 a = true -> Nbit0 a' = false -> Nless a a' = false. Proof. - intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *. - rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5. - rewrite H in H5. rewrite H0 in H5. discriminate H5. - rewrite H4. reflexivity. - intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. - intro H1. unfold Nless in |- *. rewrite H1. reflexivity. + intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless. + rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. + assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. + simpl. rewrite H, H0. reflexivity. + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. Lemma Nless_not_refl : forall a, Nless a a = false. Proof. - intro. unfold Nless in |- *. rewrite (Nxor_nilpotent a). reflexivity. + intro. unfold Nless. rewrite (Nxor_nilpotent a). reflexivity. Qed. Lemma Nless_def_1 : forall a a', Nless (Ndouble a) (Ndouble a') = Nless a a'. Proof. - simple induction a. simple induction a'. reflexivity. + destruct a; destruct a'. reflexivity. trivial. - simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial. - unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity. + unfold Nless. simpl. destruct p; trivial. + unfold Nless. simpl. destruct (Pxor p p0). reflexivity. trivial. Qed. @@ -477,10 +466,10 @@ Lemma Nless_def_2 : forall a a', Nless (Ndouble_plus_one a) (Ndouble_plus_one a') = Nless a a'. Proof. - simple induction a. simple induction a'. reflexivity. + destruct a; destruct a'. reflexivity. trivial. - simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial. - unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity. + unfold Nless. simpl. destruct p; trivial. + unfold Nless. simpl. destruct (Pxor p p0). reflexivity. trivial. Qed. @@ -500,79 +489,71 @@ Qed. Lemma Nless_z : forall a, Nless a N0 = false. Proof. - simple induction a. reflexivity. - unfold Nless in |- *. intro. rewrite (Nxor_neutral_right (Npos p)). elim p; trivial. + induction a. reflexivity. + unfold Nless. rewrite (Nxor_neutral_right (Npos p)). induction p; trivial. Qed. Lemma N0_less_1 : forall a, Nless N0 a = true -> {p : positive | a = Npos p}. Proof. - simple induction a. intro. discriminate H. - intros. split with p. reflexivity. + destruct a. intros. discriminate. + intros. exists p. reflexivity. Qed. Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0. Proof. - simple induction a. trivial. - unfold Nless in |- *. simpl in |- *. - cut (forall p:positive, Nless_aux N0 (Npos p) p = false -> False). - intros. elim (H p H0). - simple induction p. intros. discriminate H0. - intros. exact (H H0). - intro. discriminate H. + induction a as [|p]; intro H. trivial. + elimtype False. induction p as [|p IHp|]; discriminate || simpl; auto using IHp. Qed. Lemma Nless_trans : forall a a' a'', Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true. Proof. - intro a. pattern a; apply N_ind_double. - intros. case_eq (Nless N0 a''). trivial. - intro H1. rewrite (N0_less_2 a'' H1) in H0. rewrite (Nless_z a') in H0. discriminate H0. - intros a0 H a'. pattern a'; apply N_ind_double. - intros. rewrite (Nless_z (Ndouble a0)) in H0. discriminate H0. - intros a1 H0 a'' H1. rewrite (Nless_def_1 a0 a1) in H1. - pattern a''; apply N_ind_double; clear a''. - intro. rewrite (Nless_z (Ndouble a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_1 a1 a2) in H3. rewrite (Nless_def_1 a0 a2). - exact (H a1 a2 H1 H3). - intros. apply Nless_def_3. - intros a1 H0 a'' H1. pattern a''; apply N_ind_double. - intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3. - intros. apply Nless_def_3. - intros a0 H a'. pattern a'; apply N_ind_double. - intros. rewrite (Nless_z (Ndouble_plus_one a0)) in H0. discriminate H0. - intros. rewrite (Nless_def_4 a0 a1) in H1. discriminate H1. - intros a1 H0 a'' H1. pattern a''; apply N_ind_double. - intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2. - intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3. - rewrite (Nless_def_2 a0 a1) in H1. intros. rewrite (Nless_def_2 a1 a2) in H3. - rewrite (Nless_def_2 a0 a2). exact (H a1 a2 H1 H3). + induction a as [|a IHa|a IHa] using N_ind_double; intros a' a'' H H0. + destruct (Nless N0 a'') as []_eqn:Heqb. trivial. + rewrite (N0_less_2 a'' Heqb), (Nless_z a') in H0. discriminate H0. + induction a' as [|a' _|a' _] using N_ind_double. + rewrite (Nless_z (Ndouble a)) in H. discriminate H. + rewrite (Nless_def_1 a a') in H. + induction a'' using N_ind_double. + rewrite (Nless_z (Ndouble a')) in H0. discriminate H0. + rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a''). + exact (IHa _ _ H H0). + apply Nless_def_3. + induction a'' as [|a'' _|a'' _] using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0. + rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + apply Nless_def_3. + induction a' as [|a' _|a' _] using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a)) in H. discriminate H. + rewrite (Nless_def_4 a a') in H. discriminate H. + induction a'' using N_ind_double. + rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0. + rewrite (Nless_def_4 a' a'') in H0. discriminate H0. + rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. + rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0). Qed. Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. - intro a. - pattern a; apply N_rec_double; clear a. - intro. case_eq (Nless N0 a'). intro H. left. left. auto. - intro H. right. rewrite (N0_less_2 a' H). reflexivity. - intros a0 H a'. - pattern a'; apply N_rec_double; clear a'. - case_eq (Nless N0 (Ndouble a0)). intro H0. left. right. auto. - intro H0. right. exact (N0_less_2 _ H0). - intros a1 H0. rewrite Nless_def_1. rewrite Nless_def_1. elim (H a1). intro H1. - left. assumption. - intro H1. right. rewrite H1. reflexivity. - intros a1 H0. left. left. apply Nless_def_3. - intros a0 H a'. - pattern a'; apply N_rec_double; clear a'. - left. right. case a0; reflexivity. - intros a1 H0. left. right. apply Nless_def_3. - intros a1 H0. rewrite Nless_def_2. rewrite Nless_def_2. elim (H a1). intro H1. - left. assumption. - intro H1. right. rewrite H1. reflexivity. + induction a using N_rec_double; intro a'. + destruct (Nless N0 a') as []_eqn:Heqb. left. left. auto. + right. rewrite (N0_less_2 a' Heqb). reflexivity. + induction a' as [|a' _|a' _] using N_rec_double. + destruct (Nless N0 (Ndouble a)) as []_eqn:Heqb. left. right. auto. + right. exact (N0_less_2 _ Heqb). + rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->]. + left. assumption. + right. reflexivity. + left. left. apply Nless_def_3. + induction a' as [|a' _|a' _] using N_rec_double. + left. right. destruct a; reflexivity. + left. right. apply Nless_def_3. + rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->]. + left. assumption. + right. reflexivity. Qed. (** Number of digits in a number *) @@ -621,7 +602,7 @@ Proof. induction n; intros. rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. -generalize (IHn (Vtail _ _ bv)); clear IHn. +specialize IHn with (Vtail _ _ bv). destruct (Vhead _ _ bv); destruct (Bv2N n (Vtail bool n bv)); simpl; auto with arith. @@ -701,7 +682,7 @@ Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), Proof. intros. unfold Blow. -pattern bv at 1; rewrite (VSn_eq _ _ bv). +rewrite (VSn_eq _ _ bv) at 1. simpl. destruct (Bv2N n (Vtail bool n bv)); simpl; destruct (Vhead bool n bv); auto. @@ -750,9 +731,9 @@ Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), Proof. induction n. intros. -rewrite (V0_eq _ bv); rewrite (V0_eq _ bv'); simpl; auto. +rewrite (V0_eq _ bv), (V0_eq _ bv'); simpl; auto. intros. -rewrite (VSn_eq _ _ bv); rewrite (VSn_eq _ _ bv'); simpl; auto. +rewrite (VSn_eq _ _ bv), (VSn_eq _ _ bv'); simpl; auto. rewrite IHn. destruct (Vhead bool n bv); destruct (Vhead bool n bv'); destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto. diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 29e18548..0f71f2cc 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Decidable. Require Export ZAxioms. @@ -36,14 +36,14 @@ Proof NZpred_succ. Theorem Zeq_refl : forall n : Z, n == n. Proof (proj1 NZeq_equiv). -Theorem Zeq_symm : forall n m : Z, n == m -> m == n. +Theorem Zeq_sym : forall n m : Z, n == m -> m == n. Proof (proj2 (proj2 NZeq_equiv)). Theorem Zeq_trans : forall n m p : Z, n == m -> m == p -> n == p. Proof (proj1 (proj2 NZeq_equiv)). -Theorem Zneq_symm : forall n m : Z, n ~= m -> m ~= n. -Proof NZneq_symm. +Theorem Zneq_sym : forall n m : Z, n ~= m -> m ~= n. +Proof NZneq_sym. Theorem Zsucc_inj : forall n1 n2 : Z, S n1 == S n2 -> n1 == n2. Proof NZsucc_inj. diff --git a/theories/Numbers/Integer/Abstract/ZDomain.v b/theories/Numbers/Integer/Abstract/ZDomain.v index 15beb2b9..9a17e151 100644 --- a/theories/Numbers/Integer/Abstract/ZDomain.v +++ b/theories/Numbers/Integer/Abstract/ZDomain.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZDomain.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id: ZDomain.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export NumPrelude. @@ -49,7 +49,7 @@ assert (x == y); [rewrite Exx'; now rewrite Eyy' | rewrite <- H2; assert (H3 : e x y); [now apply -> eq_equiv_e | now inversion H3]]]. Qed. -Theorem neq_symm : forall n m, n # m -> m # n. +Theorem neq_sym : forall n m, n # m -> m # n. Proof. intros n m H1 H2; symmetry in H2; false_hyp H2 H1. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index e3f1d9aa..c7996ffd 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMulOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZMulOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export ZAddOrder. @@ -173,7 +173,7 @@ Notation Zmul_neg := Zlt_mul_0 (only parsing). Theorem Zle_0_mul : forall n m : Z, 0 <= n * m -> 0 <= n /\ 0 <= m \/ n <= 0 /\ m <= 0. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. rewrite Zlt_0_mul, Zeq_mul_0. pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. @@ -184,7 +184,7 @@ Notation Zmul_nonneg := Zle_0_mul (only parsing). Theorem Zle_mul_0 : forall n m : Z, n * m <= 0 -> 0 <= n /\ m <= 0 \/ n <= 0 /\ 0 <= m. Proof. -assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_symm). +assert (R : forall n : Z, 0 == n <-> n == 0) by (intros; split; apply Zeq_sym). intros n m. repeat rewrite Zlt_eq_cases. repeat rewrite R. rewrite Zlt_mul_0, Zeq_mul_0. pose proof (Zlt_trichotomy n 0); pose proof (Zlt_trichotomy m 0). tauto. diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index cb920124..e5e950ac 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: BigZ.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: BigZ.v 11576 2008-11-10 19:13:15Z msozeau $ i*) Require Export BigN. Require Import ZMulOrder. @@ -104,8 +104,6 @@ exact sub_opp. exact add_opp. Qed. -Typeclasses unfold NZadd NZmul NZsub NZeq. - Add Ring BigZr : BigZring. (** Todo: tactic translating from [BigZ] to [Z] + omega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index 6305156b..98ad4c64 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZMake.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: ZMake.v 11576 2008-11-10 19:13:15Z msozeau $ i*) Require Import ZArith. Require Import BigNumPrelude. @@ -30,7 +30,6 @@ Module Make (N:NType) <: ZType. | Neg : N.t -> t_. Definition t := t_. - Typeclasses unfold t. Definition zero := Pos N.zero. Definition one := Pos N.one. diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 8b3d815d..9427b37b 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: ZNatPairs.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: ZNatPairs.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NSub. (* The most complete file for natural numbers *) Require Export ZMulOrder. (* The most complete file for integers *) @@ -110,7 +110,7 @@ Proof. unfold reflexive, Zeq. reflexivity. Qed. -Theorem ZE_symm : symmetric Z Zeq. +Theorem ZE_sym : symmetric Z Zeq. Proof. unfold symmetric, Zeq; now symmetry. Qed. @@ -127,7 +127,7 @@ Qed. Theorem NZeq_equiv : equiv Z Zeq. Proof. -unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_symm]. +unfold equiv; repeat split; [apply ZE_refl | apply ZE_trans | apply ZE_sym]. Qed. Add Relation Z Zeq diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 8b01e353..bd4d6232 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -8,14 +8,14 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZBase.v 10934 2008-05-15 21:58:20Z letouzey $ i*) +(*i $Id: NZBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NZAxioms. Module NZBasePropFunct (Import NZAxiomsMod : NZAxiomsSig). Open Local Scope NatIntScope. -Theorem NZneq_symm : forall n m : NZ, n ~= m -> m ~= n. +Theorem NZneq_sym : forall n m : NZ, n ~= m -> m ~= n. Proof. intros n m H1 H2; symmetry in H2; false_hyp H2 H1. Qed. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 15004824..d0e2faf8 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NZOrder.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NZOrder.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import NZAxioms. Require Import NZMul. @@ -118,7 +118,7 @@ Qed. Theorem NZneq_succ_diag_r : forall n : NZ, n ~= S n. Proof. -intro n; apply NZneq_symm; apply NZneq_succ_diag_l. +intro n; apply NZneq_sym; apply NZneq_succ_diag_l. Qed. Theorem NZnlt_succ_diag_l : forall n : NZ, ~ S n < n. diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index f58b87d8..91ae5b70 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NAdd.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NAdd.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export NBase. @@ -103,7 +103,7 @@ Qed. Theorem succ_add_discr : forall n m : N, m ~= S (n + m). Proof. intro n; induct m. -apply neq_symm. apply neq_succ_0. +apply neq_sym. apply neq_succ_0. intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. unfold not in IH; now apply IH. Qed. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index 3e4032b5..85e2c2ab 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NBase.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NBase.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Decidable. Require Export NAxioms. @@ -48,14 +48,14 @@ Proof pred_0. Theorem Neq_refl : forall n : N, n == n. Proof (proj1 NZeq_equiv). -Theorem Neq_symm : forall n m : N, n == m -> m == n. +Theorem Neq_sym : forall n m : N, n == m -> m == n. Proof (proj2 (proj2 NZeq_equiv)). Theorem Neq_trans : forall n m p : N, n == m -> m == p -> n == p. Proof (proj1 (proj2 NZeq_equiv)). -Theorem neq_symm : forall n m : N, n ~= m -> m ~= n. -Proof NZneq_symm. +Theorem neq_sym : forall n m : N, n ~= m -> m ~= n. +Proof NZneq_sym. Theorem succ_inj : forall n1 n2 : N, S n1 == S n2 -> n1 == n2. Proof NZsucc_inj. @@ -111,7 +111,7 @@ Qed. Theorem neq_0_succ : forall n : N, 0 ~= S n. Proof. -intro n; apply neq_symm; apply neq_succ_0. +intro n; apply neq_sym; apply neq_succ_0. Qed. (* Next, we show that all numbers are nonnegative and recover regular induction diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index e15e4672..0a8f5f1e 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NDefOps.v 11039 2008-06-02 23:26:13Z letouzey $ i*) +(*i $Id: NDefOps.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Import Bool. (* To get the orb and negb function *) Require Export NStrongRec. @@ -243,7 +243,7 @@ Definition E2 := prod_rel Neq Neq. Add Relation (prod N N) E2 reflexivity proved by (prod_rel_refl N N Neq Neq E_equiv E_equiv) -symmetry proved by (prod_rel_symm N N Neq Neq E_equiv E_equiv) +symmetry proved by (prod_rel_sym N N Neq Neq E_equiv E_equiv) transitivity proved by (prod_rel_trans N N Neq Neq E_equiv E_equiv) as E2_rel. diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 031dbdea..c6a6da48 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NStrongRec.v 11040 2008-06-03 00:04:16Z letouzey $ i*) +(*i $Id: NStrongRec.v 11674 2008-12-12 19:48:40Z letouzey $ i*) (** This file defined the strong (course-of-value, well-founded) recursion and proves its properties *) @@ -81,9 +81,9 @@ Proof. intros n1 n2 H. unfold g. now apply strong_rec_wd. Qed. -Theorem NtoA_eq_symm : symmetric (N -> A) (fun_eq Neq Aeq). +Theorem NtoA_eq_sym : symmetric (N -> A) (fun_eq Neq Aeq). Proof. -apply fun_eq_symm. +apply fun_eq_sym. exact (proj2 (proj2 NZeq_equiv)). exact (proj2 (proj2 Aeq_equiv)). Qed. @@ -97,7 +97,7 @@ exact (proj1 (proj2 Aeq_equiv)). Qed. Add Relation (N -> A) (fun_eq Neq Aeq) - symmetry proved by NtoA_eq_symm + symmetry proved by NtoA_eq_sym transitivity proved by NtoA_eq_trans as NtoA_eq_rel. diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index 41c255b1..16007656 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: BigN.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: BigN.v 11576 2008-11-10 19:13:15Z msozeau $ i*) (** * Natural numbers in base 2^31 *) @@ -78,8 +78,6 @@ exact mul_assoc. exact mul_add_distr_r. Qed. -Typeclasses unfold NZadd NZsub NZmul. - Add Ring BigNr : BigNring. (** Todo: tactic translating from [BigN] to [Z] + omega *) diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 4d6b45c5..04c7b96d 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -8,7 +8,7 @@ (* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) (************************************************************************) -(*i $Id: NMake_gen.ml 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: NMake_gen.ml 11576 2008-11-10 19:13:15Z msozeau $ i*) (*S NMake_gen.ml : this file generates NMake.v *) @@ -139,7 +139,6 @@ let _ = pr ""; pr " Definition %s := %s_." t t; pr ""; - pr " Typeclasses unfold %s." t; pr " Definition w_0 := w0_op.(znz_0)."; pr ""; diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index fdccf214..95d8b366 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -8,7 +8,7 @@ (* Evgeny Makarov, INRIA, 2007 *) (************************************************************************) -(*i $Id: NumPrelude.v 10943 2008-05-19 08:45:13Z letouzey $ i*) +(*i $Id: NumPrelude.v 11674 2008-12-12 19:48:40Z letouzey $ i*) Require Export Setoid. @@ -212,7 +212,7 @@ unfold reflexive, prod_rel. destruct x; split; [apply (proj1 EA_equiv) | apply (proj1 EB_equiv)]; simpl. Qed. -Lemma prod_rel_symm : symmetric (A * B) prod_rel. +Lemma prod_rel_sym : symmetric (A * B) prod_rel. Proof. unfold symmetric, prod_rel. destruct x; destruct y; @@ -229,7 +229,7 @@ Qed. Theorem prod_rel_equiv : equiv (A * B) prod_rel. Proof. -unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_symm]]. +unfold equiv; split; [exact prod_rel_refl | split; [exact prod_rel_trans | exact prod_rel_sym]]. Qed. End RelationOnProduct. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index a1a78acc..29494069 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -5,19 +5,19 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Basics.v 11709 2008-12-20 11:42:15Z msozeau $ *) -(* Standard functions and combinators. - * Proofs about them require functional extensionality and can be found in [Combinators]. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud - * 91405 Orsay, France *) +(** Standard functions and combinators. + + Proofs about them require functional extensionality and can be found in [Combinators]. -(* $Id: Basics.v 11046 2008-06-03 22:48:06Z msozeau $ *) + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitĂ© Paris Sud + 91405 Orsay, France *) -(** The polymorphic identity function. *) +(** The polymorphic identity function is defined in [Datatypes]. *) -Definition id {A} := fun x : A => x. +Implicit Arguments id [[A]]. (** Function composition. *) diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index e267fbbe..ae9749de 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -5,15 +5,16 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Combinators.v 11709 2008-12-20 11:42:15Z msozeau $ *) -(* Proofs about standard combinators, exports functional extensionality. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud - * 91405 Orsay, France *) +(** Proofs about standard combinators, exports functional extensionality. + + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud + 91405 Orsay, France *) Require Import Coq.Program.Basics. -Require Export Coq.Program.FunctionalExtensionality. +Require Export FunctionalExtensionality. Open Scope program_scope. @@ -40,7 +41,8 @@ Proof. reflexivity. Qed. -Hint Rewrite @compose_id_left @compose_id_right @compose_assoc : core. +Hint Rewrite @compose_id_left @compose_id_right : core. +Hint Rewrite <- @compose_assoc : core. (** [flip] is involutive. *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index c776070a..99d54755 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-emacs-U") -*- *) +(* -*- coq-prog-name: "~/research/coq/trunk/bin/coqtop.byte"; coq-prog-args: ("-emacs-U"); compile-command: "make -C ../.. TIME='time'" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Equality.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: Equality.v 11709 2008-12-20 11:42:15Z msozeau $ i*) (** Tactics related to (dependent) equality and proof irrelevance. *) @@ -20,6 +20,10 @@ Require Import Coq.Program.Tactics. Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level). +(** Notation for the single element of [x = x] *) + +Notation "'refl'" := (@refl_equal _ _). + (** Do something on an heterogeneous equality appearing in the context. *) Ltac on_JMeq tac := @@ -30,7 +34,7 @@ Ltac on_JMeq tac := (** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) Ltac simpl_one_JMeq := - on_JMeq ltac:(fun H => replace_hyp H (JMeq_eq H)). + on_JMeq ltac:(fun H => apply JMeq_eq in H). (** Repeat it for every possible hypothesis. *) @@ -185,7 +189,6 @@ Ltac simplify_eqs := (** A tactic that tries to remove trivial equality guards in induction hypotheses coming from [dependent induction]/[generalize_eqs] invocations. *) - Ltac simpl_IH_eq H := match type of H with | @JMeq _ ?x _ _ -> _ => @@ -224,9 +227,291 @@ Ltac do_simpl_IHs_eqs := Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs. -Ltac simpl_depind := subst* ; autoinjections ; try discriminates ; +(** We split substitution tactics in the two directions depending on which + names we want to keep corresponding to the generalization performed by the + [generalize_eqs] tactic. *) + +Ltac subst_left_no_fail := + repeat (match goal with + [ H : ?X = ?Y |- _ ] => subst X + end). + +Ltac subst_right_no_fail := + repeat (match goal with + [ H : ?X = ?Y |- _ ] => subst Y + end). + +Ltac inject_left H := + progress (inversion H ; subst_left_no_fail ; clear_dups) ; clear H. + +Ltac inject_right H := + progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. + +Ltac autoinjections_left := repeat autoinjection ltac:inject_left. +Ltac autoinjections_right := repeat autoinjection ltac:inject_right. + +Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; + simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + +Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. +Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; + simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. + +(** Support for the [Equations] command. + These tactics implement the necessary machinery to solve goals produced by the + [Equations] command relative to dependent pattern-matching. + It is completely inspired from the "Eliminating Dependent Pattern-Matching" paper by + Goguen, McBride and McKinna. *) + + +(** The NoConfusionPackage class provides a method for making progress on proving a property + [P] implied by an equality on an inductive type [I]. The type of [noConfusion] for a given + [P] should be of the form [ Î Î, (x y : I Î) (x = y) -> NoConfusion P x y ], where + [NoConfusion P x y] for constructor-headed [x] and [y] will give a formula ending in [P]. + This gives a general method for simplifying by discrimination or injectivity of constructors. + + Some actual instances are defined later in the file using the more primitive [discriminate] and + [injection] tactics on which we can always fall back. + *) + +Class NoConfusionPackage (I : Type) := { NoConfusion : Î P : Prop, Type ; noConfusion : Î P, NoConfusion P }. + +(** The [DependentEliminationPackage] provides the default dependent elimination principle to + be used by the [equations] resolver. It is especially useful to register the dependent elimination + principles for things in [Prop] which are not automatically generated. *) + +Class DependentEliminationPackage (A : Type) := + { elim_type : Type ; elim : elim_type }. + +(** A higher-order tactic to apply a registered eliminator. *) + +Ltac elim_tac tac p := + let ty := type of p in + let eliminator := eval simpl in (elim (A:=ty)) in + tac p eliminator. + +(** Specialization to do case analysis or induction. + Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register + generated induction principles. *) + +Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. +Ltac elim_ind p := elim_tac ltac:(fun p el => induction p using el) p. + +(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype, + allowing to talk about course-of-value recursion on it. *) + +Class BelowPackage (A : Type) := { + Below : A -> Type ; + below : Î (a : A), Below a }. + +(** The [Recursor] class defines a recursor on a type, based on some definition of [Below]. *) + +Class Recursor (A : Type) (BP : BelowPackage A) := + { rec_type : A -> Type ; rec : Î (a : A), rec_type a }. + +(** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) + +Lemma solution_left : Î A (B : A -> Type) (t : A), B t -> (Î x, x = t -> B x). +Proof. intros; subst. apply X. Defined. + +Lemma solution_right : Î A (B : A -> Type) (t : A), B t -> (Î x, t = x -> B x). +Proof. intros; subst; apply X. Defined. + +Lemma deletion : Î A B (t : A), B -> (t = t -> B). +Proof. intros; assumption. Defined. + +Lemma simplification_heq : Î A B (x y : A), (x = y -> B) -> (JMeq x y -> B). +Proof. intros; apply X; apply (JMeq_eq H). Defined. + +Lemma simplification_existT2 : Î A (P : A -> Type) B (p : A) (x y : P p), + (x = y -> B) -> (existT P p x = existT P p y -> B). +Proof. intros. apply X. apply inj_pair2. exact H. Defined. + +Lemma simplification_existT1 : Î A (P : A -> Type) B (p q : A) (x : P p) (y : P q), + (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B). +Proof. intros. injection H. intros ; auto. Defined. + +Lemma simplification_K : Î A (x : A) (B : x = x -> Type), B (refl_equal x) -> (Î p : x = x, B p). +Proof. intros. rewrite (UIP_refl A). assumption. Defined. + +(** This hint database and the following tactic can be used with [autosimpl] to + unfold everything to [eq_rect]s. *) + +Hint Unfold solution_left solution_right deletion simplification_heq + simplification_existT1 simplification_existT2 + eq_rect_r eq_rec eq_ind : equations. + +(** Simply unfold as much as possible. *) + +Ltac unfold_equations := repeat progress autosimpl with equations. + +(** The tactic [simplify_equations] is to be used when a program generated using [Equations] + is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) + +Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). + +(** We will use the [block_induction] definition to separate the goal from the + equalities generated by the tactic. *) + +Definition block_dep_elim {A : Type} (a : A) := a. + +(** Using these we can make a simplifier that will perform the unification + steps needed to put the goal in normalised form (provided there are only + constructor forms). Compare with the lemma 16 of the paper. + We don't have a [noCycle] procedure yet. *) + +Ltac simplify_one_dep_elim_term c := + match c with + | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) + | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) + | eq (existT _ _ _) (existT _ _ _) -> _ => + refine (simplification_existT2 _ _ _ _ _ _ _) || + refine (simplification_existT1 _ _ _ _ _ _ _ _) + | ?x = ?y -> _ => (* variables case *) + (let hyp := fresh in intros hyp ; + move hyp before x ; + generalize dependent x ; refine (solution_left _ _ _ _) ; intros until 0) || + (let hyp := fresh in intros hyp ; + move hyp before y ; + generalize dependent y ; refine (solution_right _ _ _ _) ; intros until 0) + | @eq ?A ?t ?u -> ?P => apply (noConfusion (I:=A) P) + | ?f ?x = ?g ?y -> _ => let H := fresh in progress (intros H ; injection H ; clear H) + | ?t = ?u -> _ => let hyp := fresh in + intros hyp ; elimtype False ; discriminate + | ?x = ?y -> _ => let hyp := fresh in + intros hyp ; (try (clear hyp ; (* If non dependent, don't clear it! *) fail 1)) ; + case hyp ; clear hyp + | block_dep_elim ?T => fail 1 (* Do not put any part of the rhs in the hyps *) + | _ => intro + end. + +Ltac simplify_one_dep_elim := + match goal with + | [ |- ?gl ] => simplify_one_dep_elim_term gl + end. + +(** Repeat until no progress is possible. By construction, it should leave the goal with + no remaining equalities generated by the [generalize_eqs] tactic. *) + +Ltac simplify_dep_elim := repeat simplify_one_dep_elim. + +(** To dependent elimination on some hyp. *) + +Ltac depelim id := + generalize_eqs id ; destruct id ; simplify_dep_elim. + +(** Do dependent elimination of the last hypothesis, but not simplifying yet + (used internally). *) + +Ltac destruct_last := + on_last_hyp ltac:(fun id => simpl in id ; generalize_eqs id ; destruct id). + +(** The rest is support tactics for the [Equations] command. *) + +(** Notation for inaccessible patterns. *) + +Definition inaccessible_pattern {A : Type} (t : A) := t. + +Notation "?( t )" := (inaccessible_pattern t). + +(** To handle sections, we need to separate the context in two parts: + variables introduced by the section and the rest. We introduce a dummy variable + between them to indicate that. *) + +CoInductive end_of_section := the_end_of_the_section. + +Ltac set_eos := let eos := fresh "eos" in + assert (eos:=the_end_of_the_section). + +(** We have a specialized [reverse_local] tactic to reverse the goal until the begining of the + section variables *) + +Ltac reverse_local := + match goal with + | [ H : ?T |- _ ] => + match T with + | end_of_section => idtac | _ => revert H ; reverse_local end + | _ => idtac + end. + +(** Do as much as possible to apply a method, trying to get the arguments right. + !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some + non-dependent arguments of the method can remain after [apply]. *) + +Ltac simpl_intros m := ((apply m || refine m) ; auto) || (intro ; simpl_intros m). + +(** Hopefully the first branch suffices. *) + +Ltac try_intros m := + solve [ intros ; unfold block_dep_elim ; refine m || apply m ] || + solve [ unfold block_dep_elim ; simpl_intros m ]. + +(** To solve a goal by inversion on a particular target. *) + +Ltac solve_empty target := + do_nat target intro ; elimtype False ; destruct_last ; simplify_dep_elim. + +Ltac simplify_method tac := repeat (tac || simplify_one_dep_elim) ; reverse_local. + +(** Solving a method call: we can solve it by splitting on an empty family member + or we must refine the goal until the body can be applied. *) + +Ltac solve_method rec := + match goal with + | [ H := ?body : nat |- _ ] => subst H ; clear ; abstract (simplify_method idtac ; solve_empty body) + | [ H := [ ?body ] : ?T |- _ ] => clear H ; simplify_method ltac:(exact body) ; rec ; try_intros (body:T) + end. + +(** Impossible cases, by splitting on a given target. *) + +Ltac solve_split := + match goal with + | [ |- let split := ?x : nat in _ ] => clear ; abstract (intros _ ; solve_empty x) + end. + +(** If defining recursive functions, the prototypes come first. *) + +Ltac intro_prototypes := + match goal with + | [ |- Î x : _, _ ] => intro ; intro_prototypes + | _ => idtac + end. + +Ltac do_case p := destruct p || elim_case p || (case p ; clear p). +Ltac do_ind p := induction p || elim_ind p. + +Ltac dep_elimify := match goal with [ |- ?T ] => change (block_dep_elim T) end. + +Ltac un_dep_elimify := unfold block_dep_elim in *. + +Ltac case_last := dep_elimify ; + on_last_hyp ltac:(fun p => + let ty := type of p in + match ty with + | ?x = ?x => revert p ; refine (simplification_K _ x _ _) + | ?x = ?y => revert p + | _ => simpl in p ; generalize_eqs p ; do_case p + end). + +Ltac nonrec_equations := + solve [solve_equations (case_last) (solve_method idtac)] || solve [ solve_split ] + || fail "Unnexpected equations goal". + +Ltac recursive_equations := + solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] + || fail "Unnexpected recursive equations goal". + +(** The [equations] tactic is the toplevel tactic for solving goals generated + by [Equations]. *) + +Ltac equations := set_eos ; + match goal with + | [ |- Î x : _, _ ] => intro ; recursive_equations + | _ => nonrec_equations + end. + (** The following tactics allow to do induction on an already instantiated inductive predicate by first generalizing it and adding the proper equalities to the context, in a maner similar to the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) @@ -235,43 +520,49 @@ Ltac simpl_depind := subst* ; autoinjections ; try discriminates ; and starts a dependent induction using this tactic. *) Ltac do_depind tac H := - generalize_eqs_vars H ; tac H ; repeat progress simpl_depind. + (try intros until H) ; dep_elimify ; generalize_eqs_vars H ; tac H ; simplify_dep_elim ; un_dep_elimify. (** A variant where generalized variables should be given by the user. *) Ltac do_depind' tac H := - generalize_eqs H ; tac H ; repeat progress simpl_depind. + (try intros until H) ; dep_elimify ; generalize_eqs H ; tac H ; simplify_dep_elim ; un_dep_elimify. -(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. *) +(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. + By default, we don't try to generalize the hyp by its variable indices. *) Tactic Notation "dependent" "destruction" ident(H) := - do_depind ltac:(fun hyp => destruct hyp ; intros) H ; subst*. + do_depind' ltac:(fun hyp => do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := - do_depind ltac:(fun hyp => destruct hyp using c ; intros) H. + do_depind' ltac:(fun hyp => destruct hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => revert l ; destruct hyp ; intros) H. + do_depind' ltac:(fun hyp => revert l ; do_case hyp) H. Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => revert l ; destruct hyp using c ; intros) H. + do_depind' ltac:(fun hyp => revert l ; destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by - writting another wrapper calling do_depind. *) + writting another wrapper calling do_depind. We suppose the hyp has to be generalized before + calling [induction]. *) Tactic Notation "dependent" "induction" ident(H) := - do_depind ltac:(fun hyp => induction hyp ; intros) H. + do_depind ltac:(fun hyp => do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := - do_depind ltac:(fun hyp => induction hyp using c ; intros) H. + do_depind ltac:(fun hyp => induction hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp ; intros) H. + do_depind' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := - do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c ; intros) H. + do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. +Ltac simplify_IH_hyps := repeat + match goal with + | [ hyp : _ |- _ ] => specialize_hypothesis hyp + end.
\ No newline at end of file diff --git a/theories/Program/FunctionalExtensionality.v b/theories/Program/FunctionalExtensionality.v deleted file mode 100644 index b5ad5b4d..00000000 --- a/theories/Program/FunctionalExtensionality.v +++ /dev/null @@ -1,109 +0,0 @@ -(* -*- coq-prog-args: ("-emacs-U" "-nois") -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: FunctionalExtensionality.v 10739 2008-04-01 14:45:20Z herbelin $ i*) - -(** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion. - It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. - - It also defines two lemmas for expansion of fixpoint defs using extensionnality and proof-irrelevance - to avoid a side condition on the functionals. *) - -Require Import Coq.Program.Utils. -Require Import Coq.Program.Wf. -Require Import Coq.Program.Equality. - -Set Implicit Arguments. -Unset Strict Implicit. - -(** The converse of functional equality. *) - -Lemma equal_f : forall A B : Type, forall (f g : A -> B), - f = g -> forall x, f x = g x. -Proof. - intros. - rewrite H. - auto. -Qed. - -(** Statements of functional equality for simple and dependent functions. *) - -Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), - forall (f g : forall x : A, B x), - (forall x, f x = g x) -> f = g. - -Lemma fun_extensionality : forall A B (f g : A -> B), - (forall x, f x = g x) -> f = g. -Proof. - intros ; apply fun_extensionality_dep. - assumption. -Qed. - -Hint Resolve fun_extensionality fun_extensionality_dep : program. - -(** Apply [fun_extensionality], introducing variable x. *) - -Tactic Notation "extensionality" ident(x) := - match goal with - [ |- ?X = ?Y ] => apply (@fun_extensionality _ _ X Y) || apply (@fun_extensionality_dep _ _ X Y) ; intro x - end. - -(** Eta expansion follows from extensionality. *) - -Lemma eta_expansion_dep : forall A (B : A -> Type) (f : forall x : A, B x), - f = fun x => f x. -Proof. - intros. - extensionality x. - reflexivity. -Qed. - -Lemma eta_expansion : forall A B (f : A -> B), - f = fun x => f x. -Proof. - intros ; apply eta_expansion_dep. -Qed. - -(** The two following lemmas allow to unfold a well-founded fixpoint definition without - restriction using the functional extensionality axiom. *) - -(** For a function defined with Program using a well-founded order. *) - -Program Lemma fix_sub_eq_ext : - forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) - (P : A -> Set) - (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), - forall x : A, - Fix_sub A R Rwf P F_sub x = - F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y). -Proof. - intros ; apply Fix_eq ; auto. - intros. - assert(f = g). - extensionality y ; apply H. - rewrite H0 ; auto. -Qed. - -(** For a function defined with Program using a measure. *) - -Program Lemma fix_sub_measure_eq_ext : - forall (A : Type) (f : A -> nat) (P : A -> Type) - (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), - forall x : A, - Fix_measure_sub A f P F_sub x = - F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). -Proof. - intros ; apply Fix_measure_eq ; auto. - intros. - assert(f0 = g). - extensionality y ; apply H. - rewrite H0 ; auto. -Qed. - - diff --git a/theories/Program/Program.v b/theories/Program/Program.v index b6c3031e..7d0c3948 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -1,3 +1,12 @@ +(************************************************************************) +(* 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: Program.v 11709 2008-12-20 11:42:15Z msozeau $ *) + Require Export Coq.Program.Utils. Require Export Coq.Program.Wf. Require Export Coq.Program.Equality. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index d021326a..3d551281 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -5,14 +5,15 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Subset.v 11709 2008-12-20 11:42:15Z msozeau $ *) + +(** Tactics related to subsets and proof irrelevance. *) Require Import Coq.Program.Utils. Require Import Coq.Program.Equality. Open Local Scope program_scope. -(** Tactics related to subsets and proof irrelevance. *) - (** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *) diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 6cd75257..222b5c8d 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -1,4 +1,3 @@ -(* -*- coq-prog-args: ("-emacs-U") -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) @@ -6,14 +5,15 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* $Id: Syntax.v 11823 2009-01-21 15:32:37Z msozeau $ *) -(* Custom notations and implicits for Coq prelude definitions. - * - * Author: Matthieu Sozeau - * Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud - * 91405 Orsay, France *) +(** Custom notations and implicits for Coq prelude definitions. -(** Notations for the unit type and value. *) + Author: Matthieu Sozeau + Institution: LRI, CNRS UMR 8623 - UniversitĂcopyright Paris Sud + 91405 Orsay, France *) + +(** Notations for the unit type and value Ă la Haskell. *) Notation " () " := Datatypes.unit : type_scope. Notation " () " := tt. @@ -42,7 +42,7 @@ Notation " [ ] " := nil : list_scope. Notation " [ x ] " := (cons x nil) : list_scope. Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. -(** n-ary exists *) +(** Treating n-ary exists *) Notation " 'exists' x y , p" := (ex (fun x => (ex (fun y => p)))) (at level 200, x ident, y ident, right associativity) : type_scope. @@ -53,7 +53,7 @@ Notation " 'exists' x y z , p" := (ex (fun x => (ex (fun y => (ex (fun z => p))) Notation " 'exists' x y z w , p" := (ex (fun x => (ex (fun y => (ex (fun z => (ex (fun w => p)))))))) (at level 200, x ident, y ident, z ident, w ident, right associativity) : type_scope. -Tactic Notation "exist" constr(x) := exists x. -Tactic Notation "exist" constr(x) constr(y) := exists x ; exists y. -Tactic Notation "exist" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. -Tactic Notation "exist" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. +Tactic Notation "exists" constr(x) := exists x. +Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y. +Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. +Tactic Notation "exists" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index bb5054b4..499629a6 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -6,11 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Tactics.v 11282 2008-07-28 11:51:53Z msozeau $ i*) +(*i $Id: Tactics.v 11709 2008-12-20 11:42:15Z msozeau $ i*) (** This module implements various tactics used to simplify the goals produced by Program, which are also generally useful. *) +(** The [do] tactic but using a Coq-side nat. *) + +Ltac do_nat n tac := + match n with + | 0 => idtac + | S ?n' => tac ; do_nat n' tac + end. + +(** Do something on the last hypothesis, or fail *) + +Ltac on_last_hyp tac := + match goal with [ H : _ |- _ ] => tac H || fail 1 end. + (** Destructs one pair, without care regarding naming. *) Ltac destruct_one_pair := @@ -80,7 +93,7 @@ Ltac clear_dup := | [ H' : ?Y |- _ ] => match H with | H' => fail 2 - | _ => conv X Y ; (clear H' || clear H) + | _ => unify X Y ; (clear H' || clear H) end end end. @@ -91,7 +104,7 @@ Ltac clear_dups := repeat clear_dup. Ltac subst_no_fail := repeat (match goal with - [ H : ?X = ?Y |- _ ] => subst X || subst Y + [ H : ?X = ?Y |- _ ] => subst X || subst Y end). Tactic Notation "subst" "*" := subst_no_fail. @@ -108,6 +121,26 @@ Ltac on_application f tac T := | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. + +(** A variant of [apply] using [refine], doing as much conversion as necessary. *) + +Ltac rapply p := + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _) || + refine (p _ _ _ _ _) || + refine (p _ _ _ _) || + refine (p _ _ _) || + refine (p _ _) || + refine (p _) || + refine p. (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) @@ -154,13 +187,14 @@ Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(i (** Try to inject any potential constructor equality hypothesis. *) -Ltac autoinjection := - let tac H := progress (inversion H ; subst ; clear_dups) ; clear H in - match goal with - | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H - end. +Ltac autoinjection tac := + match goal with + | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H + end. + +Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H. -Ltac autoinjections := repeat autoinjection. +Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject). (** Destruct an hypothesis by first copying it to avoid dependencies. *) diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index fcd85f41..b08093bf 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -6,7 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Utils.v 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id: Utils.v 11709 2008-12-20 11:42:15Z msozeau $ i*) + +(** Various syntaxic shortands that are useful with [Program]. *) Require Export Coq.Program.Tactics. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index b6ba5d44..12bdf3a7 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -1,3 +1,15 @@ +(************************************************************************) +(* 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: Wf.v 11709 2008-12-20 11:42:15Z msozeau $ *) + +(** Reformulation of the Wf module using subsets where possible, providing + the support for [Program]'s treatment of well-founded definitions. *) + Require Import Coq.Init.Wf. Require Import Coq.Program.Utils. Require Import ProofIrrelevance. @@ -6,8 +18,6 @@ Open Local Scope program_scope. Implicit Arguments Acc_inv [A R x y]. -(** Reformulation of the Wellfounded module using subsets where possible. *) - Section Well_founded. Variable A : Type. Variable R : A -> A -> Prop. @@ -146,3 +156,196 @@ Section Well_founded_measure. End Well_founded_measure. Extraction Inline Fix_measure_F_sub Fix_measure_sub. + +Set Implicit Arguments. + +(** Reasoning about well-founded fixpoints on measures. *) + +Section Measure_well_founded. + + (* Measure relations are well-founded if the underlying relation is well-founded. *) + + Variables T M: Set. + Variable R: M -> M -> Prop. + Hypothesis wf: well_founded R. + Variable m: T -> M. + + Definition MR (x y: T): Prop := R (m x) (m y). + + Lemma measure_wf: well_founded MR. + Proof with auto. + unfold well_founded. + cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a). + intros. + apply (H (m a))... + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). + intros. + apply Acc_intro. + intros. + unfold MR in H1. + rewrite H0 in H1. + apply (H (m y))... + Defined. + +End Measure_well_founded. + +Section Fix_measure_rects. + + Variable A: Set. + Variable m: A -> nat. + Variable P: A -> Type. + Variable f: forall (x : A), (forall y: { y: A | m y < m x }, P (proj1_sig y)) -> P x. + + Lemma F_unfold x r: + Fix_measure_F_sub A m P f x r = + f (fun y => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv r (proj2_sig y))). + Proof. intros. case r; auto. Qed. + + (* Fix_measure_F_sub_rect lets one prove a property of + functions defined using Fix_measure_F_sub by showing + that property to be invariant over single application of the + function body (f in our case). *) + + Lemma Fix_measure_F_sub_rect + (Q: forall x, P x -> Type) + (inv: forall x: A, + (forall (y: A) (H: MR lt m y x) (a: Acc lt (m y)), + Q y (Fix_measure_F_sub A m P f y a)) -> + forall (a: Acc lt (m x)), + Q x (f (fun y: {y: A | m y < m x} => + Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))) + : forall x a, Q _ (Fix_measure_F_sub A m P f x a). + Proof with auto. + intros Q inv. + set (R := fun (x: A) => forall a, Q _ (Fix_measure_F_sub A m P f x a)). + cut (forall x, R x)... + apply (well_founded_induction_type (measure_wf lt_wf m)). + subst R. + simpl. + intros. + rewrite F_unfold... + Qed. + + (* Let's call f's second parameter its "lowers" function, since it + provides it access to results for inputs with a lower measure. + + In preparation of lemma similar to Fix_measure_F_sub_rect, but + for Fix_measure_sub, we first + need an extra hypothesis stating that the function body has the + same result for different "lowers" functions (g and h below) as long + as those produce the same results for lower inputs, regardless + of the lt proofs. *) + + Hypothesis equiv_lowers: + forall x0 (g h: forall x: {y: A | m y < m x0}, P (proj1_sig x)), + (forall x p p', g (exist (fun y: A => m y < m x0) x p) = h (exist _ x p')) -> + f g = f h. + + (* From equiv_lowers, it follows that + [Fix_measure_F_sub A m P f x] applications do not not + depend on the Acc proofs. *) + + Lemma eq_Fix_measure_F_sub x (a a': Acc lt (m x)): + Fix_measure_F_sub A m P f x a = + Fix_measure_F_sub A m P f x a'. + Proof. + intros x a. + pattern x, (Fix_measure_F_sub A m P f x a). + apply Fix_measure_F_sub_rect. + intros. + rewrite F_unfold. + apply equiv_lowers. + intros. + apply H. + assumption. + Qed. + + (* Finally, Fix_measure_F_rect lets one prove a property of + functions defined using Fix_measure_F by showing that + property to be invariant over single application of the function + body (f). *) + + Lemma Fix_measure_sub_rect + (Q: forall x, P x -> Type) + (inv: forall + (x: A) + (H: forall (y: A), MR lt m y x -> Q y (Fix_measure_sub A m P f y)) + (a: Acc lt (m x)), + Q x (f (fun y: {y: A | m y < m x} => Fix_measure_sub A m P f (proj1_sig y)))) + : forall x, Q _ (Fix_measure_sub A m P f x). + Proof with auto. + unfold Fix_measure_sub. + intros. + apply Fix_measure_F_sub_rect. + intros. + assert (forall y: A, MR lt m y x0 -> Q y (Fix_measure_F_sub A m P f y (lt_wf (m y))))... + set (inv x0 X0 a). clearbody q. + rewrite <- (equiv_lowers (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (lt_wf (m (proj1_sig y)))) (fun y: {y: A | m y < m x0} => Fix_measure_F_sub A m P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... + intros. + apply eq_Fix_measure_F_sub. + Qed. + +End Fix_measure_rects. + +(** Tactic to fold a definitions based on [Fix_measure_sub]. *) + +Ltac fold_sub f := + match goal with + | [ |- ?T ] => + match T with + appcontext C [ @Fix_measure_sub _ _ _ _ ?arg ] => + let app := context C [ f arg ] in + change app + end + end. + +(** This module provides the fixpoint equation provided one assumes + functional extensionality. *) + +Module WfExtensionality. + + Require Import FunctionalExtensionality. + + (** The two following lemmas allow to unfold a well-founded fixpoint definition without + restriction using the functional extensionality axiom. *) + + (** For a function defined with Program using a well-founded order. *) + + Program Lemma fix_sub_eq_ext : + forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) + (P : A -> Set) + (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x), + forall x : A, + Fix_sub A R Rwf P F_sub x = + F_sub x (fun (y : A | R y x) => Fix A R Rwf P F_sub y). + Proof. + intros ; apply Fix_eq ; auto. + intros. + assert(f = g). + extensionality y ; apply H. + rewrite H0 ; auto. + Qed. + + (** For a function defined with Program using a measure. *) + + Program Lemma fix_sub_measure_eq_ext : + forall (A : Type) (f : A -> nat) (P : A -> Type) + (F_sub : forall x : A, (forall (y : A | f y < f x), P y) -> P x), + forall x : A, + Fix_measure_sub A f P F_sub x = + F_sub x (fun (y : A | f y < f x) => Fix_measure_sub A f P F_sub y). + Proof. + intros ; apply Fix_measure_eq ; auto. + intros. + assert(f0 = g). + extensionality y ; apply H. + rewrite H0 ; auto. + Qed. + + (** Tactic to unfold once a definition based on [Fix_measure_sub]. *) + + Ltac unfold_sub f fargs := + set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; + rewrite fix_sub_measure_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. + +End WfExtensionality. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index 8672592d..efaefbb7 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -221,7 +221,7 @@ repeat rewrite Zpos_mult_morphism. repeat rewrite Z2P_correct. repeat rewrite Zpower_pos_1_r; ring. apply Zpower_pos_pos; red; auto. -repeat apply Zmult_lt_0_compat; auto; +repeat apply Zmult_lt_0_compat; red; auto; apply Zpower_pos_pos; red; auto. (* xO *) rewrite IHp, <-Pplus_diag. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 0638ca8f..d0916b09 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -6,15 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Operators_Properties.v 9598 2007-02-06 19:45:52Z herbelin $ i*) +(*i $Id: Operators_Properties.v 11481 2008-10-20 19:23:51Z herbelin $ i*) -(****************************************************************************) -(* Bruno Barras *) -(****************************************************************************) +(************************************************************************) +(** * Some properties of the operators on relations *) +(************************************************************************) +(** * Initial version by Bruno Barras *) +(************************************************************************) Require Import Relation_Definitions. Require Import Relation_Operators. - +Require Import Setoid. Section Properties. @@ -25,6 +27,8 @@ Section Properties. Section Clos_Refl_Trans. + (** Correctness of the reflexive-transitive closure operator *) + Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R). Proof. apply Build_preorder. @@ -33,6 +37,8 @@ Section Properties. exact (rt_trans A R). Qed. + (** Idempotency of the reflexive-transitive closure operator *) + Lemma clos_rt_idempotent : incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R). Proof. @@ -42,32 +48,13 @@ Section Properties. apply rt_trans with y; auto with sets. Qed. - Lemma clos_refl_trans_ind_left : - forall (A:Type) (R:A -> A -> Prop) (M:A) (P:A -> Prop), - P M -> - (forall P0 N:A, clos_refl_trans A R M P0 -> P P0 -> R P0 N -> P N) -> - forall a:A, clos_refl_trans A R M a -> P a. - Proof. - intros. - generalize H H0. - clear H H0. - elim H1; intros; auto with sets. - apply H2 with x; auto with sets. - - apply H3. - apply H0; auto with sets. - - intros. - apply H5 with P0; auto with sets. - apply rt_trans with y; auto with sets. - Qed. - - End Clos_Refl_Trans. - Section Clos_Refl_Sym_Trans. + (** Reflexive-transitive closure is included in the + reflexive-symmetric-transitive closure *) + Lemma clos_rt_clos_rst : inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R). Proof. @@ -76,6 +63,8 @@ Section Properties. apply rst_trans with y; auto with sets. Qed. + (** Correctness of the reflexive-symmetric-transitive closure *) + Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R). Proof. apply Build_equivalence. @@ -84,6 +73,8 @@ Section Properties. exact (rst_sym A R). Qed. + (** Idempotency of the reflexive-symmetric-transitive closure operator *) + Lemma clos_rst_idempotent : incl (clos_refl_sym_trans A (clos_refl_sym_trans A R)) (clos_refl_sym_trans A R). @@ -92,7 +83,294 @@ Section Properties. induction 1; auto with sets. apply rst_trans with y; auto with sets. Qed. - + End Clos_Refl_Sym_Trans. + Section Equivalences. + + (** *** Equivalences between the different definition of the reflexive, + symmetric, transitive closures *) + + (** *** Contributed by P. Casteran *) + + (** Direct transitive closure vs left-step extension *) + + Lemma t1n_trans : forall x y, clos_trans_1n A R x y -> clos_trans A R x y. + Proof. + induction 1. + left; assumption. + right with y; auto. + left; auto. + Qed. + + Lemma trans_t1n : forall x y, clos_trans A R x y -> clos_trans_1n A R x y. + Proof. + induction 1. + left; assumption. + generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. + right with y; auto. + right with y; auto. + eapply IHIHclos_trans1; auto. + apply t1n_trans; auto. + Qed. + + Lemma t1n_trans_equiv : forall x y, + clos_trans A R x y <-> clos_trans_1n A R x y. + Proof. + split. + apply trans_t1n. + apply t1n_trans. + Qed. + + (** Direct transitive closure vs right-step extension *) + + Lemma tn1_trans : forall x y, clos_trans_n1 A R x y -> clos_trans A R x y. + Proof. + induction 1. + left; assumption. + right with y; auto. + left; assumption. + Qed. + + Lemma trans_tn1 : forall x y, clos_trans A R x y -> clos_trans_n1 A R x y. + Proof. + induction 1. + left; assumption. + elim IHclos_trans2. + intro y0; right with y. + auto. + auto. + intros. + right with y0; auto. + Qed. + + Lemma tn1_trans_equiv : forall x y, + clos_trans A R x y <-> clos_trans_n1 A R x y. + Proof. + split. + apply trans_tn1. + apply tn1_trans. + Qed. + + (** Direct reflexive-transitive closure is equivalent to + transitivity by left-step extension *) + + Lemma R_rt1n : forall x y, R x y -> clos_refl_trans_1n A R x y. + Proof. + intros x y H. + right with y;[assumption|left]. + Qed. + + Lemma R_rtn1 : forall x y, R x y -> clos_refl_trans_n1 A R x y. + Proof. + intros x y H. + right with x;[assumption|left]. + Qed. + + Lemma rt1n_trans : forall x y, + clos_refl_trans_1n A R x y -> clos_refl_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 3 with y; auto. + constructor 1; auto. + Qed. + + Lemma trans_rt1n : forall x y, + clos_refl_trans A R x y -> clos_refl_trans_1n A R x y. + Proof. + induction 1. + apply R_rt1n; assumption. + left. + generalize IHclos_refl_trans2; clear IHclos_refl_trans2; + induction IHclos_refl_trans1; auto. + + right with y; auto. + eapply IHIHclos_refl_trans1; auto. + apply rt1n_trans; auto. + Qed. + + Lemma rt1n_trans_equiv : forall x y, + clos_refl_trans A R x y <-> clos_refl_trans_1n A R x y. + Proof. + split. + apply trans_rt1n. + apply rt1n_trans. + Qed. + + (** Direct reflexive-transitive closure is equivalent to + transitivity by right-step extension *) + + Lemma rtn1_trans : forall x y, + clos_refl_trans_n1 A R x y -> clos_refl_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 3 with y; auto. + constructor 1; assumption. + Qed. + + Lemma trans_rtn1 : forall x y, + clos_refl_trans A R x y -> clos_refl_trans_n1 A R x y. + Proof. + induction 1. + apply R_rtn1; auto. + left. + elim IHclos_refl_trans2; auto. + intros. + right with y0; auto. + Qed. + + Lemma rtn1_trans_equiv : forall x y, + clos_refl_trans A R x y <-> clos_refl_trans_n1 A R x y. + Proof. + split. + apply trans_rtn1. + apply rtn1_trans. + Qed. + + (** Induction on the left transitive step *) + + Lemma clos_refl_trans_ind_left : + forall (x:A) (P:A -> Prop), P x -> + (forall y z:A, clos_refl_trans A R x y -> P y -> R y z -> P z) -> + forall z:A, clos_refl_trans A R x z -> P z. + Proof. + intros. + revert H H0. + induction H1; intros; auto with sets. + apply H1 with x; auto with sets. + + apply IHclos_refl_trans2. + apply IHclos_refl_trans1; auto with sets. + + intros. + apply H0 with y0; auto with sets. + apply rt_trans with y; auto with sets. + Qed. + + (** Induction on the right transitive step *) + + Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A), + P z -> + (forall x y, R x y -> clos_refl_trans_1n A R y z -> P y -> P x) -> + forall x, clos_refl_trans_1n A R x z -> P x. + induction 3; auto. + apply H0 with y; auto. + Qed. + + Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A), + P z -> + (forall x y, R x y -> P y -> clos_refl_trans A R y z -> P x) -> + forall x, clos_refl_trans A R x z -> P x. + intros. + rewrite rt1n_trans_equiv in H1. + elim H1 using rt1n_ind_right; auto. + intros; rewrite <- rt1n_trans_equiv in *. + eauto. + Qed. + + (** Direct reflexive-symmetric-transitive closure is equivalent to + transitivity by symmetric left-step extension *) + + Lemma rts1n_rts : forall x y, + clos_refl_sym_trans_1n A R x y -> clos_refl_sym_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. + Qed. + + Lemma rts_1n_trans : forall x y, clos_refl_sym_trans_1n A R x y -> + forall z, clos_refl_sym_trans_1n A R y z -> + clos_refl_sym_trans_1n A R x z. + induction 1. + auto. + intros; right with y; eauto. + Qed. + + Lemma rts1n_sym : forall x y, clos_refl_sym_trans_1n A R x y -> + clos_refl_sym_trans_1n A R y x. + Proof. + intros x y H; elim H. + constructor 1. + intros x0 y0 z D H0 H1; apply rts_1n_trans with y0; auto. + right with x0. + tauto. + left. + Qed. + + Lemma rts_rts1n : forall x y, + clos_refl_sym_trans A R x y -> clos_refl_sym_trans_1n A R x y. + induction 1. + constructor 2 with y; auto. + constructor 1. + constructor 1. + apply rts1n_sym; auto. + eapply rts_1n_trans; eauto. + Qed. + + Lemma rts_rts1n_equiv : forall x y, + clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_1n A R x y. + Proof. + split. + apply rts_rts1n. + apply rts1n_rts. + Qed. + + (** Direct reflexive-symmetric-transitive closure is equivalent to + transitivity by symmetric right-step extension *) + + Lemma rtsn1_rts : forall x y, + clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans A R x y. + Proof. + induction 1. + constructor 2. + constructor 4 with y; auto. + case H;[constructor 1|constructor 3; constructor 1]; auto. + Qed. + + Lemma rtsn1_trans : forall y z, clos_refl_sym_trans_n1 A R y z-> + forall x, clos_refl_sym_trans_n1 A R x y -> + clos_refl_sym_trans_n1 A R x z. + Proof. + induction 1. + auto. + intros. + right with y0; eauto. + Qed. + + Lemma rtsn1_sym : forall x y, clos_refl_sym_trans_n1 A R x y -> + clos_refl_sym_trans_n1 A R y x. + Proof. + intros x y H; elim H. + constructor 1. + intros y0 z D H0 H1. apply rtsn1_trans with y0; auto. + right with z. + tauto. + left. + Qed. + + Lemma rts_rtsn1 : forall x y, + clos_refl_sym_trans A R x y -> clos_refl_sym_trans_n1 A R x y. + Proof. + induction 1. + constructor 2 with x; auto. + constructor 1. + constructor 1. + apply rtsn1_sym; auto. + eapply rtsn1_trans; eauto. + Qed. + + Lemma rts_rtsn1_equiv : forall x y, + clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_n1 A R x y. + Proof. + split. + apply rts_rtsn1. + apply rtsn1_rts. + Qed. + + End Equivalences. + End Properties. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 87cd1e6f..027a9e6c 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -6,68 +6,119 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Relation_Operators.v 10681 2008-03-16 13:40:45Z msozeau $ i*) +(*i $Id: Relation_Operators.v 11481 2008-10-20 19:23:51Z herbelin $ i*) -(****************************************************************************) -(* Bruno Barras, Cristina Cornes *) -(* *) -(* Some of these definitons were taken from : *) -(* Constructing Recursion Operators in Type Theory *) -(* L. Paulson JSC (1986) 2, 325-355 *) -(****************************************************************************) +(************************************************************************) +(** * Bruno Barras, Cristina Cornes *) +(** * *) +(** * Some of these definitions were taken from : *) +(** * Constructing Recursion Operators in Type Theory *) +(** * L. Paulson JSC (1986) 2, 325-355 *) +(************************************************************************) Require Import Relation_Definitions. Require Import List. -(** Some operators to build relations *) +(** * Some operators to build relations *) + +(** ** Transitive closure *) Section Transitive_Closure. Variable A : Type. Variable R : relation A. - + + (** Definition by direct transitive closure *) + Inductive clos_trans (x: A) : A -> Prop := - | t_step : forall y:A, R x y -> clos_trans x y - | t_trans : - forall y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z. + | t_step (y:A) : R x y -> clos_trans x y + | t_trans (y z:A) : clos_trans x y -> clos_trans y z -> clos_trans x z. + + (** Alternative definition by transitive extension on the left *) + + Inductive clos_trans_1n (x: A) : A -> Prop := + | t1n_step (y:A) : R x y -> clos_trans_1n x y + | t1n_trans (y z:A) : R x y -> clos_trans_1n y z -> clos_trans_1n x z. + + (** Alternative definition by transitive extension on the right *) + + Inductive clos_trans_n1 (x: A) : A -> Prop := + | tn1_step (y:A) : R x y -> clos_trans_n1 x y + | tn1_trans (y z:A) : R y z -> clos_trans_n1 x y -> clos_trans_n1 x z. + End Transitive_Closure. +(** ** Reflexive-transitive closure *) Section Reflexive_Transitive_Closure. Variable A : Type. Variable R : relation A. - Inductive clos_refl_trans (x:A) : A -> Prop:= - | rt_step : forall y:A, R x y -> clos_refl_trans x y + (** Definition by direct reflexive-transitive closure *) + + Inductive clos_refl_trans (x:A) : A -> Prop := + | rt_step (y:A) : R x y -> clos_refl_trans x y | rt_refl : clos_refl_trans x x - | rt_trans : - forall y z:A, + | rt_trans (y z:A) : clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z. + + (** Alternative definition by transitive extension on the left *) + + Inductive clos_refl_trans_1n (x: A) : A -> Prop := + | rt1n_refl : clos_refl_trans_1n x x + | rt1n_trans (y z:A) : + R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. + + (** Alternative definition by transitive extension on the right *) + + Inductive clos_refl_trans_n1 (x: A) : A -> Prop := + | rtn1_refl : clos_refl_trans_n1 x x + | rtn1_trans (y z:A) : + R y z -> clos_refl_trans_n1 x y -> clos_refl_trans_n1 x z. + End Reflexive_Transitive_Closure. +(** ** Reflexive-symmetric-transitive closure *) Section Reflexive_Symetric_Transitive_Closure. Variable A : Type. Variable R : relation A. + (** Definition by direct reflexive-symmetric-transitive closure *) + Inductive clos_refl_sym_trans : relation A := - | rst_step : forall x y:A, R x y -> clos_refl_sym_trans x y - | rst_refl : forall x:A, clos_refl_sym_trans x x - | rst_sym : - forall x y:A, clos_refl_sym_trans x y -> clos_refl_sym_trans y x - | rst_trans : - forall x y z:A, + | rst_step (x y:A) : R x y -> clos_refl_sym_trans x y + | rst_refl (x:A) : clos_refl_sym_trans x x + | rst_sym (x y:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y x + | rst_trans (x y z:A) : clos_refl_sym_trans x y -> clos_refl_sym_trans y z -> clos_refl_sym_trans x z. + + (** Alternative definition by symmetric-transitive extension on the left *) + + Inductive clos_refl_sym_trans_1n (x: A) : A -> Prop := + | rts1n_refl : clos_refl_sym_trans_1n x x + | rts1n_trans (y z:A) : R x y \/ R y x -> + clos_refl_sym_trans_1n y z -> clos_refl_sym_trans_1n x z. + + (** Alternative definition by symmetric-transitive extension on the right *) + + Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := + | rtsn1_refl : clos_refl_sym_trans_n1 x x + | rtsn1_trans (y z:A) : R y z \/ R z y -> + clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. + End Reflexive_Symetric_Transitive_Closure. +(** ** Converse of a relation *) -Section Transposee. +Section Converse. Variable A : Type. Variable R : relation A. Definition transp (x y:A) := R y x. -End Transposee. +End Converse. +(** ** Union of relations *) Section Union. Variable A : Type. @@ -76,6 +127,7 @@ Section Union. Definition union (x y:A) := R1 x y \/ R2 x y. End Union. +(** ** Disjoint union of relations *) Section Disjoint_Union. Variables A B : Type. @@ -83,16 +135,15 @@ Variable leA : A -> A -> Prop. Variable leB : B -> B -> Prop. Inductive le_AsB : A + B -> A + B -> Prop := - | le_aa : forall x y:A, leA x y -> le_AsB (inl _ x) (inl _ y) - | le_ab : forall (x:A) (y:B), le_AsB (inl _ x) (inr _ y) - | le_bb : forall x y:B, leB x y -> le_AsB (inr _ x) (inr _ y). + | le_aa (x y:A) : leA x y -> le_AsB (inl _ x) (inl _ y) + | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) + | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). End Disjoint_Union. - +(** ** Lexicographic order on dependent pairs *) Section Lexicographic_Product. - (* Lexicographic order on dependent pairs *) Variable A : Type. Variable B : A -> Type. @@ -106,8 +157,10 @@ Section Lexicographic_Product. | right_lex : forall (x:A) (y y':B x), leB x y y' -> lexprod (existS B x y) (existS B x y'). + End Lexicographic_Product. +(** ** Product of relations *) Section Symmetric_Product. Variable A : Type. @@ -123,16 +176,15 @@ Section Symmetric_Product. End Symmetric_Product. +(** ** Multiset of two relations *) Section Swap. Variable A : Type. Variable R : A -> A -> Prop. Inductive swapprod : A * A -> A * A -> Prop := - | sp_noswap : forall x x':A * A, symprod A A R R x x' -> swapprod x x' - | sp_swap : - forall (x y:A) (p:A * A), - symprod A A R R (x, y) p -> swapprod (y, x) p. + | sp_noswap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (x, y) p + | sp_swap x y (p:A * A) : symprod A A R R (x, y) p -> swapprod (y, x) p. End Swap. @@ -144,16 +196,14 @@ Section Lexicographic_Exponentiation. Let List := list A. Inductive Ltl : List -> List -> Prop := - | Lt_nil : forall (a:A) (x:List), Ltl Nil (a :: x) - | Lt_hd : forall a b:A, leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) - | Lt_tl : forall (a:A) (x y:List), Ltl x y -> Ltl (a :: x) (a :: y). - + | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) + | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) + | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y). Inductive Desc : List -> Prop := | d_nil : Desc Nil - | d_one : forall x:A, Desc (x :: Nil) - | d_conc : - forall (x y:A) (l:List), + | d_one (x:A) : Desc (x :: Nil) + | d_conc (x y:A) (l:List) : leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index d6975e91..e7fe82b2 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -6,38 +6,53 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Setoid.v 10765 2008-04-08 16:15:23Z msozeau $: i*) +(*i $Id: Setoid.v 11720 2008-12-28 07:12:15Z letouzey $: i*) Require Export Coq.Classes.SetoidTactics. (** For backward compatibility *) -Definition Setoid_Theory := @Equivalence. -Definition Build_Setoid_Theory := @Build_Equivalence. -Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x := - Eval compute in reflexivity. -Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x := - Eval compute in symmetry. -Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z := - Eval compute in transitivity. +Definition Setoid_Theory := @Equivalence. +Definition Build_Setoid_Theory := @Build_Equivalence. -(** Some tactics for manipulating Setoid Theory not officially - declared as Setoid. *) +Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. + unfold Setoid_Theory. intros ; reflexivity. +Defined. + +Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x. + unfold Setoid_Theory. intros ; symmetry ; assumption. +Defined. -Ltac trans_st x := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_trans _ _ H) with x; auto - end. +Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z. + unfold Setoid_Theory. intros ; transitivity y ; assumption. +Defined. -Ltac sym_st := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_sym _ _ H); auto - end. +(** Some tactics for manipulating Setoid Theory not officially + declared as Setoid. *) -Ltac refl_st := match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => - apply (Seq_refl _ _ H); auto - end. +Ltac trans_st x := + idtac "trans_st on Setoid_Theory is OBSOLETE"; + idtac "use transitivity on Equivalence instead"; + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_trans _ _ H) with x; auto + end. + +Ltac sym_st := + idtac "sym_st on Setoid_Theory is OBSOLETE"; + idtac "use symmetry on Equivalence instead"; + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_sym _ _ H); auto + end. + +Ltac refl_st := + idtac "refl_st on Setoid_Theory is OBSOLETE"; + idtac "use reflexivity on Equivalence instead"; + 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. diff --git a/theories/Setoids/Setoid_Prop.v b/theories/Setoids/Setoid_Prop.v deleted file mode 100644 index 7300937e..00000000 --- a/theories/Setoids/Setoid_Prop.v +++ /dev/null @@ -1,79 +0,0 @@ - -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: Setoid_Prop.v 10739 2008-04-01 14:45:20Z herbelin $: i*) - -Require Import Setoid_tac. - -(** * A few examples on [iff] *) - -(** [iff] as a relation *) - -Add Relation Prop iff - reflexivity proved by iff_refl - symmetry proved by iff_sym - transitivity proved by iff_trans -as iff_relation. - -(** [impl] as a relation *) - -Theorem impl_trans: transitive _ impl. -Proof. - hnf; unfold impl; tauto. -Qed. - -Add Relation Prop impl - reflexivity proved by impl_refl - transitivity proved by impl_trans -as impl_relation. - -(** [impl] is a morphism *) - -Add Morphism impl with signature iff ==> iff ==> iff as Impl_Morphism. -Proof. - unfold impl; tauto. -Qed. - -(** [and] is a morphism *) - -Add Morphism and with signature iff ==> iff ==> iff as And_Morphism. - tauto. -Qed. - -(** [or] is a morphism *) - -Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism. -Proof. - tauto. -Qed. - -(** [not] is a morphism *) - -Add Morphism not with signature iff ==> iff as Not_Morphism. -Proof. - tauto. -Qed. - -(** The same examples on [impl] *) - -Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2. -Proof. - unfold impl; tauto. -Qed. - -Add Morphism not with signature impl --> impl as Not_Morphism2. -Proof. - unfold impl; tauto. -Qed. - diff --git a/theories/Setoids/Setoid_tac.v b/theories/Setoids/Setoid_tac.v deleted file mode 100644 index cdc4eafe..00000000 --- a/theories/Setoids/Setoid_tac.v +++ /dev/null @@ -1,595 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: Setoid_tac.v 10739 2008-04-01 14:45:20Z herbelin $ i*) - -Require Export Relation_Definitions. - -Set Implicit Arguments. - -(** * Definitions of [Relation_Class] and n-ary [Morphism_Theory] *) - -(* X will be used to distinguish covariant arguments whose type is an *) -(* Asymmetric* relation from contravariant arguments of the same type *) -Inductive X_Relation_Class (X: Type) : Type := - SymmetricReflexive : - forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> X_Relation_Class X - | AsymmetricReflexive : X -> forall A Aeq, reflexive A Aeq -> X_Relation_Class X - | SymmetricAreflexive : forall A Aeq, symmetric A Aeq -> X_Relation_Class X - | AsymmetricAreflexive : X -> forall A (Aeq : relation A), X_Relation_Class X - | Leibniz : Type -> X_Relation_Class X. - -Inductive variance : Set := - Covariant - | Contravariant. - -Definition Argument_Class := X_Relation_Class variance. -Definition Relation_Class := X_Relation_Class unit. - -Inductive Reflexive_Relation_Class : Type := - RSymmetric : - forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> Reflexive_Relation_Class - | RAsymmetric : - forall A Aeq, reflexive A Aeq -> Reflexive_Relation_Class - | RLeibniz : Type -> Reflexive_Relation_Class. - -Inductive Areflexive_Relation_Class : Type := - | ASymmetric : forall A Aeq, symmetric A Aeq -> Areflexive_Relation_Class - | AAsymmetric : forall A (Aeq : relation A), Areflexive_Relation_Class. - -Implicit Type Hole Out: Relation_Class. - -Definition relation_class_of_argument_class : Argument_Class -> Relation_Class. - destruct 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). - exact (Leibniz _ T). -Defined. - -Definition carrier_of_relation_class : forall X, X_Relation_Class X -> Type. - destruct 1. - exact A. - exact A. - exact A. - exact A. - exact T. -Defined. - -Definition relation_of_relation_class : - forall X R, @carrier_of_relation_class X R -> carrier_of_relation_class R -> Prop. - destruct R. - exact Aeq. - exact Aeq. - exact Aeq. - exact Aeq. - exact (@eq T). -Defined. - -Lemma about_carrier_of_relation_class_and_relation_class_of_argument_class : - forall R, - carrier_of_relation_class (relation_class_of_argument_class R) = - carrier_of_relation_class R. - destruct R; reflexivity. -Defined. - -Inductive nelistT (A : Type) : Type := - singl : A -> nelistT A - | necons : A -> nelistT A -> nelistT A. - -Definition Arguments := nelistT Argument_Class. - -Implicit Type In: Arguments. - -Definition function_type_of_morphism_signature : - Arguments -> Relation_Class -> Type. - intros In Out. - induction In. - exact (carrier_of_relation_class a -> carrier_of_relation_class Out). - exact (carrier_of_relation_class a -> IHIn). -Defined. - -Definition make_compatibility_goal_aux: - forall In Out - (f g: function_type_of_morphism_signature In Out), Prop. - intros; induction In; simpl in f, g. - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)). - exact (forall x, relation_of_relation_class Out (f x) (g x)). - induction a; simpl in f, g. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - destruct x. - exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)). - exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)). - exact (forall x, IHIn (f x) (g x)). -Defined. - -Definition make_compatibility_goal := - (fun In Out f => make_compatibility_goal_aux In Out f f). - -Record Morphism_Theory In Out : Type := - { Function : function_type_of_morphism_signature In Out; - Compat : make_compatibility_goal In Out Function }. - - -(** The [iff] relation class *) - -Definition Iff_Relation_Class : Relation_Class. - eapply (@SymmetricReflexive unit _ iff). - exact iff_sym. - exact iff_refl. -Defined. - -(** The [impl] relation class *) - -Definition impl (A B: Prop) := A -> B. - -Theorem impl_refl: reflexive _ impl. -Proof. - hnf; unfold impl; tauto. -Qed. - -Definition Impl_Relation_Class : Relation_Class. - eapply (@AsymmetricReflexive unit tt _ impl). - exact impl_refl. -Defined. - -(** Every function is a morphism from Leibniz+ to Leibniz *) - -Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments. - induction 1. - exact (singl (Leibniz _ a)). - exact (necons (Leibniz _ a) IHX). -Defined. - -Definition morphism_theory_of_function : - forall (In: nelistT Type) (Out: Type), - let In' := list_of_Leibniz_of_list_of_types In in - let Out' := Leibniz _ Out in - function_type_of_morphism_signature In' Out' -> - Morphism_Theory In' Out'. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - reflexivity. - intro; apply (IHIn (X x)). -Defined. - -(** Every predicate is a morphism from Leibniz+ to Iff_Relation_Class *) - -Definition morphism_theory_of_predicate : - forall (In: nelistT Type), - let In' := list_of_Leibniz_of_list_of_types In in - function_type_of_morphism_signature In' Iff_Relation_Class -> - Morphism_Theory In' Iff_Relation_Class. - intros. - exists X. - induction In; unfold make_compatibility_goal; simpl. - intro; apply iff_refl. - intro; apply (IHIn (X x)). -Defined. - -(** * Utility functions to prove that every transitive relation is a morphism *) - -Definition equality_morphism_of_symmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(sym: symmetric _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass := SymmetricAreflexive _ sym in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_symmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(sym: symmetric _ Aeq) - (trans: transitive _ Aeq), let ASetoidClass := SymmetricReflexive _ sym refl in - (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; split; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_areflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricAreflexive Contravariant Aeq in - let ASetoidClass2 := AsymmetricAreflexive Covariant Aeq in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -Definition equality_morphism_of_asymmetric_reflexive_transitive_relation: - forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(trans: transitive _ Aeq), - let ASetoidClass1 := AsymmetricReflexive Contravariant refl in - let ASetoidClass2 := AsymmetricReflexive Covariant refl in - (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class). - intros. - exists Aeq. - unfold make_compatibility_goal; simpl; unfold impl; eauto. -Defined. - -(** * The CIC part of the reflexive tactic ([setoid_rewrite]) *) - -Inductive rewrite_direction : Type := - | Left2Right - | Right2Left. - -Implicit Type dir: rewrite_direction. - -Definition variance_of_argument_class : Argument_Class -> option variance. - destruct 1. - exact None. - exact (Some v). - exact None. - exact (Some v). - exact None. -Defined. - -Definition opposite_direction := - fun dir => - match dir with - | Left2Right => Right2Left - | Right2Left => Left2Right - end. - -Lemma opposite_direction_idempotent: - forall dir, (opposite_direction (opposite_direction dir)) = dir. -Proof. - destruct dir; reflexivity. -Qed. - -Inductive check_if_variance_is_respected : - option variance -> rewrite_direction -> rewrite_direction -> Prop := - | MSNone : forall dir dir', check_if_variance_is_respected None dir dir' - | MSCovariant : forall dir, check_if_variance_is_respected (Some Covariant) dir dir - | MSContravariant : - forall dir, - check_if_variance_is_respected (Some Contravariant) dir (opposite_direction dir). - -Definition relation_class_of_reflexive_relation_class: - Reflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricReflexive _ s r). - exact (AsymmetricReflexive tt r). - exact (Leibniz _ T). -Defined. - -Definition relation_class_of_areflexive_relation_class: - Areflexive_Relation_Class -> Relation_Class. - induction 1. - exact (SymmetricAreflexive _ s). - exact (AsymmetricAreflexive tt Aeq). -Defined. - -Definition carrier_of_reflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_reflexive_relation_class R). - -Definition carrier_of_areflexive_relation_class := - fun R => carrier_of_relation_class (relation_class_of_areflexive_relation_class R). - -Definition relation_of_areflexive_relation_class := - fun R => relation_of_relation_class (relation_class_of_areflexive_relation_class R). - -Inductive Morphism_Context Hole dir : Relation_Class -> rewrite_direction -> Type := - | App : - forall In Out dir', - Morphism_Theory In Out -> Morphism_Context_List Hole dir dir' In -> - Morphism_Context Hole dir Out dir' - | ToReplace : Morphism_Context Hole dir Hole dir - | ToKeep : - forall S dir', - carrier_of_reflexive_relation_class S -> - Morphism_Context Hole dir (relation_class_of_reflexive_relation_class S) dir' - | ProperElementToKeep : - forall S dir' (x: carrier_of_areflexive_relation_class S), - relation_of_areflexive_relation_class S x x -> - Morphism_Context Hole dir (relation_class_of_areflexive_relation_class S) dir' -with Morphism_Context_List Hole dir : - rewrite_direction -> Arguments -> Type -:= - fcl_singl : - forall S dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' (singl S) - | fcl_cons : - forall S L dir' dir'', - check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' -> - Morphism_Context Hole dir (relation_class_of_argument_class S) dir' -> - Morphism_Context_List Hole dir dir'' L -> - Morphism_Context_List Hole dir dir'' (necons S L). - -Scheme Morphism_Context_rect2 := Induction for Morphism_Context Sort Type -with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Type. - -Definition product_of_arguments : Arguments -> Type. - induction 1. - exact (carrier_of_relation_class a). - exact (prod (carrier_of_relation_class a) IHX). -Defined. - -Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction. - intros dir R. - destruct (variance_of_argument_class R). - destruct v. - exact dir. (* covariant *) - exact (opposite_direction dir). (* contravariant *) - exact dir. (* symmetric relation *) -Defined. - -Definition directed_relation_of_relation_class: - forall dir (R: Relation_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - destruct 1. - exact (@relation_of_relation_class unit). - intros; exact (relation_of_relation_class _ X0 X). -Defined. - -Definition directed_relation_of_argument_class: - forall dir (R: Argument_Class), - carrier_of_relation_class R -> carrier_of_relation_class R -> Prop. - intros dir R. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class R). - exact (directed_relation_of_relation_class dir (relation_class_of_argument_class R)). -Defined. - - -Definition relation_of_product_of_arguments: - forall dir In, - product_of_arguments In -> product_of_arguments In -> Prop. - induction In. - simpl. - exact (directed_relation_of_argument_class (get_rewrite_direction dir a) a). - - simpl; intros. - destruct X; destruct X0. - apply and. - exact - (directed_relation_of_argument_class (get_rewrite_direction dir a) a c c0). - exact (IHIn p p0). -Defined. - -Definition apply_morphism: - forall In Out (m: function_type_of_morphism_signature In Out) - (args: product_of_arguments In), carrier_of_relation_class Out. - intros. - induction In. - exact (m args). - simpl in m, args. - destruct args. - exact (IHIn (m c) p). -Defined. - -Theorem apply_morphism_compatibility_Right2Left: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Right2Left _ args1 args2 -> - directed_relation_of_relation_class Right2Left _ - (apply_morphism _ _ m2 args1) - (apply_morphism _ _ m1 args2). - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Theorem apply_morphism_compatibility_Left2Right: - forall In Out (m1 m2: function_type_of_morphism_signature In Out) - (args1 args2: product_of_arguments In), - make_compatibility_goal_aux _ _ m1 m2 -> - relation_of_product_of_arguments Left2Right _ args1 args2 -> - directed_relation_of_relation_class Left2Right _ - (apply_morphism _ _ m1 args1) - (apply_morphism _ _ m2 args2). -Proof. - induction In; intros. - simpl in m1, m2, args1, args2, H0 |- *. - destruct a; simpl in H; hnf in H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - apply H; exact H0. - destruct v; simpl in H0; apply H; exact H0. - rewrite H0; apply H; exact H0. - - simpl in m1, m2, args1, args2, H0 |- *. - destruct args1; destruct args2; simpl. - destruct H0. - simpl in H. - destruct a; simpl in H. - apply IHIn. - apply H; exact H0. - exact H1. - destruct v. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - apply H; exact H0. - exact H1. - apply IHIn. - destruct v; simpl in H, H0; apply H; exact H0. - exact H1. - rewrite H0; apply IHIn. - apply H. - exact H1. -Qed. - -Definition interp : - forall Hole dir Out dir', carrier_of_relation_class Hole -> - Morphism_Context Hole dir Out dir' -> carrier_of_relation_class Out. - intros Hole dir Out dir' H t. - elim t using - (@Morphism_Context_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -(* CSC: interp and interp_relation_class_list should be mutually defined, since - the proof term of each one contains the proof term of the other one. However - I cannot do that interactively (I should write the Fix by hand) *) -Definition interp_relation_class_list : - forall Hole dir dir' (L: Arguments), carrier_of_relation_class Hole -> - Morphism_Context_List Hole dir dir' L -> product_of_arguments L. - intros Hole dir dir' L H t. - elim t using - (@Morphism_Context_List_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S) - (fun _ L fcl => product_of_arguments L)); - intros. - exact (apply_morphism _ _ (Function m) X). - exact H. - exact c. - exact x. - simpl; - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - split. - rewrite <- - (about_carrier_of_relation_class_and_relation_class_of_argument_class S); - exact X. - exact X0. -Defined. - -Theorem setoid_rewrite: - forall Hole dir Out dir' (E1 E2: carrier_of_relation_class Hole) - (E: Morphism_Context Hole dir Out dir'), - (directed_relation_of_relation_class dir Hole E1 E2) -> - (directed_relation_of_relation_class dir' Out (interp E1 E) (interp E2 E)). -Proof. - intros. - elim E using - (@Morphism_Context_rect2 Hole dir - (fun S dir'' E => directed_relation_of_relation_class dir'' S (interp E1 E) (interp E2 E)) - (fun dir'' L fcl => - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 fcl) - (interp_relation_class_list E2 fcl))); intros. - change (directed_relation_of_relation_class dir'0 Out0 - (apply_morphism _ _ (Function m) (interp_relation_class_list E1 m0)) - (apply_morphism _ _ (Function m) (interp_relation_class_list E2 m0))). - destruct dir'0. - apply apply_morphism_compatibility_Left2Right. - exact (Compat m). - exact H0. - apply apply_morphism_compatibility_Right2Left. - exact (Compat m). - exact H0. - - exact H. - - unfold interp, Morphism_Context_rect2. - (* CSC: reflexivity used here *) - destruct S; destruct dir'0; simpl; (apply r || reflexivity). - - destruct dir'0; exact r. - - destruct S; unfold directed_relation_of_argument_class; simpl in H0 |- *; - unfold get_rewrite_direction; simpl. - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; - (exact H0 || - unfold directed_relation_of_argument_class; simpl; apply s; exact H0). - (* the following mess with generalize/clear/intros is to help Coq resolving *) - (* second order unification problems. *) - generalize m c H0; clear H0 m c; inversion c; - generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros; - (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3). - destruct dir'0; destruct dir''; (exact H0 || hnf; symmetry; exact H0). - - change - (directed_relation_of_argument_class (get_rewrite_direction dir'' S) S - (eq_rect _ (fun T : Type => T) (interp E1 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) - (eq_rect _ (fun T : Type => T) (interp E2 m) _ - (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) /\ - relation_of_product_of_arguments dir'' _ - (interp_relation_class_list E1 m0) (interp_relation_class_list E2 m0)). - split. - clear m0 H1; destruct S; simpl in H0 |- *; unfold get_rewrite_direction; simpl. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0). - inversion c. - rewrite <- H3; exact H0. - rewrite (opposite_direction_idempotent dir'0); exact H0. - destruct dir''; destruct dir'0; (exact H0 || hnf; symmetry; exact H0). - exact H1. - Qed. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 4c560c6b..228a882a 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 10999 2008-05-27 15:55:22Z letouzey $ i*) +(*i $Id: Zdiv.v 11477 2008-10-20 15:16:14Z letouzey $ i*) (* Contribution by Claude MarchĂ© and Xavier Urbain *) @@ -901,66 +901,63 @@ Proof. intros; rewrite Zmult_mod, Zmod_mod, <- Zmult_mod; auto. Qed. -(** For a specific number n, equality modulo n is hence a nice setoid - equivalence, compatible with the usual operations. Due to restrictions - with Coq setoids, we cannot state this in a section, but it works - at least with a module. *) +(** For a specific number N, equality modulo N is hence a nice setoid + equivalence, compatible with [+], [-] and [*]. *) -Module Type SomeNumber. - Parameter n:Z. -End SomeNumber. +Definition eqm N a b := (a mod N = b mod N). -Module EqualityModulo (M:SomeNumber). +Lemma eqm_refl N : forall a, (eqm N) a a. +Proof. unfold eqm; auto. Qed. - Definition eqm a b := (a mod M.n = b mod M.n). - Infix "==" := eqm (at level 70). +Lemma eqm_sym N : forall a b, (eqm N) a b -> (eqm N) b a. +Proof. unfold eqm; auto. Qed. - Lemma eqm_refl : forall a, a == a. - Proof. unfold eqm; auto. Qed. +Lemma eqm_trans N : forall a b c, + (eqm N) a b -> (eqm N) b c -> (eqm N) a c. +Proof. unfold eqm; eauto with *. Qed. - Lemma eqm_sym : forall a b, a == b -> b == a. - Proof. unfold eqm; auto. Qed. +Add Parametric Relation N : Z (eqm N) + reflexivity proved by (eqm_refl N) + symmetry proved by (eqm_sym N) + transitivity proved by (eqm_trans N) as eqm_setoid. - Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. - Proof. unfold eqm; eauto with *. Qed. - - Add Relation Z eqm - reflexivity proved by eqm_refl - symmetry proved by eqm_sym - transitivity proved by eqm_trans as eqm_setoid. - - Add Morphism Zplus : Zplus_eqm. - Proof. +Add Parametric Morphism N : Zplus + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zplus_eqm. +Proof. unfold eqm; intros; rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. - Qed. +Qed. - Add Morphism Zminus : Zminus_eqm. - Proof. +Add Parametric Morphism N : Zminus + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zminus_eqm. +Proof. unfold eqm; intros; rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. - Qed. +Qed. - Add Morphism Zmult : Zmult_eqm. - Proof. +Add Parametric Morphism N : Zmult + with signature (eqm N) ==> (eqm N) ==> (eqm N) as Zmult_eqm. +Proof. unfold eqm; intros; rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. - Qed. +Qed. - Add Morphism Zopp : Zopp_eqm. - Proof. - intros; change (-x == -y) with (0-x == 0-y). +Add Parametric Morphism N : Zopp + with signature (eqm N) ==> (eqm N) as Zopp_eqm. +Proof. + intros; change ((eqm N) (-x) (-y)) with ((eqm N) (0-x) (0-y)). rewrite H; red; auto. - Qed. - - Lemma Zmod_eqm : forall a, a mod M.n == a. - Proof. - unfold eqm; intros; apply Zmod_mod. - Qed. +Qed. - (* Zmod and Zdiv are not full morphisms with respect to eqm. - For instance, take n=2. Then 3 == 1 but we don't have - 1 mod 3 == 1 mod 1 nor 1/3 == 1/1. - *) +Lemma Zmod_eqm N : forall a, (eqm N) (a mod N) a. +Proof. + intros; exact (Zmod_mod a N). +Qed. -End EqualityModulo. +(* NB: Zmod and Zdiv are not morphisms with respect to eqm. + For instance, let (==) be (eqm 2). Then we have (3 == 1) but: + ~ (3 mod 3 == 1 mod 3) + ~ (1 mod 3 == 1 mod 1) + ~ (3/3 == 1/3) + ~ (1/3 == 1/1) +*) Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 726fb45a..ffc3e70f 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 9302 2006-10-27 21:21:17Z barras $ i*) +(*i $Id: auxiliary.v 11739 2009-01-02 19:33:19Z herbelin $ i*) (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *) @@ -91,46 +91,6 @@ Proof. rewrite Zplus_opp_r; trivial. Qed. -(**********************************************************************) -(** * Factorization lemmas *) - -Theorem Zred_factor0 : forall n:Z, n = n * 1. - intro x; rewrite (Zmult_1_r x); reflexivity. -Qed. - -Theorem Zred_factor1 : forall n:Z, n + n = n * 2. -Proof. - exact Zplus_diag_eq_mult_2. -Qed. - -Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). -Proof. - intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; trivial with arith. -Qed. - -Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). -Proof. - intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; - trivial with arith. -Qed. - -Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). -Proof. - intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. -Qed. - -Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. -Proof. - intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. -Qed. - -Theorem Zred_factor6 : forall n:Z, n = n + 0. -Proof. - intro; rewrite Zplus_0_r; trivial with arith. -Qed. - Theorem Zle_mult_approx : forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p. Proof. |