diff options
Diffstat (limited to 'test-suite/success')
222 files changed, 20867 insertions, 0 deletions
diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v new file mode 100644 index 0000000000..d52a853aae --- /dev/null +++ b/test-suite/success/Abstract.v @@ -0,0 +1,26 @@ +(* Cf BZ#546 *) + +Require Import Omega. + +Section S. + +Variables n m : nat. +Variable H : n<m. + +Inductive Dummy : nat -> Set := +| Dummy0 : Dummy 0 +| Dummy2 : Dummy 2 +| DummyApp : forall i j, Dummy i -> Dummy j -> Dummy (i+j). + +Definition Bug : Dummy (2*n). +Proof. +induction n. + simpl ; apply Dummy0. + replace (2 * S n0) with (2*n0 + 2) ; auto with arith. + apply DummyApp. + 2:exact Dummy2. + apply IHn0 ; abstract omega. +Defined. + +End S. + diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v new file mode 100644 index 0000000000..563339739e --- /dev/null +++ b/test-suite/success/AdvancedCanonicalStructure.v @@ -0,0 +1,150 @@ +Require Import TestSuite.admit. +Section group_morphism. + +(* An example with default canonical structures *) + +Variable A B : Type. +Variable plusA : A -> A -> A. +Variable plusB : B -> B -> B. +Variable zeroA : A. +Variable zeroB : B. +Variable eqA : A -> A -> Prop. +Variable eqB : B -> B -> Prop. +Variable phi : A -> B. + +Record img := { + ia : A; + ib :> B; + prf : phi ia = ib +}. + +Parameter eq_img : forall (i1:img) (i2:img), + eqB (ib i1) (ib i2) -> eqA (ia i1) (ia i2). + +Lemma phi_img (a:A) : img. + exists a (phi a). + refine ( refl_equal _). +Defined. +Canonical Structure phi_img. + +Lemma zero_img : img. + exists zeroA zeroB. + admit. +Defined. +Canonical Structure zero_img. + +Lemma plus_img : img -> img -> img. +intros i1 i2. +exists (plusA (ia i1) (ia i2)) (plusB (ib i1) (ib i2)). +admit. +Defined. +Canonical Structure plus_img. + +(* Print Canonical Projections. *) + +Goal forall a1 a2, eqA (plusA a1 zeroA) a2. + intros a1 a2. + refine (eq_img _ _ _). +change (eqB (plusB (phi a1) zeroB) (phi a2)). +Admitted. + +Variable foo : A -> Type. + +Definition local0 := fun (a1 : A) (a2 : A) (a3 : A) => + (eq_refl : plusA a1 (plusA zeroA a2) = ia _). +Definition local1 := + fun (a1 : A) (a2 : A) (f : A -> A) => + (eq_refl : plusA a1 (plusA zeroA (f a2)) = ia _). + +Definition local2 := + fun (a1 : A) (f : A -> A) => + (eq_refl : (f a1) = ia _). + +Goal forall a1 a2, eqA (plusA a1 zeroA) a2. + intros a1 a2. + refine (eq_img _ _ _). +change (eqB (plusB (phi a1) zeroB) (phi a2)). +Admitted. + +End group_morphism. + +Open Scope type_scope. + +Section type_reification. + +Inductive term :Type := + Fun : term -> term -> term + | Prod : term -> term -> term + | Bool : term + | SET :term + | PROP :term + | TYPE :term + | Var : Type -> term. + +Fixpoint interp (t:term) := + match t with + Bool => bool + | SET => Set + | PROP => Prop + | TYPE => Type + | Fun a b => interp a -> interp b + | Prod a b => interp a * interp b + | Var x => x +end. + +Record interp_pair :Type := + { repr:>term; + abs:>Type; + link: abs = interp repr }. + +Lemma prod_interp :forall (a b:interp_pair),a * b = interp (Prod a b) . +Proof. +intros a b. +change (a * b = interp a * interp b). +rewrite (link a), (link b); reflexivity. +Qed. + +Lemma fun_interp :forall (a b:interp_pair), (a -> b) = interp (Fun a b). +Proof. +intros a b. +change ((a -> b) = (interp a -> interp b)). +rewrite (link a), (link b); reflexivity. +Qed. + +Canonical Structure ProdCan (a b:interp_pair) := + Build_interp_pair (Prod a b) (a * b) (prod_interp a b). + +Canonical Structure FunCan (a b:interp_pair) := + Build_interp_pair (Fun a b) (a -> b) (fun_interp a b). + +Canonical Structure BoolCan := + Build_interp_pair Bool bool (refl_equal _). + +Canonical Structure VarCan (x:Type) := + Build_interp_pair (Var x) x (refl_equal _). + +Canonical Structure SetCan := + Build_interp_pair SET Set (refl_equal _). + +Canonical Structure PropCan := + Build_interp_pair PROP Prop (refl_equal _). + +Canonical Structure TypeCan := + Build_interp_pair TYPE Type (refl_equal _). + +(* Print Canonical Projections. *) + +Variable A:Type. + +Variable Inhabited: term -> Prop. + +Variable Inhabited_correct: forall p, Inhabited (repr p) -> abs p. + +Lemma L : Prop * A -> bool * (Type -> Set) . +refine (Inhabited_correct _ _). +change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))). +Admitted. + +Check L : abs _ . + +End type_reification. diff --git a/test-suite/success/AdvancedTypeClasses.v b/test-suite/success/AdvancedTypeClasses.v new file mode 100644 index 0000000000..d0aa5c8578 --- /dev/null +++ b/test-suite/success/AdvancedTypeClasses.v @@ -0,0 +1,78 @@ +Generalizable All Variables. + +Open Scope type_scope. + +Section type_reification. + +Inductive term :Type := + Fun : term -> term -> term + | Prod : term -> term -> term + | Bool : term + | SET :term + | PROP :term + | TYPE :term + | Var : Type -> term. + +Fixpoint interp (t:term) := + match t with + Bool => bool + | SET => Set + | PROP => Prop + | TYPE => Type + | Fun a b => interp a -> interp b + | Prod a b => interp a * interp b + | Var x => x +end. + +Class interp_pair (abs : Type) := + { repr : term; + link: abs = interp repr }. + +Arguments repr _ {interp_pair}. +Arguments link _ {interp_pair}. + +Lemma prod_interp `{interp_pair a, interp_pair b} : a * b = interp (Prod (repr a) (repr b)). + simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity. +Qed. + +Lemma fun_interp :forall `{interp_pair a, interp_pair b}, (a -> b) = interp (Fun (repr a) (repr b)). + simpl. intros. rewrite <- link. rewrite <- (link b). reflexivity. +Qed. + +Coercion repr : interp_pair >-> term. + +Definition abs `{interp_pair a} : Type := a. +Coercion abs : interp_pair >-> Sortclass. + +Lemma fun_interp' :forall `{ia : interp_pair, ib : interp_pair}, (ia -> ib) = interp (Fun ia ib). + simpl. intros a ia b ib. rewrite <- link. rewrite <- (link b). reflexivity. +Qed. + +Instance ProdCan `(interp_pair a, interp_pair b) : interp_pair (a * b) := + { repr := Prod (repr a) (repr b) ; link := prod_interp }. + +Instance FunCan `(interp_pair a, interp_pair b) : interp_pair (a -> b) := + { link := fun_interp }. + +Instance BoolCan : interp_pair bool := + { repr := Bool ; link := refl_equal _ }. + +Instance VarCan x : interp_pair x | 10 := { repr := Var x ; link := refl_equal _ }. +Instance SetCan : interp_pair Set := { repr := SET ; link := refl_equal _ }. +Instance PropCan : interp_pair Prop := { repr := PROP ; link := refl_equal _ }. +Instance TypeCan : interp_pair Type := { repr := TYPE ; link := refl_equal _ }. + +(* Print Canonical Projections. *) + +Variable A:Type. + +Variable Inhabited: term -> Prop. + +Variable Inhabited_correct: forall `{interp_pair p}, Inhabited (repr p) -> p. + +Lemma L : Prop * A -> bool * (Type -> Set) . +apply (Inhabited_correct _ _). +change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))). +Admitted. + +End type_reification. diff --git a/test-suite/success/BracketsWithGoalSelector.v b/test-suite/success/BracketsWithGoalSelector.v new file mode 100644 index 0000000000..2f7425bce6 --- /dev/null +++ b/test-suite/success/BracketsWithGoalSelector.v @@ -0,0 +1,25 @@ +Goal forall A B, B \/ A -> A \/ B. +Proof. + intros * [HB | HA]. + 2: { + left. + exact HA. + Fail right. (* No such goal. Try unfocusing with "}". *) + } + Fail 2: { (* Non-existent goal. *) + idtac. (* The idtac is to get a dot, so that IDEs know to stop there. *) + 1:{ (* Syntactic test: no space before bracket. *) + right. + exact HB. +Fail Qed. + } +Qed. + +Lemma foo (n: nat) (P : nat -> Prop): + P n. +Proof. + intros. + refine (nat_ind _ ?[Base] ?[Step] _). + [Base]: { admit. } + [Step]: { admit. } +Abort. diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v new file mode 100644 index 0000000000..b8cae47196 --- /dev/null +++ b/test-suite/success/CanonicalStructure.v @@ -0,0 +1,31 @@ +(* Bug #1172 *) + +Structure foo : Type := Foo { + A : Set; Aopt := option A; unopt : Aopt -> A +}. + +Canonical Structure unopt_nat := @Foo nat (fun _ => O). + +(* Granted wish #1187 *) + +Record Silly (X : Set) : Set := mkSilly { x : X }. +Definition anotherMk := mkSilly. +Definition struct := anotherMk nat 3. +Canonical Structure struct. + +(* Intertwinning canonical structures and delta-expansion *) +(* Assia's short example *) + +Open Scope bool_scope. + +Set Implicit Arguments. + +Structure test_struct : Type := mk_test {dom :> Type; f : dom -> dom -> bool}. + +Notation " x != y":= (f _ x y)(at level 10). + +Canonical Structure bool_test := mk_test (fun x y => x || y). + +Definition b := bool. + +Check (fun x : b => x != x). diff --git a/test-suite/success/Case1.v b/test-suite/success/Case1.v new file mode 100644 index 0000000000..ea9b654def --- /dev/null +++ b/test-suite/success/Case1.v @@ -0,0 +1,15 @@ +(* Testing eta-expansion of elimination predicate *) + +Section NATIND2. +Variable P : nat -> Type. +Variable H0 : P 0. +Variable H1 : P 1. +Variable H2 : forall n : nat, P n -> P (S (S n)). +Fixpoint nat_ind2 (n : nat) : P n := + match n as x return (P x) with + | O => H0 + | S O => H1 + | S (S n) => H2 n (nat_ind2 n) + end. +End NATIND2. + diff --git a/test-suite/success/Case10.v b/test-suite/success/Case10.v new file mode 100644 index 0000000000..378859e98c --- /dev/null +++ b/test-suite/success/Case10.v @@ -0,0 +1,28 @@ +(* ============================================== *) +(* To test compilation of dependent case *) +(* Multiple Patterns *) +(* ============================================== *) +Inductive skel : Type := + | PROP : skel + | PROD : skel -> skel -> skel. + +Parameter Can : skel -> Type. +Parameter default_can : forall s : skel, Can s. + + +Type + (fun s1 s2 : skel => + match s1, s2 return (Can s1) with + | PROP, PROP => default_can PROP + | s1, _ => default_can s1 + end). + + +Type + (fun s1 s2 : skel => + match s1, s2 return (Can s1) with + | PROP, PROP => default_can PROP + | PROP as s, _ => default_can s + | PROD s1 s2 as s, PROP => default_can s + | PROD s1 s2 as s, _ => default_can s + end). diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v new file mode 100644 index 0000000000..fbe909ec41 --- /dev/null +++ b/test-suite/success/Case11.v @@ -0,0 +1,13 @@ +(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *) +(* Problème rapporté par Solange Coupet *) + +Section A. + +Variables (Alpha : Set) (Beta : Set). + +Definition nodep_prod_of_dep (c : sigT (fun a : Alpha => Beta)) : + Alpha * Beta := match c with + | existT _ a b => (a, b) + end. + +End A. diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v new file mode 100644 index 0000000000..55e17facce --- /dev/null +++ b/test-suite/success/Case12.v @@ -0,0 +1,73 @@ +(* This example was proposed by Cuihtlauac ALVARADO *) + +Require Import List. + +Fixpoint mult2 (n : nat) : nat := + match n with + | O => 0 + | S n => S (S (mult2 n)) + end. + +Inductive list : nat -> Set := + | nil : list 0 + | cons : forall n : nat, list (mult2 n) -> list (S (S (mult2 n))). + +Type + (fun (P : forall n : nat, list n -> Prop) (f : P 0 nil) + (f0 : forall (n : nat) (l : list (mult2 n)), + P (mult2 n) l -> P (S (S (mult2 n))) (cons n l)) => + fix F (n : nat) (l : list n) {struct l} : P n l := + match l as x0 in (list x) return (P x x0) with + | nil => f + | cons n0 l0 => f0 n0 l0 (F (mult2 n0) l0) + end). + +Inductive list' : nat -> Set := + | nil' : list' 0 + | cons' : forall n : nat, let m := mult2 n in list' m -> list' (S (S m)). + +Fixpoint length n (l : list' n) {struct l} : nat := + match l with + | nil' => 0 + | cons' _ m l0 => S (length m l0) + end. + +Type + (fun (P : forall n : nat, list' n -> Prop) (f : P 0 nil') + (f0 : forall n : nat, + let m := mult2 n in + forall l : list' m, P m l -> P (S (S m)) (cons' n l)) => + fix F (n : nat) (l : list' n) {struct l} : P n l := + match l as x0 in (list' x) return (P x x0) with + | nil' => f + | cons' n0 m l0 => f0 n0 l0 (F m l0) + end). + +(* Check on-the-fly insertion of let-in patterns for compatibility *) + +Inductive list'' : nat -> Set := + | nil'' : list'' 0 + | cons'' : + forall n : nat, + let m := mult2 n in list'' m -> let p := S (S m) in list'' p. + +Check + (fix length n (l : list'' n) {struct l} : nat := + match l with + | nil'' => 0 + | cons'' n l0 => S (length (mult2 n) l0) + end). + +(* Check let-in in both parameters and in constructors *) + +Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set := + | nil''' : list''' A a (a,a) + | cons''' : + forall a' : A, let m := (a',a) in list''' A a m -> list''' A a (a,a). + +Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) + {struct l} : nat := + match l with + | nil''' _ _ => 0 + | @cons''' _ _ _ _ m l0 => S (length''' A a m l0) + end. diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v new file mode 100644 index 0000000000..356a67efec --- /dev/null +++ b/test-suite/success/Case13.v @@ -0,0 +1,127 @@ +(* Check coercions in patterns *) + +Inductive I : Set := + | C1 : nat -> I + | C2 : I -> I. + +Coercion C1 : nat >-> I. + +(* Coercion at the root of pattern *) +Check (fun x => match x with + | C2 n => 0 + | O => 0 + | S n => n + end). + +(* Coercion not at the root of pattern *) +Check (fun x => match x with + | C2 O => 0 + | _ => 0 + end). + +(* Unification and coercions inside patterns *) +Check + (fun x : option nat => match x with + | None => 0 + | Some O => 0 + | _ => 0 + end). + +(* Coercion up to delta-conversion, and unification *) +Coercion somenat := Some (A:=nat). +Check (fun x => match x with + | None => 0 + | O => 0 + | S n => n + end). + +(* Coercions with parameters *) +Inductive listn : nat -> Set := + | niln : listn 0 + | consn : forall n : nat, nat -> listn n -> listn (S n). + +Inductive I' : nat -> Set := + | C1' : forall n : nat, listn n -> I' n + | C2' : forall n : nat, I' n -> I' n. + +Coercion C1' : listn >-> I'. +Check (fun x : I' 0 => match x with + | C2' _ _ => 0 + | niln => 0 + | _ => 0 + end). +Check (fun x : I' 0 => match x with + | C2' _ niln => 0 + | _ => 0 + end). + +(* This one could eventually be solved, the "Fail" is just to ensure *) +(* that it does not fail with an anomaly, as it did at some time *) +Fail Check (fun x : I' 0 => match x return _ x with + | C2' _ _ => 0 + | niln => 0 + | _ => 0 + end). + +(* Check insertion of coercions around matched subterm *) + +Parameter A:Set. +Parameter f:> A -> nat. + +Inductive J : Set := D : A -> J. + +Check (fun x => match x with + | D 0 => 0 + | D _ => 1 + end). + +(* Check coercions against the type of the term to match *) +(* Used to fail in V8.1beta *) + +Inductive C : Set := c : C. +Inductive E : Set := e :> C -> E. +Check fun (x : E) => match x with c => e c end. + +(* Check coercions with uniform parameters (cf bug #1168) *) + +Inductive C' : bool -> Set := c' : C' true. +Inductive E' (b : bool) : Set := e' :> C' b -> E' b. +Check fun (x : E' true) => match x with c' => e' true c' end. + +(* Check use of the no-dependency strategy when a type constraint is + given (and when the "inversion-and-dependencies-as-evars" strategy + is not strong enough because of a constructor with a type whose + pattern structure is not refined enough for it to be captured by + the inversion predicate) *) + +Inductive K : bool -> bool -> Type := F : K true true | G x : K x x. + +Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y, P y -> Q y z) => + match y with + | F => f y H1 + | G _ => f y H2 + end : Q y z. + +(* Check use of the maximal-dependency-in-variable strategy even when + no explicit type constraint is given (and when the + "inversion-and-dependencies-as-evars" strategy is not strong enough + because of a constructor with a type whose pattern structure is not + refined enough for it to be captured by the inversion predicate) *) + +Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z) => + match y with + | F => f y true H1 + | G b => f y b H2 + end. + +(* Check use of the maximal-dependency-in-variable strategy for "Var" + variables *) + +Goal forall z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z), Q y z. +intros z P Q y H1 H2 f. +Show. +refine (match y with + | F => f y true H1 + | G b => f y b H2 + end). +Qed. diff --git a/test-suite/success/Case14.v b/test-suite/success/Case14.v new file mode 100644 index 0000000000..f106a64cb5 --- /dev/null +++ b/test-suite/success/Case14.v @@ -0,0 +1,21 @@ +(* Test of inference of elimination predicate for "if" *) +(* submitted by Robert R Schneck *) + +Axiom bad : false = true. + +Definition try1 : False := + match bad in (_ = b) return (if b then False else True) with + | refl_equal => I + end. + +Definition try2 : False := + match bad in (_ = b) return ((if b then False else True):Prop) with + | refl_equal => I + end. + +Definition try3 : False := + match + bad in (_ = b) return ((fun b' : bool => if b' then False else True) b) + with + | refl_equal => I + end. diff --git a/test-suite/success/Case15.v b/test-suite/success/Case15.v new file mode 100644 index 0000000000..69fca48e24 --- /dev/null +++ b/test-suite/success/Case15.v @@ -0,0 +1,51 @@ +(* Check compilation of multiple pattern-matching on terms non + apparently of inductive type *) + +(* Check that the non dependency in y is OK both in V7 and V8 *) +Check + (fun x (y : Prop) z => + match x, y, z return (x = x \/ z = z) with + | O, y, z' => or_introl (z' = z') (refl_equal 0) + | _, y, O => or_intror _ (refl_equal 0) + | x, y, _ => or_introl _ (refl_equal x) + end). + +(* Suggested by Pierre Letouzey (PR#207) *) +Inductive Boite : Set := + boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. + +Definition test (B : Boite) := + match B return nat with + | boite true n => n + | boite false (n, m) => n + m + end. + +(* Check lazyness of compilation ... future work +Inductive I : Set := c : (b:bool)(if b then bool else nat)->I. + +Check [x] + Cases x of + (c (true as y) (true as x)) => (if x then y else true) + | (c false O) => true | _ => false + end. + +Check [x] + Cases x of + (c true true) => true + | (c false O) => true + | _ => false + end. + +(* Devrait produire ceci mais trouver le type intermediaire est coton ! *) +Check + [x:I] + Cases x of + (c b y) => + (<[b:bool](if b then bool else nat)->bool>if b + then [y](if y then true else false) + else [y]Cases y of + O => true + | (S _) => false + end y) + end. +*) diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v new file mode 100644 index 0000000000..ce9a0ecb4a --- /dev/null +++ b/test-suite/success/Case16.v @@ -0,0 +1,10 @@ +(**********************************************************************) +(* Test dependencies in constructors *) +(**********************************************************************) + +Check + (fun x : {b : bool | if b then True else False} => + match x return (let (b, _) := x in if b then True else False) with + | exist _ true y => y + | exist _ false z => z + end). diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v new file mode 100644 index 0000000000..a4efcca945 --- /dev/null +++ b/test-suite/success/Case17.v @@ -0,0 +1,50 @@ +(* Check the synthesis of predicate from a cast in case of matching of + the first component (here [list bool]) of a dependent type (here [sigT]) + (Simplification of an example from file parsing2.v of the Coq'Art + exercises) *) + +Require Import List. + +Variable parse_rel : list bool -> list bool -> nat -> Prop. + +Variables (l0 : list bool) + (rec : + forall l' : list bool, + length l' <= S (length l0) -> + {l'' : list bool & + {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}). + +Axiom HHH : forall A : Prop, A. + +Check + (match rec l0 (HHH _) with + | inleft (existT _ (false :: l1) _) => inright _ (HHH _) + | inleft (existT _ (true :: l1) (exist _ t1 (conj Hp Hl))) => + inright _ (HHH _) + | inleft (existT _ _ _) => inright _ (HHH _) + | inright Hnp => inright _ (HHH _) + end + :{l'' : list bool & + {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). + +(* The same but with relative links to l0 and rec *) + +Check + (fun (l0 : list bool) + (rec : forall l' : list bool, + length l' <= S (length l0) -> + {l'' : list bool & + {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) => + match rec l0 (HHH _) with + | inleft (existT _ (false :: l1) _) => inright _ (HHH _) + | inleft (existT _ (true :: l1) (exist _ t1 (conj Hp Hl))) => + inright _ (HHH _) + | inleft (existT _ _ _) => inright _ (HHH _) + | inright Hnp => inright _ (HHH _) + end + :{l'' : list bool & + {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). diff --git a/test-suite/success/Case18.v b/test-suite/success/Case18.v new file mode 100644 index 0000000000..be9ca8d41b --- /dev/null +++ b/test-suite/success/Case18.v @@ -0,0 +1,26 @@ +(* Check or-patterns *) + +Definition g x := + match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end. + +Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)). + +Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)). + +Fixpoint max (n m:nat) {struct m} : nat := + match n, m with + | S n', S m' => S (max n' m') + | 0, p | p, 0 => p + end. + +(* Check bug #1477 *) + +Inductive I : Set := + | A : nat -> nat -> I + | B : nat -> nat -> I. + +Definition foo (x:I) : nat := + match x with + | A a b | B b a => S b + end. + diff --git a/test-suite/success/Case19.v b/test-suite/success/Case19.v new file mode 100644 index 0000000000..ce98879a5f --- /dev/null +++ b/test-suite/success/Case19.v @@ -0,0 +1,38 @@ +(* This used to fail in Coq version 8.1 beta due to a non variable + universe (issued by template polymorphism) being sent by + pretyping to the kernel (bug #1182) *) + +Variable T : Type. +Variable x : nat*nat. + +Check let (_, _) := x in sigT (fun _ : T => nat). + +(* This used to raise an anomaly in V8.4, up to pl2 *) + +Goal {x: nat & x=x}. +Fail exists (fun x => + match + projT2 (projT2 x) as e in (_ = y) + return _ = existT _ (projT1 x) (existT _ y e) + with + | eq_refl => eq_refl + end). +Abort. + +(* Some tests with ltac matching on building "if" and "let" *) + +Goal forall b c d, (if negb b then c else d) = 0. +intros. +match goal with +|- (if ?b then ?c else ?d) = 0 => transitivity (if b then d else c) +end. +Abort. + +Definition swap {A} {B} '((x,y):A*B) := (y,x). + +Goal forall p, (let '(x,y) := swap p in x + y) = 0. +intros. +match goal with +|- (let '(x,y) := ?p in x + y) = 0 => transitivity (let (x,y) := p in x+y) +end. +Abort. diff --git a/test-suite/success/Case2.v b/test-suite/success/Case2.v new file mode 100644 index 0000000000..db43369503 --- /dev/null +++ b/test-suite/success/Case2.v @@ -0,0 +1,12 @@ +(* ============================================== *) +(* To test compilation of dependent case *) +(* Nested patterns *) +(* ============================================== *) + +Type + match 0 as n return (n = n) with + | O => refl_equal 0 + | m => refl_equal m + end. + + diff --git a/test-suite/success/Case20.v b/test-suite/success/Case20.v new file mode 100644 index 0000000000..67eebf7238 --- /dev/null +++ b/test-suite/success/Case20.v @@ -0,0 +1,35 @@ +(* Example taken from RelationAlgebra *) +(* Was failing from r16205 up to now *) + +Require Import BinNums. + +Section A. + +Context (A:Type) {X: A} (tst:A->Type) (top:forall X, X). + +Inductive v: (positive -> A) -> Type := +| v_L: forall f', v f' +| v_N: forall f', + v (fun n => f' (xO n)) -> + (positive -> tst (f' xH)) -> + v (fun n => f' (xI n)) -> v f'. + +Fixpoint v_add f' (t: v f') n: (positive -> tst (f' n)) -> v f' := + match t in (v o) return ((positive -> (tst (o n))) -> v o) with + | v_L f' => + match n return ((positive -> (tst (f' n))) -> v f') with + | xH => fun x => v_N _ (v_L _) x (v_L _) + | xO n => fun x => v_N _ + (v_add (fun n => f' (xO n)) (v_L _) n x) (fun _ => top _) (v_L _) + | xI n => fun x => v_N _ + (v_L _) (fun _ => top _) (v_add (fun n => f' (xI n)) (v_L _) n x) + end + | v_N f' l y r => + match n with + | xH => fun x => v_N _ l x r + | xO n => fun x => v_N _ (v_add (fun n => f' (xO n)) l n x) y r + | xI n => fun x => v_N _ l y (v_add (fun n => f' (xI n)) r n x) + end + end. + +End A. diff --git a/test-suite/success/Case21.v b/test-suite/success/Case21.v new file mode 100644 index 0000000000..db91eb402e --- /dev/null +++ b/test-suite/success/Case21.v @@ -0,0 +1,15 @@ +(* Check insertion of impossible case when there is no branch at all *) + +Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. + +Check fun H:eq_true false => match H with end : False. + +Inductive I : bool -> bool -> Prop := C : I true true. + +Check fun x (H:I x false) => match H with end : False. + +Check fun x (H:I false x) => match H with end : False. + +Inductive I' : bool -> Type := C1 : I' true | C2 : I' true. + +Check fun x : I' false => match x with end : False. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v new file mode 100644 index 0000000000..465b3eb8c0 --- /dev/null +++ b/test-suite/success/Case22.v @@ -0,0 +1,91 @@ +(* Check typing in the presence of let-in in inductive arity *) + +Inductive I : let a := 1 in a=a -> let b := 2 in Type := C : I (eq_refl). +Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => eq_refl end = eq_refl. +intro. +match goal with |- ?c => let x := eval cbv in c in change x end. +Abort. + +Check forall x:I eq_refl, match x in I x return x = x with C => eq_refl end = eq_refl. + +(* This is bug #3210 *) + +Inductive I' : let X := Set in X := +| C' : I'. + +Definition foo (x : I') : bool := + match x with + C' => true + end. + +(* Bug found in november 2015: was wrongly failing in 8.5beta2 and 8.5beta3 *) + +Inductive I2 (A:Type) : let B:=A in forall C, let D:=(C*B)%type in Type := + E2 : I2 A nat. + +Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with + E2 _ => (0,0,(0,0)) + end. + +(* This used to succeed in 8.3, 8.4 and 8.5beta1 *) + +Inductive IND : forall X:Type, let Y:=X in Type := + CONSTR : IND True. + +Definition F (x:IND True) (A:Type) := + (* This failed in 8.5beta2 though it should have been accepted *) + match x in IND X Y return Y with + CONSTR => Logic.I + end. + +Theorem paradox : False. + (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) +Fail Proof (F C False). +Abort. + +(* Another bug found in November 2015 (a substitution was wrongly + reversed at pretyping level) *) + +Inductive Ind (A:Type) : + let X:=A in forall Y:Type, let Z:=(X*Y)%type in Type := + Constr : Ind A nat. + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | Constr _ => (true,0) + end. + +(* A vm_compute bug (the type of constructors was not supposed to + contain local definitions before proper parameters) *) + +Inductive Ind2 (b:=1) (c:nat) : Type := + Constr2 : Ind2 c. + +Eval vm_compute in Constr2 2. + +(* A bug introduced in ade2363 (similar to #5322 and #5324). This + commit started to see that some List.rev was wrong in the "var" + case of a pattern-matching problem but it failed to see that a + transformation from a list of arguments into a substitution was + still needed. *) + +(* The order of real arguments was made wrong by ade2363 in the "var" + case of the compilation of "match" *) + +Inductive IND2 : forall X Y:Type, Type := + CONSTR2 : IND2 unit Empty_set. + +Check fun x:IND2 bool nat => + match x in IND2 a b return a with + | y => _ + end = true. + +(* From January 2017, using the proper function to turn arguments into + a substitution up to a context possibly containing let-ins, so that + the following, which was wrong also before ade2363, now works + correctly *) + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | y => (true,0) + end. diff --git a/test-suite/success/Case3.v b/test-suite/success/Case3.v new file mode 100644 index 0000000000..de7784aec5 --- /dev/null +++ b/test-suite/success/Case3.v @@ -0,0 +1,29 @@ +Inductive Le : nat -> nat -> Set := + | LeO : forall n : nat, Le 0 n + | LeS : forall n m : nat, Le n m -> Le (S n) (S m). + +Parameter discr_l : forall n : nat, S n <> 0. + +Type + (fun n : nat => + match n return (n = 0 \/ n <> 0) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S O => or_intror (1 = 0) (discr_l 0) + | S (S x) => or_intror (S (S x) = 0) (discr_l (S x)) + end). + +Parameter iguales : forall (n m : nat) (h : Le n m), Prop. + +Type + match LeO 0 as h in (Le n m) return Prop with + | LeO O => True + | LeS (S x) (S y) H => iguales (S x) (S y) H + | _ => False + end. + +Type + match LeO 0 as h in (Le n m) return Prop with + | LeO O => True + | LeS (S x) O H => iguales (S x) 0 H + | _ => False + end. diff --git a/test-suite/success/Case5.v b/test-suite/success/Case5.v new file mode 100644 index 0000000000..833621d2b3 --- /dev/null +++ b/test-suite/success/Case5.v @@ -0,0 +1,13 @@ + +Parameter ff : forall n m : nat, n <> m -> S n <> S m. +Parameter discr_r : forall n : nat, 0 <> S n. +Parameter discr_l : forall n : nat, S n <> 0. + + +Type + (fun n : nat => + match n return (n = 0 \/ n <> 0) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S O => or_intror (1 = 0) (discr_l 0) + | S (S x) => or_intror (S (S x) = 0) (discr_l (S x)) + end). diff --git a/test-suite/success/Case6.v b/test-suite/success/Case6.v new file mode 100644 index 0000000000..cc1994e7af --- /dev/null +++ b/test-suite/success/Case6.v @@ -0,0 +1,15 @@ +Parameter ff : forall n m : nat, n <> m -> S n <> S m. +Parameter discr_r : forall n : nat, 0 <> S n. +Parameter discr_l : forall n : nat, S n <> 0. + +Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := + match n, m return (n = m \/ n <> m) with + | O, O => or_introl (0 <> 0) (refl_equal 0) + | O, S x => or_intror (0 = S x) (discr_r x) + | S x, O => or_intror _ (discr_l x) + | S x as N, S y as M => + match eqdec x y return (N = M \/ N <> M) with + | or_introl h => or_introl (N <> M) (f_equal S h) + | or_intror h => or_intror (N = M) (ff x y h) + end + end. diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v new file mode 100644 index 0000000000..f95598aadb --- /dev/null +++ b/test-suite/success/Case7.v @@ -0,0 +1,17 @@ +Inductive List (A : Set) : Set := + | Nil : List A + | Cons : A -> List A -> List A. + +Inductive Empty (A : Set) : List A -> Prop := + intro_Empty : Empty A (Nil A). + +Parameter + inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x). + + +Type + (fun (A : Set) (l : List A) => + match l return (Empty A l \/ ~ Empty A l) with + | Nil _ => or_introl (~ Empty A (Nil A)) (intro_Empty A) + | Cons _ a y as b => or_intror (Empty A b) (inv_Empty A a y) + end). diff --git a/test-suite/success/Case8.v b/test-suite/success/Case8.v new file mode 100644 index 0000000000..a6113ab9a1 --- /dev/null +++ b/test-suite/success/Case8.v @@ -0,0 +1,11 @@ +(* Check dependencies in the matching predicate (was failing in V8.0pl1) *) + +Inductive t : forall x : 0 = 0, x = x -> Prop := + c : forall x : 0 = 0, t x (refl_equal x). + +Definition a (x : t _ (refl_equal (refl_equal 0))) := + match x return match x with + | c y => Prop + end with + | c y => y = y + end. diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v new file mode 100644 index 0000000000..e34e5b9baa --- /dev/null +++ b/test-suite/success/Case9.v @@ -0,0 +1,61 @@ +Inductive List (A : Set) : Set := + | Nil : List A + | Cons : A -> List A -> List A. + +Inductive eqlong : List nat -> List nat -> Prop := + | eql_cons : + forall (n m : nat) (x y : List nat), + eqlong x y -> eqlong (Cons nat n x) (Cons nat m y) + | eql_nil : eqlong (Nil nat) (Nil nat). + + +Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat). +Parameter + V2 : + forall (a : nat) (x : List nat), + eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x). +Parameter + V3 : + forall (a : nat) (x : List nat), + eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat). +Parameter + V4 : + forall (a : nat) (x : List nat) (b : nat) (y : List nat), + eqlong (Cons nat a x) (Cons nat b y) \/ + ~ eqlong (Cons nat a x) (Cons nat b y). + +Parameter + nff : + forall (n m : nat) (x y : List nat), + ~ eqlong x y -> ~ eqlong (Cons nat n x) (Cons nat m y). +Parameter + inv_r : forall (n : nat) (x : List nat), ~ eqlong (Nil nat) (Cons nat n x). +Parameter + inv_l : forall (n : nat) (x : List nat), ~ eqlong (Cons nat n x) (Nil nat). + +Fixpoint eqlongdec (x y : List nat) {struct x} : + eqlong x y \/ ~ eqlong x y := + match x, y return (eqlong x y \/ ~ eqlong x y) with + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => + match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with + | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) + | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) + end + end. + + +Type + match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with + | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil + | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x) + | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x) + | Cons _ a x as L1, Cons _ b y as L2 => + match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with + | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h) + | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h) + end + end. + diff --git a/test-suite/success/CaseAlias.v b/test-suite/success/CaseAlias.v new file mode 100644 index 0000000000..a92490862f --- /dev/null +++ b/test-suite/success/CaseAlias.v @@ -0,0 +1,91 @@ +(*********************************************) +(* This has been a bug reported by Y. Bertot *) +Inductive expr : Set := + | b : expr -> expr -> expr + | u : expr -> expr + | a : expr + | var : nat -> expr. + +Fixpoint f (t : expr) : expr := + match t with + | b t1 t2 => b (f t1) (f t2) + | a => a + | x => b t a + end. + +Fixpoint f2 (t : expr) : expr := + match t with + | b t1 t2 => b (f2 t1) (f2 t2) + | a => a + | x => b x a + end. + +(*********************************************) +(* Test expansion of aliases *) +(* Originally taken from NMake_gen.v *) + + Local Notation SizePlus n := (S (S (S (S (S (S n)))))). + Local Notation Size := (SizePlus O). + + Parameter zn2z : Type -> Type. + Parameter w0 : Type. + Fixpoint word (w : Type) (n : nat) {struct n} : Type := + match n with + | 0 => w + | S n0 => zn2z (word w n0) + end. + + Definition w1 := zn2z w0. + Definition w2 := zn2z w1. + Definition w3 := zn2z w2. + Definition w4 := zn2z w3. + Definition w5 := zn2z w4. + Definition w6 := zn2z w5. + + Definition dom_t n := match n with + | 0 => w0 + | 1 => w1 + | 2 => w2 + | 3 => w3 + | 4 => w4 + | 5 => w5 + | 6 => w6 + | SizePlus n => word w6 n + end. +Parameter plus_t : forall n m : nat, word (dom_t n) m -> dom_t (m + n). + +(* This used to fail because of a bug in expansion of SizePlus wrongly + reusing n as an alias for the subpattern *) +Definition plus_t1 n : forall m, word (dom_t n) m -> dom_t (m+n) := + match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with + | SizePlus (S n') as n => plus_t n + | _ as n => + fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with + | SizePlus (S (S m')) as m => plus_t n m + | _ => fun x => x + end + end. + +(* Test (useless) intermediate alias *) +Definition plus_t2 n : forall m, word (dom_t n) m -> dom_t (m+n) := + match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with + | S (S (S (S (S (S (S n'))))) as n) as n'' => plus_t n'' + | _ as n => + fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with + | SizePlus (S (S m')) as m => plus_t n m + | _ => fun x => x + end + end. + +(*****************************************************************************) +(* Check that alias expansion behaves consistently from versions to versions *) + +Definition g m := + match pred m with + | 0 => 0 + | n => n (* For compatibility, right-hand side should be (S n), not (pred m) *) + end. + +Goal forall m, g m = match pred m with 0 => 0 | S n => S n end. +intro; reflexivity. +Abort. diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v new file mode 100644 index 0000000000..ca93c8ea79 --- /dev/null +++ b/test-suite/success/CaseInClause.v @@ -0,0 +1,30 @@ +(* in clause pattern *) +Require Vector. +Check (fun n (x: Vector.t True (S n)) => + match x in Vector.t _ (S m) return True with + |Vector.cons _ h _ _ => h + end). + +(* Notation *) +Import Vector.VectorNotations. +Notation "A \dots n" := (Vector.t A n) (at level 200). +Check (fun m (x: Vector.t nat m) => + match x in _ \dots k return Vector.t nat (S k) with + | Vector.nil _ => 0 :: [] + | Vector.cons _ h _ t => h :: h :: t + end). + +(* N should be a variable and not the inductiveRef *) +Require Import NArith. +Theorem foo : forall (n m : nat) (pf : n = m), + match pf in _ = N with + | eq_refl => unit + end. +Abort. + +(* Check redundant clause is removed *) +Inductive I : nat * nat -> Type := C : I (0,0). +Check fun x : I (1,1) => match x in I (y,z) return y = z with C => eq_refl end. + +(* An example of non-local inference of the type of an impossible case *) +Check (fun y n (x:Vector.t nat (S n)) => match x with a::_ => a | _ => y end) 2. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v new file mode 100644 index 0000000000..52fe98ac07 --- /dev/null +++ b/test-suite/success/Cases.v @@ -0,0 +1,1875 @@ +(****************************************************************************) +(* Pattern-matching when non inductive terms occur *) + +(* Dependent form of annotation *) +Type match 0 as n, @eq return nat with + | O, x => 0 + | S x, y => x + end. +Type match 0, 0, @eq return nat with + | O, x, y => 0 + | S x, y, z => x + end. +Type match 0, @eq, 0 return _ with + | O, x, y => 0 + | S x, y, z => x + end. + +(* Non dependent form of annotation *) +Type match 0, @eq return nat with + | O, x => 0 + | S x, y => x + end. + +(* Combining dependencies and non inductive arguments *) +Type + (fun (A : Set) (a : A) (H : 0 = 0) => + match H in (_ = x), a return (H = H) with + | _, _ => refl_equal H + end). + +(* Interaction with coercions *) +Parameter bool2nat : bool -> nat. +Coercion bool2nat : bool >-> nat. +Definition foo : nat -> nat := + fun x => match x with + | O => true + | S _ => 0 + end. + +(****************************************************************************) +(* All remaining examples come from Cristina Cornes' V6 TESTS/MultCases.v *) + +Inductive IFExpr : Set := + | Var : nat -> IFExpr + | Tr : IFExpr + | Fa : IFExpr + | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr. + +Inductive List (A : Set) : Set := + | Nil : List A + | Cons : A -> List A -> List A. + +Inductive listn : nat -> Set := + | niln : listn 0 + | consn : forall n : nat, nat -> listn n -> listn (S n). + +Inductive Listn (A : Set) : nat -> Set := + | Niln : Listn A 0 + | Consn : forall n : nat, nat -> Listn A n -> Listn A (S n). + +Inductive Le : nat -> nat -> Set := + | LeO : forall n : nat, Le 0 n + | LeS : forall n m : nat, Le n m -> Le (S n) (S m). + +Inductive LE (n : nat) : nat -> Set := + | LE_n : LE n n + | LE_S : forall m : nat, LE n m -> LE n (S m). + +Require Import Bool. + + + +Inductive PropForm : Set := + | Fvar : nat -> PropForm + | Or : PropForm -> PropForm -> PropForm. + +Section testIFExpr. +Definition Assign := nat -> bool. +Parameter Prop_sem : Assign -> PropForm -> bool. + +Type + (fun (A : Assign) (F : PropForm) => + match F return bool with + | Fvar n => A n + | Or F G => Prop_sem A F || Prop_sem A G + end). + +Type + (fun (A : Assign) (H : PropForm) => + match H return bool with + | Fvar n => A n + | Or F G => Prop_sem A F || Prop_sem A G + end). +End testIFExpr. + + + +Type (fun x : nat => match x return nat with + | O => 0 + | x => x + end). + +Module Type testlist. +Parameter A : Set. +Inductive list : Set := + | nil : list + | cons : A -> list -> list. +Parameter inf : A -> A -> Prop. + + +Definition list_Lowert2 (a : A) (l : list) := + match l return Prop with + | nil => True + | cons b l => inf a b + end. + +Definition titi (a : A) (l : list) := + match l return list with + | nil => l + | cons b l => l + end. +End testlist. + + +(* To test translation *) +(* ------------------- *) + + +Type match 0 return nat with + | O => 0 + | _ => 0 + end. + +Type match 0 return nat with + | O as b => b + | S O => 0 + | S (S x) => x + end. + +Type match 0 with + | O as b => b + | S O => 0 + | S (S x) => x + end. + + +Type (fun x : nat => match x return nat with + | O as b => b + | S x => x + end). + +Type (fun x : nat => match x with + | O as b => b + | S x => x + end). + +Type match 0 return nat with + | O as b => b + | S x => x + end. + +Type match 0 return nat with + | x => x + end. + +Type match 0 with + | x => x + end. + +Type match 0 return nat with + | O => 0 + | S x as b => b + end. + +Type (fun x : nat => match x return nat with + | O => 0 + | S x as b => b + end). + +Type (fun x : nat => match x with + | O => 0 + | S x as b => b + end). + + +Type match 0 return nat with + | O => 0 + | S x => 0 + end. + + +Type match 0 return (nat * nat) with + | O => (0, 0) + | S x => (x, 0) + end. + +Type match 0 with + | O => (0, 0) + | S x => (x, 0) + end. + +Type + match 0 return (nat -> nat) with + | O => fun n : nat => 0 + | S x => fun n : nat => 0 + end. + +Type match 0 with + | O => fun n : nat => 0 + | S x => fun n : nat => 0 + end. + + +Type + match 0 return (nat -> nat) with + | O => fun n : nat => 0 + | S x => fun n : nat => x + n + end. + +Type match 0 with + | O => fun n : nat => 0 + | S x => fun n : nat => x + n + end. + + +Type match 0 return nat with + | O => 0 + | S x as b => b + x + end. + +Type match 0 return nat with + | O => 0 + | S a as b => b + a + end. +Type match 0 with + | O => 0 + | S a as b => b + a + end. + + +Type match 0 with + | O => 0 + | _ => 0 + end. + +Type match 0 return nat with + | O => 0 + | x => x + end. + +Type match 0, 1 return nat with + | x, y => x + y + end. + +Type match 0, 1 with + | x, y => x + y + end. + +Type match 0, 1 return nat with + | O, y => y + | S x, y => x + y + end. + +Type match 0, 1 with + | O, y => y + | S x, y => x + y + end. + + +Type match 0, 1 return nat with + | O, x => x + | S y, O => y + | x, y => x + y + end. + + + + +Type match 0, 1 with + | O, x => x + 0 + | S y, O => y + 0 + | x, y => x + y + end. + +Type + match 0, 1 return nat with + | O, x => x + 0 + | S y, O => y + 0 + | x, y => x + y + end. + + +Type + match 0, 1 return nat with + | O, x => x + | S x as b, S y => b + x + y + | x, y => x + y + end. + + +Type + match 0, 1 with + | O, x => x + | S x as b, S y => b + x + y + | x, y => x + y + end. + + +Type + (fun l : List nat => + match l return (List nat) with + | Nil _ => Nil nat + | Cons _ a l => l + end). + +Type (fun l : List nat => match l with + | Nil _ => Nil nat + | Cons _ a l => l + end). + +Type match Nil nat return nat with + | Nil _ => 0 + | Cons _ a l => S a + end. +Type match Nil nat with + | Nil _ => 0 + | Cons _ a l => S a + end. + +Type match Nil nat return (List nat) with + | Cons _ a l => l + | x => x + end. + +Type match Nil nat with + | Cons _ a l => l + | x => x + end. + +Type + match Nil nat return (List nat) with + | Nil _ => Nil nat + | Cons _ a l => l + end. + +Type match Nil nat with + | Nil _ => Nil nat + | Cons _ a l => l + end. + + +Type + match 0 return nat with + | O => 0 + | S x => match Nil nat return nat with + | Nil _ => x + | Cons _ a l => x + a + end + end. + +Type + match 0 with + | O => 0 + | S x => match Nil nat with + | Nil _ => x + | Cons _ a l => x + a + end + end. + +Type + (fun y : nat => + match y with + | O => 0 + | S x => match Nil nat with + | Nil _ => x + | Cons _ a l => x + a + end + end). + + +Type + match 0, Nil nat return nat with + | O, x => 0 + | S x, Nil _ => x + | S x, Cons _ a l => x + a + end. + + + +Type + (fun (n : nat) (l : listn n) => + match l return nat with + | niln => 0 + | x => 0 + end). + +Type (fun (n : nat) (l : listn n) => match l with + | niln => 0 + | x => 0 + end). + + +Type match niln return nat with + | niln => 0 + | x => 0 + end. + +Type match niln with + | niln => 0 + | x => 0 + end. + +Type match niln return nat with + | niln => 0 + | consn n a l => a + end. +Type match niln with + | niln => 0 + | consn n a l => a + end. + + +Type + match niln in (listn n) return nat with + | consn m _ niln => m + | _ => 1 + end. + + + +Type + (fun (n x : nat) (l : listn n) => + match x, l return nat with + | O, niln => 0 + | y, x => 0 + end). + +Type match 0, niln return nat with + | O, niln => 0 + | y, x => 0 + end. + + +Type match niln, 0 return nat with + | niln, O => 0 + | y, x => 0 + end. + +Type match niln, 0 with + | niln, O => 0 + | y, x => 0 + end. + +Type match niln, niln return nat with + | niln, niln => 0 + | x, y => 0 + end. + +Type match niln, niln with + | niln, niln => 0 + | x, y => 0 + end. + +Type + match niln, niln, niln return nat with + | niln, niln, niln => 0 + | x, y, z => 0 + end. + + +Type match niln, niln, niln with + | niln, niln, niln => 0 + | x, y, z => 0 + end. + + + +Type match niln return nat with + | niln => 0 + | consn n a l => 0 + end. + +Type match niln with + | niln => 0 + | consn n a l => 0 + end. + + +Type + match niln, niln return nat with + | niln, niln => 0 + | niln, consn n a l => n + | consn n a l, x => a + end. + + +Type + match niln, niln with + | niln, niln => 0 + | niln, consn n a l => n + | consn n a l, x => a + end. + + +Type + (fun (n : nat) (l : listn n) => + match l return nat with + | niln => 0 + | x => 0 + end). + +Type + (fun (c : nat) (s : bool) => + match c, s return nat with + | O, _ => 0 + | _, _ => c + end). + +Type + (fun (c : nat) (s : bool) => + match c, s return nat with + | O, _ => 0 + | S _, _ => c + end). + + +(* Rows of pattern variables: some tricky cases *) +Axioms (P : nat -> Prop) (f : forall n : nat, P n). + +Type + (fun i : nat => + match true, i as n return (P n) with + | true, k => f k + | _, k => f k + end). + +Type + (fun i : nat => + match i as n, true return (P n) with + | k, true => f k + | k, _ => f k + end). + +(* Nested Cases: the SYNTH of the Cases on n used to make Multcase believe + * it has to synthesize the predicate on O (which he can't) + *) +Type + match 0 as n return match n with + | O => bool + | S _ => nat + end with + | O => true + | S _ => 0 + end. + +Type (fun (n : nat) (l : listn n) => match l with + | niln => 0 + | x => 0 + end). + +Type + (fun (n : nat) (l : listn n) => + match l return nat with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end). + + +Type + (fun (n : nat) (l : listn n) => + match l with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end). + + + +Type + (fun (n : nat) (l : listn n) => + match l return nat with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end). + +Type + (fun (n : nat) (l : listn n) => + match l with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end). + + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l return nat with + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l with + | Niln _ => 0 + | Consn _ n a (Niln _) => 0 + | Consn _ n a (Consn _ m b l) => n + m + end). + +Type + (fun (A:Set) (n:nat) (l:Listn A n) => + match l return Listn A O with + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) + end). + +(* +Type + (fun (A:Set) (n:nat) (l:Listn A n) => + match l with + | Niln _ as b => b + | Consn _ n a (Niln _ as b) => (Niln A) + | Consn _ n a (Consn _ m b l) => (Niln A) + end). +*) + +Type + (fun (A:Set) (n:nat) (l:Listn A n) => + match l return Listn A (S 0) with + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) + end). + +Type + (fun (A:Set) (n:nat) (l:Listn A n) => + match l return Listn A (S 0) with + | Niln _ as b => Consn A O O b + | Consn _ n a (Niln _) as L => L + | Consn _ n a _ => Consn A O O (Niln A) + end). + +(* To test treatment of as-patterns in depth *) +Type + (fun (A : Set) (l : List A) => + match l with + | Nil _ as b => Nil A + | Cons _ a (Nil _) as L => L + | Cons _ a (Cons _ b m) as L => L + end). + + +Type + (fun (n : nat) (l : listn n) => + match l return (listn n) with + | niln => l + | consn n a c => l + end). +Type + (fun (n : nat) (l : listn n) => + match l with + | niln => l + | consn n a c => l + end). + + +Type + (fun (n : nat) (l : listn n) => + match l return (listn n) with + | niln as b => l + | _ => l + end). + + +Type + (fun (n : nat) (l : listn n) => match l with + | niln as b => l + | _ => l + end). + +Type + (fun (n : nat) (l : listn n) => + match l return (listn n) with + | niln as b => l + | x => l + end). + + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l with + | Niln _ as b => l + | _ => l + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l return (Listn A n) with + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l with + | Niln _ => l + | Consn _ n a (Niln _) => l + | Consn _ n a (Consn _ m b c) => l + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l return (Listn A n) with + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l with + | Niln _ as b => l + | Consn _ n a (Niln _ as b) => l + | Consn _ n a (Consn _ m b _) => l + end). + + +Type + match niln return nat with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end. + + +Type + match niln with + | niln => 0 + | consn n a niln => 0 + | consn n a (consn m b l) => n + m + end. + +Type match LeO 0 return nat with + | LeO x => x + | LeS n m h => n + m + end. + + +Type match LeO 0 with + | LeO x => x + | LeS n m h => n + m + end. + +Type + (fun (n : nat) (l : Listn nat n) => + match l return nat with + | Niln _ => 0 + | Consn _ n a l => 0 + end). + + +Type + (fun (n : nat) (l : Listn nat n) => + match l with + | Niln _ => 0 + | Consn _ n a l => 0 + end). + + +Type match Niln nat with + | Niln _ => 0 + | Consn _ n a l => 0 + end. + +Type match LE_n 0 return nat with + | LE_n _ => 0 + | LE_S _ m h => 0 + end. + + +Type match LE_n 0 with + | LE_n _ => 0 + | LE_S _ m h => 0 + end. + + + +Type match LE_n 0 with + | LE_n _ => 0 + | LE_S _ m h => 0 + end. + + + +Type + match niln return nat with + | niln => 0 + | consn n a niln => n + | consn n a (consn m b l) => n + m + end. + +Type + match niln with + | niln => 0 + | consn n a niln => n + | consn n a (consn m b l) => n + m + end. + + +Type + match Niln nat return nat with + | Niln _ => 0 + | Consn _ n a (Niln _ +) => n + | Consn _ n a (Consn _ m b l) => n + m + end. + +Type + match Niln nat with + | Niln _ => 0 + | Consn _ n a (Niln _) => n + | Consn _ n a (Consn _ m b l) => n + m + end. + + +Type + match LeO 0 return nat with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + x + end. + + +Type + match LeO 0 with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + x + end. + + +Type + match LeO 0 return nat with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => m + end. + +Type + match LeO 0 with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => m + end. + + +Type + (fun (n m : nat) (h : Le n m) => + match h return nat with + | LeO x => x + | x => 0 + end). + +Type (fun (n m : nat) (h : Le n m) => match h with + | LeO x => x + | x => 0 + end). + + +Type + (fun (n m : nat) (h : Le n m) => + match h return nat with + | LeS n m h => n + | x => 0 + end). + + +Type + (fun (n m : nat) (h : Le n m) => match h with + | LeS n m h => n + | x => 0 + end). + + +Type + (fun (n m : nat) (h : Le n m) => + match h return (nat * nat) with + | LeO n => (0, n) + | LeS n m _ => (S n, S m) + end). + + +Type + (fun (n m : nat) (h : Le n m) => + match h with + | LeO n => (0, n) + | LeS n m _ => (S n, S m) + end). + +Module Type F_v1. +Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := + match h in (Le n m) return (Le n (S m)) with + | LeO m' => LeO (S m') + | LeS n' m' h' => LeS n' (S m') (F n' m' h') + end. +End F_v1. + +Module Type F_v2. +Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := + match h in (Le n m) return (Le n (S m)) with + | LeS n m h => LeS n (S m) (F n m h) + | LeO m => LeO (S m) + end. +End F_v2. + +(* Rend la longueur de la liste *) + +Module Type L1. +Definition length (n : nat) (l : listn n) := + match l return nat with + | consn n _ (consn m _ _) => S (S m) + | consn n _ _ => 1 + | _ => 0 + end. +End L1. + +Module Type L1'. +Definition length (n : nat) (l : listn n) := + match l with + | consn n _ (consn m _ _) => S (S m) + | consn n _ _ => 1 + | _ => 0 + end. +End L1'. + +Module Type L2. +Definition length (n : nat) (l : listn n) := + match l return nat with + | consn n _ (consn m _ _) => S (S m) + | consn n _ _ => S n + | _ => 0 + end. +End L2. + +Module Type L2'. +Definition length (n : nat) (l : listn n) := + match l with + | consn n _ (consn m _ _) => S (S m) + | consn n _ _ => S n + | _ => 0 + end. +End L2'. + +Module Type L3. +Definition length (n : nat) (l : listn n) := + match l return nat with + | consn n _ (consn m _ l) => S n + | consn n _ _ => 1 + | _ => 0 + end. +End L3. + +Module Type L3'. +Definition length (n : nat) (l : listn n) := + match l with + | consn n _ (consn m _ l) => S n + | consn n _ _ => 1 + | _ => 0 + end. +End L3'. + +Type match LeO 0 return nat with + | LeS n m h => n + m + | x => 0 + end. +Type match LeO 0 with + | LeS n m h => n + m + | x => 0 + end. + +Type + (fun (n m : nat) (h : Le n m) => + match h return nat with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + (m + (x + y)) + end). + + +Type + (fun (n m : nat) (h : Le n m) => + match h with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + (m + (x + y)) + end). + +Type + match LeO 0 return nat with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + (m + (x + y)) + end. + +Type + match LeO 0 with + | LeO x => x + | LeS n m (LeO x) => x + m + | LeS n m (LeS x y h) => n + (m + (x + y)) + end. + + +Type + match LE_n 0 return nat with + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m + end. + + +Type + match LE_n 0 with + | LE_n _ => 0 + | LE_S _ m (LE_n _) => 0 + m + | LE_S _ m (LE_S _ y h) => 0 + m + end. + + +Type (fun (n m : nat) (h : Le n m) => match h with + | x => x + end). + +Type + (fun (n m : nat) (h : Le n m) => + match h return nat with + | LeO n => n + | x => 0 + end). +Type (fun (n m : nat) (h : Le n m) => match h with + | LeO n => n + | x => 0 + end). + + +Type + (fun n : nat => + match niln return (nat -> nat) with + | niln => fun _ : nat => 0 + | consn n a niln => fun _ : nat => 0 + | consn n a (consn m b l) => fun _ : nat => n + m + end). + + +Type + (fun n : nat => + match niln with + | niln => fun _ : nat => 0 + | consn n a niln => fun _ : nat => 0 + | consn n a (consn m b l) => fun _ : nat => n + m + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l return (nat -> nat) with + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m + end). + +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l with + | Niln _ => fun _ : nat => 0 + | Consn _ n a (Niln _) => fun _ : nat => n + | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m + end). + +(* Also tests for multiple _ patterns *) +Type + (fun (A : Set) (n : nat) (l : Listn A n) => + match l in (Listn _ n) return (Listn A n) with + | Niln _ as b => b + | Consn _ _ _ _ as b => b + end). + +(** This one was said to raised once an "Horrible error message!" *) + +Type + (fun (A:Set) (n:nat) (l:Listn A n) => + match l with + | Niln _ as b => b + | Consn _ _ _ _ as b => b + end). + +Type + match niln in (listn n) return (listn n) with + | niln as b => b + | consn _ _ _ as b => b + end. + + +Type + match niln in (listn n) return (listn n) with + | niln as b => b + | x => x + end. + +Type + (fun (n m : nat) (h : LE n m) => + match h return (nat -> nat) with + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y + end). +Type + (fun (n m : nat) (h : LE n m) => + match h with + | LE_n _ => fun _ : nat => n + | LE_S _ m (LE_n _) => fun _ : nat => n + m + | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y + end). + + +Type + (fun (n m : nat) (h : LE n m) => + match h return nat with + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') + end). + + + +Type + (fun (n m : nat) (h : LE n m) => + match h with + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y + | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y') + end). + + +Type + (fun (n m : nat) (h : LE n m) => + match h return nat with + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y + end). + + +Type + (fun (n m : nat) (h : LE n m) => + match h with + | LE_n _ => n + | LE_S _ m (LE_n _) => n + m + | LE_S _ m (LE_S _ y h) => n + m + y + end). + +Type + (fun n m : nat => + match LeO 0 return nat with + | LeS n m h => n + m + | x => 0 + end). + +Type (fun n m : nat => match LeO 0 with + | LeS n m h => n + m + | x => 0 + end). + +Parameter test : forall n : nat, {0 <= n} + {False}. +Type (fun n : nat => match test n return nat with + | left _ => 0 + | _ => 0 + end). + + +Type (fun n : nat => match test n return nat with + | left _ => 0 + | _ => 0 + end). + +Type (fun n : nat => match test n with + | left _ => 0 + | _ => 0 + end). + +Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. +Type + match compare 0 0 return nat with + + (* k<i *) | inleft (left _) => 0 + (* k=i *) | inleft _ => 0 + (* k>i *) | inright _ => 0 + end. + +Type + match compare 0 0 with + + (* k<i *) | inleft (left _) => 0 + (* k=i *) | inleft _ => 0 + (* k>i *) | inright _ => 0 + end. + + + +CoInductive SStream (A : Set) : (nat -> A -> Prop) -> Type := + scons : + forall (P : nat -> A -> Prop) (a : A), + P 0 a -> SStream A (fun n : nat => P (S n)) -> SStream A P. +Parameter B : Set. + +Type + (fun (P : nat -> B -> Prop) (x : SStream B P) => + match x return B with + | scons _ _ a _ _ => a + end). + + +Type + (fun (P : nat -> B -> Prop) (x : SStream B P) => + match x with + | scons _ _ a _ _ => a + end). + +Type match (0, 0) return (nat * nat) with + | (x, y) => (S x, S y) + end. +Type match (0, 0) return (nat * nat) with + | (b, y) => (S b, S y) + end. +Type match (0, 0) return (nat * nat) with + | (x, y) => (S x, S y) + end. + +Type match (0, 0) with + | (x, y) => (S x, S y) + end. +Type match (0, 0) with + | (b, y) => (S b, S y) + end. +Type match (0, 0) with + | (x, y) => (S x, S y) + end. + +Module Type test_concat. + +Parameter concat : forall A : Set, List A -> List A -> List A. + +Type + match Nil nat, Nil nat return (List nat) with + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c + | _, _ => Nil nat + end. +Type + match Nil nat, Nil nat with + | Nil _ as b, x => concat nat b x + | Cons _ _ _ as d, Nil _ as c => concat nat d c + | _, _ => Nil nat + end. + +End test_concat. + +Inductive redexes : Set := + | VAR : nat -> redexes + | Fun : redexes -> redexes + | Ap : bool -> redexes -> redexes -> redexes. + +Fixpoint regular (U : redexes) : Prop := + match U return Prop with + | VAR n => True + | Fun V => regular V + | Ap true (Fun _ as V) W => regular V /\ regular W + | Ap true _ W => False + | Ap false V W => regular V /\ regular W + end. + + +Type (fun n : nat => match n with + | O => 0 + | S (S n as V) => V + | _ => 0 + end). + +Parameter + concat : + forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m). +Type + (fun (n : nat) (l : listn n) (m : nat) (l' : listn m) => + match l in (listn n), l' return (listn (n + m)) with + | niln, x => x + | consn n a l'', x => consn (n + m) a (concat n l'' m x) + end). + +Type + (fun (x y z : nat) (H : x = y) (H0 : y = z) => + match H return (x = z) with + | refl_equal => + match H0 in (_ = n) return (x = n) with + | refl_equal => H + end + end). + +Type (fun h : False => match h return False with + end). + +Type (fun h : False => match h return True with + end). + +Definition is_zero (n : nat) := match n with + | O => True + | _ => False + end. + +Type + (fun (n : nat) (h : 0 = S n) => + match h in (_ = n) return (is_zero n) with + | refl_equal => I + end). + +Definition disc (n : nat) (h : 0 = S n) : False := + match h in (_ = n) return (is_zero n) with + | refl_equal => I + end. + +Definition nlength3 (n : nat) (l : listn n) := + match l with + | niln => 0 + | consn O _ _ => 1 + | consn (S n) _ _ => S (S n) + end. + +(* == Testing strategy elimintation predicate synthesis == *) +Section titi. +Variable h : False. +Type match 0 with + | O => 0 + | _ => except h + end. +End titi. + +Type match niln with + | consn _ a niln => a + | consn n _ x => 0 + | niln => 0 + end. + + + +Inductive wsort : Set := + | ws : wsort + | wt : wsort. +Inductive TS : wsort -> Set := + | id : TS ws + | lift : TS ws -> TS ws. + +Type + (fun (b : wsort) (M N : TS b) => + match M, N with + | lift M1, id => False + | _, _ => True + end). + + + +(* ===================================================================== *) +(* To test pattern matching over a non-dependent inductive type, but *) +(* having constructors with some arguments that depend on others *) +(* I.e. to test manipulation of elimination predicate *) +(* ===================================================================== *) + +Module Type test_term. + +Parameter LTERM : nat -> Set. +Inductive TERM : Type := + | var : TERM + | oper : forall op : nat, LTERM op -> TERM. + +Parameter t1 t2 : TERM. + +Type + match t1, t2 with + | var, var => True + | oper op1 l1, oper op2 l2 => False + | _, _ => False + end. + +End test_term. + + + +Require Import Peano_dec. +Parameter n : nat. +Definition eq_prf := exists m : _, n = m. +Parameter p : eq_prf. + +Type + match p with + | ex_intro _ c eqc => + match eq_nat_dec c n with + | right _ => refl_equal n + | left y => (* c=n*) refl_equal n + end + end. + + +Parameter ordre_total : nat -> nat -> Prop. + +Parameter N_cla : forall N : nat, {N = 0} + {N = 1} + {N >= 2}. + +Parameter + exist_U2 : + forall N : nat, + N >= 2 -> + {n : nat | + forall m : nat, 0 < m /\ m <= N /\ ordre_total n m /\ 0 < n /\ n < N}. + +Type + (fun N : nat => + match N_cla N with + | inright H => match exist_U2 N H with + | exist _ a b => a + end + | _ => 0 + end). + + + +(* ============================================== *) +(* To test compilation of dependent case *) +(* Nested patterns *) +(* ============================================== *) + +(* == To test that terms named with AS are correctly absolutized before + substitution in rhs == *) + +Type + (fun n : nat => + match n return nat with + | O => 0 + | S O => 0 + | S (S n1) as N => N + end). + +(* ========= *) + +Type + match niln in (listn n) return Prop with + | niln => True + | consn (S O) _ _ => False + | _ => True + end. + +Type + match niln in (listn n) return Prop with + | niln => True + | consn (S (S O)) _ _ => False + | _ => True + end. + + +Type + match LeO 0 as h in (Le n m) return nat with + | LeO _ => 0 + | LeS (S x) _ _ => x + | _ => 1 + end. + +Type + match LeO 0 as h in (Le n m) return nat with + | LeO _ => 0 + | LeS (S x) (S y) _ => x + | _ => 1 + end. + +Type + match LeO 0 as h in (Le n m) return nat with + | LeO _ => 0 + | LeS (S x as b) (S y) _ => b + | _ => 1 + end. + + +Module Type ff. + +Parameter ff : forall n m : nat, n <> m -> S n <> S m. +Parameter discr_r : forall n : nat, 0 <> S n. +Parameter discr_l : forall n : nat, S n <> 0. + +Type + (fun n : nat => + match n return (n = 0 \/ n <> 0) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S x => or_intror (S x = 0) (discr_l x) + end). + +Module Type eqdec. + +Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := + match n, m return (n = m \/ n <> m) with + | O, O => or_introl (0 <> 0) (refl_equal 0) + | O, S x => or_intror (0 = S x) (discr_r x) + | S x, O => or_intror _ (discr_l x) + | S x, S y => + match eqdec x y return (S x = S y \/ S x <> S y) with + | or_introl h => or_introl (S x <> S y) (f_equal S h) + | or_intror h => or_intror (S x = S y) (ff x y h) + end + end. + +End eqdec. + +Module Type eqdec'. + +Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := + match n return (forall m : nat, n = m \/ n <> m) with + | O => + fun m : nat => + match m return (0 = m \/ 0 <> m) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S x => or_intror (0 = S x) (discr_r x) + end + | S x => + fun m : nat => + match m return (S x = m \/ S x <> m) with + | O => or_intror (S x = 0) (discr_l x) + | S y => + match eqdec x y return (S x = S y \/ S x <> S y) with + | or_introl h => or_introl (S x <> S y) (f_equal S h) + | or_intror h => or_intror (S x = S y) (ff x y h) + end + end + end. + +End eqdec'. + +Inductive empty : forall n : nat, listn n -> Prop := + intro_empty : empty 0 niln. + +Parameter + inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l). + +Type + (fun (n : nat) (l : listn n) => + match l in (listn n) return (empty n l \/ ~ empty n l) with + | niln => or_introl (~ empty 0 niln) intro_empty + | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) + end). + +End ff. + +Module Type ff'. + +Parameter ff : forall n m : nat, n <> m -> S n <> S m. +Parameter discr_r : forall n : nat, 0 <> S n. +Parameter discr_l : forall n : nat, S n <> 0. + +Type + (fun n : nat => + match n return (n = 0 \/ n <> 0) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S x => or_intror (S x = 0) (discr_l x) + end). + +Module Type eqdec. + +Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := + match n, m return (n = m \/ n <> m) with + | O, O => or_introl (0 <> 0) (refl_equal 0) + | O, S x => or_intror (0 = S x) (discr_r x) + | S x, O => or_intror _ (discr_l x) + | S x, S y => + match eqdec x y return (S x = S y \/ S x <> S y) with + | or_introl h => or_introl (S x <> S y) (f_equal S h) + | or_intror h => or_intror (S x = S y) (ff x y h) + end + end. + +End eqdec. + +Module Type eqdec'. + +Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := + match n return (forall m : nat, n = m \/ n <> m) with + | O => + fun m : nat => + match m return (0 = m \/ 0 <> m) with + | O => or_introl (0 <> 0) (refl_equal 0) + | S x => or_intror (0 = S x) (discr_r x) + end + | S x => + fun m : nat => + match m return (S x = m \/ S x <> m) with + | O => or_intror (S x = 0) (discr_l x) + | S y => + match eqdec x y return (S x = S y \/ S x <> S y) with + | or_introl h => or_introl (S x <> S y) (f_equal S h) + | or_intror h => or_intror (S x = S y) (ff x y h) + end + end + end. + +End eqdec'. +End ff'. + +(* ================================================== *) +(* Pour tester parametres *) +(* ================================================== *) + + +Inductive Empty (A : Set) : List A -> Prop := + intro_Empty : Empty A (Nil A). + +Parameter + inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x). + + +Type + match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with + | Nil _ => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat) + | Cons _ a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y) + end. + + +(* ================================================== *) +(* Sur les listes *) +(* ================================================== *) + + +Inductive empty : forall n : nat, listn n -> Prop := + intro_empty : empty 0 niln. + +Parameter + inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l). + +Type + (fun (n : nat) (l : listn n) => + match l in (listn n) return (empty n l \/ ~ empty n l) with + | niln => or_introl (~ empty 0 niln) intro_empty + | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) + end). + +(* ===================================== *) +(* Test parametros: *) +(* ===================================== *) + +Inductive eqlong : List nat -> List nat -> Prop := + | eql_cons : + forall (n m : nat) (x y : List nat), + eqlong x y -> eqlong (Cons nat n x) (Cons nat m y) + | eql_nil : eqlong (Nil nat) (Nil nat). + + +Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat). +Parameter + V2 : + forall (a : nat) (x : List nat), + eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x). +Parameter + V3 : + forall (a : nat) (x : List nat), + eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat). +Parameter + V4 : + forall (a : nat) (x : List nat) (b : nat) (y : List nat), + eqlong (Cons nat a x) (Cons nat b y) \/ + ~ eqlong (Cons nat a x) (Cons nat b y). + +Type + match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y + end. + + +Type + (fun x y : List nat => + match x, y return (eqlong x y \/ ~ eqlong x y) with + | Nil _, Nil _ => V1 + | Nil _, Cons _ a x => V2 a x + | Cons _ a x, Nil _ => V3 a x + | Cons _ a x, Cons _ b y => V4 a x b y + end). + + +(* ===================================== *) + +Inductive Eqlong : +forall n : nat, listn n -> forall m : nat, listn m -> Prop := + | Eql_cons : + forall (n m : nat) (x : listn n) (y : listn m) (a b : nat), + Eqlong n x m y -> Eqlong (S n) (consn n a x) (S m) (consn m b y) + | Eql_niln : Eqlong 0 niln 0 niln. + + +Parameter W1 : Eqlong 0 niln 0 niln \/ ~ Eqlong 0 niln 0 niln. +Parameter + W2 : + forall (n a : nat) (x : listn n), + Eqlong 0 niln (S n) (consn n a x) \/ ~ Eqlong 0 niln (S n) (consn n a x). +Parameter + W3 : + forall (n a : nat) (x : listn n), + Eqlong (S n) (consn n a x) 0 niln \/ ~ Eqlong (S n) (consn n a x) 0 niln. +Parameter + W4 : + forall (n a : nat) (x : listn n) (m b : nat) (y : listn m), + Eqlong (S n) (consn n a x) (S m) (consn m b y) \/ + ~ Eqlong (S n) (consn n a x) (S m) (consn m b y). + +Type + match + niln as x in (listn n), niln as y in (listn m) + return (Eqlong n x m y \/ ~ Eqlong n x m y) + with + | niln, niln => W1 + | niln, consn n a x => W2 n a x + | consn n a x, niln => W3 n a x + | consn n a x, consn m b y => W4 n a x m b y + end. + + +Type + (fun (n m : nat) (x : listn n) (y : listn m) => + match + x in (listn n), y in (listn m) + return (Eqlong n x m y \/ ~ Eqlong n x m y) + with + | niln, niln => W1 + | niln, consn n a x => W2 n a x + | consn n a x, niln => W3 n a x + | consn n a x, consn m b y => W4 n a x m b y + end). + + +Parameter + Inv_r : + forall (n a : nat) (x : listn n), ~ Eqlong 0 niln (S n) (consn n a x). +Parameter + Inv_l : + forall (n a : nat) (x : listn n), ~ Eqlong (S n) (consn n a x) 0 niln. +Parameter + Nff : + forall (n a : nat) (x : listn n) (m b : nat) (y : listn m), + ~ Eqlong n x m y -> ~ Eqlong (S n) (consn n a x) (S m) (consn m b y). + + + +Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) + (y : listn m) {struct x} : Eqlong n x m y \/ ~ Eqlong n x m y := + match + x in (listn n), y in (listn m) + return (Eqlong n x m y \/ ~ Eqlong n x m y) + with + | niln, niln => or_introl (~ Eqlong 0 niln 0 niln) Eql_niln + | niln, consn n a x as L => or_intror (Eqlong 0 niln (S n) L) (Inv_r n a x) + | consn n a x as L, niln => or_intror (Eqlong (S n) L 0 niln) (Inv_l n a x) + | consn n a x as L1, consn m b y as L2 => + match + Eqlongdec n x m y + return (Eqlong (S n) L1 (S m) L2 \/ ~ Eqlong (S n) L1 (S m) L2) + with + | or_introl h => + or_introl (~ Eqlong (S n) L1 (S m) L2) (Eql_cons n m x y a b h) + | or_intror h => + or_intror (Eqlong (S n) L1 (S m) L2) (Nff n a x m b y h) + end + end. + +(* ============================================== *) +(* To test compilation of dependent case *) +(* Multiple Patterns *) +(* ============================================== *) +Inductive skel : Type := + | PROP : skel + | PROD : skel -> skel -> skel. + +Parameter Can : skel -> Type. +Parameter default_can : forall s : skel, Can s. + +Type + (fun s1 s2 s1 s2 : skel => + match s1, s2 return (Can s1) with + | PROP, PROP => default_can PROP + | PROD x y, PROP => default_can (PROD x y) + | PROD x y, _ => default_can (PROD x y) + | PROP, _ => default_can PROP + end). + +(* to test bindings in nested Cases *) +(* ================================ *) +Inductive Pair : Set := + | pnil : Pair + | pcons : Pair -> Pair -> Pair. + +Type + (fun p q : Pair => + match p with + | pcons _ x => match q with + | pcons _ (pcons _ x) => True + | _ => False + end + | _ => False + end). + + +Type + (fun p q : Pair => + match p with + | pcons _ x => + match q with + | pcons _ (pcons _ x) => + match q with + | pcons _ (pcons _ (pcons _ x)) => x + | _ => pnil + end + | _ => pnil + end + | _ => pnil + end). + +Type + (fun (n : nat) (l : listn (S n)) => + match l in (listn z) return (listn (pred z)) with + | niln => niln + | consn n _ l => + match l in (listn m) return (listn m) with + | niln => niln + | b => b + end + end). + + + +(* Test de la syntaxe avec nombres *) +Require Import Arith. +Type (fun n => match n with + | S (S O) => true + | _ => false + end). + +Require Import ZArith. +Type (fun n => match n with + | Z0 => true + | _ => false + end). + +(* Check that types with unknown sort, as A below, are not fatal to + the pattern-matching compilation *) + +Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := + match p with eq_refl => u end. + +(* Check in-pattern clauses with constant constructors, which were + previously interpreted as variables (before 8.5) *) + +Check match eq_refl 0 in _=O return O=O with eq_refl => eq_refl end. + +Check match niln in listn O return O=O with niln => eq_refl end. + +(* A test about nested "as" clauses *) +(* (was failing up to May 2017) *) + +Check fun x => match x with (y,z) as t as w => (y+z,t) = (0,w) end. diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v new file mode 100644 index 0000000000..8d9edbd62d --- /dev/null +++ b/test-suite/success/CasesDep.v @@ -0,0 +1,572 @@ +(* Check forward dependencies *) + +Check + (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q) + x => + match x return Q with + | exist _ O H => A H + | exist _ (S n) H => B n H + end). + +(* Check dependencies in anonymous arguments (from FTA/listn.v) *) + +Inductive listn (A : Set) : nat -> Set := + | niln : listn A 0 + | consn : forall (a : A) (n : nat), listn A n -> listn A (S n). + +Section Folding. +Variable B C : Set. +Variable g : B -> C -> C. +Variable c : C. + +Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C := + match bs with + | niln _ => c + | consn _ b _ tl => g b (foldrn _ tl) + end. +End Folding. + +(** Testing post-processing of nested dependencies *) + +Check fun x:{x|x=0}*nat+nat => match x with + | inl ((exist _ 0 eq_refl),0) => None + | _ => Some 0 + end. + +Check fun x:{_:{x|x=0}|True}+nat => match x with + | inl (exist _ (exist _ 0 eq_refl) I) => None + | _ => Some 0 + end. + +Check fun x:{_:{x|x=0}|True}+nat => match x with + | inl (exist _ (exist _ 0 eq_refl) I) => None + | _ => Some 0 + end. + +Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with + | inl (exist _ (exist _ 0 eq_refl) I) => None + | _ => Some 0 + end. + + (* the next two examples were failing from r14703 (Nov 22 2011) to r14732 *) + (* due to a bug in dependencies postprocessing (revealed by CoLoR) *) + +Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with + | exist2 _ _ (x,y) eq_refl I => None + end. + +Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with + | inl (exist _ (exist2 _ _ (x,y) eq_refl I) I) => None + | _ => Some 0 + end. + +(* -------------------------------------------------------------------- *) +(* Example to test patterns matching on dependent families *) +(* This exemple extracted from the developement done by Nacira Chabane *) +(* (equipe Paris 6) *) +(* -------------------------------------------------------------------- *) + + +Require Import Prelude. +Require Import Logic_Type. + +Section Orderings. + Variable U : Type. + + Definition Relation := U -> U -> Prop. + + Variable R : Relation. + + Definition Reflexive : Prop := forall x : U, R x x. + + Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z. + + Definition Symmetric : Prop := forall x y : U, R x y -> R y x. + + Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y. + + Definition contains (R R' : Relation) : Prop := + forall x y : U, R' x y -> R x y. + Definition same_relation (R R' : Relation) : Prop := + contains R R' /\ contains R' R. +Inductive Equivalence : Prop := + Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. + + Inductive PER : Prop := + Build_PER : Symmetric -> Transitive -> PER. + +End Orderings. + +(***** Setoid *******) + +Inductive Setoid : Type := + Build_Setoid : + forall (S : Type) (R : Relation S), Equivalence _ R -> Setoid. + +Definition elem (A : Setoid) := let (S, R, e) := A in S. + +Definition equal (A : Setoid) := + let (S, R, e) as s return (Relation (elem s)) := A in R. + + +Axiom prf_equiv : forall A : Setoid, Equivalence (elem A) (equal A). +Axiom prf_refl : forall A : Setoid, Reflexive (elem A) (equal A). +Axiom prf_sym : forall A : Setoid, Symmetric (elem A) (equal A). +Axiom prf_trans : forall A : Setoid, Transitive (elem A) (equal A). + +Section Maps. +Variable A B : Setoid. + +Definition Map_law (f : elem A -> elem B) := + forall x y : elem A, equal _ x y -> equal _ (f x) (f y). + +Inductive Map : Type := + Build_Map : forall (f : elem A -> elem B) (p : Map_law f), Map. + +Definition explicit_ap (m : Map) := + match m return (elem A -> elem B) with + | Build_Map f p => f + end. + +Axiom pres : forall m : Map, Map_law (explicit_ap m). + +Definition ext (f g : Map) := + forall x : elem A, equal _ (explicit_ap f x) (explicit_ap g x). + +Axiom Equiv_map_eq : Equivalence Map ext. + +Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq. + +End Maps. + +Notation ap := (explicit_ap _ _). + +(* <Warning> : Grammar is replaced by Notation *) + + +Definition ap2 (A B C : Setoid) (f : elem (Map_setoid A (Map_setoid B C))) + (a : elem A) := ap (ap f a). + + +(***** posint ******) + +Inductive posint : Type := + | Z : posint + | Suc : posint -> posint. + +Axiom + f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y. +Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m. + +(* The predecessor function *) + +Definition pred (n : posint) : posint := + match n return posint with + | Z => (* Z *) Z + (* Suc u *) + | Suc u => u + end. + +Axiom pred_Sucn : forall m : posint, m = pred (Suc m). +Axiom eq_add_Suc : forall n m : posint, Suc n = Suc m -> n = m. +Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m. + + +Definition IsSuc (n : posint) : Prop := + match n return Prop with + | Z => (* Z *) False + (* Suc p *) + | Suc p => True + end. +Definition IsZero (n : posint) : Prop := + match n with + | Z => True + | Suc _ => False + end. + +Axiom Z_Suc : forall n : posint, Z <> Suc n. +Axiom Suc_Z : forall n : posint, Suc n <> Z. +Axiom n_Sucn : forall n : posint, n <> Suc n. +Axiom Sucn_n : forall n : posint, Suc n <> n. +Axiom eqT_symt : forall a b : posint, a <> b -> b <> a. + + +(******* Dsetoid *****) + +Definition Decidable (A : Type) (R : Relation A) := + forall x y : A, R x y \/ ~ R x y. + + +Record DSetoid : Type := + {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}. + +(* example de Dsetoide d'entiers *) + + +Axiom eqT_equiv : Equivalence posint (eq (A:=posint)). +Axiom Eq_posint_deci : Decidable posint (eq (A:=posint)). + +(* Dsetoide des posint*) + +Definition Set_of_posint := Build_Setoid posint (eq (A:=posint)) eqT_equiv. + +Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci. + + + +(**************************************) + + +(* Definition des signatures *) +(* une signature est un ensemble d'operateurs muni + de l'arite de chaque operateur *) + + +Module Sig. + +Record Signature : Type := + {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}. + +Variable S : Signature. + + + +Variable Var : DSetoid. + +Inductive TERM : Type := + | var : elem (Set_of Var) -> TERM + | oper : + forall op : elem (Set_of (Sigma S)), LTERM (ap (Arity S) op) -> TERM +with LTERM : posint -> Type := + | nil : LTERM Z + | cons : TERM -> forall n : posint, LTERM n -> LTERM (Suc n). + + + +(* -------------------------------------------------------------------- *) +(* Examples *) +(* -------------------------------------------------------------------- *) + + +Parameter t1 t2 : TERM. + +Type + match t1, t2 with + | var v1, var v2 => True + | oper op1 l1, oper op2 l2 => False + | _, _ => False + end. + + + +Parameter n2 : posint. +Parameter l1 l2 : LTERM n2. + +Type + match l1, l2 with + | nil, nil => True + | cons v m y, nil => False + | _, _ => False + end. + + +Type + match l1, l2 with + | nil, nil => True + | cons u n x, cons v m y => False + | _, _ => False + end. + +Module Type Version1. + +Definition equalT (t1 t2 : TERM) : Prop := + match t1, t2 with + | var v1, var v2 => True + | oper op1 l1, oper op2 l2 => False + | _, _ => False + end. + +Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) + (l2 : LTERM n2) : Prop := + match l1, l2 with + | nil, nil => True + | cons t1 n1' l1', cons t2 n2' l2' => False + | _, _ => False + end. + +End Version1. + + +(* ------------------------------------------------------------------*) +(* Initial exemple (without patterns) *) +(*-------------------------------------------------------------------*) + +Module Version2. + +Fixpoint equalT (t1 : TERM) : TERM -> Prop := + match t1 return (TERM -> Prop) with + | var v1 => + (*var*) + fun t2 : TERM => + match t2 return Prop with + | var v2 => + (*var*) equal _ v1 v2 + (*oper*) + | oper op2 _ => False + end + (*oper*) + | oper op1 l1 => + fun t2 : TERM => + match t2 return Prop with + | var v2 => + (*var*) False + (*oper*) + | oper op2 l2 => + equal _ op1 op2 /\ + EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 + end + end + + with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : + forall n2 : posint, LTERM n2 -> Prop := + match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with + | nil => + (*nil*) + fun (n2 : posint) (l2 : LTERM n2) => + match l2 in (LTERM _) return Prop with + | nil => + (*nil*) True + (*cons*) + | cons t2 n2' l2' => False + end + (*cons*) + | cons t1 n1' l1' => + fun (n2 : posint) (l2 : LTERM n2) => + match l2 in (LTERM _) return Prop with + | nil => + (*nil*) False + (*cons*) + | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' + end + end. + +End Version2. + +(* ---------------------------------------------------------------- *) +(* Version with simple patterns *) +(* ---------------------------------------------------------------- *) + +Module Version3. + +Fixpoint equalT (t1 : TERM) : TERM -> Prop := + match t1 with + | var v1 => + fun t2 : TERM => + match t2 with + | var v2 => equal _ v1 v2 + | oper op2 _ => False + end + | oper op1 l1 => + fun t2 : TERM => + match t2 with + | var _ => False + | oper op2 l2 => + equal _ op1 op2 /\ + EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 + end + end + + with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : + forall n2 : posint, LTERM n2 -> Prop := + match l1 return (forall n2 : posint, LTERM n2 -> Prop) with + | nil => + fun (n2 : posint) (l2 : LTERM n2) => + match l2 with + | nil => True + | _ => False + end + | cons t1 n1' l1' => + fun (n2 : posint) (l2 : LTERM n2) => + match l2 with + | nil => False + | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' + end + end. + +End Version3. + +Module Version4. + +Fixpoint equalT (t1 : TERM) : TERM -> Prop := + match t1 with + | var v1 => + fun t2 : TERM => + match t2 with + | var v2 => equal _ v1 v2 + | oper op2 _ => False + end + | oper op1 l1 => + fun t2 : TERM => + match t2 with + | var _ => False + | oper op2 l2 => + equal _ op1 op2 /\ + EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 + end + end + + with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) + (l2 : LTERM n2) {struct l1} : Prop := + match l1 with + | nil => match l2 with + | nil => True + | _ => False + end + | cons t1 n1' l1' => + match l2 with + | nil => False + | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2' + end + end. + +End Version4. + +(* ---------------------------------------------------------------- *) +(* Version with multiple patterns *) +(* ---------------------------------------------------------------- *) + +Module Version5. + +Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop := + match t1, t2 with + | var v1, var v2 => equal _ v1 v2 + | oper op1 l1, oper op2 l2 => + equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 + | _, _ => False + end + + with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) + (l2 : LTERM n2) {struct l1} : Prop := + match l1, l2 with + | nil, nil => True + | cons t1 n1' l1', cons t2 n2' l2' => + equalT t1 t2 /\ EqListT n1' l1' n2' l2' + | _, _ => False + end. + +End Version5. + +(* ------------------------------------------------------------------ *) + +End Sig. + +(* Exemple soumis par Bruno *) + +Definition bProp (b : bool) : Prop := if b then True else False. + +Definition f0 (F : False) (ty : bool) : bProp ty := + match ty as _, ty return (bProp ty) with + | true, true => I + | _, false => F + | _, true => I + end. + +(* Simplification of bug/wish #1671 *) + +Inductive I : unit -> Type := +| C : forall a, I a -> I tt. + +(* +Definition F (l:I tt) : l = l := +match l return l = l with +| C tt (C _ l') => refl_equal (C tt (C _ l')) +end. + +one would expect that the compilation of F (this involves +some kind of pattern-unification) would produce: +*) + +Definition F (l:I tt) : l = l := +match l return l = l with +| C tt l' => match l' return C _ l' = C _ l' with C _ l'' => refl_equal (C tt (C _ l'')) end +end. + +Inductive J : nat -> Type := +| D : forall a, J (S a) -> J a. + +(* +Definition G (l:J O) : l = l := +match l return l = l with +| D O (D 1 l') => refl_equal (D O (D 1 l')) +| D _ _ => refl_equal _ +end. + +one would expect that the compilation of G (this involves inversion) +would produce: +*) + +Definition G (l:J O) : l = l := +match l return l = l with +| D 0 l'' => + match l'' as _l'' in J n return + match n return forall l:J n, Prop with + | O => fun _ => l = l + | S p => fun l'' => D p l'' = D p l'' + end _l'' with + | D 1 l' => refl_equal (D O (D 1 l')) + | _ => refl_equal _ + end +| _ => refl_equal _ +end. + +Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) := + match v with + | niln _ => w + | consn _ a n' v' => consn _ a _ (app v' w) + end. + +(* Testing regression of bug 2106 *) + +Set Implicit Arguments. +Require Import List. + +Inductive nt := E. +Definition root := E. +Inductive ctor : list nt -> nt -> Type := + Plus : ctor (cons E (cons E nil)) E. + +Inductive term : nt -> Type := +| Term : forall s n, ctor s n -> spine s -> term n +with spine : list nt -> Type := +| EmptySpine : spine nil +| ConsSpine : forall n s, term n -> spine s -> spine (n :: s). + +Inductive step : nt -> nt -> Type := + | Step : forall l n r n' (c:ctor (l++n::r) n'), spine l -> spine r -> step n +n'. + +Definition test (s:step E E) := + match s with + | @Step nil _ (cons E nil) _ Plus l l' => true + | _ => false + end. + +(* Testing regression of bug 2454 ("get" used not be type-checkable when + defined with its type constraint) *) + +Inductive K : nat -> Type := KC : forall (p q:nat), K p. + +Definition get : K O -> nat := fun x => match x with KC p q => q end. + +(* Checking correct order of substitution of realargs *) +(* (was broken from revision 14664 to 14669) *) +(* Example extracted from contrib CoLoR *) + +Inductive EQ : nat -> nat -> Prop := R x y : EQ x y. + +Check fun e t (d1 d2:EQ e t) => + match d1 in EQ e1 t1, d2 in EQ e2 t2 return + (e1,t1) = (e2,t2) -> (e1,t1) = (e,t) -> 0=0 + with + | R _ _, R _ _ => fun _ _ => eq_refl + end. diff --git a/test-suite/success/Cases_bug1834.v b/test-suite/success/Cases_bug1834.v new file mode 100644 index 0000000000..65372c2da4 --- /dev/null +++ b/test-suite/success/Cases_bug1834.v @@ -0,0 +1,12 @@ +(* Bug in the computation of generalization *) + +(* The following bug, elaborated by Bruno Barras, is solved from r11083 *) + +Parameter P : unit -> Prop. +Definition T := sig P. +Parameter Q : T -> Prop. +Definition U := sig Q. +Parameter a : U. +Check (match a with exist _ (exist _ tt e2) e3 => e3=e3 end). + +(* There is still a form submitted by Pierre Corbineau (#1834) which fails *) diff --git a/test-suite/success/Cases_bug3758.v b/test-suite/success/Cases_bug3758.v new file mode 100644 index 0000000000..e48f452326 --- /dev/null +++ b/test-suite/success/Cases_bug3758.v @@ -0,0 +1,17 @@ +(* There used to be an evar leak in the to_nat example *) + +Require Import Coq.Lists.List. +Import ListNotations. + +Fixpoint Idx {A:Type} (l:list A) : Type := + match l with + | [] => False + | _::l => True + Idx l + end. + +Fixpoint to_nat {A:Type} (l:list A) (i:Idx l) : nat := + match l,i with + | [] , i => match i with end + | _::_, inl _ => 0 + | _::l, inr i => S (to_nat l i) + end. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v new file mode 100644 index 0000000000..36fecf7204 --- /dev/null +++ b/test-suite/success/Check.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Compiling the theories allows testing parsing and typing but not printing *) +(* This file tests that pretty-printing does not fail *) +(* Test of exact output is not specified *) + +Check 0. +Check S. +Check nat. + +Type Type : Type. diff --git a/test-suite/success/CombinedScheme.v b/test-suite/success/CombinedScheme.v new file mode 100644 index 0000000000..d6ca7a299f --- /dev/null +++ b/test-suite/success/CombinedScheme.v @@ -0,0 +1,35 @@ +Inductive even (x : bool) : nat -> Type := +| evenO : even x 0 +| evenS : forall n, odd x n -> even x (S n) +with odd (x : bool) : nat -> Type := +| oddS : forall n, even x n -> odd x (S n). + +Scheme even_ind_prop := Induction for even Sort Prop +with odd_ind_prop := Induction for odd Sort Prop. + +Combined Scheme even_cprop from even_ind_prop, odd_ind_prop. + +Check even_cprop : + forall (x : bool) (P : forall n : nat, even x n -> Prop) + (P0 : forall n : nat, odd x n -> Prop), + P 0 (evenO x) -> + (forall (n : nat) (o : odd x n), P0 n o -> P (S n) (evenS x n o)) -> + (forall (n : nat) (e : even x n), P n e -> P0 (S n) (oddS x n e)) -> + (forall (n : nat) (e : even x n), P n e) /\ + (forall (n : nat) (o : odd x n), P0 n o). + +Scheme even_ind_type := Induction for even Sort Type +with odd_ind_type := Induction for odd Sort Type. + +(* This didn't work in v8.7 *) + +Combined Scheme even_ctype from even_ind_type, odd_ind_type. + +Check even_ctype : + forall (x : bool) (P : forall n : nat, even x n -> Prop) + (P0 : forall n : nat, odd x n -> Prop), + P 0 (evenO x) -> + (forall (n : nat) (o : odd x n), P0 n o -> P (S n) (evenS x n o)) -> + (forall (n : nat) (e : even x n), P n e -> P0 (S n) (oddS x n e)) -> + (forall (n : nat) (e : even x n), P n e) * + (forall (n : nat) (o : odd x n), P0 n o). diff --git a/test-suite/success/Compat88.v b/test-suite/success/Compat88.v new file mode 100644 index 0000000000..e2045900d5 --- /dev/null +++ b/test-suite/success/Compat88.v @@ -0,0 +1,18 @@ +(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(** Check that various syntax usage is available without importing + relevant files. *) +Require Coq.Strings.Ascii Coq.Strings.String. +Require Coq.ZArith.BinIntDef Coq.PArith.BinPosDef Coq.NArith.BinNatDef. +Require Coq.Reals.Rdefinitions. +Require Coq.Numbers.Cyclic.Int31.Cyclic31. + +Require Import Coq.Compat.Coq88. (* XXX FIXME Should not need [Require], see https://github.com/coq/coq/issues/8311 *) + +Check String.String "a" String.EmptyString. +Check String.eqb "a" "a". +Check Nat.eqb 1 1. +Check BinNat.N.eqb 1 1. +Check BinInt.Z.eqb 1 1. +Check BinPos.Pos.eqb 1 1. +Check Rdefinitions.Rplus 1 1. +Check Int31.iszero 1. diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v new file mode 100644 index 0000000000..5650dba236 --- /dev/null +++ b/test-suite/success/CompatCurrentFlag.v @@ -0,0 +1,3 @@ +(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(** Check that the current compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq89. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v new file mode 100644 index 0000000000..37d50ee67d --- /dev/null +++ b/test-suite/success/CompatOldFlag.v @@ -0,0 +1,5 @@ +(* -*- coq-prog-args: ("-compat" "8.7") -*- *) +(** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq89. +Import Coq.Compat.Coq88. +Import Coq.Compat.Coq87. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v new file mode 100644 index 0000000000..9981388381 --- /dev/null +++ b/test-suite/success/CompatPreviousFlag.v @@ -0,0 +1,4 @@ +(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq89. +Import Coq.Compat.Coq88. diff --git a/test-suite/success/Conjecture.v b/test-suite/success/Conjecture.v new file mode 100644 index 0000000000..ea4b5ff761 --- /dev/null +++ b/test-suite/success/Conjecture.v @@ -0,0 +1,13 @@ +(* Check keywords Conjecture and Admitted are recognized *) + +Conjecture c : forall n : nat, n = 0. + +Check c. + +Theorem d : forall n : nat, n = 0. +Proof. + induction n. + reflexivity. + assert (H : False). + 2: destruct H. +Admitted. diff --git a/test-suite/success/DHyp.v b/test-suite/success/DHyp.v new file mode 100644 index 0000000000..8b13789179 --- /dev/null +++ b/test-suite/success/DHyp.v @@ -0,0 +1 @@ + diff --git a/test-suite/success/Decompose.v b/test-suite/success/Decompose.v new file mode 100644 index 0000000000..1316cbf957 --- /dev/null +++ b/test-suite/success/Decompose.v @@ -0,0 +1,9 @@ +(* This was a Decompose bug reported by Randy Pollack (29 Mar 2000) *) + +Goal +0 = 0 /\ (forall x : nat, x = x -> x = x /\ (forall y : nat, y = y -> y = y)) -> +True. +intro H. +decompose [and] H. (* Was failing *) + +Abort. diff --git a/test-suite/success/DiscrR.v b/test-suite/success/DiscrR.v new file mode 100644 index 0000000000..54528fb56b --- /dev/null +++ b/test-suite/success/DiscrR.v @@ -0,0 +1,41 @@ +Require Import Reals. +Require Import DiscrR. + +Lemma ex0 : 1%R <> 0%R. +Proof. + discrR. +Qed. + +Lemma ex1 : 0%R <> 2%R. +Proof. + discrR. +Qed. +Lemma ex2 : 4%R <> 3%R. +Proof. + discrR. +Qed. + +Lemma ex3 : 3%R <> 5%R. +Proof. + discrR. +Qed. + +Lemma ex4 : (-1)%R <> 0%R. +Proof. + discrR. +Qed. + +Lemma ex5 : (-2)%R <> (-3)%R. +Proof. + discrR. +Qed. + +Lemma ex6 : 8%R <> (-3)%R. +Proof. + discrR. +Qed. + +Lemma ex7 : (-8)%R <> 3%R. +Proof. + discrR. +Qed. diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v new file mode 100644 index 0000000000..6abfca4c3f --- /dev/null +++ b/test-suite/success/Discriminate.v @@ -0,0 +1,47 @@ +(* Check the behaviour of Discriminate *) + +(* Check that Discriminate tries Intro until *) + +Lemma l1 : 0 = 1 -> False. + discriminate 1. +Qed. + +Lemma l2 : forall H : 0 = 1, H = H. + discriminate H. +Qed. + +(* Check the variants of discriminate *) + +Goal O = S O -> True. +discriminate 1. +Undo. +intros. +discriminate H. +Undo. +Ltac g x := discriminate x. +g H. +Abort. + +Goal (forall x y : nat, x = y -> x = S y) -> True. +intros. +try discriminate (H O) || exact I. +Qed. + +Goal (forall x y : nat, x = y -> x = S y) -> True. +intros. +ediscriminate (H O). +instantiate (1:=O). +Abort. + +(* Check discriminate on identity *) + +Goal ~ identity 0 1. +discriminate. +Qed. + +(* Check discriminate on types with local definitions *) + +Inductive A := B (T := unit) (x y : bool) (z := x). +Goal forall x y, B x true = B y false -> False. +discriminate. +Qed. diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v new file mode 100644 index 0000000000..fdf7797d4b --- /dev/null +++ b/test-suite/success/Field.v @@ -0,0 +1,97 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(**** Tests of Field with real numbers ****) + +Require Import Reals RealField. +Open Scope R_scope. + +(* Example 1 *) +Goal +forall eps : R, +eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)) = eps * (1 / 2). +Proof. + intros. + field. +Qed. + +(* Example 2 *) +Goal +forall (f g : R -> R) (x0 x1 : R), +(f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) = +(f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)). +Proof. + intros. + field. +Abort. + +(* Example 3 *) +Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a. +Proof. + intros. + field. +Abort. + +Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. +Proof. + intros. + field_simplify_eq. +Abort. + +Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. +Proof. + intros. + field_simplify (1 / (a * b) * (1 / 1 / b)). +Abort. + +(* Example 4 *) +Goal +forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a. +Proof. + intros. + field; auto. +Qed. + +(* Example 5 *) +Goal forall a : R, 1 = 1 * (1 / a) * a. +Proof. + intros. + field. +Abort. + +(* Example 6 *) +Goal forall a b : R, b = b * / a * a. +Proof. + intros. + field. +Abort. + +(* Example 7 *) +Goal forall a b : R, b = b * (1 / a) * a. +Proof. + intros. + field. +Abort. + +(* Example 8 *) +Goal forall x y : R, + x * (1 / x + x / (x + y)) = + - (1 / y) * y * (- (x * (x / (x + y))) - 1). +Proof. + intros. + field. +Abort. + +(* Example 9 *) +Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False. +Proof. +intros. +field_simplify_eq in H. +Abort. diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v new file mode 100644 index 0000000000..81c9763ccd --- /dev/null +++ b/test-suite/success/Fixpoint.v @@ -0,0 +1,121 @@ +(* Playing with (co-)fixpoints with local definitions *) + +Inductive listn : nat -> Set := + niln : listn 0 +| consn : forall n:nat, nat -> listn n -> listn (S n). + +Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat := + match n with O => p | _ => + match l with niln => p | consn q _ l => f (S q) l end + end. + +Eval compute in (f 2 (consn 0 0 niln)). + +CoInductive Stream : nat -> Set := + Consn : forall n, nat -> Stream n -> Stream (S n). + +CoFixpoint g (n:nat) (m:=pred n) (l:Stream m) (p:=S n) : Stream p := + match n return (let m:=pred n in forall l:Stream m, let p:=S n in Stream p) + with + | O => fun l:Stream 0 => Consn O 0 l + | S n' => + fun l:Stream n' => + let l' := + match l in Stream q return Stream (pred q) with Consn _ _ l => l end + in + let a := match l with Consn _ a l => a end in + Consn (S n') (S a) (g n' l') + end l. + +Eval compute in (fun l => match g 2 (Consn 0 6 l) with Consn _ a _ => a end). + +(* Check inference of simple types in presence of non ambiguous + dependencies (needs revision 10125) *) + +Section folding. + +Inductive vector (A:Type) : nat -> Type := + | Vnil : vector A 0 + | Vcons : forall (a:A) (n:nat), vector A n -> vector A (S n). + +Variables (B C : Set) (g : B -> C -> C) (c : C). + +Fixpoint foldrn n bs := + match bs with + | Vnil _ => c + | Vcons _ b _ tl => g b (foldrn _ tl) + end. + +End folding. + +(* Check definition by tactics *) + +Inductive even : nat -> Type := + | even_O : even 0 + | even_S : forall n, odd n -> even (S n) +with odd : nat -> Type := + odd_S : forall n, even n -> odd (S n). + +Fixpoint even_div2 n (H:even n) : nat := + match H with + | even_O => 0 + | even_S n H => S (odd_div2 n H) + end +with odd_div2 n H : nat. +destruct H. +apply even_div2 with n. +assumption. +Qed. + +Fixpoint even_div2' n (H:even n) : nat with odd_div2' n (H:odd n) : nat. +destruct H. +exact 0. +apply odd_div2' with n. +assumption. +destruct H. +apply even_div2' with n. +assumption. +Qed. + +CoInductive Stream1 (A B:Type) := Cons1 : A -> Stream2 A B -> Stream1 A B +with Stream2 (A B:Type) := Cons2 : B -> Stream1 A B -> Stream2 A B. + +CoFixpoint ex1 (n:nat) (b:bool) : Stream1 nat bool +with ex2 (n:nat) (b:bool) : Stream2 nat bool. +apply Cons1. +exact n. +apply (ex2 n b). +apply Cons2. +exact b. +apply (ex1 (S n) (negb b)). +Defined. + +Section visibility. + + Let Fixpoint imm (n:nat) : True := I. + + Let Fixpoint by_proof (n:nat) : True. + Proof. exact I. Defined. +End visibility. + +Fail Check imm. +Fail Check by_proof. + +Module Import mod_local. + Fixpoint imm_importable (n:nat) : True := I. + + Local Fixpoint imm_local (n:nat) : True := I. + + Fixpoint by_proof_importable (n:nat) : True. + Proof. exact I. Defined. + + Local Fixpoint by_proof_local (n:nat) : True. + Proof. exact I. Defined. +End mod_local. + +Check imm_importable. +Fail Check imm_local. +Check mod_local.imm_local. +Check by_proof_importable. +Fail Check by_proof_local. +Check mod_local.by_proof_local. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v new file mode 100644 index 0000000000..f87f2e2a9d --- /dev/null +++ b/test-suite/success/Funind.v @@ -0,0 +1,513 @@ + +Require Import Coq.funind.FunInd. + +Definition iszero (n : nat) : bool := + match n with + | O => true + | _ => false + end. + +Functional Scheme iszero_ind := Induction for iszero Sort Prop. + +Lemma toto : forall n : nat, n = 0 -> iszero n = true. +intros x eg. + functional induction iszero x; simpl. +trivial. +inversion eg. +Qed. + + +Function ftest (n m : nat) : nat := + match n with + | O => match m with + | O => 0 + | _ => 1 + end + | S p => 0 + end. +(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *) + +Lemma test1 : forall n m : nat, ftest n m <= 2. +intros n m. + functional induction ftest n m; auto. +Qed. + +Lemma test2 : forall m n, ~ 2 = ftest n m. +Proof. +intros n m;intro H. +functional inversion H ftest. +Qed. + +Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0) \/ n <> 0. +Proof. +functional inversion 1 ftest;auto. +Qed. + + +Require Import Arith. +Lemma test11 : forall m : nat, ftest 0 m <= 2. +intros m. + functional induction ftest 0 m. +auto. +auto. +auto with *. +Qed. + +Function lamfix (m n : nat) {struct n } : nat := + match n with + | O => m + | S p => lamfix m p + end. + +(* Parameter v1 v2 : nat. *) + +Lemma lamfix_lem : forall v1 v2 : nat, lamfix v1 v2 = v1. +intros v1 v2. + functional induction lamfix v1 v2. +trivial. +assumption. +Defined. + + + +(* polymorphic function *) +Require Import List. + +Functional Scheme app_ind := Induction for app Sort Prop. + +Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'. +intros A l l'. + functional induction app A l l'; intuition. + rewrite <- H0; trivial. +Qed. + + + + + +Require Export Arith. + + +Function trivfun (n : nat) : nat := + match n with + | O => 0 + | S m => trivfun m + end. + + +(* essaie de parametre variables non locaux:*) + +Parameter varessai : nat. + +Lemma first_try : trivfun varessai = 0. + functional induction trivfun varessai. +trivial. +assumption. +Defined. + + + Functional Scheme triv_ind := Induction for trivfun Sort Prop. + +Lemma bisrepetita : forall n' : nat, trivfun n' = 0. +intros n'. + functional induction trivfun n'. +trivial. +assumption. +Qed. + + + + + + + +Function iseven (n : nat) : bool := + match n with + | O => true + | S (S m) => iseven m + | _ => false + end. + + +Function funex (n : nat) : nat := + match iseven n with + | true => n + | false => match n with + | O => 0 + | S r => funex r + end + end. + + +Function nat_equal_bool (n m : nat) {struct n} : bool := + match n with + | O => match m with + | O => true + | _ => false + end + | S p => match m with + | O => false + | S q => nat_equal_bool p q + end + end. + + +Require Export Div2. +Require Import Nat. +Functional Scheme div2_ind := Induction for div2 Sort Prop. +Lemma div2_inf : forall n : nat, div2 n <= n. +intros n. + functional induction div2 n. +auto. +auto. + +apply le_S. +apply le_n_S. +exact IHn0. +Qed. + +(* reuse this lemma as a scheme:*) + +Function nested_lam (n : nat) : nat -> nat := + match n with + | O => fun m : nat => 0 + | S n' => fun m : nat => m + nested_lam n' m + end. + + +Lemma nest : forall n m : nat, nested_lam n m = n * m. +intros n m. + functional induction nested_lam n m; simpl;auto. +Qed. + + +Function essai (x : nat) (p : nat * nat) {struct x} : nat := + let (n, m) := (p: nat*nat) in + match n with + | O => 0 + | S q => match x with + | O => 1 + | S r => S (essai r (q, m)) + end + end. + +Lemma essai_essai : + forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p. +intros x p. + functional induction essai x p; intros. +inversion H. +auto with arith. + auto with arith. +Qed. + +Function plus_x_not_five'' (n m : nat) {struct n} : nat := + let x := nat_equal_bool m 5 in + let y := 0 in + match n with + | O => y + | S q => + let recapp := plus_x_not_five'' q m in + match x with + | true => S recapp + | false => S recapp + end + end. + +Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x. +intros a b. + functional induction plus_x_not_five'' a b; intros hyp; simpl; auto. +Qed. + +Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true. +intros n m. + functional induction nat_equal_bool n m; simpl; intros hyp; auto. +rewrite <- hyp in y; simpl in y;tauto. +inversion hyp. +Qed. + +Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m. +intros n m. + functional induction nat_equal_bool n m; simpl; intros eg; auto. +inversion eg. +inversion eg. +Qed. + + +Inductive istrue : bool -> Prop := + istrue0 : istrue true. + +Functional Scheme add_ind := Induction for add Sort Prop. + +Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. +intros n m. + functional induction add n m; intros. +auto with arith. +auto with arith. +Qed. + + +Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0. +intros n. +unfold plus. + functional induction plus n 0; intros. +auto with arith. +apply le_n_S. +assumption. +Qed. + +Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x. +intros n. + functional induction plus 0 n; intros; auto with arith. +Qed. + +Function mod2 (n : nat) : nat := + match n with + | O => 0 + | S (S m) => S (mod2 m) + | _ => 0 + end. + +Lemma princ_mod2 : forall n : nat, mod2 n <= n. +intros n. + functional induction mod2 n; simpl; auto with arith. +Qed. + +Function isfour (n : nat) : bool := + match n with + | S (S (S (S O))) => true + | _ => false + end. + +Function isononeorfour (n : nat) : bool := + match n with + | S O => true + | S (S (S (S O))) => true + | _ => false + end. + +Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n). +intros n. + functional induction isononeorfour n; intros istr; simpl; + inversion istr. +apply istrue0. +destruct n. inversion istr. +destruct n. tauto. +destruct n. inversion istr. +destruct n. inversion istr. +destruct n. tauto. +simpl in *. inversion H0. +Qed. + +Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n). +intros n. + functional induction isononeorfour n; intros m istr; inversion istr. +apply istrue0. +rewrite H in y; simpl in y;tauto. +Qed. + +Function ftest4 (n m : nat) : nat := + match n with + | O => match m with + | O => 0 + | S q => 1 + end + | S p => match m with + | O => 0 + | S r => 1 + end + end. + +Lemma test4 : forall n m : nat, ftest n m <= 2. +intros n m. + functional induction ftest n m; auto with arith. +Qed. + +Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2. +intros n m. +assert ({n0 | n0 = S n}). +exists (S n);reflexivity. +destruct H as [n0 H1]. +rewrite <- H1;revert H1. + functional induction ftest4 n0 m. +inversion 1. +inversion 1. + +auto with arith. +auto with arith. +Qed. + +Function ftest44 (x : nat * nat) (n m : nat) : nat := + let (p, q) := (x: nat*nat) in + match n with + | O => match m with + | O => 0 + | S q => 1 + end + | S p => match m with + | O => 0 + | S r => 1 + end + end. + +Lemma test44 : + forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2. +intros pq n m o r s. + functional induction ftest44 pq n (S m). +auto with arith. +auto with arith. +auto with arith. +auto with arith. +Qed. + +Function ftest2 (n m : nat) {struct n} : nat := + match n with + | O => match m with + | O => 0 + | S q => 0 + end + | S p => ftest2 p m + end. + +Lemma test2' : forall n m : nat, ftest2 n m <= 2. +intros n m. + functional induction ftest2 n m; simpl; intros; auto. +Qed. + +Function ftest3 (n m : nat) {struct n} : nat := + match n with + | O => 0 + | S p => match m with + | O => ftest3 p 0 + | S r => 0 + end + end. + +Lemma test3' : forall n m : nat, ftest3 n m <= 2. +intros n m. + functional induction ftest3 n m. +intros. +auto. +intros. +auto. +intros. +simpl. +auto. +Qed. + +Function ftest5 (n m : nat) {struct n} : nat := + match n with + | O => 0 + | S p => match m with + | O => ftest5 p 0 + | S r => ftest5 p r + end + end. + +Lemma test5 : forall n m : nat, ftest5 n m <= 2. +intros n m. + functional induction ftest5 n m. +intros. +auto. +intros. +auto. +intros. +simpl. +auto. +Qed. + +Function ftest7 (n : nat) : nat := + match ftest5 n 0 with + | O => 0 + | S r => 0 + end. + +Lemma essai7 : + forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2) + (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) + (n : nat), ftest7 n <= 2. +intros hyp1 hyp2 n. + functional induction ftest7 n; auto. +Qed. + +Function ftest6 (n m : nat) {struct n} : nat := + match n with + | O => 0 + | S p => match ftest5 p 0 with + | O => ftest6 p 0 + | S r => ftest6 p r + end + end. + + +Lemma princ6 : + (forall n m : nat, n = 0 -> ftest6 0 m <= 2) -> + (forall n m p : nat, + ftest6 p 0 <= 2 -> ftest5 p 0 = 0 -> n = S p -> ftest6 (S p) m <= 2) -> + (forall n m p r : nat, + ftest6 p r <= 2 -> ftest5 p 0 = S r -> n = S p -> ftest6 (S p) m <= 2) -> + forall x y : nat, ftest6 x y <= 2. +intros hyp1 hyp2 hyp3 n m. +generalize hyp1 hyp2 hyp3. +clear hyp1 hyp2 hyp3. + functional induction ftest6 n m; auto. +Qed. + +Lemma essai6 : forall n m : nat, ftest6 n m <= 2. +intros n m. + functional induction ftest6 n m; simpl; auto. +Qed. + +(* Some tests with modules *) +Module M. +Function test_m (n:nat) : nat := + match n with + | 0 => 0 + | S n => S (S (test_m n)) + end. + +Lemma test_m_is_double : forall n, div2 (test_m n) = n. +Proof. +intros n. +functional induction (test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. +End M. +(* We redefine a new Function with the same name *) +Function test_m (n:nat) : nat := + pred n. + +Lemma test_m_is_pred : forall n, test_m n = pred n. +Proof. +intro n. +functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) +reflexivity. +Qed. + +(* Checks if the dot notation are correctly treated in infos *) +Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n. +intro n. +(* here we should apply M.test_m_ind *) +functional induction (M.test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. + +Import M. +(* Now test_m is the one which defines double *) + +Lemma test_m_is_double : forall n, div2 (M.test_m n) = n. +intro n. +(* here we should apply M.test_m_ind *) +functional induction (test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. + + + + + + + + diff --git a/test-suite/success/Generalization.v b/test-suite/success/Generalization.v new file mode 100644 index 0000000000..de34e007d2 --- /dev/null +++ b/test-suite/success/Generalization.v @@ -0,0 +1,14 @@ +Generalizable All Variables. + +Check `(a = 0). +Check `(a = 0)%type. +Definition relation A := A -> A -> Prop. +Definition equivalence `(R : relation A) := True. +Check (`(@equivalence A R)). + +Definition a_eq_b : `( a = 0 /\ a = b /\ b > c \/ d = e /\ d = 1). +Admitted. +Print a_eq_b. + + + diff --git a/test-suite/success/Generalize.v b/test-suite/success/Generalize.v new file mode 100644 index 0000000000..980c89dd9c --- /dev/null +++ b/test-suite/success/Generalize.v @@ -0,0 +1,8 @@ +(* Check Generalize Dependent *) + +Lemma l1 : + let a := 0 in let b := a in forall (c : b = b) (d : True -> b = b), d = d. +intros. +generalize dependent a. +intros a b c d. +Abort. diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v new file mode 100644 index 0000000000..2f13b7c225 --- /dev/null +++ b/test-suite/success/Hints.v @@ -0,0 +1,215 @@ +(* Checks syntax of Hints commands *) +(* Old-style syntax *) +Hint Resolve eq_refl eq_sym. +Hint Resolve eq_refl eq_sym: foo. +Hint Immediate eq_refl eq_sym. +Hint Immediate eq_refl eq_sym: foo. +Hint Unfold fst eq_sym. +Hint Unfold fst eq_sym: foo. + +(* Checks that qualified names are accepted *) + +(* New-style syntax *) +Hint Resolve eq_refl: core arith. +Hint Immediate eq_trans. +Hint Unfold eq_sym: core. +Hint Constructors eq: foo bar. +Hint Extern 3 (_ = _) => apply eq_refl: foo bar. + +(* Extended new syntax with patterns *) +Hint Resolve eq_refl | 4 (_ = _) : baz. +Hint Resolve eq_sym eq_trans : baz. +Hint Extern 3 (_ = _) => apply eq_sym : baz. + +Parameter pred : nat -> Prop. +Parameter pred0 : pred 0. +Parameter f : nat -> nat. +Parameter predf : forall n, pred n -> pred (f n). + +(* No conversion on let-bound variables and constants in pred (the default) *) +Hint Resolve pred0 | 1 (pred _) : pred. +Hint Resolve predf | 0 : pred. + +(* Allow full conversion on let-bound variables and constants *) +Create HintDb predconv discriminated. +Hint Resolve pred0 | 1 (pred _) : predconv. +Hint Resolve predf | 0 : predconv. + +Goal exists n, pred n. + eexists. + Set Typeclasses Filtered Unification. + Set Typeclasses Debug Verbosity 2. + (* predf is not tried as it doesn't match the goal *) + typeclasses eauto with pred. +Qed. + +Parameter predconv : forall n, pred n -> pred (0 + S n). + +(* The inferred pattern contains 0 + ?n, syntactic match will fail to see convertible + terms *) +Hint Resolve pred0 : pred2. +Hint Resolve predconv : pred2. + +(** In this database we allow predconv to apply to pred (S _) goals, more generally + than the inferred pattern (pred (0 + S _)). *) +Create HintDb pred2conv discriminated. +Hint Resolve pred0 : pred2conv. +Hint Resolve predconv | 1 (pred (S _)) : pred2conv. + +Goal pred 3. + Fail typeclasses eauto with pred2. + typeclasses eauto with pred2conv. +Abort. + +Set Typeclasses Filtered Unification. +Set Typeclasses Debug Verbosity 2. +Hint Resolve predconv | 1 (pred _) : pred. +Hint Resolve predconv | 1 (pred (S _)) : predconv. +Test Typeclasses Limit Intros. +Goal pred 3. + (* predf is not tried as it doesn't match the goal *) + (* predconv is tried but fails as the transparent state doesn't allow + unfolding + *) + Fail typeclasses eauto with pred. + (* Here predconv succeeds as it matches (pred (S _)) and then + full unification is allowed *) + typeclasses eauto with predconv. +Qed. + +(** The other way around: goal contains redexes instead of instances *) +Goal exists n, pred (0 + n). + eexists. + (* pred0 (pred _) matches the goal *) + typeclasses eauto with predconv. +Qed. + + +(* Checks that local names are accepted *) +Section A. + Remark Refl : forall (A : Set) (x : A), x = x. + Proof. exact @eq_refl. Defined. + Definition Sym := eq_sym. + Let Trans := eq_trans. + + Hint Resolve Refl: foo. + Hint Resolve Sym: bar. + Hint Resolve Trans: foo2. + + Hint Immediate Refl. + Hint Immediate Sym. + Hint Immediate Trans. + + Hint Unfold Refl. + Hint Unfold Sym. + Hint Unfold Trans. + + Hint Resolve Sym Trans Refl. + Hint Immediate Sym Trans Refl. + Hint Unfold Sym Trans Refl. + +End A. + +Axiom a : forall n, n=0 <-> n<=0. + +Hint Resolve -> a. +Goal forall n, n=0 -> n<=0. +auto. +Qed. + + +(* This example comes from Chlipala's ltamer *) +(* It used to fail from r12902 to r13112 since type_of started to call *) +(* e_cumul (instead of conv_leq) which was not able to unify "?id" and *) +(* "(fun x => x) ?id" *) + +Notation "e :? pf" := (eq_rect _ (fun X : Set => X) e _ pf) + (no associativity, at level 90). + +Axiom cast_coalesce : + forall (T1 T2 T3 : Set) (e : T1) (pf1 : T1 = T2) (pf2 : T2 = T3), + ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2). + +Hint Rewrite cast_coalesce : ltamer. + +Require Import Program. +Module HintCut. +Class A (f : nat -> nat) := a : True. +Class B (f : nat -> nat) := b : True. +Class C (f : nat -> nat) := c : True. +Class D (f : nat -> nat) := d : True. +Class E (f : nat -> nat) := e : True. + +Instance a_is_b f : A f -> B f. +Proof. easy. Qed. +Instance b_is_c f : B f -> C f. +Proof. easy. Qed. +Instance c_is_d f : C f -> D f. +Proof. easy. Qed. +Instance d_is_e f : D f -> E f. +Proof. easy. Qed. + +Instance a_compose f g : A f -> A g -> A (compose f g). +Proof. easy. Qed. +Instance b_compose f g : B f -> B g -> B (compose f g). +Proof. easy. Qed. +Instance c_compose f g : C f -> C g -> C (compose f g). +Proof. easy. Qed. +Instance d_compose f g : D f -> D g -> D (compose f g). +Proof. easy. Qed. +Instance e_compose f g : E f -> E g -> E (compose f g). +Proof. easy. Qed. + +Instance a_id : A id. +Proof. easy. Qed. + +Instance foo f : + E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ + id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id). +Proof. +Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e) + (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances. + + Timeout 1 Fail apply _. (* 0.06s *) +Abort. +End HintCut. + + +(* Check that auto-like tactics do not prefer "eq_refl" over more complex solutions, *) +(* e.g. those tactics when considering a goal with existential varibles *) +(* like "m = ?n" won't pick "plus_n_O" hint over "eq_refl" hint. *) +(* See this Coq club post for more detail: *) +(* https://sympa.inria.fr/sympa/arc/coq-club/2017-12/msg00103.html *) + +Goal forall (m : nat), exists n, m = n /\ m = n. + intros m; eexists; split; [trivial | reflexivity]. +Qed. + +Section HintTransparent. + + Definition fn (x : nat) := S x. + + Create HintDb trans. + + Hint Resolve eq_refl | (_ = _) : trans. + + (* No reduction *) + Hint Variables Opaque : trans. Hint Constants Opaque : trans. + + Goal forall x : nat, fn x = S x. + Proof. + intros. + Fail typeclasses eauto with trans. + unfold fn. + typeclasses eauto with trans. + Qed. + + (** Now allow unfolding fn *) + Hint Constants Transparent : trans. + + Goal forall x : nat, fn x = S x. + Proof. + intros. + typeclasses eauto with trans. + Qed. + +End HintTransparent. diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v new file mode 100644 index 0000000000..b16e4a1186 --- /dev/null +++ b/test-suite/success/ImplicitArguments.v @@ -0,0 +1,35 @@ +Inductive vector {A : Type} : nat -> Type := +| vnil : vector 0 +| vcons : A -> forall {n'}, vector n' -> vector (S n'). + +Arguments vector A : clear implicits. + +Require Import Coq.Program.Program. + +Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n := + match v with + | vnil => ! + | vcons a v' => v' + end. + +Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) := + match v in vector _ n return vector A (n + m) with + | vnil => w + | vcons a v' => vcons a (app v' w) + end. + +(* Test sharing information between different hypotheses *) + +Parameters (a:_) (b:a=0). + +(* These examples were failing due to a lifting wrongly taking let-in into account *) + +Definition foo6 (x:=1) : forall {n:nat}, n=n := fun n => eq_refl. + +Fixpoint foo7 (x:=1) (n:nat) {p:nat} {struct n} : nat. +Abort. + +(* Some example which should succeed with local implicit arguments *) + +Inductive A {P:forall m {n}, n=m -> Prop} := C : P 0 eq_refl -> A. +Inductive B (P:forall m {n}, n=m -> Prop) := D : P 0 eq_refl -> B P. diff --git a/test-suite/success/Import.v b/test-suite/success/Import.v new file mode 100644 index 0000000000..ff5c1ed753 --- /dev/null +++ b/test-suite/success/Import.v @@ -0,0 +1,11 @@ +(* Test visibility of imported objects *) + +Require Import make_local. + +(* Check local implicit arguments are not imported *) + +Check (f nat 0). + +(* Check local arguments scopes are not imported *) + +Check (f nat (0*0)). diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v new file mode 100644 index 0000000000..c2130995fc --- /dev/null +++ b/test-suite/success/Inductive.v @@ -0,0 +1,206 @@ +(* Test des definitions inductives imbriquees *) + +Inductive X : Set := + cons1 : list X -> X. + +Inductive Y : Set := + cons2 : list (Y * Y) -> Y. + +(* Test inductive types with local definitions (arity) *) + +Inductive eq1 : forall A:Type, let B:=A in A -> Prop := + refl1 : eq1 True I. + +Check + fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => + let B := A in + fun (a : A) (e : eq1 A a) => + match e in (@eq1 A0 B0 a0) return (P A0 a0) with + | refl1 => f + end. + +Inductive eq2 (A:Type) (a:A) + : forall B C:Type, let D:=(A*B*C)%type in D -> Prop := + refl2 : eq2 A a unit bool (a,tt,true). + +(* Check inductive types with local definitions (parameters) *) + +Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set := + I : forall z : E, A C D x y z. + +Check + (fun C D : Prop => + let E := C in + let F := D in + fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type) + (f : forall z : C, P z (I C D x y z)) (y0 : C) + (a : A C D x y y0) => + match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with + | I _ _ _ _ x0 => f x0 + end). + +Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set := {p : C; q : E}. + +Check + (fun C D : Set => + let E := C in + let F := D in + fun (x y : E -> F) (P : B C D x y -> Type) + (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) + (b : B C D x y) => + match b as b0 return (P b0) with + | Build_B _ _ _ _ x0 x1 => f x0 x1 + end). + +(* Check inductive types with local definitions (constructors) *) + +Inductive I1 : Set := C1 (_:I1) (_:=0). + +Check (fun x:I1 => + match x with + | C1 i n => (i,n) + end). + +(* Check implicit parameters of inductive types (submitted by Pierre + Casteran and also implicit in BZ#338) *) + +Set Implicit Arguments. +Unset Strict Implicit. + +CoInductive LList (A : Set) : Set := + | LNil : LList A + | LCons : A -> LList A -> LList A. + +Arguments LNil [A]. + +Inductive Finite (A : Set) : LList A -> Prop := + | Finite_LNil : Finite LNil + | Finite_LCons : + forall (a : A) (l : LList A), Finite l -> Finite (LCons a l). + +(* Check positivity modulo reduction (cf bug BZ#983) *) + +Record P:Type := {PA:Set; PB:Set}. + +Definition F (p:P) := (PA p) -> (PB p). + +Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F. + +(* Check that test for binders capturing implicit arguments is not stronger + than needed (problem raised by Cedric Auger) *) + +Set Implicit Arguments. +Inductive bool_comp2 (b: bool): bool -> Prop := +| Opp2: forall q, (match b return Prop with + | true => match q return Prop with + true => False | + false => True end + | false => match q return Prop with + true => True | + false => False end end) -> bool_comp2 b q. + +(* This one is still to be made acceptable... + +Set Implicit Arguments. +Inductive I A : A->Prop := C a : (forall A, A) -> I a. + + *) + +(* Test recursively non-uniform parameters (was formerly in params_ind.v) *) + +Inductive list (A : Set) : Set := + | nil : list A + | cons : A -> list (A -> A) -> list A. + +(* Check inference of evars in arity using information from constructors *) + +Inductive foo1 : forall p, Prop := cc1 : foo1 0. + +(* Check cross inference of evars from constructors *) + +Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0. + +(* An example with reduction removing an occurrence of the inductive type in one of its argument *) + +Inductive IND1 (A:Type) := CONS1 : IND1 ((fun x => A) IND1). + +(* These types were considered as ill-formed before March 2015, while they + could be accepted considering that the type IND1 above was accepted *) + +Inductive IND2 (A:Type) (T:=fun _ : Type->Type => A) := CONS2 : IND2 A -> IND2 (T IND2). + +Inductive IND3 (A:Type) (T:=fun _ : Type->Type => A) := CONS3 : IND3 (T IND3) -> IND3 A. + +Inductive IND4 (A:Type) := CONS4 : IND4 ((fun x => A) IND4) -> IND4 A. + +(* This type was ok before March 2015 *) + +Inductive IND5 (A : Type) (T := A) : Type := CONS5 : IND5 ((fun _ => A) 0) -> IND5 A. + +(* An example of nested positivity which was rejected by the kernel + before 24 March 2015 (even with Unset Elimination Schemes to avoid + the _rect bug) due to the wrong computation of non-recursively + uniform parameters in list' *) + +Inductive list' (A:Type) (B:=A) := +| nil' : list' A +| cons' : A -> list' B -> list' A. + +Inductive tree := node : list' tree -> tree. + +(* This type was raising an anomaly when building the _rect scheme, + because of a bug in Inductiveops.get_arity in the presence of + let-ins and recursively non-uniform parameters. *) + +Inductive L (A:Type) (T:=A) : Type := C : L nat -> L A. + +(* This type was raising an anomaly when building the _rect scheme, + because of a wrong computation of the number of non-recursively + uniform parameters when conversion is needed, leading the example to + hit the Inductiveops.get_arity bug mentioned above (see #3491) *) + +Inductive IND6 (A:Type) (T:=A) := CONS6 : IND6 T -> IND6 A. + + +Module TemplateProp. + + (** Check lowering of a template universe polymorphic inductive to Prop *) + + Inductive Foo (A : Type) : Type := foo : A -> Foo A. + + Check Foo True : Prop. + +End TemplateProp. + +Module PolyNoLowerProp. + + (** Check lowering of a general universe polymorphic inductive to Prop is _failing_ *) + + Polymorphic Inductive Foo (A : Type) : Type := foo : A -> Foo A. + + Fail Check Foo True : Prop. + +End PolyNoLowerProp. + +(* Test building of elimination scheme with noth let-ins and + non-recursively uniform parameters *) + +Module NonRecLetIn. + + Unset Implicit Arguments. + + Inductive Ind (b:=2) (a:nat) (c:=1) : Type := + | Base : Ind a + | Rec : Ind (S a) -> Ind a. + + Check Ind_rect (fun n (b:Ind n) => b = b) + (fun n => eq_refl) + (fun n b c => f_equal (Rec n) eq_refl) 0 (Rec 0 (Base 1)). + +End NonRecLetIn. + +(* Test treatment of let-in in the definition of Records *) +(* Should fail with "Sort expected" *) + +Fail Inductive foo (T : Type) : let T := Type in T := + { r : forall x : T, x = x }. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v new file mode 100644 index 0000000000..7ee471bae7 --- /dev/null +++ b/test-suite/success/Injection.v @@ -0,0 +1,178 @@ +Require Eqdep_dec. + +(* Check the behaviour of Injection *) + +(* Check that Injection tries Intro until *) + +Unset Structural Injection. +Lemma l1 : forall x : nat, S x = S (S x) -> False. + injection 1. +apply n_Sn. +Qed. + +Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. + injection H. +intros. +apply (n_Sn x H0). +Qed. + +(* Check that no tuple needs to be built *) +Lemma l3 : + forall x y : nat, + existT (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) = + existT (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> + x = y. +intros x y H. + injection H. +exact (fun H => H). +Qed. + +(* Check that a tuple is built (actually the same as the initial one) *) +Lemma l4 : + forall p1 p2 : {0 = 0} + {0 = 0}, + existT (fun n : nat => {n = n} + {n = n}) 0 p1 = + existT (fun n : nat => {n = n} + {n = n}) 0 p2 -> + existT (fun n : nat => {n = n} + {n = n}) 0 p1 = + existT (fun n : nat => {n = n} + {n = n}) 0 p2. +intros. + injection H. +exact (fun H => H). +Qed. +Set Structural Injection. + +(* Test injection as *) + +Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z. +intros; injection H as Hxz Hyt. +exact Hxz. +Qed. + +(* Check the variants of injection *) + +Goal forall x y, S x = S y -> True. +injection 1 as H'. +Undo. +intros. +injection H as H'. +Undo. +Ltac f x := injection x. +f H. +Abort. + +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +try injection (H O) || exact I. +Qed. + +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O). +2:instantiate (1:=O). +Abort. + +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O ?[y]) as H0. +instantiate (y:=O). +Abort. + +(* Test the injection intropattern *) + +Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. +intros * [= H1 H2]. +exact H1. +Qed. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT *) + +Scheme Equality for nat. +Unset Structural Injection. +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H. +intro H0. exact H0. +Abort. +Set Structural Injection. + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H as H0. +exact H0. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Basic case, using sigT, with "as" clause *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + existT P n H1 = existT P n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT *) + +Inductive my_sig (A : Type) (P : A -> Type) : Type := + my_exist : forall x : A, P x -> my_sig A P. + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + my_exist _ _ n H1 = my_exist _ _ n H2 -> H1 = H2. +intros. +injection H as H. +exact H. +Abort. + +(* Test injection using K, knowing that an equality is decidable *) +(* Dependent case not directly exposing sigT deeply nested *) + +Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n, + (my_exist _ _ n H1,0) = (my_exist _ _ n H2,0) -> H1 = H2. +intros * [= H]. +exact H. +Abort. + +(* Test the Keep Proof Equalities option. *) +Set Keep Proof Equalities. +Unset Structural Injection. + +Inductive pbool : Prop := Pbool1 | Pbool2. + +Inductive pbool_shell : Set := Pbsc : pbool -> pbool_shell. + +Goal Pbsc Pbool1 = Pbsc Pbool2 -> True. +injection 1. +match goal with + |- Pbool1 = Pbool2 -> True => idtac | |- True => fail +end. +Abort. + +(* Injection in the presence of local definitions *) +Inductive A := B (T := unit) (x y : bool) (z := x). +Goal forall x y x' y', B x y = B x' y' -> y = y'. +intros * [= H1 H2]. +exact H2. +Qed. + +(* Injection does not project at positions in Prop... allow it? + +Inductive t (A:Prop) : Set := c : A -> t A. +Goal forall p q : True\/True, c _ p = c _ q -> False. +intros. +injection H. +Abort. + +*) + +(* Injection does not project on discriminable positions... allow it? + +Goal 1=2 -> 1=0. +intro H. +injection H. +intro; assumption. +Qed. + +*) diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v new file mode 100644 index 0000000000..ee540d7109 --- /dev/null +++ b/test-suite/success/Inversion.v @@ -0,0 +1,193 @@ +Axiom magic : False. + +(* Submitted by Dachuan Yu (BZ#220) *) +Fixpoint T (n : nat) : Type := + match n with + | O => nat -> Prop + | S n' => T n' + end. +Inductive R : forall n : nat, T n -> nat -> Prop := + | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l + | RS : + forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. +Definition Psi00 (n : nat) : Prop := False. +Definition Psi0 : T 0 := Psi00. +Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l. +inversion 1. +Abort. + +(* Submitted by Pierre Casteran (BZ#540) *) + +Set Implicit Arguments. +Unset Strict Implicit. +Parameter rule : Set -> Type. + +Inductive extension (I : Set) : Type := + | NL : extension I + | add_rule : rule I -> extension I -> extension I. + + +Inductive in_extension (I : Set) (r : rule I) : extension I -> Type := + | in_first : forall e, in_extension r (add_rule r e) + | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e). + +Arguments NL [I]. + +Inductive super_extension (I : Set) (e : extension I) : +extension I -> Type := + | super_NL : super_extension e NL + | super_add : + forall r (e' : extension I), + in_extension r e -> + super_extension e e' -> super_extension e (add_rule r e'). + + + +Lemma super_def : + forall (I : Set) (e1 e2 : extension I), + super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2. +Proof. + simple induction 1. + inversion 1; auto. + elim magic. +Qed. + +(* Example from Norbert Schirmer on Coq-Club, Sep 2000 *) + +Set Strict Implicit. +Unset Implicit Arguments. +Definition Q (n m : nat) (prf : n <= m) := True. +Goal forall (n m : nat) (H : S n <= m), Q (S n) m H = True. +intros. +dependent inversion_clear H. +elim magic. +elim magic. +Qed. + +(* Submitted by Boris Yakobowski (BZ#529) *) +(* Check that Inversion does not fail due to unnormalized evars *) + +Set Implicit Arguments. +Unset Strict Implicit. +Require Import Bvector. + +Inductive I : nat -> Set := + | C1 : I 1 + | C2 : forall k i : nat, Vector.t (I i) k -> I i. + +Inductive SI : forall k : nat, I k -> Vector.t nat k -> nat -> Prop := + SC2 : + forall (k i vf : nat) (v : Vector.t (I i) k) (xi : Vector.t nat i), + SI (C2 v) xi vf. + +Theorem SUnique : + forall (k : nat) (f : I k) (c : Vector.t nat k) v v', + SI f c v -> SI f c v' -> v = v'. +Proof. +induction 1. +intros H; inversion H. +Admitted. + +(* Used to failed at some time *) + +Set Strict Implicit. +Unset Implicit Arguments. +Parameter bar : forall p q : nat, p = q -> Prop. +Inductive foo : nat -> nat -> Prop := + C : forall (a b : nat) (Heq : a = b), bar a b Heq -> foo a b. +Lemma depinv : forall a b, foo a b -> True. +intros a b H. +inversion H. +Abort. + +(* Check non-regression of BZ#1968 *) + +Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t). +Goal forall o, foo2 o -> 0 = 1. +intros. +eapply trans_eq. +inversion H. +Abort. + +(* Check that the part of "injection" that is called by "inversion" + does the same number of intros as the number of equations + introduced, even in presence of dependent equalities that + "injection" renounces to split *) + +Fixpoint prodn (n : nat) := + match n with + | O => unit + | (S m) => prod (prodn m) nat + end. + +Inductive U : forall n : nat, prodn n -> bool -> Prop := +| U_intro : U 0 tt true. + +Lemma foo3 : forall n (t : prodn n), U n t true -> False. +Proof. +(* used to fail because dEqThen thought there were 2 new equations but + inject_at_positions actually introduced only one; leading then to + an inconsistent state that disturbed "inversion" *) +intros. inversion H. +Abort. + +(* BZ#2314 (simplified): check that errors do not show as anomalies *) + +Goal True -> True. +intro. +Fail inversion H using False. +Fail inversion foo using True_ind. +Abort. + +(* Was failing at some time between 7 and 10 September 2014 *) +(* even though, it is not clear that the resulting context is interesting *) + +Parameter P:nat*nat->Prop. +Inductive IND : nat * nat -> { x : nat * nat | P x } * nat -> Prop := +CONSTR a b (H:P (a,b)) c : IND (a,b) (exist _ (a,b) H, c). + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp. + (* By the way, why is "H" removed even in non-clear mode ? *) +reflexivity. +Qed. + +Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z. +intros * Hyp. +inversion Hyp as (a,b,H,c,(H1_1,H1_2),(H2_1,H2_2,H2_3)). +reflexivity. +Qed. + +(* Up to September 2014, Mapp below was called MApp0 because of a bug + in intro_replacing (short version of BZ#2164.v) + (example taken from CoLoR) *) + +Parameter Term : Type. +Parameter isApp : Term -> Prop. +Parameter appBodyL : forall M, isApp M -> Prop. +Parameter lower : forall M Mapp, appBodyL M Mapp -> Term. + +Inductive BetaStep : Term -> Term -> Prop := + Beta M Mapp Mabs : BetaStep M (lower M Mapp Mabs). + +Goal forall M N, BetaStep M N -> True. +intros M N H. +inversion H as (P,Mapp,Mabs,H0,H1). +clear Mapp Mabs H0 H1. +exact Logic.I. +Qed. + +(* Up to September 2014, H0 below was renamed called H1 because of a collision + with the automaticallly generated names for equations. + (example taken from CoLoR) *) + +Inductive term := Var | Fun : term -> term -> term. +Inductive lt : term -> term -> Prop := + mpo f g ss ts : lt Var (Fun f ts) -> lt (Fun f ss) (Fun g ts). + +Goal forall f g ss ts, lt (Fun f ss) (Fun g ts) -> lt Var (Fun f ts). +intros. +inversion H as (f',g',ss',ts',H0). +exact H0. +Qed. diff --git a/test-suite/success/InversionSigma.v b/test-suite/success/InversionSigma.v new file mode 100644 index 0000000000..51f33c7ce7 --- /dev/null +++ b/test-suite/success/InversionSigma.v @@ -0,0 +1,40 @@ +Section inversion_sigma. + Local Unset Implicit Arguments. + Context A (B : A -> Prop) (C C' : forall a, B a -> Prop) + (D : forall a b, C a b -> Prop) (E : forall a b c, D a b c -> Prop). + + (* Require that, after destructing sigma types and inverting + equalities, we can subst equalities of variables only, and reduce + down to [eq_refl = eq_refl]. *) + Local Ltac test_inversion_sigma := + intros; + repeat match goal with + | [ H : sig _ |- _ ] => destruct H + | [ H : sigT _ |- _ ] => destruct H + | [ H : sig2 _ _ |- _ ] => destruct H + | [ H : sigT2 _ _ |- _ ] => destruct H + end; simpl in *; + inversion_sigma; + repeat match goal with + | [ H : ?x = ?y |- _ ] => is_var x; is_var y; subst x; simpl in * + end; + match goal with + | [ |- eq_refl = eq_refl ] => reflexivity + end. + + Goal forall (x y : { a : A & { b : { b : B a & C a b } & { d : D a (projT1 b) (projT2 b) & E _ _ _ d } } }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : A | { b : { b : B a | C a b } | { d : D a (proj1_sig b) (proj2_sig b) | E _ _ _ d } } }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : { a : A & B a } & C _ (projT2 a) & C' _ (projT2 a) }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : { a : A & B a } | C _ (projT2 a) & C' _ (projT2 a) }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. +End inversion_sigma. diff --git a/test-suite/success/LetIn.v b/test-suite/success/LetIn.v new file mode 100644 index 0000000000..b61ea784b9 --- /dev/null +++ b/test-suite/success/LetIn.v @@ -0,0 +1,11 @@ +(* Simple let-in's *) +Definition l1 := let P := 0 in P. +Definition l2 := let P := nat in P. +Definition l3 := let P := True in P. +Definition l4 := let P := Prop in P. +Definition l5 := let P := Type in P. + +(* Check casting of let-in *) +Definition l6 := let P := 0:nat in P. +Definition l7 := let P := True:Prop in P. +Definition l8 := let P := True:Type in P. diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v new file mode 100644 index 0000000000..0e557aee07 --- /dev/null +++ b/test-suite/success/LetPat.v @@ -0,0 +1,55 @@ +(* Simple let-patterns *) +Variable A B : Type. + +Definition l1 (t : A * B * B) : A := let '(x, y, z) := t in x. +Print l1. +Definition l2 (t : (A * B) * B) : A := let '((x, y), z) := t in x. +Definition l3 (t : A * (B * B)) : A := let '(x, (y, z)) := t in x. +Print l3. + +Record someT (A : Type) := mkT { a : nat; b: A }. + +Definition l4 A (t : someT A) : nat := let 'mkT _ x y := t in x. +Print l4. +Print sigT. + +Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := + let 'existT _ x y := t return B (projT1 t) in y. + +Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := + let 'existT _ x y as t' := t return B (projT1 t') in y. + +Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := + let 'existT _ x y as t' in sigT _ := t return B (projT1 t') in y. + +Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := + match t with + existT _ x y => y + end. + +(** An example from algebra, using let' and inference of return clauses + to deconstruct contexts. *) + +Record a_category (A : Type) (hom : A -> A -> Type) := { }. + +Definition category := { A : Type & { hom : A -> A -> Type & a_category A hom } }. + +Record a_functor (A : Type) (hom : A -> A -> Type) (C : a_category A hom) := { }. + +Notation " x :& y " := (@existT _ _ x y) (right associativity, at level 55) : core_scope. + +Definition functor (c d : category) := + let ' A :& homA :& CA := c in + let ' B :& homB :& CB := d in + A -> B. + +Definition identity_functor (c : category) : functor c c := + let 'A :& homA :& CA := c in + fun x => x. + +Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c := + let 'A :& homA :& CA := a in + let 'B :& homB :& CB := b in + let 'C :& homB :& CB := c in + fun f g => + fun x => g (f x). diff --git a/test-suite/success/LraTest.v b/test-suite/success/LraTest.v new file mode 100644 index 0000000000..bf3a87da25 --- /dev/null +++ b/test-suite/success/LraTest.v @@ -0,0 +1,14 @@ +Require Import Reals. +Require Import Lra. + +Open Scope R_scope. + +Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). +intros; split_Rabs; lra. +Qed. + +Lemma l2 : + forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1. +intros. +split_Rabs; lra. +Qed. diff --git a/test-suite/success/LtacDeprecation.v b/test-suite/success/LtacDeprecation.v new file mode 100644 index 0000000000..633a5e4749 --- /dev/null +++ b/test-suite/success/LtacDeprecation.v @@ -0,0 +1,32 @@ +Set Warnings "+deprecated". + +#[deprecated(since = "8.8", note = "Use idtac instead")] +Ltac foo x := idtac. + +Goal True. +Fail (foo true). +Abort. + +Fail Ltac bar := foo. +Fail Tactic Notation "bar" := foo. + +#[deprecated(since = "8.8", note = "Use idtac instead")] +Tactic Notation "bar" := idtac. + +Goal True. +Fail bar. +Abort. + +Fail Ltac zar := bar. + +Set Warnings "-deprecated". + +Ltac zar := foo. +Ltac zarzar := bar. + +Set Warnings "+deprecated". + +Goal True. +zar x. +zarzar. +Abort. diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v new file mode 100644 index 0000000000..8462d36272 --- /dev/null +++ b/test-suite/success/MatchFail.v @@ -0,0 +1,29 @@ +Require Export ZArith. +Require Export ZArithRing. + +(* Cette tactique a pour objectif de remplacer toute instance + de (POS (xI e)) ou de (POS (xO e)) par + 2*(POS e)+1 ou 2*(POS e), pour rendre les expressions plus + à même d'être utilisées par Ring, lorsque ces expressions contiennent + des variables de type positive. *) +Ltac compute_POS := + match goal with + | |- context [(Zpos (xI ?X1))] => + let v := constr:(X1) in + match constr:(v) with + | 1%positive => fail 1 + | _ => rewrite (BinInt.Pos2Z.inj_xI v) + end + | |- context [(Zpos (xO ?X1))] => + let v := constr:(X1) in + match constr:(v) with + | 1%positive => fail 1 + | _ => rewrite (BinInt.Pos2Z.inj_xO v) + end + end. + +Goal forall x : positive, Zpos (xI (xI x)) = (4 * Zpos x + 3)%Z. +intros. +repeat compute_POS. + ring. +Qed. diff --git a/test-suite/success/Mod_ltac.v b/test-suite/success/Mod_ltac.v new file mode 100644 index 0000000000..44bb3a55ec --- /dev/null +++ b/test-suite/success/Mod_ltac.v @@ -0,0 +1,20 @@ +(* Submitted by Houda Anoun *) + +Module toto. +Ltac titi := auto. +End toto. + +Module ti. +Import toto. +Ltac equal := match goal with + | |- (?X1 = ?X1) => titi + | |- _ => idtac + end. + +End ti. + +Import ti. +Definition simple : forall a : nat, a = a. +intro. +equal. +Qed. diff --git a/test-suite/success/Mod_params.v b/test-suite/success/Mod_params.v new file mode 100644 index 0000000000..5151616601 --- /dev/null +++ b/test-suite/success/Mod_params.v @@ -0,0 +1,50 @@ +(* Syntax test - all possible kinds of module parameters *) + +Module Type SIG. +End SIG. + +Module Type FSIG (X: SIG). +End FSIG. + +Module F (X: SIG). +End F. + +Module Q. +End Q. + +(* +#trace Nametab.push;; +#trace Nametab.push_short_name;; +#trace Nametab.freeze;; +#trace Nametab.unfreeze;; +#trace Nametab.exists_cci;; +*) + +Module M01. End M01. +Module M02 (X: SIG). End M02. +Module M03 (X Y: SIG). End M03. +Module M04 (X: SIG) (Y: SIG). End M04. +Module M05 (X Y: SIG) (Z1 Z: SIG). End M05. +Module M06 (X: SIG) (Y: SIG). End M06. +Module M07 (X Y: SIG) (Z1 Z: SIG). End M07. +Module M08 : SIG. End M08. +Module M09 (X: SIG) : SIG. End M09. +Module M10 (X Y: SIG) : SIG. End M10. +Module M11 (X: SIG) (Y: SIG) : SIG. End M11. +Module M12 (X Y: SIG) (Z1 Z: SIG) : SIG. End M12. +Module M13 (X: SIG) (Y: SIG) : SIG. End M13. +Module M14 (X Y: SIG) (Z1 Z: SIG) : SIG. End M14. +Module M15 := F Q. +Module M16 (X: FSIG) := X Q. +Module M17 (X Y: FSIG) := X Q. +Module M18 (X: FSIG) (Y: SIG) := X Y. +Module M19 (X Y: FSIG) (Z1 Z: SIG) := X Z. +Module M20 (X: FSIG) (Y: SIG) := X Y. +Module M21 (X Y: FSIG) (Z1 Z: SIG) := X Z. +Module M22 : SIG := F Q. +Module M23 (X: FSIG) : SIG := X Q. +Module M24 (X Y: FSIG) : SIG := X Q. +Module M25 (X: FSIG) (Y: SIG) : SIG := X Y. +Module M26 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. +Module M27 (X: FSIG) (Y: SIG) : SIG := X Y. +Module M28 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. diff --git a/test-suite/success/Mod_strengthen.v b/test-suite/success/Mod_strengthen.v new file mode 100644 index 0000000000..449610be65 --- /dev/null +++ b/test-suite/success/Mod_strengthen.v @@ -0,0 +1,67 @@ +Module Type Sub. + Axiom Refl1 : forall x : nat, x = x. + Axiom Refl2 : forall x : nat, x = x. + Axiom Refl3 : forall x : nat, x = x. + Inductive T : Set := + A : T. +End Sub. + +Module Type Main. + Declare Module M: Sub. +End Main. + + +Module A <: Main. + Module M <: Sub. + Lemma Refl1 : forall x : nat, x = x. + intros; reflexivity. + Qed. + Axiom Refl2 : forall x : nat, x = x. + Lemma Refl3 : forall x : nat, x = x. + intros; reflexivity. + Defined. + Inductive T : Set := + A : T. + End M. +End A. + + + +(* first test *) + +Module F (S: Sub). + Module M := S. +End F. + +Module B <: Main with Module M:=A.M := F A.M. + + + +(* second test *) + +Lemma r1 : (A.M.Refl1 = B.M.Refl1). +Proof. + reflexivity. +Qed. + +Lemma r2 : (A.M.Refl2 = B.M.Refl2). +Proof. + reflexivity. +Qed. + +Lemma r3 : (A.M.Refl3 = B.M.Refl3). +Proof. + reflexivity. +Qed. + +Lemma t : (A.M.T = B.M.T). +Proof. + reflexivity. +Qed. + +Lemma a : (A.M.A = B.M.A). +Proof. + reflexivity. +Qed. + + diff --git a/test-suite/success/Mod_type.v b/test-suite/success/Mod_type.v new file mode 100644 index 0000000000..6c59bf6edb --- /dev/null +++ b/test-suite/success/Mod_type.v @@ -0,0 +1,31 @@ +(* Check BZ#1025 submitted by Pierre-Luc Carmel Biron *) + +Module Type FOO. + Parameter A : Type. +End FOO. + +Module Type BAR. + Declare Module Foo : FOO. +End BAR. + +Module Bar : BAR. + + Module Fu : FOO. + Definition A := Prop. + End Fu. + + Module Foo := Fu. + +End Bar. + +(* Check BZ#2809: correct printing of modules with notations *) + +Module C. + Inductive test : Type := + | c1 : test + | c2 : nat -> test. + + Notation "! x" := (c2 x) (at level 50). +End C. + +Print C. (* Should print test_rect without failing *) diff --git a/test-suite/success/NatRing.v b/test-suite/success/NatRing.v new file mode 100644 index 0000000000..22d021d543 --- /dev/null +++ b/test-suite/success/NatRing.v @@ -0,0 +1,10 @@ +Require Import ArithRing. + +Lemma l1 : 2 = 1 + 1. +ring. +Qed. + +Lemma l2 : forall x : nat, S (S x) = 1 + S x. +intro. +ring. +Qed. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v new file mode 100644 index 0000000000..3c0ad20700 --- /dev/null +++ b/test-suite/success/Notations.v @@ -0,0 +1,155 @@ +(* Check that "where" clause behaves as if given independently of the *) +(* definition (variant of BZ#1132 submitted by Assia Mahboubi) *) + +Fixpoint plus1 (n m:nat) {struct n} : nat := + match n with + | O => m + | S p => S (p+m) + end + where "n + m" := (plus1 n m) : nat_scope. + +(* Check behaviour wrt yet empty levels (see Stephane's bug #1850) *) + +Parameter P : Type -> Type -> Type -> Type. +Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). +Check (nat |= nat --> nat). + +(* Check that first non empty definition at an empty level can be of any + associativity *) + +Module Type v1. +Notation "x +1" := (S x) (at level 8, left associativity). +End v1. +Module Type v2. +Notation "x +1" := (S x) (at level 8, right associativity). +End v2. + +(* Check that empty levels (here 8 and 2 in pattern) are added in the + right order *) + +Notation "' 'C_' G ( A )" := (A,G) (at level 8, G at level 2). + +(* Check import of notations from within a section *) + +Notation "+1 x" := (S x) (at level 25, x at level 9). +Section A. Require Import make_notation. End A. + +(* Check use of "$" (see bug #1961) *) + +Notation "$ x" := (id x) (at level 30). +Check ($ 5). + +(* Check regression of bug #2087 *) + +Notation "'exists' x , P" := (x, P) + (at level 200, x ident, right associativity, only parsing). + +Definition foo P := let '(exists x, Q) := P in x = Q :> nat. + +(* Check empty levels when extending binder_constr *) + +Notation "'exists' x >= y , P" := (exists x, x >= y /\ P)%nat + (at level 200, x ident, right associativity, y at level 69). + +(* This used to loop at some time before r12491 *) + +Notation R x := (@pair _ _ x). +Check (fun x:nat*nat => match x with R x y => (x,y) end). + +(* Check multi-tokens recursive notations *) + +Local Notation "[ a # ; .. # ; b ]" := (a + .. (b + 0) ..). +Check [ 0 ]. +Check [ 0 # ; 1 ]. + +(* Check well-scoping of alpha-renaming of private binders *) +(* see bug #2248 (thanks to Marc Lasson) *) + +Notation "{ q , r | P }" := (fun (p:nat*nat) => let (q, r) := p in P). +Check (fun p => {q,r| q + r = p}). + +(* Check that declarations of empty levels are correctly backtracked *) + +Section B. +Notation "*" := 5 (at level 0) : nat_scope. +Notation "[ h ] p" := (h + p) (at level 8, p at level 9, h at level 7) : nat_scope. +End B. + +(* Should succeed *) +Definition n := 5 * 5. + +(* Check that lonely notations (here FOO) do not modify the visibility + of scoped interpretations (bug #2634 fixed in r14819) *) + +Notation "x ++++ y" := (mult x y) (at level 40). +Notation "x ++++ y" := (plus x y) : A_scope. +Open Scope A_scope. +Notation "'FOO' x" := (S x) (at level 40). +Goal (2 ++++ 3) = 5. +reflexivity. +Abort. + +(* Check correct failure handling when a non-constructor notation is + used in cases pattern (bug #2724 in 8.3 and 8.4beta) *) + +Notation "'FORALL' x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + +Fail Check fun x => match x with S (FORALL x, _) => 0 end. + +(* Bug #2708: don't check for scope of variables used as binder *) + +Parameter traverse : (nat -> unit) -> (nat -> unit). +Notation traverse_var f l := (traverse (fun l => f l) l). + +(* Check that when an ident become a keyword, it does not break + previous rules relying on the string to be classified as an ident *) + +Notation "'intros' x" := (S x) (at level 0). +Goal True -> True. intros H. exact H. Qed. + +(* Check absence of collision on ".." in nested notations with ".." *) +Notation "[ a , .. , b ]" := (a, (.. (b,tt) ..)). + +(* Check that vector notations do not break Ltac [] (bugs #4785, #4733) *) +Require Import Coq.Vectors.VectorDef. +Import VectorNotations. +Goal True. idtac; []. (* important for test: no space here *) constructor. Qed. + +(* Check parsing of { and } is not affected by notations #3479 *) +Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10). +Goal True. +{{ exact I. }} +Qed. + +Check |- {{ 0 }} 0. + +(* Check parsing of { and } is not affected by notations #3479 *) +Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10). +Goal True. +{{ exact I. }} +Qed. + +(* Check that we can have notations without any symbol iff they are "only printing". *) +Fail Notation "" := (@nil). +Notation "" := (@nil) (only printing). + +(* Check that a notation cannot be neither parsing nor printing. *) +Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing). + +(* Check "where" clause for inductive types with parameters *) + +Reserved Notation "x === y" (at level 50). +Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x + where "x === y" := (EQ x y). + +(* Check that strictly ident or _ are coerced to a name *) + +Fail Check {x@{u},y|x=x}. +Fail Check {?[n],y|0=0}. + +(* Check that 10 is well declared left associative *) + +Section C. +Notation "f $$$ x" := (id f x) (at level 10, left associativity). +End C. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v new file mode 100644 index 0000000000..1b33863e3b --- /dev/null +++ b/test-suite/success/Notations2.v @@ -0,0 +1,156 @@ +(* This file is giving some examples about how implicit arguments and + scopes are treated when using abbreviations or notations, in terms + or patterns, or when using @ and parentheses in terms and patterns. + +The convention is: + +Constant foo with implicit arguments and scopes used in a term or a pattern: + + foo do not deactivate further arguments and scopes + @foo deactivates further arguments and scopes + (foo x) deactivates further arguments and scopes + (@foo x) deactivates further arguments and scopes + +Notations binding to foo: + +# := foo do not deactivate further arguments and scopes +# := @foo deactivates further arguments and scopes +# x := foo x deactivates further arguments and scopes +# x := @foo x deactivates further arguments and scopes + +Abbreviations binding to foo: + +f := foo do not deactivate further arguments and scopes +f := @foo deactivates further arguments and scopes +f x := foo x do not deactivate further arguments and scopes +f x := @foo x do not deactivate further arguments and scopes +*) + +(* One checks that abbreviations and notations in patterns now behave like in terms *) + +Inductive prod' A : Type -> Type := +| pair' (a:A) B (b:B) (c:bool) : prod' A B. +Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. +Notation "0" := true : bool_scope. + +(* 1. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c1 x := (pair' x). +Check pair' 0 0 0 : prod' bool bool. +Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c1 0 0 0 : prod' bool bool. +Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. + +(* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c2 x := (@pair' _ x). +Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c2 0 0 0 : prod' bool bool. +Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ => 1 end. + +(* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c3 x := ((@pair') _ x). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *) +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) +Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) +Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. + +(* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +(* unless an atomic @ is given *) +Notation c4 := (@pair'). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check c4 _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with c4 _ 0%bool _ y 0%bool => 2 | _ => 1 end. +Check fun A (x :prod' bool A) => match x with (@pair') _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "# x" := (pair' x) (at level 0, x at level 1). +Check pair' 0 0 0 : prod' bool bool. +Check # 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with # 0 _ y 0%bool => 2 | _ => 1 end. + +(* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "## x" := ((@pair') _ x) (at level 0, x at level 1). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. +Check ## 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ## 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 7. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "###" := (@pair') (at level 0). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ### _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ### _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 8. Notations w/o @ preserves implicit arguments and scopes *) +Notation "####" := pair' (at level 0). +Check #### 0 0 0 : prod' bool bool. +Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end. + +(* 9. Notations w/o @ but arguments do not preserve further implicit arguments and scopes *) +Notation "##### x" := (pair' x) (at level 0, x at level 1). +Check ##### 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. + +(* 10. Check computation of binding variable through other notations *) +(* it should be detected as binding variable and the scopes not being checked *) +Notation "'FUNNAT' i => t" := (fun i : nat => i = t) (at level 200). +Notation "'Funnat' i => t" := (FUNNAT i => t + i%nat) (at level 200). + +(* 11. Notations with needed factorization of a recursive pattern *) +(* See https://github.com/coq/coq/issues/6078#issuecomment-342287412 *) +Module M11. +Notation "[:: x1 ; .. ; xn & s ]" := (cons x1 .. (cons xn s) ..). +Notation "[:: x1 ; .. ; xn ]" := (cons x1 .. (cons xn nil) ..). +Check [:: 1 ; 2 ; 3 ]. +Check [:: 1 ; 2 ; 3 & nil ]. (* was failing *) +End M11. + +(* 12. Preventively check that a variable which does not occur can be instantiated *) +(* by any term. In particular, it should not be restricted to a binder *) +Module M12. +Notation "N ++ x" := (S x) (only parsing). +Check 2 ++ 0. +End M12. + +(* 13. Check that internal data about associativity are not used in comparing levels *) +Module M13. +Notation "x ;; z" := (x + z) + (at level 100, z at level 200, only parsing, right associativity). +Notation "x ;; z" := (x * z) + (at level 100, z at level 200, only parsing) : foo_scope. +End M13. + +(* 14. Check that a notation with a "ident" binder does not include a pattern *) +Module M14. +Notation "'myexists' x , p" := (ex (fun x => p)) + (at level 200, x ident, p at level 200, right associativity) : type_scope. +Check myexists I, I = 0. (* Should not be seen as a constructor *) +End M14. + +(* 15. Testing different ways to give the same levels without failing *) + +Module M15. + Local Notation "###### x" := (S x) (right associativity, at level 79, x at next level). + Fail Local Notation "###### x" := (S x) (right associativity, at level 79). + Local Notation "###### x" := (S x) (at level 79). +End M15. + +(* 16. Some test about custom entries *) +Module M16. + (* Test locality *) + Local Declare Custom Entry foo. + Fail Notation "#" := 0 (in custom foo). (* Should be local *) + Local Notation "#" := 0 (in custom foo). + + (* Test import *) + Module A. + Declare Custom Entry foo2. + End A. + Fail Notation "##" := 0 (in custom foo2). + Import A. + Local Notation "##" := 0 (in custom foo2). + + (* Test Print Grammar *) + Print Grammar foo. + Print Grammar foo2. +End M16. diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v new file mode 100644 index 0000000000..e38affd7fa --- /dev/null +++ b/test-suite/success/Nsatz.v @@ -0,0 +1,535 @@ +Require Import TestSuite.admit. +(* compile en user 3m39.915s sur cachalot *) +Require Import Nsatz. + +(* Example with a generic domain *) + +Section test. + +Context {A:Type}`{Aid:Integral_domain A}. + +Lemma example3 : forall x y z, + x+y+z==0 -> + x*y+x*z+y*z==0-> + x*y*z==0 -> x^3%Z==0. +Proof. +Time nsatz. +Qed. + +Lemma example4 : forall x y z u, + x+y+z+u==0 -> + x*y+x*z+x*u+y*z+y*u+z*u==0-> + x*y*z+x*y*u+x*z*u+y*z*u==0-> + x*y*z*u==0 -> x^4%Z==0. +Proof. +Time nsatz. +Qed. + +Lemma example5 : forall x y z u v, + x+y+z+u+v==0 -> + x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0-> + x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0-> + x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 -> + x*y*z*u*v==0 -> x^5%Z==0. +Proof. +Time nsatz. +Qed. + +Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z. +nsatz. +Qed. + +Require Import Reals. + +Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R. +nsatz. +Qed. + +Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R. +nsatz. +Qed. + +End test. + +Section Geometry. +(* See the interactive pictures of Laurent Théry + on http://www-sop.inria.fr/marelle/CertiGeo/ + and research paper on + https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr +*) + +Require Import List. +Require Import Reals. + +Record point:Type:={ + X:R; + Y:R}. + +Definition collinear(A B C:point):= + (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0. + +Definition parallel (A B C D:point):= + ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)). + +Definition notparallel (A B C D:point)(x:R):= + x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1. + +Definition orthogonal (A B C D:point):= + ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0. + +Definition equal2(A B:point):= + (X A)=(X B) /\ (Y A)=(Y B). + +Definition equal3(A B:point):= + ((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0. + +Definition nequal2(A B:point):= + (X A)<>(X B) \/ (Y A)<>(Y B). + +Definition nequal3(A B:point):= + not (((X A)-(X B))^2%Z+((Y A)-(Y B))^2%Z = 0). + +Definition middle(A B I:point):= + 2%R*(X I)=(X A)+(X B) /\ 2%R*(Y I)=(Y A)+(Y B). + +Definition distance2(A B:point):= + (X B - X A)^2%Z + (Y B - Y A)^2%Z. + +(* AB = CD *) +Definition samedistance2(A B C D:point):= + (X B - X A)^2%Z + (Y B - Y A)^2%Z = (X D - X C)^2%Z + (Y D - Y C)^2%Z. +Definition determinant(A O B:point):= + (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O). +Definition scalarproduct(A O B:point):= + (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O). +Definition norm2(A O B:point):= + ((X A - X O)^2%Z+(Y A - Y O)^2%Z)*((X B - X O)^2%Z+(Y B - Y O)^2%Z). + +Definition equaldistance(A B C D:point):= + ((X B) - (X A))^2%Z + ((Y B) - (Y A))^2%Z = + ((X D) - (X C))^2%Z + ((Y D) - (Y C))^2%Z. + +Definition equaltangente(A B C D E F:point):= + let s1:= determinant A B C in + let c1:= scalarproduct A B C in + let s2:= determinant D E F in + let c2:= scalarproduct D E F in + s1 * c2 = s2 * c1. + +Ltac cnf2 f := + match f with + | ?A \/ (?B /\ ?C) => + let c1 := cnf2 (A\/B) in + let c2 := cnf2 (A\/C) in constr:(c1/\c2) + | (?B /\ ?C) \/ ?A => + let c1 := cnf2 (B\/A) in + let c2 := cnf2 (C\/A) in constr:(c1/\c2) + | (?A \/ ?B) \/ ?C => + let c1 := cnf2 (B\/C) in cnf2 (A \/ c1) + | _ => f + end +with cnf f := + match f with + | ?A \/ ?B => + let c1 := cnf A in + let c2 := cnf B in + cnf2 (c1 \/ c2) + | ?A /\ ?B => + let c1 := cnf A in + let c2 := cnf B in + constr:(c1 /\ c2) + | _ => f + end. + +Ltac scnf := + match goal with + | |- ?f => let c := cnf f in + assert c;[repeat split| tauto] + end. + +Ltac disj_to_pol f := + match f with + | ?a = ?b \/ ?g => let p := disj_to_pol g in constr:((a - b)* p) + | ?a = ?b => constr:(a - b) + end. + +Lemma fastnsatz1:forall x y:R, x - y = 0 -> x = y. +nsatz. +Qed. + +Ltac fastnsatz:= + try trivial; try apply fastnsatz1; try trivial; nsatz. + +Ltac proof_pol_disj := + match goal with + | |- ?g => let p := disj_to_pol g in + let h := fresh "hp" in + assert (h:p = 0); + [idtac| + prod_disj h p] + | _ => idtac + end +with prod_disj h p := + match goal with + | |- ?a = ?b \/ ?g => + match p with + | ?q * ?p1 => + let h0 := fresh "hp" in + let h1 := fresh "hp" in + let h2 := fresh "hp" in + assert (h0:a - b = 0 \/ p1 = 0); + [apply Rmult_integral; exact h| + destruct h0 as [h1|h2]; + [left; fastnsatz| + right; prod_disj h2 p1]] + end + | _ => fastnsatz + end. + +(* +Goal forall a b c d e f:R, a=b \/ c=d \/ e=f \/ e=a. +intros. scnf; proof_pol_disj . +admit.*) + +Ltac geo_unfold := + unfold collinear, parallel, notparallel, orthogonal, + equal2, equal3, nequal2, nequal3, + middle, samedistance2, + determinant, scalarproduct, norm2, distance2, + equaltangente, determinant, scalarproduct, equaldistance. + +Ltac geo_rewrite_hyps:= + repeat (match goal with + | h:X _ = _ |- _ => rewrite h in *; clear h + | h:Y _ = _ |- _ => rewrite h in *; clear h + end). + +Ltac geo_split_hyps:= + repeat (match goal with + | h:_ /\ _ |- _ => destruct h + end). + +Ltac geo_begin:= + geo_unfold; + intros; + geo_rewrite_hyps; + geo_split_hyps; + scnf; proof_pol_disj. + +(* Examples *) + +Lemma medians: forall A B C A1 B1 C1 H:point, + middle B C A1 -> + middle A C B1 -> + middle A B C1 -> + collinear A A1 H -> collinear B B1 H -> + collinear C C1 H + \/ collinear A B C. +Proof. geo_begin. +idtac "Medians". + Time nsatz. +(*Finished transaction in 2. secs (2.69359u,0.s) +*) Qed. + +Lemma Pythagore: forall A B C:point, + orthogonal A B A C -> + distance2 A C + distance2 A B = distance2 B C. +Proof. geo_begin. +idtac "Pythagore". +Time nsatz. +(*Finished transaction in 0. secs (0.354946u,0.s) +*) Qed. + +Lemma Thales: forall O A B C D:point, + collinear O A C -> collinear O B D -> + parallel A B C D -> + (distance2 O B * distance2 O C = distance2 O D * distance2 O A + /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B) + \/ collinear O A B. +geo_begin. +idtac "Thales". +Time nsatz. (*Finished transaction in 2. secs (1.598757u,0.s)*) +Time nsatz. +Qed. + +Lemma segments_of_chords: forall A B C D M O:point, + equaldistance O A O B -> + equaldistance O A O C -> + equaldistance O A O D -> + collinear A B M -> + collinear C D M -> + (distance2 M A) * (distance2 M B) = (distance2 M C) * (distance2 M D) + \/ parallel A B C D. +Proof. +geo_begin. +idtac "segments_of_chords". +Time nsatz. +(*Finished transaction in 3. secs (2.704589u,0.s) +*) Qed. + + +Lemma isoceles: forall A B C:point, + equaltangente A B C B C A -> + distance2 A B = distance2 A C + \/ collinear A B C. +Proof. geo_begin. Time nsatz. +(*Finished transaction in 1. secs (1.140827u,0.s)*) Qed. + +Lemma minh: forall A B C D O E H I:point, + X A = 0 -> Y A = 0 -> Y O = 0 -> + equaldistance O A O B -> + equaldistance O A O C -> + equaldistance O A O D -> + orthogonal A C B D -> + collinear A C E -> + collinear B D E -> + collinear A B H -> + orthogonal E H A B -> + collinear C D I -> + middle C D I -> + collinear H E I + \/ (X C)^2%Z * (X B)^5%Z * (X O)^2%Z + * (X C - 2%Z * X O)^3%Z * (-2%Z * X O + X B)=0 + \/ parallel A C B D. +Proof. geo_begin. +idtac "minh". +Time nsatz with radicalmax :=1%N strategy:=1%Z + parameters:=(X O::X B::X C::nil) + variables:= (@nil R). +(*Finished transaction in 13. secs (10.102464u,0.s) +*) +Qed. + +Lemma Pappus: forall A B C A1 B1 C1 P Q S:point, + X A = 0 -> Y A = 0 -> Y B = 0 -> Y C = 0 -> + collinear A1 B1 C1 -> + collinear A B1 P -> collinear A1 B P -> + collinear A C1 Q -> collinear A1 C Q -> + collinear B C1 S -> collinear B1 C S -> + collinear P Q S + \/ (Y A1 - Y B1)^2%Z=0 \/ (X A = X B1) + \/ (X A1 = X C) \/ (X C = X B1) + \/ parallel A B1 A1 B \/ parallel A C1 A1 C \/ parallel B C1 B1 C. +Proof. +geo_begin. +idtac "Pappus". +Time nsatz with radicalmax :=1%N strategy:=0%Z + parameters:=(X B::X A1::Y A1::X B1::Y B1::X C::Y C1::nil) + variables:= (X B + :: X A1 + :: Y A1 + :: X B1 + :: Y B1 + :: X C + :: Y C1 + :: X C1 :: Y P :: X P :: Y Q :: X Q :: Y S :: X S :: nil). +(*Finished transaction in 8. secs (7.795815u,0.000999999999999s) +*) +Qed. + +Lemma Simson: forall A B C O D E F G:point, + X A = 0 -> Y A = 0 -> + equaldistance O A O B -> + equaldistance O A O C -> + equaldistance O A O D -> + orthogonal E D B C -> + collinear B C E -> + orthogonal F D A C -> + collinear A C F -> + orthogonal G D A B -> + collinear A B G -> + collinear E F G + \/ (X C)^2%Z = 0 \/ (Y C)^2%Z = 0 \/ (X B)^2%Z = 0 \/ (Y B)^2%Z = 0 \/ (Y C - Y B)^2%Z = 0 + \/ equal3 B A + \/ equal3 A C \/ (X C - X B)^2%Z = 0 + \/ equal3 B C. +Proof. +geo_begin. +idtac "Simson". +Time nsatz with radicalmax :=1%N strategy:=0%Z + parameters:=(X B::Y B::X C::Y C::Y D::nil) + variables:= (@nil R). (* compute -[X Y]. *) +(*Finished transaction in 8. secs (7.550852u,0.s) +*) +Qed. + +Lemma threepoints: forall A B C A1 B1 A2 B2 H1 H2 H3:point, + (* H1 intersection of bisections *) + middle B C A1 -> orthogonal H1 A1 B C -> + middle A C B1 -> orthogonal H1 B1 A C -> + (* H2 intersection of medians *) + collinear A A1 H2 -> collinear B B1 H2 -> + (* H3 intersection of altitudes *) + collinear B C A2 -> orthogonal A A2 B C -> + collinear A C B2 -> orthogonal B B2 A C -> + collinear A A1 H3 -> collinear B B1 H3 -> + collinear H1 H2 H3 + \/ collinear A B C. +Proof. geo_begin. +idtac "threepoints". +Time nsatz. +(*Finished transaction in 7. secs (6.282045u,0.s) +*) Qed. + +Lemma Feuerbach: forall A B C A1 B1 C1 O A2 B2 C2 O2:point, + forall r r2:R, + X A = 0 -> Y A = 0 -> X B = 1 -> Y B = 0-> + middle A B C1 -> middle B C A1 -> middle C A B1 -> + distance2 O A1 = distance2 O B1 -> + distance2 O A1 = distance2 O C1 -> + collinear A B C2 -> orthogonal A B O2 C2 -> + collinear B C A2 -> orthogonal B C O2 A2 -> + collinear A C B2 -> orthogonal A C O2 B2 -> + distance2 O2 A2 = distance2 O2 B2 -> + distance2 O2 A2 = distance2 O2 C2 -> + r^2%Z = distance2 O A1 -> + r2^2%Z = distance2 O2 A2 -> + distance2 O O2 = (r + r2)^2%Z + \/ distance2 O O2 = (r - r2)^2%Z + \/ collinear A B C. +Proof. geo_begin. +idtac "Feuerbach". +Time nsatz. +(*Finished transaction in 21. secs (19.021109u,0.s)*) +Qed. + + + + +Lemma Euler_circle: forall A B C A1 B1 C1 A2 B2 C2 O:point, + middle A B C1 -> middle B C A1 -> middle C A B1 -> + orthogonal A B C C2 -> collinear A B C2 -> + orthogonal B C A A2 -> collinear B C A2 -> + orthogonal A C B B2 -> collinear A C B2 -> + distance2 O A1 = distance2 O B1 -> + distance2 O A1 = distance2 O C1 -> + (distance2 O A2 = distance2 O A1 + /\distance2 O B2 = distance2 O A1 + /\distance2 O C2 = distance2 O A1) + \/ collinear A B C. +Proof. geo_begin. +idtac "Euler_circle 3 goals". +Time nsatz. +(*Finished transaction in 13. secs (11.208296u,0.124981s)*) +Time nsatz. +(*Finished transaction in 10. secs (8.846655u,0.s)*) +Time nsatz. +(*Finished transaction in 11. secs (9.186603u,0.s)*) +Qed. + + + +Lemma Desargues: forall A B C A1 B1 C1 P Q R S:point, + X S = 0 -> Y S = 0 -> Y A = 0 -> + collinear A S A1 -> collinear B S B1 -> collinear C S C1 -> + collinear B1 C1 P -> collinear B C P -> + collinear A1 C1 Q -> collinear A C Q -> + collinear A1 B1 R -> collinear A B R -> + collinear P Q R + \/ X A = X B \/ X A = X C \/ X B = X C \/ X A = 0 \/ Y B = 0 \/ Y C = 0 + \/ collinear S B C \/ parallel A C A1 C1 \/ parallel A B A1 B1. +Proof. +geo_begin. +idtac "Desargues". +Time +let lv := rev (X A + :: X B + :: Y B + :: X C + :: Y C + :: Y A1 :: X A1 + :: Y B1 + :: Y C1 + :: X R + :: Y R + :: X Q + :: Y Q :: X P :: Y P :: X C1 :: X B1 :: nil) in +nsatz with radicalmax :=1%N strategy:=0%Z + parameters:=(X A::X B::Y B::X C::Y C::X A1::Y B1::Y C1::nil) + variables:= lv. (*Finished transaction in 8. secs (8.02578u,0.001s)*) +Qed. + +Lemma chords: forall O A B C D M:point, + equaldistance O A O B -> + equaldistance O A O C -> + equaldistance O A O D -> + collinear A B M -> collinear C D M -> + scalarproduct A M B = scalarproduct C M D + \/ parallel A B C D. +Proof. geo_begin. +idtac "chords". + Time nsatz. +(*Finished transaction in 4. secs (3.959398u,0.s)*) +Qed. + +Lemma Ceva: forall A B C D E F M:point, + collinear M A D -> collinear M B E -> collinear M C F -> + collinear B C D -> collinear E A C -> collinear F A B -> + (distance2 D B) * (distance2 E C) * (distance2 F A) = + (distance2 D C) * (distance2 E A) * (distance2 F B) + \/ collinear A B C. +Proof. geo_begin. +idtac "Ceva". +Time nsatz. +(*Finished transaction in 105. secs (104.121171u,0.474928s)*) +Qed. + +Lemma bissectrices: forall A B C M:point, + equaltangente C A M M A B -> + equaltangente A B M M B C -> + equaltangente B C M M C A + \/ equal3 A B. +Proof. geo_begin. +idtac "bissectrices". +Time nsatz. +(*Finished transaction in 2. secs (1.937705u,0.s)*) +Qed. + +Lemma bisections: forall A B C A1 B1 C1 H:point, + middle B C A1 -> orthogonal H A1 B C -> + middle A C B1 -> orthogonal H B1 A C -> + middle A B C1 -> + orthogonal H C1 A B + \/ collinear A B C. +Proof. geo_begin. +idtac "bisections". +Time nsatz. (*Finished transaction in 2. secs (2.024692u,0.002s)*) +Qed. + +Lemma altitudes: forall A B C A1 B1 C1 H:point, + collinear B C A1 -> orthogonal A A1 B C -> + collinear A C B1 -> orthogonal B B1 A C -> + collinear A B C1 -> orthogonal C C1 A B -> + collinear A A1 H -> collinear B B1 H -> + collinear C C1 H + \/ equal2 A B + \/ collinear A B C. +Proof. geo_begin. +idtac "altitudes". +Time nsatz. (*Finished transaction in 3. secs (3.001544u,0.s)*) +Time nsatz. (*Finished transaction in 4. secs (3.113527u,0.s)*) +Qed. + +Lemma hauteurs:forall A B C A1 B1 C1 H:point, + collinear B C A1 -> orthogonal A A1 B C -> + collinear A C B1 -> orthogonal B B1 A C -> + collinear A B C1 -> orthogonal C C1 A B -> + collinear A A1 H -> collinear B B1 H -> + + collinear C C1 H + \/ collinear A B C. + +geo_begin. +idtac "hauteurs". +Time + let lv := constr:(Y A1 + :: X A1 :: Y B1 :: X B1 :: Y A :: Y B :: X B :: X A :: X H :: Y C + :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in +nsatz with radicalmax := 2%N strategy := 1%Z parameters := (@Datatypes.nil R) + variables := lv. +(*Finished transaction in 5. secs (4.360337u,0.008999s)*) +Qed. + + +End Geometry. + diff --git a/test-suite/success/NumberScopes.v b/test-suite/success/NumberScopes.v new file mode 100644 index 0000000000..1558637476 --- /dev/null +++ b/test-suite/success/NumberScopes.v @@ -0,0 +1,41 @@ + +(* We check that various definitions or lemmas have the correct + argument scopes, especially the ones created via functor application. *) + +Close Scope nat_scope. + +Require Import PArith. +Check (Pos.add 1 2). +Check (Pos.add_comm 1 2). +Check (Pos.min_comm 1 2). +Definition f_pos (x:positive) := x. +Definition f_pos' (x:Pos.t) := x. +Check (f_pos 1). +Check (f_pos' 1). + +Require Import ZArith. +Check (Z.add 1 2). +Check (Z.add_comm 1 2). +Check (Z.min_comm 1 2). +Definition f_Z (x:Z) := x. +Definition f_Z' (x:Z.t) := x. +Check (f_Z 1). +Check (f_Z' 1). + +Require Import NArith. +Check (N.add 1 2). +Check (N.add_comm 1 2). +Check (N.min_comm 1 2). +Definition f_N (x:N) := x. +Definition f_N' (x:N.t) := x. +Check (f_N 1). +Check (f_N' 1). + +Require Import Arith. +Check (Nat.add 1 2). +Check (Nat.add_comm 1 2). +Check (Nat.min_comm 1 2). +Definition f_nat (x:nat) := x. +Definition f_nat' (x:Nat.t) := x. +Check (f_nat 1). +Check (f_nat' 1). diff --git a/test-suite/success/NumeralNotations.v b/test-suite/success/NumeralNotations.v new file mode 100644 index 0000000000..47ef381270 --- /dev/null +++ b/test-suite/success/NumeralNotations.v @@ -0,0 +1,302 @@ +(* Test that we fail, rather than raising anomalies, on opaque terms during interpretation *) + +(* https://github.com/coq/coq/pull/8064#discussion_r202497516 *) +Module Test1. + Axiom hold : forall {A B C}, A -> B -> C. + Definition opaque3 (x : Decimal.int) : Decimal.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). + Numeral Notation Decimal.int opaque3 opaque3 : opaque_scope. + Delimit Scope opaque_scope with opaque. + Fail Check 1%opaque. +End Test1. + +(* https://github.com/coq/coq/pull/8064#discussion_r202497990 *) +Module Test2. + Axiom opaque4 : option Decimal.int. + Definition opaque6 (x : Decimal.int) : option Decimal.int := opaque4. + Numeral Notation Decimal.int opaque6 opaque6 : opaque_scope. + Delimit Scope opaque_scope with opaque. + Open Scope opaque_scope. + Fail Check 1%opaque. +End Test2. + +Module Test3. + Inductive silly := SILLY (v : Decimal.uint) (f : forall A, A -> A). + Definition to_silly (v : Decimal.uint) := SILLY v (fun _ x => x). + Definition of_silly (v : silly) := match v with SILLY v _ => v end. + Numeral Notation silly to_silly of_silly : silly_scope. + Delimit Scope silly_scope with silly. + Fail Check 1%silly. +End Test3. + + +Module Test4. + Polymorphic NonCumulative Inductive punit := ptt. + Polymorphic Definition pto_punit (v : Decimal.uint) : option punit := match Nat.of_uint v with O => Some ptt | _ => None end. + Polymorphic Definition pto_punit_all (v : Decimal.uint) : punit := ptt. + Polymorphic Definition pof_punit (v : punit) : Decimal.uint := Nat.to_uint 0. + Definition to_punit (v : Decimal.uint) : option punit := match Nat.of_uint v with O => Some ptt | _ => None end. + Definition of_punit (v : punit) : Decimal.uint := Nat.to_uint 0. + Polymorphic Definition pto_unit (v : Decimal.uint) : option unit := match Nat.of_uint v with O => Some tt | _ => None end. + Polymorphic Definition pof_unit (v : unit) : Decimal.uint := Nat.to_uint 0. + Definition to_unit (v : Decimal.uint) : option unit := match Nat.of_uint v with O => Some tt | _ => None end. + Definition of_unit (v : unit) : Decimal.uint := Nat.to_uint 0. + Numeral Notation punit to_punit of_punit : pto. + Numeral Notation punit pto_punit of_punit : ppo. + Numeral Notation punit to_punit pof_punit : ptp. + Numeral Notation punit pto_punit pof_punit : ppp. + Numeral Notation unit to_unit of_unit : uto. + Delimit Scope pto with pto. + Delimit Scope ppo with ppo. + Delimit Scope ptp with ptp. + Delimit Scope ppp with ppp. + Delimit Scope uto with uto. + Check let v := 0%pto in v : punit. + Check let v := 0%ppo in v : punit. + Check let v := 0%ptp in v : punit. + Check let v := 0%ppp in v : punit. + Check let v := 0%uto in v : unit. + Fail Check 1%uto. + Fail Check (-1)%uto. + Numeral Notation unit pto_unit of_unit : upo. + Numeral Notation unit to_unit pof_unit : utp. + Numeral Notation unit pto_unit pof_unit : upp. + Delimit Scope upo with upo. + Delimit Scope utp with utp. + Delimit Scope upp with upp. + Check let v := 0%upo in v : unit. + Check let v := 0%utp in v : unit. + Check let v := 0%upp in v : unit. + + Polymorphic Definition pto_punits := pto_punit_all@{Set}. + Polymorphic Definition pof_punits := pof_punit@{Set}. + Numeral Notation punit pto_punits pof_punits : ppps (abstract after 1). + Delimit Scope ppps with ppps. + Universe u. + Constraint Set < u. + Check let v := 0%ppps in v : punit@{u}. (* Check that universes are refreshed *) + Fail Check let v := 1%ppps in v : punit@{u}. (* Note that universes are not refreshed here *) +End Test4. + +Module Test5. + Check S. (* At one point gave Error: Anomaly "Uncaught exception Pretype_errors.PretypeError(_, _, _)." Please report at http://coq.inria.fr/bugs/. *) +End Test5. + +Module Test6. + (* Check that numeral notations on enormous terms don't take forever to print/parse *) + (* Ackerman definition from https://stackoverflow.com/a/10303475/377022 *) + Fixpoint ack (n m : nat) : nat := + match n with + | O => S m + | S p => let fix ackn (m : nat) := + match m with + | O => ack p 1 + | S q => ack p (ackn q) + end + in ackn m + end. + + Timeout 1 Check (S (ack 4 4)). (* should be instantaneous *) + + Local Set Primitive Projections. + Record > wnat := wrap { unwrap :> nat }. + Definition to_uint (x : wnat) : Decimal.uint := Nat.to_uint x. + Definition of_uint (x : Decimal.uint) : wnat := Nat.of_uint x. + Module Export Scopes. + Delimit Scope wnat_scope with wnat. + End Scopes. + Module Export Notations. + Export Scopes. + Numeral Notation wnat of_uint to_uint : wnat_scope (abstract after 5000). + End Notations. + Check let v := 0%wnat in v : wnat. + Check wrap O. + Timeout 1 Check wrap (ack 4 4). (* should be instantaneous *) +End Test6. + +Module Test6_2. + Import Test6.Scopes. + Check Test6.wrap 0. + Import Test6.Notations. + Check let v := 0%wnat in v : Test6.wnat. +End Test6_2. + +Module Test7. + Local Set Primitive Projections. + Record wuint := wrap { unwrap : Decimal.uint }. + Delimit Scope wuint_scope with wuint. + Numeral Notation wuint wrap unwrap : wuint_scope. + Check let v := 0%wuint in v : wuint. + Check let v := 1%wuint in v : wuint. +End Test7. + +Module Test8. + Local Set Primitive Projections. + Record wuint := wrap { unwrap : Decimal.uint }. + Delimit Scope wuint8_scope with wuint8. + Delimit Scope wuint8'_scope with wuint8'. + Section with_var. + Context (dummy : unit). + Definition wrap' := let __ := dummy in wrap. + Definition unwrap' := let __ := dummy in unwrap. + Numeral Notation wuint wrap' unwrap' : wuint8_scope. + Check let v := 0%wuint8 in v : wuint. + End with_var. + Check let v := 0%wuint8 in v : nat. + Fail Check let v := 0%wuint8 in v : wuint. + Compute wrap (Nat.to_uint 0). + + Notation wrap'' := wrap. + Notation unwrap'' := unwrap. + Numeral Notation wuint wrap'' unwrap'' : wuint8'_scope. + Check let v := 0%wuint8' in v : wuint. +End Test8. + +Module Test9. + Delimit Scope wuint9_scope with wuint9. + Delimit Scope wuint9'_scope with wuint9'. + Section with_let. + Local Set Primitive Projections. + Record wuint := wrap { unwrap : Decimal.uint }. + Let wrap' := wrap. + Let unwrap' := unwrap. + Local Notation wrap'' := wrap. + Local Notation unwrap'' := unwrap. + Numeral Notation wuint wrap' unwrap' : wuint9_scope. + Check let v := 0%wuint9 in v : wuint. + Numeral Notation wuint wrap'' unwrap'' : wuint9'_scope. + Check let v := 0%wuint9' in v : wuint. + End with_let. + Check let v := 0%wuint9 in v : nat. + Fail Check let v := 0%wuint9 in v : wuint. +End Test9. + +Module Test10. + (* Test that it is only a warning to add abstract after to an optional parsing function *) + Definition to_uint (v : unit) := Nat.to_uint 0. + Definition of_uint (v : Decimal.uint) := match Nat.of_uint v with O => Some tt | _ => None end. + Definition of_any_uint (v : Decimal.uint) := tt. + Delimit Scope unit_scope with unit. + Delimit Scope unit2_scope with unit2. + Numeral Notation unit of_uint to_uint : unit_scope (abstract after 1). + Local Set Warnings Append "+abstract-large-number-no-op". + (* Check that there is actually a warning here *) + Fail Numeral Notation unit of_uint to_uint : unit2_scope (abstract after 1). + (* Check that there is no warning here *) + Numeral Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). +End Test10. + +Module Test11. + (* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) + Inductive unit11 := tt11. + Delimit Scope unit11_scope with unit11. + Goal True. + evar (to_uint : unit11 -> Decimal.uint). + evar (of_uint : Decimal.uint -> unit11). + Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. + exact I. + Unshelve. + all: solve [ constructor ]. + Qed. +End Test11. + +Module Test12. + (* Test for numeral notations on context variables *) + Delimit Scope test12_scope with test12. + Section test12. + Context (to_uint : unit -> Decimal.uint) (of_uint : Decimal.uint -> unit). + + Numeral Notation unit of_uint to_uint : test12_scope. + Check let v := 1%test12 in v : unit. + End test12. +End Test12. + +Module Test13. + (* Test for numeral notations on notations which do not denote references *) + Delimit Scope test13_scope with test13. + Delimit Scope test13'_scope with test13'. + Delimit Scope test13''_scope with test13''. + Definition to_uint (x y : unit) : Decimal.uint := Nat.to_uint O. + Definition of_uint (x : Decimal.uint) : unit := tt. + Definition to_uint_good := to_uint tt. + Notation to_uint' := (to_uint tt). + Notation to_uint'' := (to_uint _). + Numeral Notation unit of_uint to_uint_good : test13_scope. + Check let v := 0%test13 in v : unit. + Fail Numeral Notation unit of_uint to_uint' : test13'_scope. + Fail Check let v := 0%test13' in v : unit. + Fail Numeral Notation unit of_uint to_uint'' : test13''_scope. + Fail Check let v := 0%test13'' in v : unit. +End Test13. + +Module Test14. + (* Test that numeral notations follow [Import], not [Require], and + also test that [Local Numeral Notation]s do not escape modules + nor sections. *) + Delimit Scope test14_scope with test14. + Delimit Scope test14'_scope with test14'. + Delimit Scope test14''_scope with test14''. + Delimit Scope test14'''_scope with test14'''. + Module Inner. + Definition to_uint (x : unit) : Decimal.uint := Nat.to_uint O. + Definition of_uint (x : Decimal.uint) : unit := tt. + Local Numeral Notation unit of_uint to_uint : test14_scope. + Global Numeral Notation unit of_uint to_uint : test14'_scope. + Check let v := 0%test14 in v : unit. + Check let v := 0%test14' in v : unit. + End Inner. + Fail Check let v := 0%test14 in v : unit. + Fail Check let v := 0%test14' in v : unit. + Import Inner. + Fail Check let v := 0%test14 in v : unit. + Check let v := 0%test14' in v : unit. + Section InnerSection. + Definition to_uint (x : unit) : Decimal.uint := Nat.to_uint O. + Definition of_uint (x : Decimal.uint) : unit := tt. + Local Numeral Notation unit of_uint to_uint : test14''_scope. + Fail Global Numeral Notation unit of_uint to_uint : test14'''_scope. + Check let v := 0%test14'' in v : unit. + Fail Check let v := 0%test14''' in v : unit. + End InnerSection. + Fail Check let v := 0%test14'' in v : unit. + Fail Check let v := 0%test14''' in v : unit. +End Test14. + +Module Test15. + (** Test module include *) + Delimit Scope test15_scope with test15. + Module Inner. + Definition to_uint (x : unit) : Decimal.uint := Nat.to_uint O. + Definition of_uint (x : Decimal.uint) : unit := tt. + Numeral Notation unit of_uint to_uint : test15_scope. + Check let v := 0%test15 in v : unit. + End Inner. + Module Inner2. + Include Inner. + Check let v := 0%test15 in v : unit. + End Inner2. + Import Inner Inner2. + Check let v := 0%test15 in v : unit. +End Test15. + +Module Test16. + (** Test functors *) + Delimit Scope test16_scope with test16. + Module Type A. + Axiom T : Set. + Axiom t : T. + End A. + Module F (a : A). + Inductive Foo := foo (_ : a.T). + Definition to_uint (x : Foo) : Decimal.uint := Nat.to_uint O. + Definition of_uint (x : Decimal.uint) : Foo := foo a.t. + Global Numeral Notation Foo of_uint to_uint : test16_scope. + Check let v := 0%test16 in v : Foo. + End F. + Module a <: A. + Definition T : Set := unit. + Definition t : T := tt. + End a. + Module Import f := F a. + (** Ideally this should work, but it should definitely not anomaly *) + Fail Check let v := 0%test16 in v : Foo. +End Test16. diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v new file mode 100644 index 0000000000..470e4f0580 --- /dev/null +++ b/test-suite/success/Omega.v @@ -0,0 +1,94 @@ + +Require Import Omega. + +(* Submitted by Xavier Urbain 18 Jan 2002 *) + +Lemma lem1 : + forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. +Proof. +intros x y. + omega. +Qed. + +(* Proposed by Pierre Crégut *) + +Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. +intro. + omega. +Qed. + +(* Proposed by Jean-Christophe Filliâtre *) + +Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. +Proof. +intros. + omega. +Qed. + +(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) +(* internal variable and a section variable (June 2001) *) + +Section A. +Variable x y : Z. +Hypothesis H : (x > y)%Z. +Lemma lem4 : (x > y)%Z. + omega. +Qed. +End A. + +(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) +(* May 2002 *) + +Section B. +Variable R1 R2 S1 S2 H S : Z. +Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. +Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. +Hypothesis K : (R1 >= 0)%Z -> R2 = R1. +Hypothesis L : (R1 >= 0)%Z -> S2 = S1. +Hypothesis M : (H <= 2 * S)%Z. +Hypothesis N : (S < H)%Z. +Lemma lem5 : (H > 0)%Z. + omega. +Qed. +End B. + +(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) +Lemma lem6 : + forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. +intros. + omega. +Qed. + +(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) +Require Import Omega. +Section C. +Parameter g : forall m : nat, m <> 0 -> Prop. +Parameter f : forall (m : nat) (H : m <> 0), g m H. +Variable n : nat. +Variable ap_n : n <> 0. +Let delta := f n ap_n. +Lemma lem7 : n = n. + omega. +Qed. +End C. + +(* Problem of dependencies *) +Require Import Omega. +Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. +intros; omega. +Qed. + +(* Bug that what caused by the use of intro_using in Omega *) +Require Import Omega. +Lemma lem9 : + forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. +intros; omega. +Qed. + +(* Check that the interpretation of mult on nat enforces its positivity *) +(* Submitted by Hubert Thierry (BZ#743) *) +(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) +Lemma lem10 : forall n m:nat, le n (plus n (mult n m)). +Proof. +intros; omega with *. +Qed. diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v new file mode 100644 index 0000000000..6fd936935c --- /dev/null +++ b/test-suite/success/Omega0.v @@ -0,0 +1,149 @@ +Require Import ZArith Omega. +Open Scope Z_scope. + +(* Pierre L: examples gathered while debugging romega. *) + +Lemma test_romega_0 : + forall m m', + 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_0b : + forall m m', + 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. +Proof. +intros m m'. +omega. +Qed. + +Lemma test_romega_1 : + forall (z z1 z2 : Z), + z2 <= z1 -> + z1 <= z2 -> + z1 >= 0 -> + z2 >= 0 -> + z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> + z >= 0. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_1b : + forall (z z1 z2 : Z), + z2 <= z1 -> + z1 <= z2 -> + z1 >= 0 -> + z2 >= 0 -> + z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> + z >= 0. +Proof. +intros z z1 z2. +omega. +Qed. + +Lemma test_romega_2 : forall a b c:Z, + 0<=a-b<=1 -> b-c<=2 -> a-c<=3. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_2b : forall a b c:Z, + 0<=a-b<=1 -> b-c<=2 -> a-c<=3. +Proof. +intros a b c. +omega. +Qed. + +Lemma test_romega_3 : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> + -2 <= hl - hr <= 2 -> + h =b+1 -> + (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> + (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> + (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> + 0 <= hb - h <= 1. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_3b : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> + -2 <= hl - hr <= 2 -> + h =b+1 -> + (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> + (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> + (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> + 0 <= hb - h <= 1. +Proof. +intros a b h hl hr ha hb. +omega. +Qed. + + +Lemma test_romega_4 : forall hr ha, + ha = 0 -> + (ha = 0 -> hr =0) -> + hr = 0. +Proof. +intros hr ha. +omega. +Qed. + +Lemma test_romega_5 : forall hr ha, + ha = 0 -> + (~ha = 0 \/ hr =0) -> + hr = 0. +Proof. +intros hr ha. +omega. +Qed. + +Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. +Proof. +intros z. +omega. +Qed. + +Lemma test_romega_7 : forall z, + 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. +Proof. +intros. +omega. +Qed. + +Lemma test_romega_7b : forall z, + 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. +Proof. +intros. +omega. +Qed. + +(* Magaud BZ#240 *) + +Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +intros. +omega. +Qed. + +Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +intros x y. +omega. +Qed. + + + + diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v new file mode 100644 index 0000000000..4e726335c9 --- /dev/null +++ b/test-suite/success/Omega2.v @@ -0,0 +1,28 @@ +Require Import ZArith Omega. + +(* Submitted by Yegor Bryukhov (BZ#922) *) + +Open Scope Z_scope. + +Lemma Test46 : +forall v1 v2 v3 v4 v5 : Z, +((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> +9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> +((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> +0 > 6 * v1 -> +(0 * v3) + (6 * v2) <> 2 -> +(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> +7 * v3 > 5 * v5 -> +0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> +7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> +0 * v3 > 7 * v1 -> +9 * v2 < 9 * v5 -> +(2 * v3) + (8 * v1) <= 5 * v4 -> +5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> +0 * v5 <= 9 * v2 -> +((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) +-> False. +intros. +omega. +Qed. + diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v new file mode 100644 index 0000000000..17531064cc --- /dev/null +++ b/test-suite/success/OmegaPre.v @@ -0,0 +1,127 @@ +Require Import ZArith Nnat Omega. +Open Scope Z_scope. + +(** Test of the zify preprocessor for (R)Omega *) + +(* More details in file PreOmega.v + + (r)omega with Z : starts with zify_op + (r)omega with nat : starts with zify_nat + (r)omega with positive : starts with zify_positive + (r)omega with N : starts with uses zify_N + (r)omega with * : starts zify (a saturation of the others) +*) + +(* zify_op *) + +Goal forall a:Z, Z.max a a = a. +intros. +omega with *. +Qed. + +Goal forall a b:Z, Z.max a b = Z.max b a. +intros. +omega with *. +Qed. + +Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. +intros. +omega with *. +Qed. + +Goal forall a b:Z, Z.max a b + Z.min a b = a + b. +intros. +omega with *. +Qed. + +Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. +intros. +zify. +intuition; subst; omega. (* pure multiplication: omega alone can't do it *) +Qed. + +Goal forall a:Z, Z.abs a = a -> a >= 0. +intros. +omega with *. +Qed. + +Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. +intros. +omega with *. +Qed. + +(* zify_nat *) + +Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. +intros. +omega with *. +Qed. + +Goal forall m:nat, (m<1)%nat -> (m=0)%nat. +intros. +omega with *. +Qed. + +Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. +intros. +omega with *. +Qed. +(* 2000 instead of 200: works, but quite slow *) + +Goal forall m: nat, (m*m>=0)%nat. +intros. +omega with *. +Qed. + +(* zify_positive *) + +Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. +intros. +omega with *. +Qed. + +Goal forall m:positive, (m<2)%positive -> (m=1)%positive. +intros. +omega with *. +Qed. + +Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. +intros. +omega with *. +Qed. + +Goal forall m: positive, (m*m>=1)%positive. +intros. +omega with *. +Qed. + +(* zify_N *) + +Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. +intros. +omega with *. +Qed. + +Goal forall m:N, (m<1)%N -> (m=0)%N. +intros. +omega with *. +Qed. + +Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. +intros. +omega with *. +Qed. + +Goal forall m:N, (m*m>=0)%N. +intros. +omega with *. +Qed. + +(* mix of datatypes *) + +Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. +intros. +omega with *. +Qed. + + diff --git a/test-suite/success/PCase.v b/test-suite/success/PCase.v new file mode 100644 index 0000000000..67d680ba87 --- /dev/null +++ b/test-suite/success/PCase.v @@ -0,0 +1,66 @@ + +(** Some tests of patterns containing matchs ending with joker branches. + Cf. the new form of the [constr_pattern] constructor [PCase] + in [pretyping/pattern.ml] *) + +(* A universal match matcher *) + +Ltac kill_match := + match goal with + |- context [ match ?x with _ => _ end ] => destruct x + end. + +(* A match matcher restricted to a given type : nat *) + +Ltac kill_match_nat := + match goal with + |- context [ match ?x in nat with _ => _ end ] => destruct x + end. + +(* Another way to restrict to a given type : give a branch *) + +Ltac kill_match_nat2 := + match goal with + |- context [ match ?x with S _ => _ | _ => _ end ] => destruct x + end. + +(* This should act only on empty match *) + +Ltac kill_match_empty := + match goal with + |- context [ match ?x with end ] => destruct x + end. + +Lemma test1 (b:bool) : if b then True else O=O. +Proof. + Fail kill_match_nat. + Fail kill_match_nat2. + Fail kill_match_empty. + kill_match. exact I. exact eq_refl. +Qed. + +Lemma test2a (n:nat) : match n with O => True | S n => (n = n) end. +Proof. + Fail kill_match_empty. + kill_match_nat. exact I. exact eq_refl. +Qed. + +Lemma test2b (n:nat) : match n with O => True | S n => (n = n) end. +Proof. + kill_match_nat2. exact I. exact eq_refl. +Qed. + +Lemma test2c (n:nat) : match n with O => True | S n => (n = n) end. +Proof. + kill_match. exact I. exact eq_refl. +Qed. + +Lemma test3a (f:False) : match f return Prop with end. +Proof. + kill_match_empty. +Qed. + +Lemma test3b (f:False) : match f return Prop with end. +Proof. + kill_match. +Qed. diff --git a/test-suite/success/PPFix.v b/test-suite/success/PPFix.v new file mode 100644 index 0000000000..833eb3ad1c --- /dev/null +++ b/test-suite/success/PPFix.v @@ -0,0 +1,9 @@ + +(* To test PP of fixpoints *) +Require Import Arith. +Check fix a(n: nat): n<5 -> nat := + match n return n<5 -> nat with + | 0 => fun _ => 0 + | S n => fun h => S (a n (lt_S_n _ _ (lt_S _ _ h))) + end. + diff --git a/test-suite/success/PatternsInBinders.v b/test-suite/success/PatternsInBinders.v new file mode 100644 index 0000000000..7771079158 --- /dev/null +++ b/test-suite/success/PatternsInBinders.v @@ -0,0 +1,67 @@ +(** The purpose of this file is to test functional properties of the + destructive patterns used in binders ([fun] and [forall]). *) + + +Definition swap {A B} '((x,y) : A*B) := (y,x). + +(** Tests the use of patterns in [fun] and [Definition] *) +Section TestFun. + + Variables A B : Type. + + Goal forall (x:A) (y:B), swap (x,y) = (y,x). + Proof. reflexivity. Qed. + + Goal forall u:A*B, swap (swap u) = u. + Proof. destruct u. reflexivity. Qed. + + Goal @swap A B = fun '(x,y) => (y,x). + Proof. reflexivity. Qed. + +End TestFun. + + +(** Tests the use of patterns in [forall] *) +Section TestForall. + + Variables A B : Type. + + Goal forall '((x,y) : A*B), swap (x,y) = (y,x). + Proof. intros [x y]. reflexivity. Qed. + + Goal forall x0:A, exists '((x,y) : A*A), swap (x,y) = (x,y). + Proof. + intros x0. + exists (x0,x0). + reflexivity. + Qed. + +End TestForall. + + + +(** Tests the use of patterns in dependent definitions. *) + +Section TestDependent. + + Inductive Fin (n:nat) := Z : Fin n. + + Definition F '(n,p) : Type := (Fin n * Fin p)%type. + + Definition both_z '(n,p) : F (n,p) := (Z _,Z _). + +End TestDependent. + + +(** Tests with a few other types just to make sure parsing is + robust. *) +Section TestExtra. + + Definition proj_informative {A P} '(exist _ x _ : { x:A | P x }) : A := x. + + Inductive Foo := Bar : nat -> bool -> unit -> nat -> Foo. + + Definition foo '(Bar n b tt p) := + if b then n+p else n-p. + +End TestExtra. diff --git a/test-suite/success/Print.v b/test-suite/success/Print.v new file mode 100644 index 0000000000..c1cb86caf1 --- /dev/null +++ b/test-suite/success/Print.v @@ -0,0 +1,20 @@ +Print Tables. +Print ML Path. +Print ML Modules. +Print LoadPath. +Print Graph. +Print Coercions. +Print Classes. +Print nat. +Print Term O. +Print All. +Print Grammar constr. +Inspect 10. + +Section A. +Coercion f (x : nat) : Prop := True. +Print Coercion Paths nat Sortclass. + +Print Section A. + +End A. diff --git a/test-suite/success/PrintSortedUniverses.v b/test-suite/success/PrintSortedUniverses.v new file mode 100644 index 0000000000..8132658084 --- /dev/null +++ b/test-suite/success/PrintSortedUniverses.v @@ -0,0 +1,2 @@ +Require Reals. +Print Sorted Universes. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v new file mode 100644 index 0000000000..85d7a770fc --- /dev/null +++ b/test-suite/success/ProgramWf.v @@ -0,0 +1,105 @@ +(* Before loading Program, check non-anomaly on missing library Program *) + +Fail Program Definition f n (e:n=n): {n|n=0} := match n,e with 0, refl => 0 | _, _ => 0 end. + +(* Then we test Program properly speaking *) + +Require Import Arith Program. +Require Import ZArith Zwf. + +Set Implicit Arguments. +(* Set Printing All. *) +Print sigT_rect. +Obligation Tactic := program_simplify ; auto with *. +About MR. + +Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat := + match n with + | 0 => 0 + | S n' => merge n' m + end. + +Print merge. + + +Print Z.lt. +Print Zwf. + +Local Open Scope Z_scope. + +Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z := + match n ?= m with + | Lt => Zwfrec n (Z.pred m) + | _ => 0 + end. + +Next Obligation. + red. Admitted. + +Close Scope Z_scope. + +Program Fixpoint merge_wf (n m : nat) {wf lt m} : nat := + match n with + | 0 => 0 + | S n' => merge n' m + end. + +Print merge_wf. + +Program Fixpoint merge_one (n : nat) {measure n} : nat := + match n with + | 0 => 0 + | S n' => merge_one n' + end. + +Print Hint well_founded. +Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one. + +Import WfExtensionality. + +Lemma merge_unfold n m : merge n m = + match n with + | 0 => 0 + | S n' => merge n' m + end. +Proof. intros. unfold merge at 1. unfold merge_func. + unfold_sub merge (merge n m). + simpl. destruct n ; reflexivity. +Qed. + +Print merge. + +Require Import Arith. +Unset Implicit Arguments. + +Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) + (H : forall (i : { i | i < n }), i < p -> P i = true) + {measure (n - p)} : + Exc (forall (p : { i | i < n}), P p = true) := + match le_lt_dec n p with + | left _ => value _ + | right cmp => + if dec (P p) then + check_n n P (S p) _ + else + error + end. + +Require Import Omega Setoid. + +Next Obligation. + intros ; simpl in *. apply H. + simpl in * ; omega. +Qed. + +Next Obligation. simpl in *; intros. + revert H0 ; clear_subset_proofs. intros. + case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. + revert H0 ; clear_subset_proofs ; tauto. + + apply H. simpl. omega. +Qed. + +Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) + {measure (p - n) p} : nat := + _. diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v new file mode 100644 index 0000000000..3ffd41ea07 --- /dev/null +++ b/test-suite/success/Projection.v @@ -0,0 +1,48 @@ +Record foo (A : Type) := { B :> Type }. + +Lemma bar (f : foo nat) (x : f) : x = x. + destruct f. simpl B. simpl B in x. +Abort. + +Structure S : Type := {Dom : Type; Op : Dom -> Dom -> Dom}. + +Check (fun s : S => Dom s). +Check (fun s : S => Op s). +Check (fun (s : S) (a b : Dom s) => Op s a b). + +(* v8 +Check fun s:S => s.(Dom). +Check fun s:S => s.(Op). +Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b. +*) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Strict Implicit. + +Structure S' (A : Set) : Type := {Dom' : Type; Op' : A -> Dom' -> Dom'}. + +Check (fun s : S' nat => Dom' s). +Check (fun s : S' nat => Op' (s:=s)). +Check (fun s : S' nat => Op' (A:=nat) (s:=s)). +Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' a b). +Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' (A:=nat) (s:=s) a b). + +(* v8 +Check fun s:S' => s.(Dom'). +Check fun s:S' => s.(Op'). +Check fun (s:S') (a b:s.(Dom')) => _.(Op') a b. +Check fun (s:S') (a b:s.(Dom')) => s.(Op') a b. + +Set Implicit Arguments. +Unset Strict Implicits. + +Structure S' (A:Set) : Type := + {Dom' : Type; + Op' : A -> Dom' -> Dom'}. + +Check fun s:S' nat => s.(Dom'). +Check fun s:S' nat => s.(Op'). +Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => _.(@Op' nat) a b. +Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => s.(Op') a b. +*) diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v new file mode 100644 index 0000000000..a97afa7ff0 --- /dev/null +++ b/test-suite/success/ROmega.v @@ -0,0 +1,95 @@ +(* This file used to test the `romega` tactics. + In Coq 8.9 (end of 2018), these tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) +Require Import ZArith Lia. + +(* Submitted by Xavier Urbain 18 Jan 2002 *) + +Lemma lem1 : + forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. +Proof. +intros x y. +lia. +Qed. + +(* Proposed by Pierre Crégut *) + +Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z. +intro. + lia. +Qed. + +(* Proposed by Jean-Christophe Filliâtre *) + +Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. +Proof. +intros. +lia. +Qed. + +(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) +(* internal variable and a section variable (June 2001) *) + +Section A. +Variable x y : Z. +Hypothesis H : (x > y)%Z. +Lemma lem4 : (x > y)%Z. + lia. +Qed. +End A. + +(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *) +(* May 2002 *) + +Section B. +Variable R1 R2 S1 S2 H S : Z. +Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z. +Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z. +Hypothesis K : (R1 >= 0)%Z -> R2 = R1. +Hypothesis L : (R1 >= 0)%Z -> S2 = S1. +Hypothesis M : (H <= 2 * S)%Z. +Hypothesis N : (S < H)%Z. +Lemma lem5 : (H > 0)%Z. + lia. +Qed. +End B. + +(* From Nicolas Oury (BZ#180): handling -> on Set (fixed Oct 2002) *) +Lemma lem6 : + forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z. +intros. + lia. +Qed. + +(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *) +Section C. +Parameter g : forall m : nat, m <> 0 -> Prop. +Parameter f : forall (m : nat) (H : m <> 0), g m H. +Variable n : nat. +Variable ap_n : n <> 0. +Let delta := f n ap_n. +Lemma lem7 : n = n. + lia. +Qed. +End C. + +(* Problem of dependencies *) +Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. +intros. +lia. +Qed. + +(* Bug that what caused by the use of intro_using in Omega *) +Lemma lem9 : + forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. +intros. +lia. +Qed. + +(* Check that the interpretation of mult on nat enforces its positivity *) +(* Submitted by Hubert Thierry (BZ#743) *) +(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *) +Lemma lem10 : forall n m : nat, le n (plus n (mult n m)). +Proof. +intros; lia. +Qed. diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v new file mode 100644 index 0000000000..7f69422ab3 --- /dev/null +++ b/test-suite/success/ROmega0.v @@ -0,0 +1,170 @@ +Require Import ZArith Lia. +Open Scope Z_scope. + +(* Pierre L: examples gathered while debugging romega. *) +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) + +Lemma test_lia_0 : + forall m m', + 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_0b : + forall m m', + 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. +Proof. +intros m m'. +lia. +Qed. + +Lemma test_lia_1 : + forall (z z1 z2 : Z), + z2 <= z1 -> + z1 <= z2 -> + z1 >= 0 -> + z2 >= 0 -> + z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> + z >= 0. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_1b : + forall (z z1 z2 : Z), + z2 <= z1 -> + z1 <= z2 -> + z1 >= 0 -> + z2 >= 0 -> + z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 -> + z >= 0. +Proof. +intros z z1 z2. +lia. +Qed. + +Lemma test_lia_2 : forall a b c:Z, + 0<=a-b<=1 -> b-c<=2 -> a-c<=3. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_2b : forall a b c:Z, + 0<=a-b<=1 -> b-c<=2 -> a-c<=3. +Proof. +intros a b c. +lia. +Qed. + +Lemma test_lia_3 : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> + -2 <= hl - hr <= 2 -> + h =b+1 -> + (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> + (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> + (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> + 0 <= hb - h <= 1. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_3b : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> + -2 <= hl - hr <= 2 -> + h =b+1 -> + (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> + (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> + (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> + 0 <= hb - h <= 1. +Proof. +intros a b h hl hr ha hb. +lia. +Qed. + + +Lemma test_lia_4 : forall hr ha, + ha = 0 -> + (ha = 0 -> hr =0) -> + hr = 0. +Proof. +intros hr ha. +lia. +Qed. + +Lemma test_lia_5 : forall hr ha, + ha = 0 -> + (~ha = 0 \/ hr =0) -> + hr = 0. +Proof. +intros hr ha. +lia. +Qed. + +Lemma test_lia_6 : forall z, z>=0 -> 0>z+2 -> False. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_6b : forall z, z>=0 -> 0>z+2 -> False. +Proof. +intros z. +lia. +Qed. + +Lemma test_lia_7 : forall z, + 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_7b : forall z, + 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. +Proof. +intros. +lia. +Qed. + +(* Magaud BZ#240 *) + +Lemma test_lia_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Proof. +intros. +lia. +Qed. + +Lemma test_lia_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x. +Proof. +intros x y. +lia. +Qed. + +(* Besson BZ#1298 *) + +Lemma test_lia9 : forall z z':Z, z<>z' -> z'=z -> False. +Proof. +intros. +lia. +Qed. + +(* Letouzey, May 2017 *) + +Lemma test_lia10 : forall x a a' b b', + a' <= b -> + a <= b' -> + b < b' -> + a < a' -> + a <= x < b' <-> a <= x < b \/ a' <= x < b'. +Proof. + intros. + lia. +Qed. diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v new file mode 100644 index 0000000000..e3b090699d --- /dev/null +++ b/test-suite/success/ROmega2.v @@ -0,0 +1,43 @@ +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) +Require Import ZArith Lia. + +(* Submitted by Yegor Bryukhov (BZ#922) *) + +Open Scope Z_scope. + + +(* First a simplified version used during debug of romega on Test46 *) +Lemma Test46_simplified : +forall v1 v2 v5 : Z, +0 = v2 + v5 -> +0 < v5 -> +0 < v2 -> +4*v2 <> 5*v1. +intros. +lia. +Qed. + + +(* The complete problem *) +Lemma Test46 : +forall v1 v2 v3 v4 v5 : Z, +((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> +9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> +((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 -> +0 > 6 * v1 -> +(0 * v3) + (6 * v2) <> 2 -> +(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) -> +7 * v3 > 5 * v5 -> +0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) -> +7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) -> +0 * v3 > 7 * v1 -> +9 * v2 < 9 * v5 -> +(2 * v3) + (8 * v1) <= 5 * v4 -> +5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) -> +0 * v5 <= 9 * v2 -> +((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) +-> False. +intros. +lia. +Qed. diff --git a/test-suite/success/ROmega3.v b/test-suite/success/ROmega3.v new file mode 100644 index 0000000000..ef9cb17b4b --- /dev/null +++ b/test-suite/success/ROmega3.v @@ -0,0 +1,35 @@ + +Require Import ZArith Lia. +Local Open Scope Z_scope. + +(** Benchmark provided by Chantal Keller, that romega used to + solve far too slowly (compared to omega or lia). *) + +(* In Coq 8.9 (end of 2018), the `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) + + +Parameter v4 : Z. +Parameter v3 : Z. +Parameter o4 : Z. +Parameter s5 : Z. +Parameter v2 : Z. +Parameter o5 : Z. +Parameter s6 : Z. +Parameter v1 : Z. +Parameter o6 : Z. +Parameter s7 : Z. +Parameter v0 : Z. +Parameter o7 : Z. + +Lemma lemma_5833 : + ~ 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + + (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + + (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 8192 +\/ + 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + + (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + + (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 1024. +Proof. +Timeout 1 lia. (* should take a few milliseconds, not seconds *) +Timeout 1 Qed. (* ditto *) diff --git a/test-suite/success/ROmega4.v b/test-suite/success/ROmega4.v new file mode 100644 index 0000000000..a724592749 --- /dev/null +++ b/test-suite/success/ROmega4.v @@ -0,0 +1,26 @@ +(** ROmega is now aware of the bodies of context variables + (of type Z or nat). + See also #148 for the corresponding improvement in Omega. +*) + +Require Import ZArith Lia. +Open Scope Z. + +Goal let x := 3 in x = 3. +intros. +lia. +Qed. + +(** Example seen in #4132 + (actually solvable even if b isn't known to be 5) *) + +Lemma foo + (x y x' zxy zxy' z : Z) + (b := 5) + (Ry : - b <= y < b) + (Bx : x' <= b) + (H : - zxy' <= zxy) + (H' : zxy' <= x') : - b <= zxy. +Proof. +lia. +Qed. diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v new file mode 100644 index 0000000000..6ca32f450f --- /dev/null +++ b/test-suite/success/ROmegaPre.v @@ -0,0 +1,123 @@ +Require Import ZArith Nnat Lia. +Open Scope Z_scope. + +(** Test of the zify preprocessor for (R)Omega *) +(* Starting from Coq 8.9 (late 2018), `romega` tactics are deprecated. + The tests in this file remain but now call the `lia` tactic. *) + +(* More details in file PreOmega.v +*) + +(* zify_op *) + +Goal forall a:Z, Z.max a a = a. +intros. +lia. +Qed. + +Goal forall a b:Z, Z.max a b = Z.max b a. +intros. +lia. +Qed. + +Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c. +intros. +lia. +Qed. + +Goal forall a b:Z, Z.max a b + Z.min a b = a + b. +intros. +lia. +Qed. + +Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a. +intros. +zify. +intuition; subst; lia. (* pure multiplication: omega alone can't do it *) +Qed. + +Goal forall a:Z, Z.abs a = a -> a >= 0. +intros. +lia. +Qed. + +Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1. +intros. +lia. +Qed. + +(* zify_nat *) + +Goal forall m: nat, (m<2)%nat -> (0<= m+m <=2)%nat. +intros. +lia. +Qed. + +Goal forall m:nat, (m<1)%nat -> (m=0)%nat. +intros. +lia. +Qed. + +Goal forall m: nat, (m<=100)%nat -> (0<= m+m <=200)%nat. +intros. +lia. +Qed. +(* 2000 instead of 200: works, but quite slow *) + +Goal forall m: nat, (m*m>=0)%nat. +intros. +lia. +Qed. + +(* zify_positive *) + +Goal forall m: positive, (m<2)%positive -> (2 <= m+m /\ m+m <= 2)%positive. +intros. +lia. +Qed. + +Goal forall m:positive, (m<2)%positive -> (m=1)%positive. +intros. +lia. +Qed. + +Goal forall m: positive, (m<=1000)%positive -> (2<=m+m/\m+m <=2000)%positive. +intros. +lia. +Qed. + +Goal forall m: positive, (m*m>=1)%positive. +intros. +lia. +Qed. + +(* zify_N *) + +Goal forall m:N, (m<2)%N -> (0 <= m+m /\ m+m <= 2)%N. +intros. +lia. +Qed. + +Goal forall m:N, (m<1)%N -> (m=0)%N. +intros. +lia. +Qed. + +Goal forall m:N, (m<=1000)%N -> (0<=m+m/\m+m <=2000)%N. +intros. +lia. +Qed. + +Goal forall m:N, (m*m>=0)%N. +intros. +lia. +Qed. + +(* mix of datatypes *) + +Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p. +intros. +lia. +Qed. + + diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v new file mode 100644 index 0000000000..6370cab6b2 --- /dev/null +++ b/test-suite/success/RecTutorial.v @@ -0,0 +1,1216 @@ +Module Type LocalNat. + +Inductive nat : Set := + | O : nat + | S : nat->nat. +Check nat. +Check O. +Check S. + +End LocalNat. + +Print nat. + + +Print le. + +Theorem zero_leq_three: 0 <= 3. + +Proof. + constructor 2. + constructor 2. + constructor 2. + constructor 1. + +Qed. + +Print zero_leq_three. + + +Lemma zero_leq_three': 0 <= 3. + repeat constructor. +Qed. + + +Lemma zero_lt_three : 0 < 3. +Proof. + unfold lt. + repeat constructor. +Qed. + + +Require Import List. + +Print list. + +Check list. + +Check (nil (A:=nat)). + +Check (nil (A:= nat -> nat)). + +Check (fun A: Set => (cons (A:=A))). + +Check (cons 3 (cons 2 nil)). + + + + +Require Import Bvector. + +Print Vector.t. + +Check (Vector.nil nat). + +Check (fun (A:Set)(a:A)=> Vector.cons _ a _ (Vector.nil _)). + +Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))). + + + + + + + + + + + + + +Lemma eq_3_3 : 2 + 1 = 3. +Proof. + reflexivity. +Qed. +Print eq_3_3. + +Lemma eq_proof_proof : refl_equal (2*6) = refl_equal (3*4). +Proof. + reflexivity. +Qed. +Print eq_proof_proof. + +Lemma eq_lt_le : ( 2 < 4) = (3 <= 4). +Proof. + reflexivity. +Qed. + +Lemma eq_nat_nat : nat = nat. +Proof. + reflexivity. +Qed. + +Lemma eq_Set_Set : Set = Set. +Proof. + reflexivity. +Qed. + +Lemma eq_Type_Type : Type = Type. +Proof. + reflexivity. +Qed. + + +Check (2 + 1 = 3). + + +Check (Type = Type). + +Goal Type = Type. +reflexivity. +Qed. + + +Print or. + +Print and. + + +Print sumbool. + +Print ex. + +Require Import ZArith. +Require Import Compare_dec. + +Check le_lt_dec. + +Definition max (n p :nat) := match le_lt_dec n p with + | left _ => p + | right _ => n + end. + +Theorem le_max : forall n p, n <= p -> max n p = p. +Proof. + intros n p ; unfold max ; case (le_lt_dec n p); simpl. + trivial. + intros; absurd (p < p); eauto with arith. +Qed. + +Require Coq.extraction.Extraction. +Extraction max. + + + + + + +Inductive tree(A:Set) : Set := + node : A -> forest A -> tree A +with + forest (A: Set) : Set := + nochild : forest A | + addchild : tree A -> forest A -> forest A. + + + + + +Inductive + even : nat->Prop := + evenO : even O | + evenS : forall n, odd n -> even (S n) +with + odd : nat->Prop := + oddS : forall n, even n -> odd (S n). + +Lemma odd_49 : odd (7 * 7). + simpl; repeat constructor. +Qed. + + + +Definition nat_case := + fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => + match n return Q with + | 0 => g0 + | S p => g1 p + end. + +Eval simpl in (nat_case nat 0 (fun p => p) 34). + +Eval simpl in (fun g0 g1 => nat_case nat g0 g1 34). + +Eval simpl in (fun g0 g1 => nat_case nat g0 g1 0). + + +Definition pred (n:nat) := match n with O => O | S m => m end. + +Eval simpl in pred 56. + +Eval simpl in pred 0. + +Eval simpl in fun p => pred (S p). + + +Definition xorb (b1 b2:bool) := +match b1, b2 with + | false, true => true + | true, false => true + | _ , _ => false +end. + + + Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. + + + Definition predecessor : forall n:nat, pred_spec n. + intro n;case n. + unfold pred_spec;exists 0;auto. + unfold pred_spec; intro n0;exists n0; auto. + Defined. + +Print predecessor. + +Extraction predecessor. + +Theorem nat_expand : + forall n:nat, n = match n with 0 => 0 | S p => S p end. + intro n;case n;simpl;auto. +Qed. + +Check (fun p:False => match p return 2=3 with end). + +Theorem fromFalse : False -> 0=1. + intro absurd. + contradiction. +Qed. + +Section equality_elimination. + Variables (A: Type) + (a b : A) + (p : a = b) + (Q : A -> Type). + Check (fun H : Q a => + match p in (eq _ y) return Q y with + refl_equal => H + end). + +End equality_elimination. + + +Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. +Proof. + intros n m p eqnm. + case eqnm. + trivial. +Qed. + +Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. + intros x y e; do 2 rewrite <- e. + reflexivity. +Qed. + + +Require Import Arith. + +Check mult_1_l. +(* +mult_1_l + : forall n : nat, 1 * n = n +*) + +Check mult_plus_distr_r. +(* +mult_plus_distr_r + : forall n m p : nat, (n + m) * p = n * p + m * p + +*) + +Lemma mult_distr_S : forall n p : nat, n * p + p = (S n)* p. + simpl;auto with arith. +Qed. + +Lemma four_n : forall n:nat, n+n+n+n = 4*n. + intro n;rewrite <- (mult_1_l n). + + Undo. + intro n; pattern n at 1. + + + rewrite <- mult_1_l. + repeat rewrite mult_distr_S. + trivial. +Qed. + + +Section Le_case_analysis. + Variables (n p : nat) + (H : n <= p) + (Q : nat -> Prop) + (H0 : Q n) + (HS : forall m, n <= m -> Q (S m)). + Check ( + match H in (_ <= q) return (Q q) with + | le_n _ => H0 + | le_S _ m Hm => HS m Hm + end + ). + + +End Le_case_analysis. + + +Lemma predecessor_of_positive : forall n, 1 <= n -> exists p:nat, n = S p. +Proof. + intros n H; case H. + exists 0; trivial. + intros m Hm; exists m;trivial. +Qed. + +Definition Vtail_total + (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= +match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with +| Vector.nil _ => Vector.nil A +| Vector.cons _ _ n0 v0 => v0 +end. + +Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). + case v. + simpl. + exact (Vector.nil A). + simpl. + auto. +Defined. + +(* +Inductive Lambda : Set := + lambda : (Lambda -> False) -> Lambda. + + +Error: Non strictly positive occurrence of "Lambda" in + "(Lambda -> False) -> Lambda" + +*) + +Section Paradox. + Variable Lambda : Set. + Variable lambda : (Lambda -> False) ->Lambda. + + Variable matchL : Lambda -> forall Q:Prop, ((Lambda ->False) -> Q) -> Q. + (* + understand matchL Q l (fun h : Lambda -> False => t) + + as match l return Q with lambda h => t end + *) + + Definition application (f x: Lambda) :False := + matchL f False (fun h => h x). + + Definition Delta : Lambda := lambda (fun x : Lambda => application x x). + + Definition loop : False := application Delta Delta. + + Theorem two_is_three : 2 = 3. + Proof. + elim loop. + Qed. + +End Paradox. + + +Require Import ZArith. + + + +Inductive itree : Set := +| ileaf : itree +| inode : Z-> (nat -> itree) -> itree. + +Definition isingle l := inode l (fun i => ileaf). + +Definition t1 := inode 0 (fun n => isingle (Z.of_nat (2*n))). + +Definition t2 := inode 0 + (fun n : nat => + inode (Z.of_nat n) + (fun p => isingle (Z.of_nat (n*p)))). + + +Inductive itree_le : itree-> itree -> Prop := + | le_leaf : forall t, itree_le ileaf t + | le_node : forall l l' s s', + Z.le l l' -> + (forall i, exists j:nat, itree_le (s i) (s' j)) -> + itree_le (inode l s) (inode l' s'). + + +Theorem itree_le_trans : + forall t t', itree_le t t' -> + forall t'', itree_le t' t'' -> itree_le t t''. + induction t. + constructor 1. + + intros t'; case t'. + inversion 1. + intros z0 i0 H0. + intro t'';case t''. + inversion 1. + intros. + inversion_clear H1. + constructor 2. + inversion_clear H0;eauto with zarith. + inversion_clear H0. + intro i2; case (H4 i2). + intros. + generalize (H i2 _ H0). + intros. + case (H3 x);intros. + generalize (H5 _ H6). + exists x0;auto. +Qed. + + + +Inductive itree_le' : itree-> itree -> Prop := + | le_leaf' : forall t, itree_le' ileaf t + | le_node' : forall l l' s s' g, + Z.le l l' -> + (forall i, itree_le' (s i) (s' (g i))) -> + itree_le' (inode l s) (inode l' s'). + + + + + +Lemma t1_le_t2 : itree_le t1 t2. + unfold t1, t2. + constructor. + auto with zarith. + intro i; exists (2 * i). + unfold isingle. + constructor. + auto with zarith. + exists i;constructor. +Qed. + + + +Lemma t1_le'_t2 : itree_le' t1 t2. + unfold t1, t2. + constructor 2 with (fun i : nat => 2 * i). + auto with zarith. + unfold isingle; + intro i ; constructor 2 with (fun i :nat => i). + auto with zarith. + constructor . +Qed. + + +Require Import List. + +Inductive ltree (A:Set) : Set := + lnode : A -> list (ltree A) -> ltree A. + +Inductive prop : Prop := + prop_intro : Prop -> prop. + +Lemma prop_inject: prop. +Proof prop_intro prop. + + +Inductive ex_Prop (P : Prop -> Prop) : Prop := + exP_intro : forall X : Prop, P X -> ex_Prop P. + +Lemma ex_Prop_inhabitant : ex_Prop (fun P => P -> P). +Proof. + exists (ex_Prop (fun P => P -> P)). + trivial. +Qed. + + + + + +Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) => + match p with exP_intro X HX => X end). +(* +Error: +Incorrect elimination of "p" in the inductive type +"ex_Prop", the return type has sort "Type" while it should be +"Prop" + +Elimination of an inductive object of sort "Prop" +is not allowed on a predicate in sort "Type" +because proofs can be eliminated only to build proofs +*) + + +Fail Check (match prop_inject with (prop_intro p) => p end). +(* +Error: +Incorrect elimination of "prop_inject" in the inductive type +"prop", the return type has sort "Type" while it should be +"Prop" + +Elimination of an inductive object of sort "Prop" +is not allowed on a predicate in sort "Type" +because proofs can be eliminated only to build proofs +*) +Print prop_inject. + +(* +prop_inject = +prop_inject = prop_intro prop + : prop +*) + + +Inductive typ : Type := + typ_intro : Type -> typ. + +Definition typ_inject: typ. +split. +Fail exact typ. +(* +Error: Universe Inconsistency. +*) +Abort. + +Fail Inductive aSet : Set := + aSet_intro: Set -> aSet. +(* +User error: Large non-propositional inductive types must be in Type +*) + +Inductive ex_Set (P : Set -> Prop) : Type := + exS_intro : forall X : Set, P X -> ex_Set P. + + +Module Type Version1. + +Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop := + c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p). + +Goal (comes_from_the_left _ _ (or_introl True I)). +split. +Qed. + +Goal ~(comes_from_the_left _ _ (or_intror True I)). + red;inversion 1. + (* discriminate H0. + *) +Abort. + +End Version1. + +Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := + match H with + | or_introl p => True + | or_intror q => False + end. + +(* +Error: +Incorrect elimination of "H" in the inductive type +"or", the return type has sort "Type" while it should be +"Prop" + +Elimination of an inductive object of sort "Prop" +is not allowed on a predicate in sort "Type" +because proofs can be eliminated only to build proofs +*) + +Definition comes_from_the_left_sumbool + (P Q:Prop)(x:{P}+{Q}): Prop := + match x with + | left p => True + | right q => False + end. + + + + +Close Scope Z_scope. + + + + + +Theorem S_is_not_O : forall n, S n <> 0. + +Set Nested Proofs Allowed. + +Definition Is_zero (x:nat):= match x with + | 0 => True + | _ => False + end. + Lemma O_is_zero : forall m, m = 0 -> Is_zero m. + Proof. + intros m H; subst m. + (* + ============================ + Is_zero 0 + *) + simpl;trivial. + Qed. + + red; intros n Hn. + apply O_is_zero with (m := S n). + assumption. +Qed. + +Theorem disc2 : forall n, S (S n) <> 1. +Proof. + intros n Hn; discriminate. +Qed. + + +Theorem disc3 : forall n, S (S n) = 0 -> forall Q:Prop, Q. +Proof. + intros n Hn Q. + discriminate. +Qed. + + + +Theorem inj_succ : forall n m, S n = S m -> n = m. +Proof. + + +Lemma inj_pred : forall n m, n = m -> pred n = pred m. +Proof. + intros n m eq_n_m. + rewrite eq_n_m. + trivial. +Qed. + + intros n m eq_Sn_Sm. + apply inj_pred with (n:= S n) (m := S m); assumption. +Qed. + +Lemma list_inject : forall (A:Set)(a b :A)(l l':list A), + a :: b :: l = b :: a :: l' -> a = b /\ l = l'. +Proof. + intros A a b l l' e. + injection e. + auto. +Qed. + + +Theorem not_le_Sn_0 : forall n:nat, ~ (S n <= 0). +Proof. + red; intros n H. + case H. +Undo. + +Lemma not_le_Sn_0_with_constraints : + forall n p , S n <= p -> p = 0 -> False. +Proof. + intros n p H; case H ; + intros; discriminate. +Qed. + +eapply not_le_Sn_0_with_constraints; eauto. +Qed. + + +Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). +Proof. + red; intros n H ; inversion H. +Qed. + +Derive Inversion le_Sn_0_inv with (forall n :nat, S n <= 0). +Check le_Sn_0_inv. + +Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . +Proof. + intros n p H; + inversion H using le_Sn_0_inv. +Qed. + +Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). +Check le_Sn_0_inv'. + + +Theorem le_reverse_rules : + forall n m:nat, n <= m -> + n = m \/ + exists p, n <= p /\ m = S p. +Proof. + intros n m H; inversion H. + left;trivial. + right; exists m0; split; trivial. +Restart. + intros n m H; inversion_clear H. + left;trivial. + right; exists m0; split; trivial. +Qed. + +Inductive ArithExp : Set := + Zero : ArithExp + | Succ : ArithExp -> ArithExp + | Plus : ArithExp -> ArithExp -> ArithExp. + +Inductive RewriteRel : ArithExp -> ArithExp -> Prop := + RewSucc : forall e1 e2 :ArithExp, + RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) + | RewPlus0 : forall e:ArithExp, + RewriteRel (Plus Zero e) e + | RewPlusS : forall e1 e2:ArithExp, + RewriteRel e1 e2 -> + RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). + + + +Fixpoint plus (n p:nat) {struct n} : nat := + match n with + | 0 => p + | S m => S (plus m p) + end. + +Fixpoint plus' (n p:nat) {struct p} : nat := + match p with + | 0 => n + | S q => S (plus' n q) + end. + +Fixpoint plus'' (n p:nat) {struct n} : nat := + match n with + | 0 => p + | S m => plus'' m (S p) + end. + +Module Type even_test_v1. + +Fixpoint even_test (n:nat) : bool := + match n + with 0 => true + | 1 => false + | S (S p) => even_test p + end. + +End even_test_v1. + +Module even_test_v2. + +Fixpoint even_test (n:nat) : bool := + match n + with + | 0 => true + | S p => odd_test p + end +with odd_test (n:nat) : bool := + match n + with + | 0 => false + | S p => even_test p + end. + +Eval simpl in even_test. + +Eval simpl in (fun x : nat => even_test x). + +Eval simpl in (fun x : nat => plus 5 x). +Eval simpl in (fun x : nat => even_test (plus 5 x)). + +Eval simpl in (fun x : nat => even_test (plus x 5)). + +End even_test_v2. + + +Section Principle_of_Induction. +Variable P : nat -> Prop. +Hypothesis base_case : P 0. +Hypothesis inductive_step : forall n:nat, P n -> P (S n). +Fixpoint nat_ind (n:nat) : (P n) := + match n return P n with + | 0 => base_case + | S m => inductive_step m (nat_ind m) + end. + +End Principle_of_Induction. + +Scheme Even_induction := Minimality for even Sort Prop +with Odd_induction := Minimality for odd Sort Prop. + +Theorem even_plus_four : forall n:nat, even n -> even (4+n). +Proof. + intros n H. + elim H using Even_induction with (P0 := fun n => odd (4+n)); + simpl;repeat constructor;assumption. +Qed. + + +Section Principle_of_Double_Induction. +Variable P : nat -> nat ->Prop. +Hypothesis base_case1 : forall x:nat, P 0 x. +Hypothesis base_case2 : forall x:nat, P (S x) 0. +Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). +Fixpoint nat_double_ind (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x + | (S x), 0 => base_case2 x + | (S x), (S y) => inductive_step x y (nat_double_ind x y) + end. +End Principle_of_Double_Induction. + +Section Principle_of_Double_Recursion. +Variable P : nat -> nat -> Set. +Hypothesis base_case1 : forall x:nat, P 0 x. +Hypothesis base_case2 : forall x:nat, P (S x) 0. +Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). +Fixpoint nat_double_rec (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x + | (S x), 0 => base_case2 x + | (S x), (S y) => inductive_step x y (nat_double_rec x y) + end. +End Principle_of_Double_Recursion. + +Definition min : nat -> nat -> nat := + nat_double_rec (fun (x y:nat) => nat) + (fun (x:nat) => 0) + (fun (y:nat) => 0) + (fun (x y r:nat) => S r). + +Eval compute in (min 5 8). +Eval compute in (min 8 5). + + + +Lemma not_circular : forall n:nat, n <> S n. +Proof. + intro n. + apply nat_ind with (P:= fun n => n <> S n). + discriminate. + red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;auto. +Qed. + +Definition eq_nat_dec : forall n p:nat , {n=p}+{n <> p}. +Proof. + intros n p. + apply nat_double_rec with (P:= fun (n q:nat) => {q=p}+{q <> p}). +Undo. + pattern p,n. + elim n using nat_double_rec. + destruct x; auto. + destruct x; auto. + intros n0 m H; case H. + intro eq; rewrite eq ; auto. + intro neg; right; red ; injection 1; auto. +Defined. + +Definition eq_nat_dec' : forall n p:nat, {n=p}+{n <> p}. + decide equality. +Defined. + +Print Acc. + + +Require Import Minus. + +Fail Fixpoint div (x y:nat){struct x}: nat := + if eq_nat_dec x 0 + then 0 + else if eq_nat_dec y 0 + then x + else S (div (x-y) y). +(* +Error: +Recursive definition of div is ill-formed. +In environment +div : nat -> nat -> nat +x : nat +y : nat +_ : x <> 0 +_ : y <> 0 + +Recursive call to div has principal argument equal to +"x - y" +instead of a subterm of x + +*) + +Lemma minus_smaller_S: forall x y:nat, x - y < S x. +Proof. + intros x y; pattern y, x; + elim x using nat_double_ind. + destruct x0; auto with arith. + simpl; auto with arith. + simpl; auto with arith. +Qed. + +Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> + x - y < x. +Proof. + destruct x; destruct y; + ( simpl;intros; apply minus_smaller_S || + intros; absurd (0=0); auto). +Qed. + +Definition minus_decrease : forall x y:nat, Acc lt x -> + x <> 0 -> + y <> 0 -> + Acc lt (x-y). +Proof. + intros x y H; case H. + intros Hz posz posy. + apply Hz; apply minus_smaller_positive; assumption. +Defined. + +Print minus_decrease. + + + +Fixpoint div_aux (x y:nat)(H: Acc lt x):nat. + refine (if eq_nat_dec x 0 + then 0 + else if eq_nat_dec y 0 + then y + else div_aux (x-y) y _). + apply (minus_decrease x y H);assumption. +Defined. + + +Print div_aux. +(* +div_aux = +(fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := + match eq_nat_dec x 0 with + | left _ => 0 + | right _ => + match eq_nat_dec y 0 with + | left _ => y + | right _0 => div_aux (x - y) y (minus_decrease x y H _ _0) + end + end) + : forall x : nat, nat -> Acc lt x -> nat +*) + +Require Import Wf_nat. +Definition div x y := div_aux x y (lt_wf x). + +Extraction div. +(* +let div x y = + div_aux x y +*) + +Extraction div_aux. + +(* +let rec div_aux x y = + match eq_nat_dec x O with + | Left -> O + | Right -> + (match eq_nat_dec y O with + | Left -> y + | Right -> div_aux (minus x y) y) +*) + +Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. +Proof. + intros A v;inversion v. +Abort. + + +Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), + n= 0 -> v = Vector.nil A. +(* +Error: In environment +A : Set +n : nat +v : Vector.t A n +The term "[]" has type "Vector.t A 0" while it is expected to have type + "Vector.t A n" +*) + Require Import JMeq. + +Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), + n= 0 -> JMeq v (Vector.nil A). +Proof. + destruct v. + auto. + intro; discriminate. +Qed. + +Lemma vector0_is_vnil : forall (A:Set)(v:Vector.t A 0), v = Vector.nil A. +Proof. + intros a v;apply JMeq_eq. + apply vector0_is_vnil_aux. + trivial. +Qed. + + +Arguments Vector.cons [A] _ [n]. +Arguments Vector.nil [A]. +Arguments Vector.hd [A n]. +Arguments Vector.tl [A n]. + +Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n. +Proof. + destruct n; intro v. + exact Vector.nil. + exact (Vector.cons (Vector.hd v) (Vector.tl v)). +Defined. + +Eval simpl in (fun (A:Set)(v:Vector.t A 0) => (Vid _ _ v)). + +Eval simpl in (fun (A:Set)(v:Vector.t A 0) => v). + + + +Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v). +Proof. + destruct v. + reflexivity. + reflexivity. +Defined. + +Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil. +Proof. + intros. + change (Vector.nil (A:=A)) with (Vid _ 0 v). + apply Vid_eq. +Defined. + + +Theorem decomp : + forall (A : Set) (n : nat) (v : Vector.t A (S n)), + v = Vector.cons (Vector.hd v) (Vector.tl v). +Proof. + intros. + change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _ (S n) v). + apply Vid_eq. +Defined. + + + +Definition vector_double_rect : + forall (A:Set) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type), + P 0 Vector.nil Vector.nil -> + (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 -> + P (S n) (Vector.cons a v1) (Vector.cons b v2)) -> + forall n (v1 v2 : Vector.t A n), P n v1 v2. + induction n. + intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). + auto. + intros v1 v2; rewrite (decomp _ _ v1);rewrite (decomp _ _ v2). + apply X0; auto. +Defined. + +Require Import Bool. + +Definition bitwise_or n v1 v2 : Vector.t bool n := + vector_double_rect bool (fun n v1 v2 => Vector.t bool n) + Vector.nil + (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2. + + +Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v} + : option A := + match n,v with + _ , Vector.nil => None + | 0 , Vector.cons b _ => Some b + | S n', Vector.cons _ v' => vector_nth A n' _ v' + end. + +Arguments vector_nth [A] _ [p]. + + +Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i a b, + vector_nth i v1 = Some a -> + vector_nth i v2 = Some b -> + vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). +Proof. + intros n v1 v2; pattern n,v1,v2. + apply vector_double_rect. + simpl. + destruct i; discriminate 1. + destruct i; simpl;auto. + injection 1 as ->; injection 1 as ->; auto. +Qed. + + Set Implicit Arguments. + + CoInductive Stream (A:Set) : Set := + | Cons : A -> Stream A -> Stream A. + + CoInductive LList (A: Set) : Set := + | LNil : LList A + | LCons : A -> LList A -> LList A. + + + + + + Definition head (A:Set)(s : Stream A) := match s with Cons a s' => a end. + + Definition tail (A : Set)(s : Stream A) := + match s with Cons a s' => s' end. + + CoFixpoint repeat (A:Set)(a:A) : Stream A := Cons a (repeat a). + + CoFixpoint iterate (A: Set)(f: A -> A)(a : A) : Stream A:= + Cons a (iterate f (f a)). + + CoFixpoint map (A B:Set)(f: A -> B)(s : Stream A) : Stream B:= + match s with Cons a tl => Cons (f a) (map f tl) end. + +Eval simpl in (fun (A:Set)(a:A) => repeat a). + +Eval simpl in (fun (A:Set)(a:A) => head (repeat a)). + + +CoInductive EqSt (A: Set) : Stream A -> Stream A -> Prop := + eqst : forall s1 s2: Stream A, + head s1 = head s2 -> + EqSt (tail s1) (tail s2) -> + EqSt s1 s2. + + +Section Parks_Principle. +Variable A : Set. +Variable R : Stream A -> Stream A -> Prop. +Hypothesis bisim1 : forall s1 s2:Stream A, R s1 s2 -> + head s1 = head s2. +Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> + R (tail s1) (tail s2). + +CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> + EqSt s1 s2 := + fun s1 s2 (p : R s1 s2) => + eqst s1 s2 (bisim1 p) + (park_ppl (bisim2 p)). +End Parks_Principle. + + +Theorem map_iterate : forall (A:Set)(f:A->A)(x:A), + EqSt (iterate f (f x)) (map f (iterate f x)). +Proof. + intros A f x. + apply park_ppl with + (R:= fun s1 s2 => exists x: A, + s1 = iterate f (f x) /\ s2 = map f (iterate f x)). + + intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. + intros s1 s2 (x0,(eqs1,eqs2)). + exists (f x0);split;[rewrite eqs1|rewrite eqs2]; reflexivity. + exists x;split; reflexivity. +Qed. + +Ltac infiniteproof f := + cofix f; constructor; [clear f| simpl; try (apply f; clear f)]. + + +Theorem map_iterate' : forall (A:Set)(f:A->A)(x:A), + EqSt (iterate f (f x)) (map f (iterate f x)). +infiniteproof map_iterate'. + reflexivity. +Qed. + + +Arguments LNil [A]. + +Lemma Lnil_not_Lcons : forall (A:Set)(a:A)(l:LList A), + LNil <> (LCons a l). + intros;discriminate. +Qed. + +Lemma injection_demo : forall (A:Set)(a b : A)(l l': LList A), + LCons a (LCons b l) = LCons b (LCons a l') -> + a = b /\ l = l'. +Proof. + intros A a b l l' e; injection e; auto. +Qed. + + +Inductive Finite (A:Set) : LList A -> Prop := +| Lnil_fin : Finite (LNil (A:=A)) +| Lcons_fin : forall a l, Finite l -> Finite (LCons a l). + +CoInductive Infinite (A:Set) : LList A -> Prop := +| LCons_inf : forall a l, Infinite l -> Infinite (LCons a l). + +Lemma LNil_not_Infinite : forall (A:Set), ~ Infinite (LNil (A:=A)). +Proof. + intros A H;inversion H. +Qed. + +Lemma Finite_not_Infinite : forall (A:Set)(l:LList A), + Finite l -> ~ Infinite l. +Proof. + intros A l H; elim H. + apply LNil_not_Infinite. + intros a l0 F0 I0' I1. + case I0'; inversion_clear I1. + trivial. +Qed. + +Lemma Not_Finite_Infinite : forall (A:Set)(l:LList A), + ~ Finite l -> Infinite l. +Proof. + cofix H. + destruct l. + intro; absurd (Finite (LNil (A:=A)));[auto|constructor]. + constructor. + apply H. + red; intro H1;case H0. + constructor. + trivial. +Qed. + + + + diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v new file mode 100644 index 0000000000..18ebcd6384 --- /dev/null +++ b/test-suite/success/Record.v @@ -0,0 +1,94 @@ +(* Nijmegen expects redefinition of sorts *) +Definition CProp := Prop. +Record test : CProp := {n : nat ; m : bool ; _ : n <> 0 }. +Require Import Program. +Require Import List. + +Record vector {A : Type} {n : nat} := { vec_list : list A ; vec_len : length vec_list = n }. +Arguments vector : clear implicits. + +Coercion vec_list : vector >-> list. + +Hint Rewrite @vec_len : datatypes. + +Ltac crush := repeat (program_simplify ; autorewrite with list datatypes ; auto with *). + +Obligation Tactic := crush. + +Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}. + +Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := + {| vec_list := cons a (vec_list v) |}. + +Hint Rewrite map_length rev_length : datatypes. + +Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := + {| vec_list := map f v |}. + +Program Definition vreverse {A n} (v : vector A n) : vector A n := + {| vec_list := rev v |}. + +Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := + match v, w with + | nil, nil => nil + | cons f fs, cons x xs => cons (f x) (va_list fs xs) + | _, _ => nil + end. + +Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := + {| vec_list := va_list v w |}. + +Next Obligation. + destruct v as [v Hv]; destruct w as [w Hw] ; simpl. + subst n. revert w Hw. induction v ; destruct w ; crush. + rewrite IHv ; auto. +Qed. + +(* Correct type inference of record notation. Initial example by Spiwack. *) + +Inductive Machin := { + Bazar : option Machin +}. + +Definition bli : Machin := + {| Bazar := Some ({| Bazar := None |}:Machin) |}. + +Definition bli' : option (option Machin) := + Some (Some {| Bazar := None |} ). + +Definition bli'' : Machin := + {| Bazar := Some {| Bazar := None |} |}. + +Definition bli''' := {| Bazar := Some {| Bazar := None |} |}. + +(** Correctly use scoping information *) + +Require Import ZArith. + +Record Foo := { bar : Z }. +Definition foo := {| bar := 0 |}. + +(** Notations inside records *) + +Require Import Relation_Definitions. + +Record DecidableOrder : Type := +{ A : Type +; le : relation A where "x <= y" := (le x y) +; le_refl : reflexive _ le +; le_antisym : antisymmetric _ le +; le_trans : transitive _ le +; le_total : forall x y, {x <= y}+{y <= x} +}. + +(* Test syntactic sugar suggested by wish report #2138 *) + +Record R : Type := { + P (A : Type) : Prop := exists x : A -> A, x = x; + Q A : P A -> P A +}. + +(* We allow reusing an implicit parameter named in non-recursive types *) +(* This is used in a couple of development such as UniMatch *) + +Record S {A:Type} := { a : A; b : forall A:Type, A }. diff --git a/test-suite/success/Reg.v b/test-suite/success/Reg.v new file mode 100644 index 0000000000..c2d5cb2f47 --- /dev/null +++ b/test-suite/success/Reg.v @@ -0,0 +1,144 @@ +Require Import Reals. + +Axiom y : R -> R. +Axiom d_y : derivable y. +Axiom n_y : forall x : R, y x <> 0%R. +Axiom dy_0 : derive_pt y 0 (d_y 0%R) = 1%R. + +Lemma essai0 : continuity_pt (fun x : R => ((x + 2) / y x + x / y x)%R) 0. +assert (H := d_y). +assert (H0 := n_y). +reg. +Qed. + +Lemma essai1 : derivable_pt (fun x : R => (/ 2 * sin x)%R) 1. +reg. +Qed. + +Lemma essai2 : continuity (fun x : R => (Rsqr x * cos (x * x) + x)%R). +reg. +Qed. + +Lemma essai3 : derivable_pt (fun x : R => (x * (Rsqr x + 3))%R) 0. +reg. +Qed. + +Lemma essai4 : derivable (fun x : R => ((x + x) * sin x)%R). +reg. +Qed. + +Lemma essai5 : derivable (fun x : R => (1 + sin (2 * x + 3) * cos (cos x))%R). +reg. +Qed. + +Lemma essai6 : derivable (fun x : R => cos (x + 3)). +reg. +Qed. + +Lemma essai7 : + derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1. +reg. +apply Rlt_0_1. +red; intro; rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0; + assumption. +Qed. + +Lemma essai8 : derivable_pt (fun x : R => sqrt (Rsqr x + sin x + 1)) 0. +reg. + rewrite sin_0. + rewrite Rsqr_0. + replace (0 + 0 + 1)%R with 1%R; [ apply Rlt_0_1 | ring ]. +Qed. + +Lemma essai9 : derivable_pt (id + sin) 1. +reg. +Qed. + +Lemma essai10 : derivable_pt (fun x : R => (x + 2)%R) 0. +reg. +Qed. + +Lemma essai11 : derive_pt (fun x : R => (x + 2)%R) 0 essai10 = 1%R. +reg. +Qed. + +Lemma essai12 : derivable (fun x : R => (x + Rsqr (x + 2))%R). +reg. +Qed. + +Lemma essai13 : + derive_pt (fun x : R => (x + Rsqr (x + 2))%R) 0 (essai12 0%R) = 5%R. +reg. +Qed. + +Lemma essai14 : derivable_pt (fun x : R => (2 * x + x)%R) 2. +reg. +Qed. + +Lemma essai15 : derive_pt (fun x : R => (2 * x + x)%R) 2 essai14 = 3%R. +reg. +Qed. + +Lemma essai16 : derivable_pt (fun x : R => (x + sin x)%R) 0. +reg. +Qed. + +Lemma essai17 : derive_pt (fun x : R => (x + sin x)%R) 0 essai16 = 2%R. +reg. + rewrite cos_0. +reflexivity. +Qed. + +Lemma essai18 : derivable_pt (fun x : R => (x + y x)%R) 0. +assert (H := d_y). +reg. +Qed. + +Lemma essai19 : derive_pt (fun x : R => (x + y x)%R) 0 essai18 = 2%R. +assert (H := dy_0). +assert (H0 := d_y). +reg. +Qed. + +Axiom z : R -> R. +Axiom d_z : derivable z. + +Lemma essai20 : derivable_pt (fun x : R => z (y x)) 0. +reg. +apply d_y. +apply d_z. +Qed. + +Lemma essai21 : derive_pt (fun x : R => z (y x)) 0 essai20 = 1%R. +assert (H := dy_0). +reg. +Abort. + +Lemma essai22 : derivable (fun x : R => (sin (z x) + Rsqr (z x) / y x)%R). +assert (H := d_y). +reg. +apply n_y. +apply d_z. +Qed. + +(* Pour tester la continuite de sqrt en 0 *) +Lemma essai23 : + continuity_pt + (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1. +reg. +left; apply Rlt_0_1. +right; unfold Rminus; rewrite Rplus_opp_r; reflexivity. +Qed. + +Lemma essai24 : + derivable (fun x : R => (sqrt (x * x + 2 * x + 2) + Rabs (x * x + 1))%R). +reg. + replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R. +apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ]. +unfold Rsqr; ring. +red; intro; cut (0 < x * x + 1)%R. +intro; rewrite H in H0; elim (Rlt_irrefl _ H0). +apply Rplus_le_lt_0_compat; + [ replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ] + | apply Rlt_0_1 ]. +Qed. diff --git a/test-suite/success/Remark.v b/test-suite/success/Remark.v new file mode 100644 index 0000000000..2dd6a2113e --- /dev/null +++ b/test-suite/success/Remark.v @@ -0,0 +1,12 @@ +(* Test obsolete, Remark est maintenant global +Section A. +Section B. +Section C. +Remark t : True. Proof I. +End C. +Locate C.t. +End B. +Locate B.C.t. +End A. +Locate A.B.C.t. +*) diff --git a/test-suite/success/Rename.v b/test-suite/success/Rename.v new file mode 100644 index 0000000000..2789c6c9a6 --- /dev/null +++ b/test-suite/success/Rename.v @@ -0,0 +1,18 @@ +Goal forall n : nat, n = 0 -> n = 0. +intros. +rename n into p. +induction p; auto. +Qed. + +(* Submitted by Iris Loeb (BZ#842) *) + +Section rename. + +Variable A:Prop. + +Lemma Tauto: A->A. +rename A into B. +tauto. +Qed. + +End rename. diff --git a/test-suite/success/Reordering.v b/test-suite/success/Reordering.v new file mode 100644 index 0000000000..de9b997590 --- /dev/null +++ b/test-suite/success/Reordering.v @@ -0,0 +1,15 @@ +(* Testing the reordering of hypothesis required by pattern, fold and change. *) +Goal forall (A:Set) (x:A) (A':=A), True. +intros. +fold A' in x. (* suceeds: x is moved after A' *) +Undo. +pattern A' in x. +Undo. +change A' in x. +Abort. + +(* p and m should be moved before H *) +Goal forall n:nat, n=n -> forall m:nat, let p := (m,n) in True. +intros. +change n with (snd p) in H. +Abort. diff --git a/test-suite/success/Require.v b/test-suite/success/Require.v new file mode 100644 index 0000000000..de5987c4f7 --- /dev/null +++ b/test-suite/success/Require.v @@ -0,0 +1,8 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) + +Require Import Coq.Arith.Plus. +Require Coq.Arith.Minus. +Locate Library Coq.Arith.Minus. + +(* Check that Init didn't get exported by the import above *) +Fail Check nat. diff --git a/test-suite/success/Scheme.v b/test-suite/success/Scheme.v new file mode 100644 index 0000000000..855f26698c --- /dev/null +++ b/test-suite/success/Scheme.v @@ -0,0 +1,27 @@ +(* This failed in 8.3pl2 *) + +Scheme Induction for eq Sort Prop. +Check eq_ind_dep. + +(* This was broken in v8.5 *) + +Set Rewriting Schemes. +Inductive myeq A (a:A) : A -> Prop := myrefl : myeq A a a. +Unset Rewriting Schemes. + +Check myeq_rect. +Check myeq_ind. +Check myeq_rec. +Check myeq_congr. +Check myeq_sym_internal. +Check myeq_rew. +Check myeq_rew_dep. +Check myeq_rew_fwd_dep. +Check myeq_rew_r. +Check internal_myeq_sym_involutive. +Check myeq_rew_r_dep. +Check myeq_rew_fwd_r_dep. + +Set Rewriting Schemes. +Inductive myeq_true : bool -> Prop := myrefl_true : myeq_true true. +Unset Rewriting Schemes. diff --git a/test-suite/success/SchemeEquality.v b/test-suite/success/SchemeEquality.v new file mode 100644 index 0000000000..85d5c3e123 --- /dev/null +++ b/test-suite/success/SchemeEquality.v @@ -0,0 +1,29 @@ +(* Examples of use of Scheme Equality *) + +Module A. +Definition N := nat. +Inductive list := nil | cons : N -> list -> list. +Scheme Equality for list. +End A. + +Module B. + Section A. + Context A (eq_A:A->A->bool) + (A_bl : forall x y, eq_A x y = true -> x = y) + (A_lb : forall x y, x = y -> eq_A x y = true). + Inductive I := C : A -> I. + Scheme Equality for I. + End A. +End B. + +Module C. + Parameter A : Type. + Parameter eq_A : A->A->bool. + Parameter A_bl : forall x y, eq_A x y = true -> x = y. + Parameter A_lb : forall x y, x = y -> eq_A x y = true. + Hint Resolve A_bl A_lb : core. + Inductive I := C : A -> I. + Scheme Equality for I. + Inductive J := D : list A -> J. + Scheme Equality for J. +End C. diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v new file mode 100644 index 0000000000..06697af901 --- /dev/null +++ b/test-suite/success/Scopes.v @@ -0,0 +1,28 @@ +(* Check exportation of Argument Scopes even without import of modules *) + +Require Import ZArith. + +Module A. +Definition opp := Z.opp. +End A. +Check (A.opp 3). + +(* Test extra scopes to be used in the presence of coercions *) + +Record B := { f :> Z -> Z }. +Variable a:B. +Arguments a _%Z_scope : extra scopes. +Check a 0. + +(* Check that casts activate scopes if ever possible *) + +Inductive U := A. +Bind Scope u with U. +Notation "'ε'" := A : u. +Definition c := ε : U. + +(* Check activation of type scope for tactics such as assert *) + +Goal True. +assert (nat * nat). +Abort. diff --git a/test-suite/success/Section.v b/test-suite/success/Section.v new file mode 100644 index 0000000000..8e9e79b3e5 --- /dev/null +++ b/test-suite/success/Section.v @@ -0,0 +1,6 @@ +(* Test bug 2168: ending section of some name was removing objects of the + same name *) + +Require Import make_notation. + +Check add2 3. diff --git a/test-suite/success/ShowExtraction.v b/test-suite/success/ShowExtraction.v new file mode 100644 index 0000000000..a4a35003df --- /dev/null +++ b/test-suite/success/ShowExtraction.v @@ -0,0 +1,31 @@ + +Require Extraction. +Require Import List. + +Section Test. +Variable A : Type. +Variable decA : forall (x y:A), {x=y}+{x<>y}. + +(** Should fail when no proofs are started *) +Fail Show Extraction. + +Lemma decListA : forall (xs ys : list A), {xs=ys}+{xs<>ys}. +Proof. +Show Extraction. +fix decListA 1. +destruct xs as [|x xs], ys as [|y ys]. +Show Extraction. +- now left. +- now right. +- now right. +- Show Extraction. + destruct (decA x y). + + destruct (decListA xs ys). + * left; now f_equal. + * Show Extraction. + right. congruence. + + right. congruence. +Show Extraction. +Defined. + +End Test. diff --git a/test-suite/success/Simplify_eq.v b/test-suite/success/Simplify_eq.v new file mode 100644 index 0000000000..d9abdbf5a6 --- /dev/null +++ b/test-suite/success/Simplify_eq.v @@ -0,0 +1,13 @@ +(* Check the behaviour of Simplify_eq *) + +(* Check that Simplify_eq tries Intro until *) + +Lemma l1 : 0 = 1 -> False. + simplify_eq 1. +Qed. + +Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. + simplify_eq H. +intros. +apply (n_Sn x H0). +Qed. diff --git a/test-suite/success/TacticNotation1.v b/test-suite/success/TacticNotation1.v new file mode 100644 index 0000000000..289f2816e5 --- /dev/null +++ b/test-suite/success/TacticNotation1.v @@ -0,0 +1,20 @@ +Module Type S. +End S. + +Module F (E : S). + + Tactic Notation "foo" := idtac. + + Ltac bar := foo. + +End F. + +Module G (E : S). + Module M := F E. + + Lemma Foo : True. + Proof. + M.bar. + Abort. + +End G. diff --git a/test-suite/success/TacticNotation2.v b/test-suite/success/TacticNotation2.v new file mode 100644 index 0000000000..cb341b8e10 --- /dev/null +++ b/test-suite/success/TacticNotation2.v @@ -0,0 +1,12 @@ +Tactic Notation "complete" tactic(tac) := tac; fail. + +Ltac f0 := complete (intuition idtac). +(** FIXME: This is badly printed because of bug #3079. + At least we check that it does not fail anomalously. *) +Print Ltac f0. + +Ltac f1 := complete f1. +Print Ltac f1. + +Ltac f2 := complete intuition. +Print Ltac f2. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v new file mode 100644 index 0000000000..7d01d3b07b --- /dev/null +++ b/test-suite/success/Tauto.v @@ -0,0 +1,244 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(**** Tactics Tauto and Intuition ****) + +(**** Tauto: + Tactic for automating proof in Intuionnistic Propositional Calculus, based on + the contraction-free LJT* of Dickhoff ****) + +(**** Intuition: + Simplifications of goals, based on LJT* calcul ****) + +(**** Examples of intuitionistic tautologies ****) +Parameter A B C D E F : Prop. +Parameter even : nat -> Prop. +Parameter P : nat -> Prop. + +Lemma Ex_Wallen : (A -> B /\ C) -> (A -> B) \/ (A -> C). +Proof. + tauto. +Qed. + +Lemma Ex_Klenne : ~ ~ (A \/ ~ A). +Proof. + tauto. +Qed. + +Lemma Ex_Klenne' : forall n : nat, ~ ~ (even n \/ ~ even n). +Proof. + tauto. +Qed. + +Lemma Ex_Klenne'' : + ~ ~ ((forall n : nat, even n) \/ ~ (forall m : nat, even m)). +Proof. + tauto. +Qed. + +Lemma tauto : (forall x : nat, P x) -> forall y : nat, P y. +Proof. + tauto. +Qed. + +Lemma tauto1 : A -> A. +Proof. + tauto. +Qed. + +Lemma tauto2 : (A -> B -> C) -> (A -> B) -> A -> C. +Proof. + tauto. +Qed. + +Lemma a : forall (x0 : A \/ B) (x1 : B /\ C), A -> B. +Proof. + tauto. +Qed. + +Lemma a2 : (A -> B /\ C) -> (A -> B) \/ (A -> C). +Proof. + tauto. +Qed. + +Lemma a4 : ~ A -> ~ A. +Proof. + tauto. +Qed. + +Lemma e2 : ~ ~ (A \/ ~ A). +Proof. + tauto. +Qed. + +Lemma e4 : ~ ~ (A \/ B -> A \/ B). +Proof. + tauto. +Qed. + +Lemma y0 : + forall (x0 : A) (x1 : ~ A) (x2 : A -> B) (x3 : A \/ B) (x4 : A /\ B), + A -> False. +Proof. + tauto. +Qed. + +Lemma y1 : forall x0 : (A /\ B) /\ C, B. +Proof. + tauto. +Qed. + +Lemma y2 : forall (x0 : A) (x1 : B), C \/ B. +Proof. + tauto. +Qed. + +Lemma y3 : forall x0 : A /\ B, B /\ A. +Proof. + tauto. +Qed. + +Lemma y5 : forall x0 : A \/ B, B \/ A. +Proof. + tauto. +Qed. + +Lemma y6 : forall (x0 : A -> B) (x1 : A), B. +Proof. + tauto. +Qed. + +Lemma y7 : forall (x0 : A /\ B -> C) (x1 : B) (x2 : A), C. +Proof. + tauto. +Qed. + +Lemma y8 : forall (x0 : A \/ B -> C) (x1 : A), C. +Proof. + tauto. +Qed. + +Lemma y9 : forall (x0 : A \/ B -> C) (x1 : B), C. +Proof. + tauto. +Qed. + +Lemma y10 : forall (x0 : (A -> B) -> C) (x1 : B), C. +Proof. + tauto. +Qed. + +(* This example took much time with the old version of Tauto *) +Lemma critical_example0 : (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. +Proof. + tauto. +Qed. + +(* Same remark as previously *) +Lemma critical_example1 : (~ ~ B -> B) -> (~ B -> ~ A) -> ~ ~ A -> B. +Proof. + tauto. +Qed. + +(* This example took very much time (about 3mn on a PIII 450MHz in bytecode) + with the old Tauto. Now, it's immediate (less than 1s). *) +Lemma critical_example2 : (~ A <-> B) -> (~ B <-> A) -> (~ ~ A <-> A). +Proof. + tauto. +Qed. + +(* This example was a bug *) +Lemma old_bug0 : + (~ A <-> B) -> (~ (C \/ E) <-> D /\ F) -> (~ (C \/ A \/ E) <-> D /\ B /\ F). +Proof. + tauto. +Qed. + +(* Another bug *) +Lemma old_bug1 : ((A -> B -> False) -> False) -> (B -> False) -> False. +Proof. + tauto. +Qed. + +(* A bug again *) +Lemma old_bug2 : + ((((C -> False) -> A) -> ((B -> False) -> A) -> False) -> False) -> + (((C -> B -> False) -> False) -> False) -> ~ A -> A. +Proof. + tauto. +Qed. + +(* A bug from CNF form *) +Lemma old_bug3 : + ((~ A \/ B) /\ (~ B \/ B) /\ (~ A \/ ~ B) /\ (~ B \/ ~ B) -> False) -> + ~ ((A -> B) -> B) -> False. +Proof. + tauto. +Qed. + +(* sometimes, the behaviour of Tauto depends on the order of the hyps *) +Lemma old_bug3bis : + ~ ((A -> B) -> B) -> + ((~ B \/ ~ B) /\ (~ B \/ ~ A) /\ (B \/ ~ B) /\ (B \/ ~ A) -> False) -> False. +Proof. + tauto. +Qed. + +(* A bug found by Freek Wiedijk <freek@cs.kun.nl> *) +Lemma new_bug : + ((A <-> B) -> (B <-> C)) -> + ((B <-> C) -> (C <-> A)) -> ((C <-> A) -> (A <-> B)) -> (A <-> B). +Proof. + tauto. +Qed. + + +(* A private club has the following rules : + * + * . rule 1 : Every non-scottish member wears red socks + * . rule 2 : Every member wears a kilt or doesn't wear red socks + * . rule 3 : The married members don't go out on sunday + * . rule 4 : A member goes out on sunday if and only if he is scottish + * . rule 5 : Every member who wears a kilt is scottish and married + * . rule 6 : Every scottish member wears a kilt + * + * Actually, no one can be accepted ! + *) + +Section club. + +Variable Scottish RedSocks WearKilt Married GoOutSunday : Prop. + +Hypothesis rule1 : ~ Scottish -> RedSocks. +Hypothesis rule2 : WearKilt \/ ~ RedSocks. +Hypothesis rule3 : Married -> ~ GoOutSunday. +Hypothesis rule4 : GoOutSunday <-> Scottish. +Hypothesis rule5 : WearKilt -> Scottish /\ Married. +Hypothesis rule6 : Scottish -> WearKilt. + +Lemma NoMember : False. + tauto. +Qed. + +End club. + +(**** Use of Intuition ****) +Lemma intu0 : + (forall x : nat, P x) /\ B -> (forall y : nat, P y) /\ P 0 \/ B /\ P 0. +Proof. + intuition. +Qed. + +Lemma intu1 : + (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y. +Proof. + intuition. +Qed. + diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v new file mode 100644 index 0000000000..cfc25c3346 --- /dev/null +++ b/test-suite/success/Template.v @@ -0,0 +1,48 @@ +Set Printing Universes. + +Module AutoYes. + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + (* This checks that Box is template poly, see module No for how it fails *) + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Definition box_lti A := Box A : Type@{i}. + +End AutoYes. + +Module AutoNo. + Unset Auto Template Polymorphism. + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Fail Definition box_lti A := Box A : Type@{i}. + +End AutoNo. + +Module Yes. + #[universes(template)] + Inductive Box@{i} (A:Type@{i}) : Type@{i} := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Definition box_lti A := Box A : Type@{i}. + +End Yes. + +Module No. + #[universes(notemplate)] + Inductive Box (A:Type) : Type := box : A -> Box A. + + About Box. + + Universe i j. Constraint i < j. + Definition j_lebox (A:Type@{j}) := Box A. + Fail Definition box_lti A := Box A : Type@{i}. +End No. diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v new file mode 100644 index 0000000000..f1683078cb --- /dev/null +++ b/test-suite/success/TestRefine.v @@ -0,0 +1,225 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(************************************************************************) + +Lemma essai : forall x : nat, x = x. + refine + ((fun x0 : nat => match x0 with + | O => _ + | S p => _ + end)). + +Restart. + + refine + (fun x0 : nat => match x0 as n return (n = n) with + | O => _ + | S p => _ + end). (* OK *) + +Restart. + + refine + (fun x0 : nat => match x0 as n return (n = n) with + | O => _ + | S p => _ + end). (* OK *) + +Restart. + +(** +Refine [x0:nat]Cases x0 of O => ? | (S p) => ? end. (* cannot be executed *) +**) + +Abort. + + +(************************************************************************) + +Lemma T : nat. + + refine (S _). + +Abort. + + +(************************************************************************) + +Lemma essai2 : forall x : nat, x = x. + +refine (fix f (x : nat) : x = x := _). + +Restart. + + refine + (fix f (x : nat) : x = x := + match x as n return (n = n :>nat) with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fix f (x : nat) : x = x := + match x as n return (n = n) with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fix f (x : nat) : x = x := + match x as n return (n = n :>nat) with + | O => _ + | S p => f_equal S _ + end). + +Restart. + + refine + (fix f (x : nat) : x = x := + match x as n return (n = n :>nat) with + | O => _ + | S p => f_equal S _ + end). + +Abort. + + +(************************************************************************) +Parameter f : nat * nat -> nat -> nat. + +Lemma essai : nat. + + refine (f _ ((fun x : nat => _:nat) 0)). + +Restart. + + refine (f _ 0). + +Abort. + + +(************************************************************************) + +Parameter P : nat -> Prop. + +Lemma essai : {x : nat | x = 1}. + + refine (exist _ 1 _). (* ECHEC *) + +Restart. + +(* mais si on contraint par le but alors ca marche : *) +(* Remarque : on peut toujours faire ça *) + refine (exist _ 1 _:{x : nat | x = 1}). + +Restart. + + refine (exist (fun x : nat => x = 1) 1 _). + +Abort. + + +(************************************************************************) + +Lemma essai : forall n : nat, {x : nat | x = S n}. + + refine + (fun n : nat => + match n return {x : nat | x = S n} with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fun n : nat => match n with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fun n : nat => + match n return {x : nat | x = S n} with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fix f (n : nat) : {x : nat | x = S n} := + match n return {x : nat | x = S n} with + | O => _ + | S p => _ + end). + +Restart. + + refine + (fix f (n : nat) : {x : nat | x = S n} := + match n return {x : nat | x = S n} with + | O => _ + | S p => _ + end). + +exists 1. trivial. +elim (f p). + refine + (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). + rewrite h. auto. +Qed. + + + +(* Quelques essais de recurrence bien fondée *) + +Require Import Wf. +Require Import Wf_nat. + +Lemma essai_wf : nat -> nat. + + refine + (fun x : nat => + well_founded_induction _ (fun _ : nat => nat -> nat) + (fun (phi0 : nat) (w : forall phi : nat, phi < phi0 -> nat -> nat) => + w x _) x x). +exact lt_wf. + +Abort. + + +Require Import Compare_dec. +Require Import Lt. + +Lemma fibo : nat -> nat. + refine + (well_founded_induction _ (fun _ : nat => nat) + (fun (x0 : nat) (fib : forall x : nat, x < x0 -> nat) => + match zerop x0 with + | left _ => 1 + | right h1 => + match zerop (pred x0) with + | left _ => 1 + | right h2 => fib (pred x0) _ + fib (pred (pred x0)) _ + end + end)). +exact lt_wf. +auto with arith. +apply lt_trans with (m := pred x0); auto with arith. +Qed. + diff --git a/test-suite/success/Try.v b/test-suite/success/Try.v new file mode 100644 index 0000000000..76aac39a55 --- /dev/null +++ b/test-suite/success/Try.v @@ -0,0 +1,8 @@ +(* To shorten interactive scripts, it is better that Try catches + non-existent names in Unfold [cf BZ#263] *) + +Lemma lem1 : True. +try unfold i_dont_exist. +trivial. +Qed. + diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v new file mode 100644 index 0000000000..400479ae85 --- /dev/null +++ b/test-suite/success/Typeclasses.v @@ -0,0 +1,259 @@ +Module onlyclasses. + +(* In 8.6 we still allow non-class subgoals *) + Variable Foo : Type. + Variable foo : Foo. + Hint Extern 0 Foo => exact foo : typeclass_instances. + Goal Foo * Foo. + split. shelve. + Set Typeclasses Debug. + typeclasses eauto. + Unshelve. typeclasses eauto. + Qed. + + Module RJung. + Class Foo (x : nat). + + Instance foo x : x = 2 -> Foo x. + Hint Extern 0 (_ = _) => reflexivity : typeclass_instances. + Typeclasses eauto := debug. + Check (_ : Foo 2). + + + Fail Definition foo := (_ : 0 = 0). + + End RJung. +End onlyclasses. + +Module shelve_non_class_subgoals. + Variable Foo : Type. + Variable foo : Foo. + Hint Extern 0 Foo => exact foo : typeclass_instances. + Class Bar := {}. + Instance bar1 (f:Foo) : Bar := {}. + + Typeclasses eauto := debug. + Set Typeclasses Debug Verbosity 2. + Goal Bar. + (* Solution has shelved subgoals (of non typeclass type) *) + typeclasses eauto. + Abort. +End shelve_non_class_subgoals. + +Module RefineVsNoTceauto. + + Class Foo (A : Type) := foo : A. + Instance: Foo nat := { foo := 0 }. + Instance: Foo nat := { foo := 42 }. + Hint Extern 0 (_ = _) => refine eq_refl : typeclass_instances. + Goal exists (f : Foo nat), @foo _ f = 0. + Proof. + unshelve (notypeclasses refine (ex_intro _ _ _)). + Set Typeclasses Debug. Set Printing All. + all:once (typeclasses eauto). + Fail idtac. (* Check no subgoals are left *) + Undo 3. + (** In this case, the (_ = _) subgoal is not considered + by typeclass resolution *) + refine (ex_intro _ _ _). Fail reflexivity. + Abort. + +End RefineVsNoTceauto. + +Module Leivantex2PR339. + (** Was a bug preventing to find hints associated with no pattern *) + Class Bar := {}. + Instance bar1 (t:Type) : Bar. + Hint Extern 0 => exact True : typeclass_instances. + Typeclasses eauto := debug. + Goal Bar. + Set Typeclasses Debug Verbosity 2. + typeclasses eauto. (* Relies on resolution of a non-class subgoal *) + Undo 1. + typeclasses eauto with typeclass_instances. + Qed. +End Leivantex2PR339. + +Module bt. +Require Import Equivalence. + +Record Equ (A : Type) (R : A -> A -> Prop). +Definition equiv {A} R (e : Equ A R) := R. +Record Refl (A : Type) (R : A -> A -> Prop). +Axiom equ_refl : forall A R (e : Equ A R), Refl _ (@equiv A R e). +Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [shelve|] : foo. + +Variable R : nat -> nat -> Prop. +Lemma bas : Equ nat R. +Admitted. +Hint Resolve bas : foo. +Hint Extern 1 => match goal with |- (_ -> _ -> Prop) => shelve end : foo. + +Goal exists R, @Refl nat R. + eexists. + Set Typeclasses Debug. + (* Fail solve [unshelve eauto with foo]. *) + Set Typeclasses Debug Verbosity 1. + Test Typeclasses Depth. + solve [typeclasses eauto with foo]. +Qed. + +Set Typeclasses Compatibility "8.5". +Parameter f : nat -> Prop. +Parameter g : nat -> nat -> Prop. +Parameter h : nat -> nat -> nat -> Prop. +Axiom a : forall x y, g x y -> f x -> f y. +Axiom b : forall x (y : Empty_set), g (fst (x,y)) x. +Axiom c : forall x y z, h x y z -> f x -> f y. +Hint Resolve a b c : mybase. +Goal forall x y z, h x y z -> f x -> f y. + intros. + Fail Timeout 1 typeclasses eauto with mybase. (* Loops now *) + Unshelve. +Abort. +End bt. +Generalizable All Variables. + +Module mon. + +Reserved Notation "'return' t" (at level 0). +Reserved Notation "x >>= y" (at level 65, left associativity). + + + +Record Monad {m : Type -> Type} := { + unit : forall {α}, α -> m α where "'return' t" := (unit t) ; + bind : forall {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ; + bind_unit_left : forall {α β} (a : α) (f : α -> m β), return a >>= f = f a }. + +Print Visibility. +Print unit. +Arguments unit {m m0 α}. +Arguments Monad : clear implicits. +Notation "'return' t" := (unit t). + +(* Test correct handling of existentials and defined fields. *) + +Class A `(e: T) := { a := True }. +Class B `(e_: T) := { e := e_; sg_ass :> A e }. + +(* Set Typeclasses Debug. *) +(* Set Typeclasses Debug Verbosity 2. *) + +Goal forall `{B T}, Prop. + intros. apply a. +Defined. + +Goal forall `{B T}, Prop. + intros. refine (@a _ _ _). +Defined. + +Class B' `(e_: T) := { e' := e_; sg_ass' :> A e_ }. + +Goal forall `{B' T}, a. + intros. exact I. +Defined. + +End mon. + +(* Correct treatment of dependent goals *) + +(* First some preliminaries: *) + +Section sec. + Context {N: Type}. + Class C (f: N->N) := {}. + Class E := { e: N -> N }. + Context + (g: N -> N) `(E) `(C e) + `(forall (f: N -> N), C f -> C (fun x => f x)) + (U: forall f: N -> N, C f -> False). + +(* Now consider the following: *) + + Let foo := U (fun x => e x). + Check foo _. + +(* This type checks fine, so far so good. But now + let's try to get rid of the intermediate constant foo. + Surely we can just expand it inline, right? Wrong!: *) + Check U (fun x => e x) _. +End sec. + +Module UniqueSolutions. + Set Typeclasses Unique Solutions. + Class Eq (A : Type) : Set. + Instance eqa : Eq nat := {}. + Instance eqb : Eq nat := {}. + + Goal Eq nat. + try apply _. + Fail exactly_once typeclasses eauto. + Abort. +End UniqueSolutions. + + +Module UniqueInstances. + (** Optimize proof search on this class by never backtracking on (closed) goals + for it. *) + Set Typeclasses Unique Instances. + Class Eq (A : Type) : Set. + Instance eqa : Eq nat := _. constructor. Qed. + Instance eqb : Eq nat := {}. + Class Foo (A : Type) (e : Eq A) : Set. + Instance fooa : Foo _ eqa := {}. + + Tactic Notation "refineu" open_constr(c) := unshelve refine c. + + Set Typeclasses Debug. + Goal { e : Eq nat & Foo nat e }. + unshelve refineu (existT _ _ _). + all:simpl. + (** Does not backtrack on the (wrong) solution eqb *) + Fail all:typeclasses eauto. + Abort. +End UniqueInstances. + +Module IterativeDeepening. + + Class A. + Class B. + Class C. + + Instance: B -> A | 0. + Instance: C -> A | 0. + Instance: C -> B -> A | 0. + Instance: A -> A | 0. + + Goal C -> A. + intros. + Set Typeclasses Debug. + Fail Timeout 1 typeclasses eauto. + Set Typeclasses Iterative Deepening. + Fail typeclasses eauto 1. + typeclasses eauto 2. + Undo. + Unset Typeclasses Iterative Deepening. + Fail Timeout 1 typeclasses eauto. + Set Typeclasses Iterative Deepening. + typeclasses eauto. + Qed. + +End IterativeDeepening. + +Module AxiomsAreInstances. + Set Typeclasses Axioms Are Instances. + Class TestClass1 := {}. + Axiom testax1 : TestClass1. + Definition testdef1 : TestClass1 := _. + + Unset Typeclasses Axioms Are Instances. + Class TestClass2 := {}. + Axiom testax2 : TestClass2. + Fail Definition testdef2 : TestClass2 := _. + + (* we didn't break typeclasses *) + Existing Instance testax2. + Definition testdef2 : TestClass2 := _. + +End AxiomsAreInstances. diff --git a/test-suite/success/abstract_chain.v b/test-suite/success/abstract_chain.v new file mode 100644 index 0000000000..0ff61e87f8 --- /dev/null +++ b/test-suite/success/abstract_chain.v @@ -0,0 +1,43 @@ +Lemma foo1 : nat -> True. +Proof. +intros _. +assert (H : True -> True). +{ abstract (exact (fun x => x)) using bar. } +assert (H' : True). +{ abstract (exact (bar I)) using qux. } +exact H'. +Qed. + +Lemma foo2 : True. +Proof. +assert (H : True -> True). +{ abstract (exact (fun x => x)) using bar. } +assert (H' : True). +{ abstract (exact (bar I)) using qux. } +assert (H'' : True). +{ abstract (exact (bar qux)) using quz. } +exact H''. +Qed. + +Set Universe Polymorphism. + +Lemma foo3 : nat -> True. +Proof. +intros _. +assert (H : True -> True). +{ abstract (exact (fun x => x)) using bar. } +assert (H' : True). +{ abstract (exact (bar I)) using qux. } +exact H'. +Qed. + +Lemma foo4 : True. +Proof. +assert (H : True -> True). +{ abstract (exact (fun x => x)) using bar. } +assert (H' : True). +{ abstract (exact (bar I)) using qux. } +assert (H'' : True). +{ abstract (exact (bar qux)) using quz. } +exact H''. +Qed. diff --git a/test-suite/success/abstract_poly.v b/test-suite/success/abstract_poly.v new file mode 100644 index 0000000000..aa8da53361 --- /dev/null +++ b/test-suite/success/abstract_poly.v @@ -0,0 +1,20 @@ +Set Universe Polymorphism. + +Inductive path@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := refl : path x x. +Inductive unit@{i} : Type@{i} := tt. + +Lemma foo@{i j} : forall (m n : unit@{i}) (P : unit -> Type@{j}), path m n -> P m -> P n. +Proof. +intros m n P e p. +abstract (rewrite e in p; exact p). +Defined. + +Check foo_subproof@{Set Set}. + +Lemma bar : forall (m n : unit) (P : unit -> Type), path m n -> P m -> P n. +Proof. +intros m n P e p. +abstract (rewrite e in p; exact p). +Defined. + +Check bar_subproof@{Set Set}. diff --git a/test-suite/success/all_check.v b/test-suite/success/all_check.v new file mode 100644 index 0000000000..391bc540e4 --- /dev/null +++ b/test-suite/success/all_check.v @@ -0,0 +1,3 @@ +Goal True. +Fail all:Check _. +Abort. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v new file mode 100644 index 0000000000..e1df9ba84a --- /dev/null +++ b/test-suite/success/apply.v @@ -0,0 +1,584 @@ +(* Test apply in *) + +Goal (forall x y, x = S y -> y=y) -> 2 = 4 -> 3=3. +intros H H0. +apply H in H0. +assumption. +Qed. + +Require Import ZArith. +Goal (forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y)%Z. +intros; apply Znot_le_gt, Z.gt_lt in H. +apply Zmult_lt_reg_r, Z.lt_le_incl in H0; auto. +Qed. + +(* Test application under tuples *) + +Goal (forall x, x=0 <-> 0=x) -> 1=0 -> 0=1. +intros H H'. +apply H in H'. +exact H'. +Qed. + +(* Test as clause *) + +Goal (forall x, x=0 <-> (0=x /\ True)) -> 1=0 -> True. +intros H H'. +apply H in H' as (_,H'). +exact H'. +Qed. + +(* Test application modulo conversion *) + +Goal (forall x, id x = 0 -> 0 = x) -> 1 = id 0 -> 0 = 1. +intros H H'. +apply H in H'. +exact H'. +Qed. + +(* Check apply/eapply distinction in presence of open terms *) + +Parameter h : forall x y z : nat, x = z -> x = y. +Arguments h {x y}. +Goal 1 = 0 -> True. +intro H. +apply h in H || exact I. +Qed. + +Goal False -> 1 = 0. +intro H. +apply h || contradiction. +Qed. + +(* Check if it unfolds when there are not enough premises *) + +Goal forall n, n = S n -> False. +intros. +apply n_Sn in H. +assumption. +Qed. + +(* Check naming in with bindings; printing used to be inconsistent before *) +(* revision 9450 *) + +Notation S':=S (only parsing). +Goal (forall S, S = S' S) -> (forall S, S = S' S). +intros. +apply H with (S0 := S). +Qed. + +(* Check inference of implicit arguments in bindings *) + +Goal exists y : nat -> Type, y 0 = y 0. +exists (fun x => True). +trivial. +Qed. + +(* Check universe handling in typed unificationn *) + +Definition E := Type. +Goal exists y : E, y = y. +exists Prop. +trivial. +Qed. + +Variable Eq : Prop = (Prop -> Prop) :> E. +Goal Prop. +rewrite Eq. +Abort. + +(* Check insertion of coercions in bindings *) + +Coercion eq_true : bool >-> Sortclass. +Goal exists A:Prop, A = A. +exists true. +trivial. +Qed. + +(* Check use of unification of bindings types in specialize *) + +Module Type Test. +Variable P : nat -> Prop. +Variable L : forall (l : nat), P l -> P l. +Goal P 0 -> True. +intros. +specialize L with (1:=H). +Abort. +End Test. + +(* Two examples that show that hnf_constr is used when unifying types + of bindings (a simplification of a script from Field_Theory) *) + +Require Import List. +Open Scope list_scope. +Fixpoint P (l : list nat) : Prop := + match l with + | nil => True + | e1 :: nil => e1 = e1 + | e1 :: l1 => e1 = e1 /\ P l1 + end. +Variable L : forall n l, P (n::l) -> P l. + +Goal forall (x:nat) l, P (x::l) -> P l. +intros. +apply L with (1:=H). +Qed. + +Goal forall (x:nat) l, match l with nil => x=x | _::_ => x=x /\ P l end -> P l. +intros. +apply L with (1:=H). +Qed. + +(* The following call to auto fails if the type of the clause + associated to the H is not beta-reduced [but apply H works] + (a simplification of a script from FSetAVL) *) + +Definition apply (f:nat->Prop) := forall x, f x. +Goal apply (fun n => n=0) -> 1=0. +intro H. +auto. +Qed. + +(* The following fails if the coercion Zpos is not introduced around p + before trying a subterm that matches the left-hand-side of the equality + (a simplication of an example taken from Nijmegen/QArith) *) + +Require Import ZArith. +Coercion Zpos : positive >-> Z. +Variable f : Z -> Z -> Z. +Variable g : forall q1 q2 p : Z, f (f q1 p) (f q2 p) = Z0. +Goal forall p q1 q2, f (f q1 (Zpos p)) (f q2 (Zpos p)) = Z0. +intros; rewrite g with (p:=p). +reflexivity. +Qed. + +(* A funny example where the behavior differs depending on which of a + multiple solution to a unification problem is chosen (an instance + of this case can be found in the proof of Buchberger.BuchRed.nf_divp) *) + +Definition succ x := S x. +Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), + (forall x y, P x -> Q x y) -> + (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y. +intros. +apply H with (y:=y). +(* [x] had two possible instances: [S 0], coming from unifying the + type of [y] with [I ?n] and [succ 0] coming from the unification with + the goal; only the first one allows the next apply (which + does not work modulo delta) work *) +apply H0. +Qed. + +(* A similar example with a arbitrary long conversion between the two + possible instances *) + +Fixpoint compute_succ x := + match x with O => S 0 | S n => S (compute_succ n) end. + +Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), + (forall x y, P x -> Q x y) -> + (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y. +intros. +apply H with (y:=y). +apply H0. +Qed. + +(* Another example with multiple convertible solutions to the same + metavariable (extracted from Algebra.Hom_module.Hom_module, 10th + subgoal which precisely fails) *) + +Definition ID (A:Type) := A. +Goal forall f:Type -> Type, + forall (P : forall A:Type, A -> Prop), + (forall (B:Type) x, P (f B) x -> P (f B) x) -> + (forall (A:Type) x, P (f (f A)) x) -> + forall (A:Type) (x:f (f A)), P (f (ID (f A))) x. +intros. +apply H. +(* The parameter [B] had two possible instances: [ID (f A)] by direct + unification and [f A] by unification of the type of [x]; only the + first choice makes the next command fail, as it was + (unfortunately?) in Hom_module *) +try apply H. +unfold ID; apply H0. +Qed. + +(* Test hyp in "apply -> ... in hyp" is correctly instantiated by Ltac *) + +Goal (True <-> False) -> True -> False. +intros Heq H. +match goal with [ H : True |- _ ] => apply -> Heq in H end. +Abort. + +(* Test coercion below product and on non meta-free terms in with bindings *) +(* Cf wishes #1408 from E. Makarov *) + +Parameter bool_Prop :> bool -> Prop. +Parameter r : bool -> bool -> bool. +Axiom ax : forall (A : Set) (R : A -> A -> Prop) (x y : A), R x y. + +Theorem t : r true false. +apply ax with (R := r). +Qed. + +(* Check verification of type at unification (submitted by Stéphane Lengrand): + without verification, the first "apply" works what leads to the incorrect + instantiation of x by Prop *) + +Theorem u : ~(forall x:Prop, ~x). +unfold not. +intro. +eapply H. +apply (forall B:Prop,B->B) || (instantiate (1:=True); exact I). +Defined. + +(* Fine-tuning coercion insertion in presence of unfolding (bug #1883) *) + +Parameter name : Set. +Definition atom := name. + +Inductive exp : Set := + | var : atom -> exp. + +Coercion var : atom >-> exp. + +Axiom silly_axiom : forall v : exp, v = v -> False. + +Lemma silly_lemma : forall x : atom, False. +intros x. +apply silly_axiom with (v := x). (* fails *) +reflexivity. +Qed. + +(* Check that unification does not commit too early to a representative + of an eta-equivalence class that would be incompatible with other + unification constraints *) + +Lemma eta : forall f : (forall P, P 1), + (forall P, f P = f P) -> + forall Q, f (fun x => Q x) = f (fun x => Q x). +intros. +apply H. +Qed. + +(* Test propagation of evars from subgoal to brother subgoals *) + + (* This works because unfold calls clos_norm_flags which calls nf_evar *) + +Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O. +intros x H; eapply eq_trans; +[apply H | unfold x;match goal with |- ?x = ?x => reflexivity end]. +Qed. + +(* Test non-regression of (temporary) bug 1981 *) + +Goal exists n : nat, True. +eapply ex_intro. +exact O. +trivial. +Qed. + +(* Check pattern-unification on evars in apply unification *) + +Lemma evar : exists f : nat -> nat, forall x, f x = 0 -> x = 0. +Proof. +eexists; intros x H. +apply H. +Qed. + +(* Check that "as" clause applies to main premise only and leave the + side conditions away *) + +Lemma side_condition : + forall (A:Type) (B:Prop) x, (True -> B -> x=0) -> B -> x=x. +Proof. +intros. +apply H in H0 as ->. +reflexivity. +exact I. +Qed. + +(* Check that "apply" is chained on the last subgoal of each lemma and + that side conditions come first (as it is the case since 8.2) *) + +Lemma chaining : + forall A B C : Prop, + (1=1 -> (2=2 -> A -> B) /\ True) -> + (3=3 -> (True /\ (4=4 -> C -> A))) -> C -> B. +Proof. +intros. +apply H, H0. +exact (refl_equal 1). +exact (refl_equal 2). +exact (refl_equal 3). +exact (refl_equal 4). +assumption. +Qed. + +(* Check that the side conditions of "apply in", even when chained and + used through conjunctions, come last (as it is the case for single + calls to "apply in" w/o destruction of conjunction since 8.2) *) + +Lemma chaining_in : + forall A B C : Prop, + (1=1 -> True /\ (B -> 2=2 -> 5=0)) -> + (3=3 -> (A -> 4=4 -> B) /\ True) -> A -> 0=5. +Proof. +intros. +apply H0, H in H1 as ->. +exact (refl_equal 0). +exact (refl_equal 1). +exact (refl_equal 2). +exact (refl_equal 3). +exact (refl_equal 4). +Qed. + +(* From 12612, Dec 2009, descent in conjunctions is more powerful *) +(* The following, which was failing badly in bug 1980, is now + properly rejected, as descend in conjunctions builds an + ill-formed elimination from Prop to the domain of ex which is in Type. *) + +Goal True. +Fail eapply ex_intro. +exact I. +Qed. + +Goal True. +Fail eapply (ex_intro _). +exact I. +Qed. + +(* No failure here, because the domain of ex is in Prop *) + +Goal True. +eapply (ex_intro (fun _ => 0=0) I). +reflexivity. +Qed. + +Goal True. +eapply (ex_intro (fun _ => 0=0) I _). +Unshelve. (* In 8.4: Grab Existential Variables. *) +reflexivity. +Qed. + +Goal True. +eapply (fun (A:Prop) (x:A) => conj I x). +Unshelve. (* In 8.4: the goal ?A was there *) +exact I. +Qed. + +(* Testing compatibility mode with v8.4 *) + +Goal True. +Fail eapply existT. +Set Universal Lemma Under Conjunction. +eapply existT. +Abort. + +(* The following was not accepted from r12612 to r12657 *) + +Record sig0 := { p1 : nat; p2 : p1 = 0 }. + +Goal forall x : sig0, p1 x = 0. +intro x; +apply x. +Qed. + +(* The following worked in 8.2 but was not accepted from r12229 to + r12926 because "simple apply" started to use pattern unification of + evars. Evars pattern unification for simple (e)apply was disabled + in 12927 but "simple eapply" below worked from 12898 to 12926 + because pattern-unification also started supporting abstraction + over Metas. However it did not find the "simple" solution and hence + the subsequent "assumption" failed. *) + +Goal exists f:nat->nat, forall x y, x = y -> f x = f y. +intros; eexists; intros. +simple eapply (@f_equal nat). +assumption. +Existential 1 := fun x => x. +Qed. + +(* The following worked in 8.2 but was not accepted from r12229 to + r12897 for the same reason because eauto uses "simple apply". It + worked from 12898 to 12926 because eauto uses eassumption and not + assumption. *) + +Goal exists f:nat->nat, forall x y, x = y -> f x = f y. +intros; eexists; intros. +eauto. +Existential 1 := fun x => x. +Qed. + +(* The following was accepted before r12612 but is still not accepted in r12658 + +Goal forall x : { x:nat | x = 0}, proj1_sig x = 0. +intro x; +apply x. + +*) + +Section A. + +Variable map : forall (T1 T2 : Type) (f : T1 -> T2) (t11 t12 : T1), + identity (f t11) (f t12). + +Variable mapfuncomp : forall (X Y Z : Type) (f : X -> Y) (g : Y -> Z) (x x' : X), + identity (map Y Z g (f x) (f x')) (map X Z (fun x0 : X => g (f x0)) x x'). + +Goal forall X:Type, forall Y:Type, forall f:X->Y, forall x : X, forall x' : X, + forall g : Y -> X, + let gf := (fun x : X => g (f x)) : X -> X in + identity (map Y X g (f x) (f x')) (map X X gf x x'). +intros. +apply mapfuncomp. +Abort. + +End A. + +(* Check "with" clauses refer to names as they are printed *) + +Definition hide p := forall n:nat, p = n. + +Goal forall n, (forall n, n=0) -> hide n -> n=0. +unfold hide. +intros n H H'. +(* H is displayed as (forall n, n=0) *) +apply H with (n:=n). +Undo. +(* H' is displayed as (forall n0, n=n0) *) +apply H' with (n0:=0). +Qed. + +(* Check that evars originally present in goal do not prevent apply in to work*) + +Goal (forall x, x <= 0 -> x = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +apply H in H0. +Abort. + +(* Check correct failure of apply in when hypothesis is dependent *) + +Goal forall H:0=0, H = H. +intros. +Fail apply eq_sym in H. +Abort. + +(* Check that unresolved evars not originally present in goal prevent + apply in to work*) + +Goal (forall x y, x <= 0 -> x + y = 0) -> exists x, x <= 0 -> 0 = 0. +intros. +eexists. +intros. +Fail apply H in H0. +Abort. + +(* Check naming pattern in apply in *) + +Goal ((False /\ (True -> True))) -> True -> True. +intros F H. +apply F in H as H0. (* Check that H0 is not used internally *) +exact H0. +Qed. + +Goal ((False /\ (True -> True/\True))) -> True -> True/\True. +intros F H. +apply F in H as (?,?). +split. +exact H. (* Check that generated names are H and H0 *) +exact H0. +Qed. + +(* This failed at some time in between 18 August 2014 and 2 September 2014 *) + +Goal forall A B C: Prop, (True -> A -> B /\ C) -> A -> B. +intros * H. +apply H. +Abort. + +(* This failed between 2 and 3 September 2014 *) + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A -> B. +intros. +apply H in H0. +pose proof I as H1. (* Test that H1 does not exist *) +Abort. + +Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A. +intros. +apply H. +pose proof I as H0. (* Test that H0 does not exist *) +Abort. + +(* The first example below failed at some time in between 18 August + 2014 and 2 September 2014 *) + +Goal forall x, 2=0 -> x+1=2 -> (forall x, S x = 0) -> True. +intros x H H0 H1. +eapply eq_trans in H. 2:apply H0. +rewrite H1 in H. +change (x+0=0) in H. (* Check the result in H1 *) +Abort. + +Goal forall x, 2=x+1 -> (forall x, S x = 0) -> 2 = 0. +intros x H H0. +eapply eq_trans. apply H. +rewrite H0. +change (x+0=0). +Abort. + +(* 2nd order apply used to have delta on local definitions even though + it does not have delta on global definitions; keep it by + compatibility while finding a more uniform way to proceed. *) + +Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0. +intros f H x. +apply H. +Qed. + +(* Test that occur-check is not too restrictive (see comments of #3141) *) +Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): + exists x, exists y, X x y. +Proof. +intros; eexists; eexists ?[y]; case H. +apply (foo ?y). +Grab Existential Variables. +exact 0. +Qed. + +(* Test position of new hypotheses when using "apply ... in ... as ..." *) +Goal (True -> 0=0 /\ True) -> True -> False -> True/\0=0. +intros H H0 H1. +apply H in H0 as (a,b). +(* clear H1:False *) match goal with H:_ |- _ => clear H end. +split. +- (* use b:True *) match goal with H:_ |- _ => exact H end. +- (* clear b:True *) match goal with H:_ |- _ => clear H end. + (* use a:0=0 *) match goal with H:_ |- _ => exact H end. +Qed. + +(* Test choice of most dependent solution *) +Goal forall n, n = 0 -> exists p, p = n /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. (* Compatibility tells [?p:=n] rather than [?p:=0] *) +exact H. (* this checks that the goal is [n=0], not [0=0] *) +Qed. + +(* Check insensitivity to alphabetic order of names*) +(* In both cases, the last name is conventionally chosen *) +(* Before 8.9, the name coming first in alphabetic order *) +(* was chosen. *) +Goal forall m n, m = n -> n = 0 -> exists p, p = n /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. +exact H0. +Qed. + +Goal forall n m, n = m -> m = 0 -> exists p, p = m /\ p = 0. +intros. eexists ?[p]. split. rewrite H. +reflexivity. +exact H0. +Qed. diff --git a/test-suite/success/applyTC.v b/test-suite/success/applyTC.v new file mode 100644 index 0000000000..c2debdecfe --- /dev/null +++ b/test-suite/success/applyTC.v @@ -0,0 +1,15 @@ +Axiom P : nat -> Prop. + +Class class (A : Type) := { val : A }. + +Lemma usetc {t : class nat} : P (@val nat t). +Admitted. + +Notation "{val:= v }" := (@val _ v). + +Instance zero : class nat := {| val := 0 |}. + +Lemma test : P 0. +Fail apply usetc. +pose (tmp := usetc); apply tmp; clear tmp. +Qed. diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v new file mode 100644 index 0000000000..f4f59a3c16 --- /dev/null +++ b/test-suite/success/attribute_syntax.v @@ -0,0 +1,34 @@ +From Coq Require Program.Wf. + +Section Scope. + +#[local] Coercion nat_of_bool (b: bool) : nat := + if b then 0 else 1. + +Check (refl_equal : true = 0 :> nat). + +End Scope. + +Fail Check 0 = true :> nat. + +#[universes(polymorphic)] +Definition ι T (x: T) := x. + +Check ι _ ι. + +#[program] +Fixpoint f (n: nat) {wf lt n} : nat := _. +Reset f. + +#[deprecated(since="8.9.0")] +Ltac foo := foo. + +Module M. + #[local] #[universes(polymorphic)] Definition zed := Type. + + #[local, universes(polymorphic)] Definition kats := Type. +End M. +Check M.zed@{_}. +Fail Check zed. +Check M.kats@{_}. +Fail Check kats. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v new file mode 100644 index 0000000000..5477c83316 --- /dev/null +++ b/test-suite/success/auto.v @@ -0,0 +1,136 @@ +(* Wish #2154 by E. van der Weegen *) + +(* auto was not using f_equal-style lemmas with metavariables occurring + only in the type of an evar of the concl, but not directly in the + concl itself *) + +Parameters + (F: Prop -> Prop) + (G: forall T, (T -> Prop) -> Type) + (L: forall A (P: A -> Prop), G A P -> forall x, F (P x)) + (Q: unit -> Prop). + +Hint Resolve L. + +Goal G unit Q -> F (Q tt). + intro. + eauto. +Qed. + +(* Test implicit arguments in "using" clause *) + +Goal forall n:nat, nat * nat. +auto using (pair O). +Undo. +eauto using (pair O). +Qed. + +Create HintDb test discriminated. + +Parameter foo : forall x, x = x + 0. +Hint Resolve foo : test. + +Variable C : nat -> Type -> Prop. + +Variable c_inst : C 0 nat. + +Hint Resolve c_inst : test. + +Hint Mode C - + : test. +Hint Resolve c_inst : test2. +Hint Mode C + + : test2. + +Goal exists n, C n nat. +Proof. + eexists. Fail progress debug eauto with test2. + progress eauto with test. +Qed. + +(** Patterns of Extern have a "matching" semantics. + It is not so for apply/exact hints *) + +Class B (A : Type). +Class I. +Instance i : I. + +Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. +Class D (f : nat -> nat -> nat). +Definition ftest (x y : nat) := x + y. +Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). + Admitted. +Module Instnopat. + Local Instance: B nat. + (* pattern_of_constr -> B nat *) + (* exact hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. + + Local Instance: D ftest. + Local Hint Resolve flipD | 0 : typeclass_instances. + (* pattern: D (flip _) *) + Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) + +End Instnopat. + +Module InstnopatApply. + Local Instance: I -> B nat. + (* pattern_of_constr -> B nat *) + (* apply hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. +End InstnopatApply. + +Module InstPat. + Hint Extern 3 (B nat) => split : typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> true *) + Check (_ : B nat). + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false: + Because an inductive in the pattern does not match an evar in the goal *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + (* map_existential -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail progress eauto with typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail typeclasses eauto. + Abort. + + Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. + Module withftest. + Local Instance: D ftest. + + Check (_ : D _). + (* D_instance_0 : D ftest *) + Check (_ : D (flip _)). + (* ... : D (flip ftest) *) + End withftest. + Module withoutftest. + Hint Extern 0 (D ftest) => split : typeclass_instances. + Check (_ : D _). + (* ? : D ?, _not_ looping *) + Check (_ : D (flip _)). + (* ? : D (flip ?), _not_ looping *) + + Check (_ : D (flip ftest)). + (* flipD ftest {| |} : D (flip ftest) *) + End withoutftest. +End InstPat. diff --git a/test-suite/success/autointros.v b/test-suite/success/autointros.v new file mode 100644 index 0000000000..1140a537fc --- /dev/null +++ b/test-suite/success/autointros.v @@ -0,0 +1,13 @@ +Inductive even : nat -> Prop := +| even_0 : even 0 +| even_odd : forall n, odd n -> even (S n) +with odd : nat -> Prop := +| odd_1 : odd 1 +| odd_even : forall n, even n -> odd (S n). + +Lemma foo {n : nat} (E : even n) : even (S (S n)) +with bar {n : nat} (O : odd n) : odd (S (S n)). +Proof. destruct E. constructor. constructor. apply even_odd. apply (bar _ H). + destruct O. repeat constructor. apply odd_even. apply (foo _ H). +Defined. + diff --git a/test-suite/success/autorewrite.v b/test-suite/success/autorewrite.v new file mode 100644 index 0000000000..71d333d439 --- /dev/null +++ b/test-suite/success/autorewrite.v @@ -0,0 +1,30 @@ +Variable Ack : nat -> nat -> nat. + +Axiom Ack0 : forall m : nat, Ack 0 m = S m. +Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1. +Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m). + +Hint Rewrite Ack0 Ack1 Ack2 : base0. + +Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False. +Proof. + intros. + autorewrite with base0 in H using try (apply H; reflexivity). +Qed. + +Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False. +Proof. + intros. + autorewrite with base0 in *. + apply H;reflexivity. +Qed. + +(* Check autorewrite does not solve existing evars *) +(* See discussion started by A. Chargueraud in Oct 2010 on coqdev *) + +Hint Rewrite <- plus_n_O : base1. +Goal forall y, exists x, y+x = y. +eexists. autorewrite with base1. +Fail reflexivity. + +Abort. diff --git a/test-suite/success/boundvars.v b/test-suite/success/boundvars.v new file mode 100644 index 0000000000..fafe272925 --- /dev/null +++ b/test-suite/success/boundvars.v @@ -0,0 +1,14 @@ +(* An example showing a bug in the detection of free variables *) +(* "x" is not free in the common type of "x" and "y" *) + +Check forall (x z:unit) (x y : match z as x return x=x with tt => eq_refl end = eq_refl), x=x. + +(* An example showing a bug in the detection of bound variables *) + +Goal forall x, match x return x = x with 0 => eq_refl | _ => eq_refl end = eq_refl. +intro. +match goal with +|- (match x as y in nat return y = y with O => _ | S n => _ end) = _ => assert (forall y, y = 0) end. +intro. +Check x0. (* Check that "y" has been bound to "x0" while matching "match x as x0 return x0=x0 with ... end" *) +Abort. diff --git a/test-suite/success/btauto.v b/test-suite/success/btauto.v new file mode 100644 index 0000000000..d2512b5cbb --- /dev/null +++ b/test-suite/success/btauto.v @@ -0,0 +1,9 @@ +Require Import Btauto. + +Open Scope bool_scope. + +Lemma test_orb a b : (if a || b then negb (negb b && negb a) else negb a && negb b) = true. +Proof. btauto. Qed. + +Lemma test_xorb a : xorb a a = false. +Proof. btauto. Qed. diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v new file mode 100644 index 0000000000..730b367d60 --- /dev/null +++ b/test-suite/success/bteauto.v @@ -0,0 +1,171 @@ +Require Import Program.Tactics. +Module Backtracking. + Class A := { foo : nat }. + + Instance A_1 : A | 2 := { foo := 42 }. + Instance A_0 : A | 1 := { foo := 0 }. + Lemma aeq (a : A) : foo = foo. + reflexivity. + Qed. + + Arguments foo A : clear implicits. + Example find42 : exists n, n = 42. + Proof. + eexists. + eapply eq_trans. + evar (a : A). subst a. + refine (@aeq ?a). + Unshelve. all:cycle 1. + typeclasses eauto. + Fail reflexivity. + Undo 2. + (* Without multiple successes it fails *) + Set Typeclasses Debug Verbosity 2. + Fail all:((once (typeclasses eauto with typeclass_instances)) + + apply eq_refl). + (* Does backtrack if other goals fail *) + all:[> typeclasses eauto + reflexivity .. ]. + Undo 1. + all:(typeclasses eauto + reflexivity). (* Note "+" is a focussing combinator *) + Show Proof. + Qed. + + Print find42. + + Hint Extern 0 (_ = _) => reflexivity : equality. + + Goal exists n, n = 42. + eexists. + eapply eq_trans. + evar (a : A). subst a. + refine (@aeq ?a). + Unshelve. all:cycle 1. + typeclasses eauto. + Fail reflexivity. + Undo 2. + + (* Does backtrack between individual goals *) + Set Typeclasses Debug. + all:(typeclasses eauto with typeclass_instances equality). + Qed. + + Unset Typeclasses Debug. + + Module Leivant. + Axiom A : Type. + Existing Class A. + Axioms a b c d e: A. + Existing Instances a b c d e. + + Ltac get_value H := eval cbv delta [H] in H. + + Goal True. + Fail refine (let H := _ : A in _); let v := get_value H in idtac v; fail. + Admitted. + + Goal exists x:A, x=a. + unshelve evar (t : A). all:cycle 1. + refine (@ex_intro _ _ t _). + all:cycle 1. + all:(typeclasses eauto + reflexivity). + Qed. + End Leivant. +End Backtracking. + + +Hint Resolve 100 eq_sym eq_trans : core. +Hint Cut [(_)* eq_sym eq_sym] : core. +Hint Cut [_* eq_trans eq_trans] : core. +Hint Cut [_* eq_trans eq_sym eq_trans] : core. + + +Goal forall x y z : nat, x = y -> z = y -> x = z. +Proof. + intros. + typeclasses eauto with core. +Qed. + +Module Hierarchies. + Class A := mkA { data : nat }. + Class B := mkB { aofb :> A }. + + Existing Instance mkB. + + Definition makeB (a : A) : B := _. + Definition makeA (a : B) : A := _. + + Fail Timeout 1 Definition makeA' : A := _. + + Hint Cut [_* mkB aofb] : typeclass_instances. + Fail Definition makeA' : A := _. + Fail Definition makeB' : B := _. +End Hierarchies. + +(** Hint modes *) + +Class Equality (A : Type) := { eqp : A -> A -> Prop }. + +Check (eqp 0%nat 0). + +Instance nat_equality : Equality nat := { eqp := eq }. + +Instance default_equality A : Equality A | 1000 := + { eqp := eq }. + +Check (eqp 0%nat 0). + +(* Defaulting *) +Check (fun x y => eqp x y). +(* No more defaulting, reduce "trigger-happiness" *) +Definition ambiguous x y := eqp x y. + +Hint Mode Equality ! : typeclass_instances. +Fail Definition ambiguous' x y := eqp x y. +Definition nonambiguous (x y : nat) := eqp x y. + +(** Typical looping instances with defaulting: *) +Definition flip {A B C} (f : A -> B -> C) := fun x y => f y x. + +Class SomeProp {A : Type} (f : A -> A -> A) := + { prf : forall x y, f x y = f x y }. + +Instance propflip (A : Type) (f : A -> A -> A) : + SomeProp f -> SomeProp (flip f). +Proof. + intros []. constructor. reflexivity. +Qed. + +Fail Timeout 1 Check prf. + +Hint Mode SomeProp + + : typeclass_instances. +Check prf. +Check (fun H : SomeProp plus => _ : SomeProp (flip plus)). + +(** Iterative deepening / breadth-first search *) + +Module IterativeDeepening. + + Class A. + Class B. + Class C. + + Instance: B -> A | 0. + Instance: C -> A | 0. + Instance: C -> B -> A | 0. + Instance: A -> A | 0. + + Goal C -> A. + intros. + Fail Timeout 1 typeclasses eauto. + Set Typeclasses Iterative Deepening. + Fail typeclasses eauto 1. + typeclasses eauto 2. + Undo. + Unset Typeclasses Iterative Deepening. + Fail Timeout 1 typeclasses eauto. + Set Typeclasses Iterative Deepening. + Typeclasses eauto := debug 3. + typeclasses eauto. + Qed. + +End IterativeDeepening. diff --git a/test-suite/success/bullet.v b/test-suite/success/bullet.v new file mode 100644 index 0000000000..1099f3e197 --- /dev/null +++ b/test-suite/success/bullet.v @@ -0,0 +1,5 @@ +Goal True /\ True. +split. +- exact I. +- exact I. +Qed. diff --git a/test-suite/success/cbn.v b/test-suite/success/cbn.v new file mode 100644 index 0000000000..c98689c234 --- /dev/null +++ b/test-suite/success/cbn.v @@ -0,0 +1,18 @@ +(* cbn is able to refold mutual recursive calls *) + +Fixpoint foo (n : nat) := + match n with + | 0 => true + | S n => g n + end +with g (n : nat) : bool := + match n with + | 0 => true + | S n => foo n + end. +Goal forall n, foo (S n) = g n. + intros. cbn. + match goal with + |- g _ = g _ => reflexivity + end. +Qed. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v new file mode 100644 index 0000000000..49a8b9cf46 --- /dev/null +++ b/test-suite/success/cc.v @@ -0,0 +1,167 @@ + +Theorem t1 : forall (A : Set) (a : A) (f : A -> A), f a = a -> f (f a) = a. +intros. + congruence. +Qed. + +Theorem t2 : + forall (A : Set) (a b : A) (f : A -> A) (g : A -> A -> A), + a = f a -> g b (f a) = f (f a) -> g a b = f (g b a) -> g a b = a. +intros. + congruence. +Qed. + +(* 15=0 /\ 10=0 /\ 6=0 -> 0=1 *) + +Theorem t3 : + forall (N : Set) (o : N) (s d : N -> N), + s (s (s (s (s (s (s (s (s (s (s (s (s (s (s o)))))))))))))) = o -> + s (s (s (s (s (s (s (s (s (s o))))))))) = o -> + s (s (s (s (s (s o))))) = o -> o = s o. +intros. + congruence. +Qed. + +(* Examples that fail due to dependencies *) + +(* yields transitivity problem *) + +Theorem dep : + forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) + (x y : A) (e : x = y) (e0 : f y = g y), f x = g x. +intros; dependent rewrite e; exact e0. +Qed. + +(* yields congruence problem *) + +Theorem dep2 : + forall (A B : Set) + (f : forall (A : Set) (b : bool), if b then unit else A -> unit) + (e : A = B), f A true = f B true. +intros; rewrite e; reflexivity. +Qed. + + +(* example that Congruence. can solve + (dependent function applied to the same argument)*) + +Theorem dep3 : + forall (A : Set) (P : A -> Set) (f g : forall x : A, P x), + f = g -> forall x : A, f x = g x. intros. + congruence. +Qed. + +(* Examples with injection rule *) + +Theorem inj1 : + forall (A : Set) (a b c d : A), (a, c) = (b, d) -> a = b /\ c = d. +intros. +split; congruence. +Qed. + +Theorem inj2 : + forall (A : Set) (a c d : A) (f : A -> A * A), + f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d. +intros. + congruence. +Qed. + +(* Examples with discrimination rule *) + +Theorem discr1 : true = false -> False. +intros. + congruence. +Qed. + +Theorem discr2 : Some true = Some false -> False. +intros. + congruence. +Qed. + +(* example with implications *) + +Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D -> +(A -> C) = (B -> D). +congruence. +Qed. + + +Set Implicit Arguments. + +Parameter elt: Set. +Parameter elt_eq: forall (x y: elt), {x = y} + {x <> y}. +Definition t (A: Set) := elt -> A. +Definition get (A: Set) (x: elt) (m: t A) := m x. +Definition set (A: Set) (x: elt) (v: A) (m: t A) := + fun (y: elt) => if elt_eq y x then v else m y. +Lemma gsident: + forall (A: Set) (i j: elt) (m: t A), get j (set i (get i m) m) = get j m. +Proof. + intros. unfold get, set. case (elt_eq j i); intro. + congruence. + auto. +Qed. + +(* bug 2447 is now closed (PC, 2014) *) + +Section bug_2447. + +Variable T:Type. + +Record R := mkR {x:T;y:T;z:T}. + +Variables a a' b b' c c':T. + + + +Lemma bug_2447: mkR a b c = mkR a' b c -> a = a'. +congruence. +Qed. + +Lemma bug_2447_variant1: mkR a b c = mkR a b' c -> b = b'. +congruence. +Qed. + +Lemma bug_2447_variant2: mkR a b c = mkR a b c' -> c = c'. +congruence. +Qed. + + +End bug_2447. + +(* congruence was supposed to do discriminate but it was bugged for + types with indices *) + +Inductive I : nat -> Type := C : I 0 | D : I 0. +Goal ~C=D. +congruence. +Qed. + +(* Example by Jonathan Leivant, congruence up to universes *) +Section JLeivant. + Variables S1 S2 : Set. + + Definition T1 : Type := S1. + Definition T2 : Type := S2. + + Goal T1 = T1. + congruence. + Undo. + unfold T1. + congruence. + Qed. +End JLeivant. + +(* An example with primitive projections *) + +Module PrimitiveProjections. +Set Primitive Projections. +Record t (A:Type) := { f : A }. +Goal forall g (a:t nat), @f nat = g -> f a = 0 -> g a = 0. +congruence. +Undo. +intros. +unfold f in H0. (* internally turn the projection to unfolded form *) +congruence. +Qed. +End PrimitiveProjections. diff --git a/test-suite/success/change.v b/test-suite/success/change.v new file mode 100644 index 0000000000..a9821b027f --- /dev/null +++ b/test-suite/success/change.v @@ -0,0 +1,70 @@ +(* A few tests of the syntax of clauses and of the interpretation of change *) + +Goal let a := 0+0 in a=a. +intro. +change 0 in (value of a). +change ((fun A:Type => A) nat) in (type of a). +Abort. + +Goal forall x, 2 + S x = 1 + S x. +intro. +change (?u + S x) with (S (u + x)). +Abort. + +(* Check the combination of at, with and in (see bug #2146) *) + +Goal 3=3 -> 3=3. intro H. +change 3 at 2 with (1+2). +change 3 at 2 with (1+2) in H |-. +change 3 with (1+2) in H at 1 |- * at 1. +(* Now check that there are no more 3's *) +change 3 with (1+2) in * || reflexivity. +Qed. + +(* Note: the following is invalid and must fail +change 3 at 1 with (1+2) at 3. +change 3 at 1 with (1+2) in *. +change 3 at 1 with (1+2) in H at 2 |-. +change 3 at 1 with (1+2) at 3. +change 3 at 1 with (1+2) in H |- *. +change 3 at 1 with (1+2) in H, H|-. +change 3 at 1. + *) + +(* Test that pretyping checks allowed elimination sorts *) + +Goal True. +Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x). +Fail change True with + match ex_intro _ True (eq_refl True) with ex_intro x _ => x end. +Abort. + +(* Check absence of loop in identity substitution (was failing up to + Sep 2014, see #3641) *) + +Goal True. +change ?x with x. +Abort. + +(* Check typability after change of type subterms *) +Goal nat = nat :> Set. +Fail change nat with (@id Type nat). (* would otherwise be ill-typed *) +Abort. + +(* Check typing env for rhs is the correct one *) + +Goal forall n, let x := n in id (fun n => n + x) 0 = 0. +intros. +unfold x. +(* check that n in 0+n is not interpreted as the n from "fun n" *) +change n with (0+n). +Abort. + +(* Check non-collision of non-normalized defined evars with pattern variables *) + +Goal exists x, 1=1 -> x=1/\x=1. +eexists ?[n]; intros; split. +eassumption. +match goal with |- ?x=1 => change (x=1) with (0+x=1) end. +match goal with |- 0+1=1 => trivial end. +Qed. diff --git a/test-suite/success/change_pattern.v b/test-suite/success/change_pattern.v new file mode 100644 index 0000000000..104585a720 --- /dev/null +++ b/test-suite/success/change_pattern.v @@ -0,0 +1,35 @@ +Set Implicit Arguments. +Unset Strict Implicit. + +Axiom vector : Type -> nat -> Type. + +Record KleeneStore i j a := kleeneStore + { dim : nat + ; peek : vector j dim -> a + ; pos : vector i dim + }. + +Definition KSmap i j a b (f : a -> b) (s : KleeneStore i j a) : KleeneStore i j b := + kleeneStore (fun v => f (peek v)) (pos s). + +Record KleeneCoalg (i o : Type -> Type) := kleeneCoalg + { coalg :> forall a b, (o a) -> KleeneStore (i a) (i b) (o b) }. + +Axiom free_b_dim : forall i o (k : KleeneCoalg i o) a b b' (x : o a), dim (coalg k b x) = dim (coalg k b' x). +Axiom t : Type -> Type. +Axiom traverse : KleeneCoalg (fun x => x) t. + +Definition size a (x:t a) : nat := dim (traverse a a x). + +Lemma iso1_iso2_2 a (y : {x : t unit & vector a (size x)}) : False. +Proof. +destruct y. +pose (X := KSmap (traverse a unit) (traverse unit a x)). +set (e :=(eq_sym (free_b_dim traverse (a:=unit) a unit x))). +clearbody e. +(** The pattern generated by change must have holes where there were implicit + arguments in the original user-provided term. This particular example fails + if this is not the case because the inferred argument does not coincide with + the one in the considered term. *) +progress (change (dim (traverse unit a x)) with (dim X) in e). +Abort. diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v new file mode 100644 index 0000000000..03034cf130 --- /dev/null +++ b/test-suite/success/clear.v @@ -0,0 +1,33 @@ +Goal forall x:nat, (forall x, x=0 -> True)->True. + intros; eapply H. + instantiate (1:=(fun y => _) (S x)). + simpl. + clear x. trivial. +Qed. + +Goal forall y z, (forall x:nat, x=y -> True) -> y=z -> True. + intros; eapply H. + rename z into z'. + clear H0. + clear z'. + reflexivity. +Qed. + +Class A. + +Section Foo. + + Variable a : A. + + Goal A. + solve [typeclasses eauto]. + Undo 1. + clear a. + try typeclasses eauto. + assert(a:=Build_A). + solve [ typeclasses eauto ]. + Undo 2. + assert(b:=Build_A). + solve [ typeclasses eauto ]. + Qed. +End Foo. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v new file mode 100644 index 0000000000..9389c9d32e --- /dev/null +++ b/test-suite/success/coercions.v @@ -0,0 +1,188 @@ +(* Interaction between coercions and casts *) +(* Example provided by Eduardo Gimenez *) + +Parameter Z S : Set. + +Parameter f : S -> Z. +Coercion f : S >-> Z. + +Parameter g : Z -> Z. + +Check (fun s => g (s:S)). + + +(* Check uniform inheritance condition *) + +Parameter h : nat -> nat -> Prop. +Parameter i : forall n m : nat, h n m -> nat. +Coercion i : h >-> nat. + +(* Check coercion to funclass when the source occurs in the target *) + +Parameter C : nat -> nat -> nat. +Coercion C : nat >-> Funclass. + +(* Remark: in the following example, it cannot be decided whether C is + from nat to Funclass or from A to nat. An explicit Coercion command is + expected + +Parameter A : nat -> Prop. +Parameter C:> forall n:nat, A n -> nat. +*) + +(* Check coercion between products based on eta-expansion *) +(* (there was a de Bruijn bug until rev 9254) *) + +Section P. + +Variable E : Set. +Variables C D : E -> Prop. +Variable G :> forall x, C x -> D x. + +Check fun (H : forall y:E, y = y -> C y) => (H : forall y:E, y = y -> D y). + +End P. + +(* Check that class arguments are computed the same when looking for a + coercion and when applying it (class_args_of) (failed until rev 9255) *) + +Section Q. + +Variable bool : Set. +Variables C D : bool -> Prop. +Variable G :> forall x, C x -> D x. +Variable f : nat -> bool. + +Definition For_all (P : nat -> Prop) := forall x, P x. + +Check fun (H : For_all (fun x => C (f x))) => H : forall x, D (f x). +Check fun (H : For_all (fun x => C (f x))) x => H x : D (f x). +Check fun (H : For_all (fun x => C (f x))) => H : For_all (fun x => D (f x)). + +End Q. + +(* Combining class lookup and path lookup so that if a lookup fails, another + descent in the class can be found (see wish #1934) *) + +Record Setoid : Type := +{ car :> Type }. + +Record Morphism (X Y:Setoid) : Type := +{evalMorphism :> X -> Y}. + +Definition extSetoid (X Y:Setoid) : Setoid. +constructor. +exact (Morphism X Y). +Defined. + +Definition ClaimA := forall (X Y:Setoid) (f: extSetoid X Y) x, f x= f x. + +Coercion irrelevent := (fun _ => I) : True -> car (Build_Setoid True). + +Definition ClaimB := forall (X Y:Setoid) (f: extSetoid X Y) (x:X), f x= f x. + +(* Check that coercions are made visible only when modules are imported *) + +Module A. + Module B. Coercion b2n (b:bool) := if b then 0 else 1. End B. + Fail Check S true. +End A. +Import A. +Fail Check S true. + +(* Tests after the inheritance condition constraint is relaxed *) + +Inductive list (A : Type) : Type := + nil : list A | cons : A -> list A -> list A. +Inductive vect (A : Type) : nat -> Type := + vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n). +Fixpoint size A (l : list A) : nat := match l with nil _ => 0 | cons _ _ tl => 1+size _ tl end. + +Section test_non_unif_but_complete. +Fixpoint l2v A (l : list A) : vect A (size A l) := + match l as l return vect A (size A l) with + | nil _ => vnil A + | cons _ x xs => vcons A (size A xs) x (l2v A xs) + end. + +Local Coercion l2v : list >-> vect. +Check (fun l : list nat => (l : vect _ _)). + +End test_non_unif_but_complete. + +Section what_we_could_do. +Variables T1 T2 : Type. +Variable c12 : T1 -> T2. + +Class coercion (A B : Type) : Type := cast : A -> B. +Instance atom : coercion T1 T2 := c12. +Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) (B * D) := + fun x => (c1 (fst x), c2 (snd x)). + +Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := + match l as l return vect B (size A l) with + | nil _ => vnil B + | cons _ x xs => vcons _ _ (c x) (l2v2 xs) end. + +Local Coercion l2v2 : list >-> vect. + +(* This shows that there is still something to do to take full profit + of coercions *) +Fail Check (fun l : list (T1 * T1) => (l : vect _ _)). +Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)). +End what_we_could_do. + + +(** Unit test for Prop as source class *) + +Module TestPropAsSourceCoercion. + + Parameter heap : Prop. + + Parameter heap_empty : heap. + + Definition hprop := heap -> Prop. + + Coercion hpure (P:Prop) : hprop := fun h => h = heap_empty /\ P. + + Parameter heap_single : nat -> nat -> hprop. + + Parameter hstar : hprop -> hprop -> hprop. + + Notation "H1 \* H2" := (hstar H1 H2) (at level 69). + + Definition test := heap_single 4 5 \* (5 <> 4) \* heap_single 2 4 \* (True). + + (* Print test. -- reveals [hpure] coercions *) + +End TestPropAsSourceCoercion. + + +(** Unit test for Type as source class *) + +Module TestTypeAsSourceCoercion. + + Require Import Coq.Setoids.Setoid. + + Record setoid := { A : Type ; R : relation A ; eqv : Equivalence R }. + + Definition default_setoid (T : Type) : setoid + := {| A := T ; R := eq ; eqv := _ |}. + + Coercion default_setoid : Sortclass >-> setoid. + + Definition foo := Type : setoid. + + Inductive type := U | Nat. + Inductive term : type -> Type := + | ty (_ : Type) : term U + | nv (_ : nat) : term Nat. + + Coercion ty : Sortclass >-> term. + + Definition ty1 := Type : term _. + Definition ty2 := Prop : term _. + Definition ty3 := Set : term _. + Definition ty4 := (Type : Type) : term _. + +End TestTypeAsSourceCoercion. diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v new file mode 100644 index 0000000000..05ab913932 --- /dev/null +++ b/test-suite/success/coindprim.v @@ -0,0 +1,92 @@ +Require Import Program. + +Set Primitive Projections. + +CoInductive Stream (A : Type) := mkStream { hd : A; tl : Stream A}. + +Arguments mkStream [A] hd tl. +Arguments hd [A] s. +Arguments tl [A] s. + +Definition eta {A} (s : Stream A) := {| hd := s.(hd); tl := s.(tl) |}. + +CoFixpoint ones := {| hd := 1; tl := ones |}. +CoFixpoint ticks := {| hd := tt; tl := ticks |}. + +CoInductive stream_equiv {A} (s : Stream A) (s' : Stream A) : Prop := + mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv s.(tl) s'.(tl) }. +Arguments hdeq {A} {s} {s'}. +Arguments tleq {A} {s} {s'}. + +Program CoFixpoint ones_eq : stream_equiv ones ones.(tl) := + {| hdeq := eq_refl; tleq := ones_eq |}. + +CoFixpoint stream_equiv_refl {A} (s : Stream A) : stream_equiv s s := + {| hdeq := eq_refl; tleq := stream_equiv_refl (tl s) |}. + +CoFixpoint stream_equiv_sym {A} (s s' : Stream A) (H : stream_equiv s s') : stream_equiv s' s := + {| hdeq := eq_sym H.(hdeq); tleq := stream_equiv_sym _ _ H.(tleq) |}. + +CoFixpoint stream_equiv_trans {A} {s s' s'' : Stream A} + (H : stream_equiv s s') (H' : stream_equiv s' s'') : stream_equiv s s'' := + {| hdeq := eq_trans H.(hdeq) H'.(hdeq); + tleq := stream_equiv_trans H.(tleq) H'.(tleq) |}. + +Program Definition eta_eq {A} (s : Stream A) : stream_equiv s (eta s):= + {| hdeq := eq_refl; tleq := stream_equiv_refl (tl (eta s))|}. + +Section Parks. + Variable A : Type. + + Variable R : Stream A -> Stream A -> Prop. + Hypothesis bisim1 : forall s1 s2:Stream A, + R s1 s2 -> hd s1 = hd s2. + Hypothesis bisim2 : forall s1 s2:Stream A, + R s1 s2 -> R (tl s1) (tl s2). + CoFixpoint park_ppl : + forall s1 s2:Stream A, R s1 s2 -> stream_equiv s1 s2 := + fun s1 s2 (p : R s1 s2) => + mkStreamEq _ _ _ (bisim1 s1 s2 p) + (park_ppl (tl s1) + (tl s2) + (bisim2 s1 s2 p)). +End Parks. + +Program CoFixpoint iterate {A} (f : A -> A) (x : A) : Stream A := + {| hd := x; tl := iterate f (f x) |}. + +Program CoFixpoint map {A B} (f : A -> B) (s : Stream A) : Stream B := + {| hd := f s.(hd); tl := map f s.(tl) |}. + +Theorem map_iterate A (f : A -> A) (x : A) : stream_equiv (iterate f (f x)) + (map f (iterate f x)). +Proof. +apply park_ppl with +(R:= fun s1 s2 => exists x : A, s1 = iterate f (f x) /\ + s2 = map f (iterate f x)). +now intros s1 s2 (x0,(->,->)). +intros s1 s2 (x0,(->,->)). +now exists (f x0). +now exists x. +Qed. + +Fail Check (fun A (s : Stream A) => eq_refl : s = eta s). + +Notation convertible x y := (eq_refl x : x = y). + +Fail Check convertible ticks {| hd := hd ticks; tl := tl ticks |}. + +CoInductive U := inU + { outU : U }. + +CoFixpoint u : U := + inU u. + +CoFixpoint force (u : U) : U := + inU (outU u). + +Lemma eq (x : U) : x = force x. +Proof. + Fail destruct x. +Abort. + (* Impossible *) diff --git a/test-suite/success/contradiction.v b/test-suite/success/contradiction.v new file mode 100644 index 0000000000..92a7c6ccbc --- /dev/null +++ b/test-suite/success/contradiction.v @@ -0,0 +1,32 @@ +(* Some tests for contradiction *) + +Lemma L1 : forall A B : Prop, A -> ~A -> B. +Proof. +intros; contradiction. +Qed. + +Lemma L2 : forall A B : Prop, ~A -> A -> B. +Proof. +intros; contradiction. +Qed. + +Lemma L3 : forall A : Prop, ~True -> A. +Proof. +intros; contradiction. +Qed. + +Lemma L4 : forall A : Prop, forall x : nat, ~x=x -> A. +Proof. +intros; contradiction. +Qed. + +Lemma L5 : forall A : Prop, forall x y : nat, ~x=y -> x=y -> A. +Proof. +intros; contradiction. +Qed. + +Lemma L6 : forall A : Prop, forall x y : nat, x=y -> ~x=y -> A. +Proof. +intros; contradiction. +Qed. + diff --git a/test-suite/success/conv_pbs.v b/test-suite/success/conv_pbs.v new file mode 100644 index 0000000000..05d2c98fa9 --- /dev/null +++ b/test-suite/success/conv_pbs.v @@ -0,0 +1,228 @@ +(* A bit complex but realistic example whose last fixpoint definition + used to fail in 8.1 because of wrong environment in conversion + problems (see revision 9664) *) + +Require Import List. +Require Import Arith. + +Parameter predicate : Set. +Parameter function : Set. +Definition variable := nat. +Definition x0 := 0. +Definition var_eq_dec := eq_nat_dec. + +Inductive term : Set := + | App : function -> term -> term + | Var : variable -> term. + +Definition atom := (predicate * term)%type. + +Inductive formula : Set := + | Atom : atom -> formula + | Imply : formula -> formula -> formula + | Forall : variable -> formula -> formula. + +Notation "A --> B" := (Imply A B) (at level 40). + +Definition substitution range := list (variable * range). + +Fixpoint remove_assoc (A:Set)(x:variable)(rho: substitution A){struct rho} + : substitution A := + match rho with + | nil => rho + | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho + else (y,t) :: remove_assoc A x rho + end. + +Fixpoint assoc (A:Set)(x:variable)(rho:substitution A){struct rho} + : option A := + match rho with + | nil => None + | (y,t) :: rho => if var_eq_dec x y then Some t + else assoc A x rho + end. + +Fixpoint subst_term (rho:substitution term)(t:term){struct t} : term := + match t with + | Var x => match assoc _ x rho with + | Some a => a + | None => Var x + end + | App f t' => App f (subst_term rho t') + end. + +Fixpoint subst_formula (rho:substitution term)(A:formula){struct A}:formula := + match A with + | Atom (p,t) => Atom (p, subst_term rho t) + | A --> B => subst_formula rho A --> subst_formula rho B + | Forall y A => Forall y (subst_formula (remove_assoc _ y rho) A) + (* assume t closed *) + end. + +Definition subst A x t := subst_formula ((x,t):: nil) A. + +Record Kripke : Type := { + worlds: Set; + wle : worlds -> worlds -> Type; + wle_refl : forall w, wle w w ; + wle_trans : forall w w' w'', wle w w' -> wle w' w'' -> wle w w''; + domain : Set; + vars : variable -> domain; + funs : function -> domain -> domain; + atoms : worlds -> predicate * domain -> Type; + atoms_mon : forall w w', wle w w' -> forall P, atoms w P -> atoms w' P +}. + +Section Sem. + +Variable K : Kripke. + +Fixpoint sem (rho: substitution (domain K))(t:term){struct t} : domain K := + match t with + | Var x => match assoc _ x rho with + | Some a => a + | None => vars K x + end + | App f t' => funs K f (sem rho t') + end. + +End Sem. + +Notation "w <= w'" := (wle _ w w'). + +Set Implicit Arguments. + +Reserved Notation "w ||- A" (at level 70). + +Definition context := list formula. + +Variable fresh : variable -> context -> Prop. + +Variable fresh_out : context -> variable. + +Axiom fresh_out_spec : forall Gamma, fresh (fresh_out Gamma) Gamma. + +Axiom fresh_peel : forall x A Gamma, fresh x (A::Gamma) -> fresh x Gamma. + +Fixpoint force (K:Kripke)(rho: substitution (domain K))(w:worlds K)(A:formula) + {struct A} : Type := + match A with + | Atom (p,t) => atoms K w (p, sem K rho t) + | A --> B => forall w', w <= w' -> force K rho w' A -> force K rho w' B + | Forall x A => forall w', w <= w' -> forall t, force K ((x,t)::remove_assoc _ x rho) w' A + end. + +Notation "w ||- A" := (force _ nil w A). + +Reserved Notation "Gamma |- A" (at level 70). +Reserved Notation "Gamma ; A |- C" (at level 70, A at next level). + +Inductive context_prefix (Gamma:context) : context -> Type := + | CtxPrefixRefl : context_prefix Gamma Gamma + | CtxPrefixTrans : forall A Gamma', context_prefix Gamma Gamma' -> context_prefix Gamma (cons A Gamma'). + +Inductive in_context (A:formula) : list formula -> Prop := + | InAxiom : forall Gamma, in_context A (cons A Gamma) + | OmWeak : forall Gamma B, in_context A Gamma -> in_context A (cons B Gamma). + +Inductive prove : list formula -> formula -> Type := + | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B + -> prove Gamma (A --> B) + | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) + -> prove Gamma (subst A x (Var y))) -> prove Gamma (Forall x A) + | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' + -> (prove_stoup Gamma' A C) -> (Gamma' |- C) + +where "Gamma |- A" := (prove Gamma A) + + with prove_stoup : list formula -> formula -> formula -> Type := + | ProofAxiom Gamma C: Gamma ; C |- C + | ProofImplyL Gamma C : forall A B, (Gamma |- A) + -> (prove_stoup Gamma B C) -> (prove_stoup Gamma (A --> B) C) + | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) + -> (prove_stoup Gamma (Forall x A) C) + +where " Gamma ; B |- A " := (prove_stoup Gamma B A). + +Axiom context_prefix_trans : + forall Gamma Gamma' Gamma'', + context_prefix Gamma Gamma' + -> context_prefix Gamma' Gamma'' + -> context_prefix Gamma Gamma''. + +Axiom Weakening : + forall Gamma Gamma' A, + context_prefix Gamma Gamma' -> Gamma |- A -> Gamma' |- A. + +Axiom universal_weakening : + forall Gamma Gamma', context_prefix Gamma Gamma' + -> forall P, Gamma |- Atom P -> Gamma' |- Atom P. + +Canonical Structure Universal := Build_Kripke + context + context_prefix + CtxPrefixRefl + context_prefix_trans + term + Var + App + (fun Gamma P => Gamma |- Atom P) + universal_weakening. + +Axiom subst_commute : + forall A rho x t, + subst_formula ((x,t)::rho) A = subst (subst_formula rho A) x t. + +Axiom subst_formula_atom : + forall rho p t, + Atom (p, sem _ rho t) = subst_formula rho (Atom (p,t)). + +Fixpoint universal_completeness (Gamma:context)(A:formula){struct A} + : forall rho:substitution term, + force _ rho Gamma A -> Gamma |- subst_formula rho A + := + match A + return forall rho, force _ rho Gamma A + -> Gamma |- subst_formula rho A + with + | Atom (p,t) => fun rho H => eq_rect _ (fun A => Gamma |- A) H _ (subst_formula_atom rho p t) + | A --> B => fun rho HImplyAB => + let A' := subst_formula rho A in + ProofImplyR (universal_completeness (A'::Gamma) B rho + (HImplyAB (A'::Gamma)(CtxPrefixTrans A' (CtxPrefixRefl Gamma)) + (universal_completeness_stoup A rho (fun C Gamma' Hle p + => ProofCont Hle p)))) + | Forall x A => fun rho HForallA + => ProofForallR x (fun y Hfresh + => eq_rect _ _ (universal_completeness Gamma A _ + (HForallA Gamma (CtxPrefixRefl Gamma)(Var y))) _ (subst_commute _ _ _ _ )) + end +with universal_completeness_stoup (Gamma:context)(A:formula){struct A} + : forall rho, (forall C Gamma', context_prefix Gamma Gamma' + -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) + -> force _ rho Gamma A + := + match A return forall rho, + (forall C Gamma', context_prefix Gamma Gamma' + -> Gamma' ; subst_formula rho A |- C + -> Gamma' |- C) + -> force _ rho Gamma A + with + | Atom (p,t) as C => fun rho H + => H _ Gamma (CtxPrefixRefl Gamma)(ProofAxiom _ _) + | A --> B => fun rho H => fun Gamma' Hle HA + => universal_completeness_stoup B rho (fun C Gamma'' Hle' p + => H C Gamma'' (context_prefix_trans Hle Hle') + (ProofImplyL (Weakening Hle' (universal_completeness Gamma' A rho HA)) p)) + | Forall x A => fun rho H => fun Gamma' Hle t + => (universal_completeness_stoup A ((x,t)::remove_assoc _ x rho) + (fun C Gamma'' Hle' p => + H C Gamma'' (context_prefix_trans Hle Hle') + (ProofForallL x t (subst_formula (remove_assoc _ x rho) A) + (eq_rect _ (fun D => Gamma'' ; D |- C) p _ (subst_commute _ _ _ _))))) + end. + + +(* A simple example that raised an uncaught exception at some point *) + +Fail Check fun x => @eq_refl x <: true = true. diff --git a/test-suite/success/coqbugs0181.v b/test-suite/success/coqbugs0181.v new file mode 100644 index 0000000000..d541dcf7b0 --- /dev/null +++ b/test-suite/success/coqbugs0181.v @@ -0,0 +1,7 @@ + +(* test the strength of pretyping unification *) + +Require Import List. +Definition listn A n := {l : list A | length l = n}. +Definition make_ln A n (l : list A) (h : (fun l => length l = n) l) := + exist _ l h. diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v new file mode 100644 index 0000000000..3d97f27b16 --- /dev/null +++ b/test-suite/success/cumulativity.v @@ -0,0 +1,139 @@ +Polymorphic Cumulative Inductive T1 := t1 : T1. +Fail Monomorphic Cumulative Inductive T2 := t2 : T2. + +Polymorphic Cumulative Record R1 := { r1 : T1 }. +Fail Monomorphic Cumulative Inductive R2 := {r2 : T1}. + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. +Set Printing Universes. + +Inductive List (A: Type) := nil | cons : A -> List A -> List A. + +Definition LiftL@{k i j|k <= i, k <= j} {A:Type@{k}} : List@{i} A -> List@{j} A := fun x => x. + +Lemma LiftL_Lem A (l : List A) : l = LiftL l. +Proof. reflexivity. Qed. + +Inductive Tp := tp : Type -> Tp. + +Definition LiftTp@{i j|i <= j} : Tp@{i} -> Tp@{j} := fun x => x. + +Fail Definition LowerTp@{i j|j < i} : Tp@{i} -> Tp@{j} := fun x => x. + +Record Tp' := { tp' : Tp }. + +Definition CTp := Tp. +(* here we have to reduce a constant to infer the correct subtyping. *) +Record Tp'' := { tp'' : CTp }. + +Definition LiftTp'@{i j|i <= j} : Tp'@{i} -> Tp'@{j} := fun x => x. +Definition LiftTp''@{i j|i <= j} : Tp''@{i} -> Tp''@{j} := fun x => x. + +Lemma LiftC_Lem (t : Tp) : LiftTp t = t. +Proof. reflexivity. Qed. + +Section subtyping_test. + Universe i j. + Constraint i < j. + + Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. + +End subtyping_test. + +Record A : Type := { a :> Type; }. + +Record B (X : A) : Type := { b : X; }. + +NonCumulative Inductive NCList (A: Type) + := ncnil | nccons : A -> NCList A -> NCList A. + +Fail Definition LiftNCL@{k i j|k <= i, k <= j} {A:Type@{k}} + : NCList@{i} A -> NCList@{j} A := fun x => x. + +Inductive eq@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := eq_refl : eq x x. + +Definition funext_type@{a b e} (A : Type@{a}) (B : A -> Type@{b}) + := forall f g : (forall a, B a), + (forall x, eq@{e} (f x) (g x)) + -> eq@{e} f g. + +Section down. + Universes a b e e'. + Constraint e' < e. + Lemma funext_down {A B} + : @funext_type@{a b e} A B -> @funext_type@{a b e'} A B. + Proof. + intros H f g Hfg. exact (H f g Hfg). + Defined. +End down. + +Record Arrow@{i j} := { arrow : Type@{i} -> Type@{j} }. + +Fail Definition arrow_lift@{i i' j j' | i' < i, j < j'} + : Arrow@{i j} -> Arrow@{i' j'} + := fun x => x. + +Definition arrow_lift@{i i' j j' | i' = i, j <= j'} + : Arrow@{i j} -> Arrow@{i' j'} + := fun x => x. + +Inductive Mut1 A := +| Base1 : Type -> Mut1 A +| Node1 : (A -> Mut2 A) -> Mut1 A +with Mut2 A := + | Base2 : Type -> Mut2 A + | Node2 : Mut1 A -> Mut2 A. + +(* If we don't reduce T while inferring cumulativity for the + constructor we will see a Rel and believe i is irrelevant. *) +Inductive withparams@{i j} (T:=Type@{i}:Type@{j}) := mkwithparams : T -> withparams. + +Definition withparams_co@{i i' j|i < i', i' < j} : withparams@{i j} -> withparams@{i' j} + := fun x => x. + +Fail Definition withparams_not_irr@{i i' j|i' < i, i' < j} : withparams@{i j} -> withparams@{i' j} + := fun x => x. + +(** Cumulative constructors *) + + +Record twotys@{u v w} : Type@{w} := + twoconstr { fstty : Type@{u}; sndty : Type@{v} }. + +Monomorphic Universes i j k l. + +Monomorphic Constraint i < j. +Monomorphic Constraint j < k. +Monomorphic Constraint k < l. + +Parameter Tyi : Type@{i}. + +Definition checkcumul := + eq_refl _ : @eq twotys@{k k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi). + +(* They can only be compared at the highest type *) +Fail Definition checkcumul' := + eq_refl _ : @eq twotys@{i k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi). + +(* An inductive type with an irrelevant universe *) +Inductive foo@{i} : Type@{i} := mkfoo { }. + +Definition bar := foo. + +(* The universe on mkfoo is flexible and should be unified with i. *) +Definition foo1@{i} : foo@{i} := let x := mkfoo in x. (* fast path for conversion *) +Definition foo2@{i} : bar@{i} := let x := mkfoo in x. (* must reduce *) + +(* Rigid universes however should not be unified unnecessarily. *) +Definition foo3@{i j|} : foo@{i} := let x := mkfoo@{j} in x. +Definition foo4@{i j|} : bar@{i} := let x := mkfoo@{j} in x. + +(* Constructors for an inductive with indices *) +Module WithIndex. + Inductive foo@{i} : (Prop -> Prop) -> Prop := mkfoo: foo (fun x => x). + + Monomorphic Universes i j. + Monomorphic Constraint i < j. + Definition bar : eq mkfoo@{i} mkfoo@{j} := eq_refl _. +End WithIndex. diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v new file mode 100644 index 0000000000..55ae54ca04 --- /dev/null +++ b/test-suite/success/dependentind.v @@ -0,0 +1,162 @@ +Require Import Coq.Program.Program Coq.Program.Equality. + +Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt. +intros. +dependent destruction x. +reflexivity. +Qed. + +Variable A : Set. + +Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n). + +Goal forall n, forall v : vector (S n), vector n. +Proof. + intros n H. + dependent destruction H. + assumption. +Qed. + +Require Import ProofIrrelevance. + +Goal forall n, forall v : vector (S n), exists v' : vector n, exists a : A, v = vcons a v'. +Proof. + intros n v. + dependent destruction v. + exists v ; exists a. + reflexivity. +Qed. + +(* Extraction Unnamed_thm. *) + +Inductive type : Type := +| base : type +| arrow : type -> type -> type. + +Notation " t --> t' " := (arrow t t') (at level 20, t' at next level). + +Inductive ctx : Type := +| empty : ctx +| snoc : ctx -> type -> ctx. + +Bind Scope context_scope with ctx. +Delimit Scope context_scope with ctx. + +Arguments snoc _%context_scope. + +Notation " Γ , τ " := (snoc Γ τ) (at level 25, τ at next level, left associativity) : context_scope. + +Fixpoint conc (Δ Γ : ctx) : ctx := + match Δ with + | empty => Γ + | snoc Δ' x => snoc (conc Δ' Γ) x + end. + +Notation " Γ ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope. + +Reserved Notation " Γ ⊢ τ " (at level 30, no associativity). + +Generalizable All Variables. + +Inductive term : ctx -> type -> Type := +| ax : `(Γ, τ ⊢ τ) +| weak : `{Γ ⊢ τ -> Γ, τ' ⊢ τ} +| abs : `{Γ, τ ⊢ τ' -> Γ ⊢ τ --> τ'} +| app : `{Γ ⊢ τ --> τ' -> Γ ⊢ τ -> Γ ⊢ τ'} + +where " Γ ⊢ τ " := (term Γ τ) : type_scope. + +Hint Constructors term : lambda. + +Local Open Scope context_scope. + +Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps. + +Lemma weakening : forall Γ Δ τ, Γ ; Δ ⊢ τ -> + forall τ', Γ , τ' ; Δ ⊢ τ. +Proof with simpl in * ; eqns ; eauto with lambda. + intros Γ Δ τ H. + + dependent induction H. + + destruct Δ as [|Δ τ'']... + + destruct Δ as [|Δ τ'']... + + destruct Δ as [|Δ τ'']... + apply abs. + specialize (IHterm Γ (Δ, τ'', τ))... + + intro. eapply app... +Defined. + +Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ ⊢ τ -> + forall Δ', Γ ; Δ' ; Δ ⊢ τ. +Proof with simpl in * ; eqns ; eauto with lambda. + intros Γ Δ τ H. + + dependent induction H. + + destruct Δ as [|Δ τ'']... + induction Δ'... + + destruct Δ as [|Δ τ'']... + induction Δ'... + + destruct Δ as [|Δ τ'']... + apply abs. + specialize (IHterm Γ (empty, τ))... + + apply abs. + specialize (IHterm Γ (Δ, τ'', τ))... + + intro. eapply app... +Defined. + +Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ. +Proof with simpl in * ; eqns ; eauto. + intros until 1. + dependent induction H. + + destruct Δ ; eqns. + apply weak ; apply ax. + + apply ax. + + destruct Δ... + pose (weakening Γ (empty, α))... + + apply weak... + + apply abs... + specialize (IHterm Γ (Δ, τ))... + + eapply app... +Defined. + + + +(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *) + +Set Implicit Arguments. + +Inductive Ty := + | Nat : Ty + | Prod : Ty -> Ty -> Ty. + +Inductive Exp : Ty -> Type := +| Const : nat -> Exp Nat +| Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2) +| Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1. + +Inductive Ev : forall t, Exp t -> Exp t -> Prop := +| EvConst : forall n, Ev (Const n) (Const n) +| EvPair : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2', + Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2') +| EvFst : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2, + Ev e (Pair e1 e2) -> + Ev (Fst e) e1. + +Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2). +intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption. +Qed. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v new file mode 100644 index 0000000000..d1d384659b --- /dev/null +++ b/test-suite/success/destruct.v @@ -0,0 +1,439 @@ +(* Submitted by Robert Schneck *) + +Parameters A B C D : Prop. +Axiom X : A -> B -> C /\ D. + +Lemma foo : A -> B -> C. +Proof. +intros. +destruct X. (* Should find axiom X and should handle arguments of X *) +assumption. +assumption. +assumption. +Qed. + +(* Simplification of BZ#711 *) + +Parameter f : true = false. +Goal let p := f in True. +intro p. +set (b := true) in *. +(* Check that it doesn't fail with an anomaly *) +(* Ultimately, adapt destruct to make it succeeding *) +try destruct b. +Abort. + +(* Used to fail with error "n is used in conclusion" before revision 9447 *) + +Goal forall n, n = S n. +induction S. +Abort. + +(* Check that elimination with remaining evars do not raise an bad + error message *) + +Theorem Refl : forall P, P <-> P. tauto. Qed. +Goal True. +case Refl || ecase Refl. +Abort. + +(* Submitted by B. Baydemir (BZ#1882) *) + +Require Import List. + +Definition alist R := list (nat * R)%type. + +Section Properties. + Variable A : Type. + Variable a : A. + Variable E : alist A. + + Lemma silly : E = E. + Proof. + clear. induction E. (* this fails. *) + Abort. + +End Properties. + +(* This used not to work before revision 11944 *) + +Goal forall P:(forall n, 0=n -> Prop), forall H: 0=0, P 0 H. +destruct H. +Abort. + +(* The calls to "destruct" below did not work before revision 12356 *) + +Variable A0:Type. +Variable P:A0->Type. +Require Import JMeq. +Goal forall a b (p:P a) (q:P b), + forall H:a = b, eq_rect a P p b H = q -> JMeq (existT _ a p) (existT _ b q). +intros. +destruct H. +destruct H0. +reflexivity. +Qed. + +(* These did not work before 8.4 *) + +Goal (exists x, x=0) -> True. +destruct 1 as (_,_); exact I. +Abort. + +Goal (exists x, x=0 /\ True) -> True. +destruct 1 as (_,(_,H)); exact H. +Abort. + +Goal (exists x, x=0 /\ True) -> True. +destruct 1 as (_,(_,x)); exact x. +Abort. + +Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0. +intros. +destruct (g _). (* This was failing in at least r14571 *) +Abort. + +(* Check that subterm selection does not solve existing evars *) + +Goal exists x, S x = S 0. +eexists ?[x]. +Show x. (* Incidentally test Show on a named goal *) +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S 0). +Abort. + +Goal exists x, S 0 = S x. +eexists ?[x]. +destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) +change (0 = S ?x). +[x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) +Abort. + +Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. +eexists ?[n]; eexists ?[p]. +destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) +change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). +Abort. + +(* An example with incompatible but convertible occurrences *) + +Goal id (id 0) = 0. +Fail destruct (id _) at 1 2. +Abort. + +(* Avoid unnatural selection of a subterm larger than expected *) + +Goal let g := fun x:nat => x in g (S 0) = 0. +intro. +destruct S. +(* Check that it is not the larger subterm "g (S 0)" which is + selected, as it was the case in 8.4 *) +unfold g at 1. +Abort. + +(* Some tricky examples convenient to support *) + +Goal forall x, nat_rect (fun _ => nat) O (fun x y => S x) x = nat_rect (fun _ => nat) O (fun x y => S x) x. +intros. +destruct (nat_rect _ _ _ _). +Abort. +(* Check compatibility in selecting what is open or "shelved" *) + +Goal (forall x, x=0 -> nat) -> True. +intros. +Fail destruct H. +edestruct H. +- reflexivity. +- exact Logic.I. +- exact Logic.I. +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct H. +- trivial. +- apply (eq_refl x). +Qed. + +(* Check an example which was working with case/elim in 8.4 but not with + destruct/induction (not the different order between induction/destruct) *) + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +induction H. +- apply (eq_refl x). +- trivial. +Qed. + +(* This test assumes that destruct/induction on non-dependent hypotheses behave the same + when using holes or not + +Goal forall x, (True -> x = 0) -> 0=0. +intros. +destruct (H _). +- apply I. +- apply (eq_refl x). +Qed. +*) + +(* Check destruct vs edestruct *) + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct H. +edestruct H. +- trivial. +- apply (eq_refl x). +Qed. + +Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0. +intros. +Fail destruct (H _ _). +(* Now a test which assumes that edestruct on non-dependent + hypotheses accept unresolved subterms in the induction argument. +edestruct (H _ _). +- trivial. +- apply (eq_refl x). +Qed. +*) +Abort. + +(* Test selection when not in an inductive type *) +Parameter T:Type. +Axiom elim: forall P, T -> P. +Goal forall a:T, a = a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction (a 0) using elim. +Qed. + +(* From Oct 2014, a subterm is found, as if without "using"; in 8.4, + it did not find a subterm *) + +Goal forall a:nat -> T, a 0 = a 1. +intro a. +induction a using elim. +Qed. + +Goal forall a:nat -> T, forall b, a 0 = b. +intros a b. +induction a using elim. +Qed. + +(* From Oct 2014, first subterm is found; in 8.4, it failed because it + found "a 0" and wanted to clear a *) + +Goal forall a:nat -> nat, a 0 = a 1. +intro a. +destruct a. +change (0 = a 1). +Abort. + +(* This example of a variable not fully applied in the goal was working in 8.4*) + +Goal forall H : 0<>0, H = H. +destruct H. +reflexivity. +Qed. + +(* Check that variables not fully applied in the goal are not erased + (this example was failing in 8.4 because of a forbidden "clear H" in + the code of "destruct H" *) + +Goal forall H : True -> True, H = H. +destruct H. +- exact I. +- reflexivity. +Qed. + +(* Check destruct on idents with maximal implicit arguments - which did + not work in 8.4 *) + +Parameter g : forall {n:nat}, n=n -> nat. +Goal g (eq_refl 0) = 0. +destruct g. +Abort. + +(* This one was working in 8.4 (because of full conv on closed arguments) *) + +Class E. +Instance a:E. +Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0. +intros. +destruct (h _). +change (0=0). +Abort. + +(* This one was not working in 8.4 because an occurrence of f was + remaining, blocking the "clear f" *) + +Goal forall h : E -> nat -> nat, h a 0 = h a 1. +intros. +destruct h. +Abort. + +(* This was not working in 8.4 *) + +Section S1. +Variables x y : Type. +Variable H : x = y. +Goal True. +destruct H. (* Was not working in 8.4 *) +(* Now check that H statement has itself be subject of the rewriting *) +change (x=x) in H. +Abort. +End S1. + +(* This was not working in 8.4 because of untracked dependencies *) +Goal forall y, forall h:forall x, x = y, h 0 = h 0. +intros. +destruct (h 0). +Abort. + +(* Check absence of useless local definitions *) + +Section S2. +Variable H : 1=1. +Goal 0=1. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Abort. +End S2. + +Goal forall x:nat, x=x->x=1. +intros x H. +destruct H. +Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *) +Fail clear H. (* Check that H has been removed *) +Abort. + +(* Check support for induction arguments which do not expose an inductive + type rightaway *) + +Definition U := nat -> nat. +Definition S' := S : U. +Goal forall n, S' n = 0. +intro. +destruct S'. +Abort. + +(* This was working by chance in 8.4 thanks to "accidental" use of select + subterms _syntactically_ equal to the first matching one. + +Parameter f2:bool -> unit. +Parameter r2:f2 true=f2 true. +Goal forall (P: forall b, b=b -> Prop), f2 (id true) = tt -> P (f2 true) r2. +intros. +destruct f2. +Abort. +*) + +(* This did not work in 8.4, because of a clear failing *) + +Inductive IND : forall x y:nat, x=y -> Type := CONSTR : IND 0 0 eq_refl. +Goal forall x y e (h:x=y -> y=x) (z:IND y x (h e)), e = e /\ z = z. +intros. +destruct z. +Abort. + +(* The two following examples show how the variables occurring in the + term being destruct affects the generalization; don't know if these + behaviors are "good". None of them was working in 8.4. *) + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e /\ z t = z t. +intros. +destruct (z t). +change (0=0) in t. (* Generalization made *) +Abort. + +(* Check that destruct on a scheme with a functional argument works *) + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat, h 0 = h 0. +intros. +destruct h using H. +Qed. + +Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat->nat, h 0 0 = h 1 0. +intros. +induction (h 1) using H. +Qed. + +(* Check blocking generalization is not too strong (failed at some time) *) + +Goal (E -> 0=1) -> 1=0 -> True. +intros. +destruct (H _). +change (0=0) in H0. (* Check generalization on H0 was made *) +Abort. + +(* Check absence of anomaly (failed at some time) *) + +Goal forall A (a:A) (P Q:A->Prop), (forall a, P a -> Q a) -> True. +intros. +Fail destruct H. +Abort. + +(* Check keep option (BZ#3791) *) + +Goal forall b:bool, True. +intro b. +destruct (b). +clear b. (* b has to be here *) +Abort. + +(* Check clearing of names *) + +Inductive IND2 : nat -> Prop := CONSTR2 : forall y, y = y -> IND2 y. +Goal forall x y z:nat, y = z -> x = y -> y = x -> x = y. +intros * Heq H Heq'. +destruct H. +Abort. + +Goal 2=1 -> 1=0. +intro H. destruct H. +Fail (match goal with n:nat |- _ => unfold n end). (* Check that no let-in remains *) +Abort. + +(* Check clearing of names *) + +Inductive eqnat (x : nat) : nat -> Prop := + reflnat : forall y, x = y -> eqnat x y. + +Goal forall x z:nat, x = z -> eqnat x z -> True. +intros * H1 H. +destruct H. +Fail clear z. (* Should not be here *) +Abort. + +(* Check ok in the presence of an equation *) + +Goal forall b:bool, b = b. +intros. +destruct b eqn:H. +Abort. + +(* Check natural instantiation behavior when the goal has already an evar *) + +Goal exists x, S x = x. +eexists ?[x]. +destruct (S _). +change (0 = ?x). +Abort. + +Goal (forall P, P 0 -> True/\True) -> True. +intro H. +destruct (H (fun x => True)). +match goal with |- True => idtac end. +Abort. diff --git a/test-suite/success/dtauto_let_deps.v b/test-suite/success/dtauto_let_deps.v new file mode 100644 index 0000000000..094b2f8b3c --- /dev/null +++ b/test-suite/success/dtauto_let_deps.v @@ -0,0 +1,24 @@ +(* +This test is sensitive to changes in which let-ins are expanded when checking +for dependencies in constructors. +If the (x := X) is not reduced, Foo1 won't be recognized as a conjunction, +and if the (y := X) is reduced, Foo2 will be recognized as a conjunction. + +This tests the behavior of engine/termops.ml : prod_applist_assum, +which is currently specified to reduce exactly the parameters. + +If dtauto is changed to reduce lets in constructors before checking dependency, +this test will need to be changed. +*) + +Context (P Q : Type). +Inductive Foo1 (X : Type) (x := X) := foo1 : let y := X in P -> Q -> Foo1 x. +Inductive Foo2 (X : Type) (x := X) := foo2 : let y := X in P -> Q -> Foo2 y. + +Goal P -> Q -> Foo1 nat. +solve [dtauto]. +Qed. + +Goal P -> Q -> Foo2 nat. +Fail solve [dtauto]. +Abort. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v new file mode 100644 index 0000000000..c44747379f --- /dev/null +++ b/test-suite/success/eauto.v @@ -0,0 +1,223 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Class A (A : Type). + Instance an: A nat. + +Class B (A : Type) (a : A). +Instance bn0: B nat 0. +Instance bn1: B nat 1. + +Goal A nat. +Proof. + typeclasses eauto. +Qed. + +Goal B nat 2. +Proof. + Fail typeclasses eauto. +Abort. + +Goal exists T : Type, A T. +Proof. + eexists. typeclasses eauto. +Defined. + +Hint Extern 0 (_ /\ _) => constructor : typeclass_instances. + +Existing Class and. + +Goal exists (T : Type) (t : T), A T /\ B T t. +Proof. + eexists. eexists. typeclasses eauto. +Defined. + +Instance ab: A bool. (* Backtrack on A instance *) +Goal exists (T : Type) (t : T), A T /\ B T t. +Proof. + eexists. eexists. typeclasses eauto. +Defined. + +Class C {T} `(a : A T) (t : T). +Require Import Classes.Init. +Hint Extern 0 { x : ?A & _ } => + unshelve class_apply @existT : typeclass_instances. +Existing Class sigT. +Set Typeclasses Debug. +Instance can: C an 0. +(* Backtrack on instance implementation *) +Goal exists (T : Type) (t : T), { x : A T & C x t }. +Proof. + eexists. eexists. typeclasses eauto. +Defined. + +Class D T `(a: A T). + Instance: D _ an. +Goal exists (T : Type), { x : A T & D T x }. +Proof. + eexists. typeclasses eauto. +Defined. + + +(* Example from Nicolas Magaud on coq-club - Jul 2000 *) + +Definition Nat : Set := nat. +Parameter S' : Nat -> Nat. +Parameter plus' : Nat -> Nat -> Nat. + +Lemma simpl_plus_l_rr1 : + (forall n0 : Nat, + (forall m p : Nat, plus' n0 m = plus' n0 p -> m = p) -> + forall m p : Nat, S' (plus' n0 m) = S' (plus' n0 p) -> m = p) -> + forall n : Nat, + (forall m p : Nat, plus' n m = plus' n p -> m = p) -> + forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p. + intros. + apply H0. apply f_equal_nat. + Time info_eauto. + Undo. + Set Typeclasses Debug. + Set Typeclasses Iterative Deepening. + Time typeclasses eauto 6 with nocore. Show Proof. + Undo. + Time eauto. (* does EApply H *) +Qed. + +(* Example from Nicolas Tabareau on coq-club - Feb 2016. + Full backtracking on dependent subgoals. + *) +Require Import Coq.Classes.Init. + +Module NTabareau. + +Set Typeclasses Dependency Order. +Unset Typeclasses Iterative Deepening. +Notation "x .1" := (projT1 x) (at level 3). +Notation "x .2" := (projT2 x) (at level 3). + +Parameter myType: Type. + +Class Foo (a:myType) := {}. + +Class Bar (a:myType) := {}. + +Class Qux (a:myType) := {}. + +Parameter fooTobar : forall a (H : Foo a), {b: myType & Bar b}. + +Parameter barToqux : forall a (H : Bar a), {b: myType & Qux b}. + +Hint Extern 5 (Bar ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 5 (Qux ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 1 myType => + unshelve refine (fooTobar _ _).1 : typeclass_instances. + +Hint Extern 1 myType => unshelve refine (barToqux _ _).1 : typeclass_instances. + +Hint Extern 0 { x : _ & _ } => simple refine (existT _ _ _) : typeclass_instances. + +Unset Typeclasses Debug. +Definition trivial a (H : Foo a) : {b : myType & Qux b}. +Proof. + Time typeclasses eauto 10 with typeclass_instances. + Undo. Set Typeclasses Iterative Deepening. + Time typeclasses eauto with typeclass_instances. +Defined. + +End NTabareau. + +Module NTabareauClasses. + +Set Typeclasses Dependency Order. +Unset Typeclasses Iterative Deepening. +Notation "x .1" := (projT1 x) (at level 3). +Notation "x .2" := (projT2 x) (at level 3). + +Parameter myType: Type. +Existing Class myType. + +Class Foo (a:myType) := {}. + +Class Bar (a:myType) := {}. + +Class Qux (a:myType) := {}. + +Parameter fooTobar : forall a (H : Foo a), {b: myType & Bar b}. + +Parameter barToqux : forall a (H : Bar a), {b: myType & Qux b}. + +Hint Extern 5 (Bar ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 5 (Qux ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 1 myType => + unshelve notypeclasses refine (fooTobar _ _).1 : typeclass_instances. + +Hint Extern 1 myType => + unshelve notypeclasses refine (barToqux _ _).1 : typeclass_instances. + +Hint Extern 0 { x : _ & _ } => + unshelve notypeclasses refine (existT _ _ _) : typeclass_instances. + +Unset Typeclasses Debug. + +Definition trivial a (H : Foo a) : {b : myType & Qux b}. +Proof. + Time typeclasses eauto 10 with typeclass_instances. + Undo. Set Typeclasses Iterative Deepening. + (* Much faster in iteratove deepening mode *) + Time typeclasses eauto with typeclass_instances. +Defined. + +End NTabareauClasses. + + +Require Import List. + +Parameter in_list : list (nat * nat) -> nat -> Prop. +Definition not_in_list (l : list (nat * nat)) (n : nat) : Prop := + ~ in_list l n. + +(* Hints Unfold not_in_list. *) + +Axiom + lem1 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list (l1 ++ l2) n -> not_in_list l1 n. + +Axiom + lem2 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list (l1 ++ l2) n -> not_in_list l2 n. + +Axiom + lem3 : + forall (l : list (nat * nat)) (n p q : nat), + not_in_list ((p, q) :: l) n -> not_in_list l n. + +Axiom + lem4 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list l1 n -> not_in_list l2 n -> not_in_list (l1 ++ l2) n. + +Hint Resolve lem1 lem2 lem3 lem4: essai. + +Goal +forall (l : list (nat * nat)) (n p q : nat), +not_in_list ((p, q) :: l) n -> not_in_list l n. + intros. + eauto with essai. +Qed. diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v new file mode 100644 index 0000000000..9b3fb3c5c7 --- /dev/null +++ b/test-suite/success/eqdecide.v @@ -0,0 +1,40 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Inductive T : Set := + | A : T + | B : T -> T. + +Lemma lem1 : forall x y : T, {x = y} + {x <> y}. + decide equality. +Qed. + +Lemma lem1' : forall x y : T, x = y \/ x <> y. + decide equality. +Qed. + +Lemma lem1'' : forall x y : T, {x <> y} + {x = y}. + decide equality. +Qed. + +Lemma lem1''' : forall x y : T, x <> y \/ x = y. + decide equality. +Qed. + +Lemma lem2 : forall x y : T, {x = y} + {x <> y}. +intros x y. + decide equality. +Qed. + +Lemma lem4 : forall x y : T, {x = y} + {x <> y}. +intros x y. + compare x y; auto. +Qed. + diff --git a/test-suite/success/eta.v b/test-suite/success/eta.v new file mode 100644 index 0000000000..08078012a9 --- /dev/null +++ b/test-suite/success/eta.v @@ -0,0 +1,19 @@ +(* Kernel test (head term is a constant) *) +Check (fun a : S = S => a : S = fun x => S x). + +(* Kernel test (head term is a variable) *) +Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => f x). + +(* Test type inference (head term is syntactically rigid) *) +Check (fun (a : list = list) => a : list = fun A => _ A). + +(* Test type inference (head term is a variable) *) +(* This one is still to be done... +Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => _ x). +*) + +(* Test tactic unification *) +Goal (forall f:nat->nat, (fun x => f x) = (fun x => f x)) -> S = S. +intro H; apply H. +Qed. + diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v new file mode 100644 index 0000000000..253b48e4d9 --- /dev/null +++ b/test-suite/success/evars.v @@ -0,0 +1,428 @@ + +(* The "?" of cons and eq should be inferred *) +Variable list : Set -> Set. +Variable cons : forall T : Set, T -> list T -> list T. +Check (forall n : list nat, exists l : _, (exists x : _, n = cons _ x l)). + +(* Examples provided by Eduardo Gimenez *) + +Definition c A (Q : (nat * A -> Prop) -> Prop) P := + Q (fun p : nat * A => let (i, v) := p in P i v). + +(* What does this test ? *) +Require Import List. +Definition list_forall_bool (A : Set) (p : A -> bool) + (l : list A) : bool := + fold_right (fun a r => if p a then r else false) true l. + +(* Checks that solvable ? in the lambda prefix of the definition are harmless*) +Parameter A1 A2 F B C : Set. +Parameter f : F -> A1 -> B. +Definition f1 frm0 a1 : B := f frm0 a1. + +(* Checks that solvable ? in the type part of the definition are harmless *) +Definition f2 frm0 a1 : B := f frm0 a1. + +(* Checks that sorts that are evars are handled correctly (BZ#705) *) +Require Import List. + +Fixpoint build (nl : list nat) : + match nl with + | nil => True + | _ => False + end -> unit := + match nl return (match nl with + | nil => True + | _ => False + end -> unit) with + | nil => fun _ => tt + | n :: rest => + match n with + | O => fun _ => tt + | S m => fun a => build rest (False_ind _ a) + end + end. + + +(* Checks that disjoint contexts are correctly set by restrict_hyp *) +(* Bug de 1999 corrigé en déc 2004 *) + +Check + (let p := + fun (m : nat) f (n : nat) => + match f m n with + | exist _ a b => exist _ a b + end in + p + :forall x : nat, + (forall y n : nat, {q : nat | y = q * n}) -> + forall n : nat, {q : nat | x = q * n}). + +(* Check instantiation of nested evars (BZ#1089) *) + +Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))). + +(* This used to fail with anomaly (Pp.str "evar was not declared.") in V8.0pl3 *) + +Theorem contradiction : forall p, ~ p -> p -> False. +Proof. trivial. Qed. +Hint Resolve contradiction. +Goal False. +eauto. +Abort. + +(* This used to fail in V8.1beta because first-order unification was + used before using type information *) + +Check (exist _ O (refl_equal 0) : {n:nat|n=0}). +Check (exist _ O I : {n:nat|True}). + +(* An example (initially from Marseille/Fairisle) that involves an evar with + different solutions (Input, Output or bool) that may or may not be + considered distinct depending on which kind of conversion is used *) + +Section A. +Definition STATE := (nat * bool)%type. +Let Input := bool. +Let Output := bool. +Parameter Out : STATE -> Output. +Check fun (s : STATE) (reg : Input) => reg = Out s. +End A. + +(* The return predicate found should be: "in _=U return U" *) +(* (feature already available in V8.0) *) + +Definition g (T1 T2:Type) (x:T1) (e:T1=T2) : T2 := + match e with + | refl_equal => x + end. + +(* An example extracted from FMapAVL which (may) test restriction on + evars problems of the form ?n[args1]=?n[args2] with distinct args1 + and args2 *) + +Set Implicit Arguments. +Parameter t:Set->Set. +Parameter map:forall elt elt' : Set, (elt -> elt') -> t elt -> t elt'. +Parameter avl: forall elt : Set, t elt -> Prop. +Parameter bst: forall elt : Set, t elt -> Prop. +Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), + avl m -> avl (map f m). +Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), + bst m -> bst (map f m). +Record bbst (elt:Set) : Set := + Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}. +Definition t' := bbst. +Section B. +Variables elt elt': Set. +Definition map' f (m:t' elt) : t' elt' := + Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). +End B. +Unset Implicit Arguments. + +(* An example from Lexicographic_Exponentiation that tests the + contraction of reducible fixpoints in type inference *) + +Require Import List. +Check (fun (A:Set) (a b x:A) (l:list A) + (H : l ++ cons x nil = cons b (cons a nil)) => + app_inj_tail l (cons b nil) _ _ H). + +(* An example from NMake (simplified), that uses restriction in solve_refl *) + +Parameter h:(nat->nat)->(nat->nat). +Fixpoint G p cont {struct p} := + h (fun n => match p with O => cont | S p => G p cont end n). + +(* An example from Bordeaux/Cantor that applies evar restriction + below a binder *) + +Require Import Relations. +Parameter lex : forall (A B : Set), (forall (a1 a2:A), {a1=a2}+{a1<>a2}) +-> relation A -> relation B -> A * B -> A * B -> Prop. +Check + forall (A B : Set) eq_A_dec o1 o2, + antisymmetric A o1 -> transitive A o1 -> transitive B o2 -> + transitive _ (lex _ _ eq_A_dec o1 o2). + +(* Another example from Julien Forest that tests unification below binders *) + +Require Import List. +Set Implicit Arguments. +Parameter + merge : forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2}) + (eqB : forall (b1 b2 : B), {b1=b2}+{b1<>b2}) + (partial_res l : list (A*B)), option (list (A*B)). +Axiom merge_correct : + forall (A B : Set) eqA eqB (l1 l2 : list (A*B)), + (forall a2 b2 c2, In (a2,b2) l2 -> In (a2,c2) l2 -> b2 = c2) -> + match merge eqA eqB l1 l2 with _ => True end. +Unset Implicit Arguments. + +(* An example from Bordeaux/Additions that tests restriction below binders *) + +Section Additions_while. + +Variable A : Set. +Variables P Q : A -> Prop. +Variable le : A -> A -> Prop. +Hypothesis Q_dec : forall s : A, P s -> {Q s} + {~ Q s}. +Hypothesis le_step : forall s : A, ~ Q s -> P s -> {s' | P s' /\ le s' s}. +Hypothesis le_wf : well_founded le. + +Lemma loopexec : forall s : A, P s -> {s' : A | P s' /\ Q s'}. +refine + (well_founded_induction_type le_wf (fun s => _ -> {s' : A | _ /\ _}) + (fun s hr i => + match Q_dec s i with + | left _ => _ + | right _ => + match le_step s _ _ with + | exist _ s' h' => + match hr s' _ _ with + | exist _ s'' _ => exist _ s'' _ + end + end + end)). +Abort. + +End Additions_while. + +(* Two examples from G. Melquiond (BZ#1878 and BZ#1884) *) + +Parameter F1 G1 : nat -> Prop. +Goal forall x : nat, F1 x -> G1 x. +refine (fun x H => proj2 (_ x H)). +Abort. + +Goal forall x : nat, F1 x -> G1 x. +refine (fun x H => proj2 (_ x H) _). +Abort. + +(* An example from y-not that was failing in 8.2rc1 *) + +Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := + match l with + | nil => nil + | (existT _ k v)::l' => (existT _ k v):: (filter A l') + end. + +(* BZ#2000: used to raise Out of memory in 8.2 while it should fail by + lack of information on the conclusion of the type of j *) + +Goal True. +set (p:=fun j => j (or_intror _ (fun a:True => j (or_introl _ a)))) || idtac. +Abort. + +(* Remark: the following example stopped succeeding at some time in + the development of 8.2 but it works again (this was because 8.2 + algorithm was more general and did not exclude a solution that it + should have excluded for typing reason; handling of types and + backtracking is still to be done) *) + +Section S. +Variables A B : nat -> Prop. +Goal forall x : nat, A x -> B x. +refine (fun x H => proj2 (_ x H) _). +Abort. +End S. + +(* Check that constraints are taken into account by tactics that instantiate *) + +Lemma inj : forall n m, S n = S m -> n = m. +intros n m H. +eapply f_equal with (* should fail because ill-typed *) + (f := fun n => + match n return match n with S _ => nat | _ => unit end with + | S n => n + | _ => tt + end) in H +|| injection H. +Abort. + +(* A legitimate simple eapply that was failing in coq <= 8.3. + Cf. in Unification.w_merge the addition of an extra pose_all_metas_as_evars + on 30/9/2010 +*) + +Lemma simple_eapply_was_failing : + (forall f:nat->nat, exists g, f = g) -> True. +Proof. + assert (modusponens : forall P Q, P -> (P->Q) -> Q) by auto. + intros. + eapply modusponens. + simple eapply H. + (* error message with V8.3 : + Impossible to unify "?18" with "fun g : nat -> nat => ?6 = g". *) +Abort. + +(* Regression test *) + +Definition fo : option nat -> nat := option_rec _ (fun a => 0) 0. + +(* This example revealed an incorrect evar restriction at some time + around October 2011 *) + +Goal forall (A:Type) (a:A) (P:forall A, A -> Prop), (P A a) /\ (P A a). +intros. +refine ((fun H => conj (proj1 H) (proj2 H)) _). +Abort. + +(* The argument of e below failed to be inferred from r14219 (Oct 2011) to *) +(* r14753 after the restrictions made on detecting Miller's pattern in the *) +(* presence of alias, only the second-order unification procedure was *) +(* able to solve this problem but it was deactivated for 8.4 in r14219 *) + +Definition k0 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, n = a) o := + match o with (* note: match introduces an alias! *) + | Some a => e _ (j a) + | None => O + end. + +Definition k1 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j a). + +Definition k2 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b). + +(* Other examples about aliases involved in pattern unification *) + +Definition k3 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, let a' := a in n = a') a (b:=a) := e _ (j b). + +Definition k4 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, let a' := S a in n = a') a (b:=a) := e _ (j b). + +Definition k5 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, let a' := S a in exists n : nat, n = a') a (b:=a) := e _ (j b). + +Definition k6 + (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat) + (j : forall a, exists n : nat, let n' := S n in n' = a) a (b:=a) := e _ (j b). + +Definition k7 + (e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat) + (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b). + +(* An example that uses materialize_evar under binders *) +(* Extracted from bigop.v in the mathematical components library *) + +Section Bigop. + +Variable bigop : forall R I: Type, + R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R. + +Hypothesis eq_bigr : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R), + (forall i : I, P i -> F1 i = F2 i) -> + bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx. + +Hypothesis big_tnth : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), + bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx. + +Hypothesis big_tnth_with_letin : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), + bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx. + +Variable R : Type. +Variable idx : R. +Variable op : R -> R -> R. +Variable I : Type. +Variable J : Type. +Variable rI : list I. +Variable rJ : list J. +Variable xQ : J -> Prop. +Variable P : I -> Prop. +Variable Q : I -> J -> Prop. +Variable F : I -> J -> R. + +(* Check unification under binders *) + +Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _)) + : (bigop R J idx op rJ + (fun j : J => let k:=j in xQ k) + (fun j : J => let k:=j in + bigop R I idx + op rI + (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. + +(* Check also with let-in *) + +Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _)) + : (bigop R J idx op rJ + (fun j : J => let k:=j in xQ k) + (fun j : J => let k:=j in + bigop R I idx + op rI + (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. + +End Bigop. + +(* Check the use of (at least) an heuristic to solve problems of the form + "?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can + eventually be erased in t *) + +Section evar_evar_occur. + Variable id : nat -> nat. + Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2. + Variable g : forall y, id y = 0 /\ id y = 0. + (* Still evars in the resulting type, but constraints should be solved *) + Check match g _ with conj a b => f _ a b end. +End evar_evar_occur. + +(* Eta expansion (BZ#2936) *) +Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }. +Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri { + tri0 : forall a b c, R a b -> S a c -> T b c +}. +Arguments mkTri [R S T]. +Definition tri_iffT : tri iffT iffT iffT := + (mkTri + (fun X0 X1 X2 E01 E02 => + (mkIff _ _ (fun x1 => iffLR _ _ E02 (iffRL _ _ E01 x1)) + (fun x2 => iffLR _ _ E01 (iffRL _ _ E02 x2))))). + +(* Check that local defs names are preserved if possible during unification *) + +Goal forall x (x':=x) (f:forall y, y=y:>nat -> Prop), f _ (eq_refl x'). +intros. +unfold x' at 2. (* A way to check that there are indeed 2 occurrences of x' *) +Abort. + +(* A simple example we would like not to fail (it used to fail because of + not strict enough evar restriction) *) + +Check match Some _ with None => _ | _ => _ end. + +(* Used to fail for a couple of days in Nov 2014 *) + +Axiom test : forall P1 P2, P1 = P2 -> P1 -> P2. + +(* Check use of candidates *) + +Import EqNotations. +Definition test2 {A B:Type} {H:A=B} (a:A) : B := rew H in a. + +(* Check that pre-existing evars are not counted as newly undefined in "set" *) +(* Reported by Théo *) + +Goal exists n : nat, n = n -> True. +eexists. +set (H := _ = _). +Abort. + +(* Check interpretation of default evar instance in pretyping *) +(* (reported as bug #7356) *) + +Check fun (P : nat -> Prop) (x:nat) (h:P x) => exist _ ?[z] (h : P ?z). diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v new file mode 100644 index 0000000000..95ae070940 --- /dev/null +++ b/test-suite/success/extraction.v @@ -0,0 +1,642 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Coq.extraction.Extraction. +Require Import Arith. +Require Import List. + +(**** A few tests for the extraction mechanism ****) + +(* Ideally, we should monitor the extracted output + for changes, but this is painful. For the moment, + we just check for failures of this script. *) + +(*** STANDARD EXAMPLES *) + +(** Functions. *) + +Definition idnat (x:nat) := x. +Extraction idnat. +(* let idnat x = x *) + +Definition id (X:Type) (x:X) := x. +Extraction id. (* let id x = x *) +Definition id' := id Set nat. +Extraction id'. (* type id' = nat *) + +Definition test2 (f:nat -> nat) (x:nat) := f x. +Extraction test2. +(* let test2 f x = f x *) + +Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. +Extraction test3. +(* let test3 f x = f x __ *) + +Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. +Extraction test4. +(* let test4 f x g = f g *) + +Definition test5 := (1, 0). +Extraction test5. +(* let test5 = Pair ((S O), O) *) + +Definition cf (x:nat) (_:x <= 0) := S x. +Extraction NoInline cf. +Definition test6 := cf 0 (le_n 0). +Extraction test6. +(* let test6 = cf O *) + +Definition test7 := (fun (X:Set) (x:X) => x) nat. +Extraction test7. +(* let test7 x = x *) + +Definition d (X:Type) := X. +Extraction d. (* type 'x d = 'x *) +Definition d2 := d Set. +Extraction d2. (* type d2 = __ d *) +Definition d3 (x:d Set) := 0. +Extraction d3. (* let d3 _ = O *) +Definition d4 := d nat. +Extraction d4. (* type d4 = nat d *) +Definition d5 := (fun x:d Type => 0) Type. +Extraction d5. (* let d5 = O *) +Definition d6 (x:d Type) := x. +Extraction d6. (* type 'x d6 = 'x *) + +Definition test8 := (fun (X:Type) (x:X) => x) Set nat. +Extraction test8. (* type test8 = nat *) + +Definition test9 := let t := nat in id Set t. +Extraction test9. (* type test9 = nat *) + +Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. +Extraction test10. (* let test10 = O *) + +Definition test11 := let n := 0 in let p := S n in S p. +Extraction test11. (* let test11 = S (S O) *) + +Definition test12 := forall x:forall X:Type, X -> X, x Type Type. +Extraction test12. +(* type test12 = (__ -> __ -> __) -> __ *) + + +Definition test13 := match @left True True I with + | left x => 1 + | right x => 0 + end. +Extraction test13. (* let test13 = S O *) + + +(** example with more arguments that given by the type *) + +Definition test19 := + nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) + (fun (n:nat) (f:nat -> nat) => f) 0 0. +Extraction test19. +(* let test19 = + let rec f = function + | O -> (fun n0 -> O) + | S n0 -> f n0 + in f O O +*) + + +(** casts *) + +Definition test20 := True:Type. +Extraction test20. +(* type test20 = __ *) + + +(** Simple inductive type and recursor. *) + +Extraction nat. +(* +type nat = + | O + | S of nat +*) + +Extraction sumbool_rect. +(* +let sumbool_rect f f0 = function + | Left -> f __ + | Right -> f0 __ +*) + +(** Less simple inductive type. *) + +Inductive c (x:nat) : nat -> Set := + | refl : c x x + | trans : forall y z:nat, c x y -> y <= z -> c x z. +Extraction c. +(* +type c = + | Refl + | Trans of nat * nat * c +*) + +Definition Ensemble (U:Type) := U -> Prop. +Definition Empty_set (U:Type) (x:U) := False. +Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. + +Inductive Finite (U:Type) : Ensemble U -> Type := + | Empty_is_finite : Finite U (Empty_set U) + | Union_is_finite : + forall A:Ensemble U, + Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). +Extraction Finite. +(* +type 'u finite = + | Empty_is_finite + | Union_is_finite of 'u finite * 'u +*) + + +(** Mutual Inductive *) + +Inductive tree : Set := + Node : nat -> forest -> tree +with forest : Set := + | Leaf : nat -> forest + | Cons : tree -> forest -> forest. + +Extraction tree. +(* +type tree = + | Node of nat * forest +and forest = + | Leaf of nat + | Cons of tree * forest +*) + +Fixpoint tree_size (t:tree) : nat := + match t with + | Node a f => S (forest_size f) + end + + with forest_size (f:forest) : nat := + match f with + | Leaf b => 1 + | Cons t f' => tree_size t + forest_size f' + end. + +Extraction tree_size. +(* +let rec tree_size = function + | Node (a, f) -> S (forest_size f) +and forest_size = function + | Leaf b -> S O + | Cons (t, f') -> plus (tree_size t) (forest_size f') +*) + + +(** Eta-expansions of inductive constructor *) + +Inductive titi : Set := + tata : nat -> nat -> nat -> nat -> titi. +Definition test14 := tata 0. +Extraction test14. +(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) +Definition test15 := tata 0 1. +Extraction test15. +(* let test15 x x0 = Tata (O, (S O), x, x0) *) + +Inductive eta : Type := + eta_c : nat -> Prop -> nat -> Prop -> eta. +Extraction eta_c. +(* +type eta = + | Eta_c of nat * nat +*) +Definition test16 := eta_c 0. +Extraction test16. +(* let test16 x = Eta_c (O, x) *) +Definition test17 := eta_c 0 True. +Extraction test17. +(* let test17 x = Eta_c (O, x) *) +Definition test18 := eta_c 0 True 0. +Extraction test18. +(* let test18 _ = Eta_c (O, O) *) + + +(** Example of singleton inductive type *) + +Inductive bidon (A:Prop) (B:Type) : Type := + tb : forall (x:A) (y:B), bidon A B. +Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) + (x:A) (y:B) := f x y. +Extraction bidon. +(* type 'b bidon = 'b *) +Extraction tb. +(* tb : singleton inductive constructor *) +Extraction fbidon. +(* let fbidon f x y = + f x y +*) + +Definition fbidon2 := fbidon True nat (tb True nat). +Extraction fbidon2. (* let fbidon2 y = y *) +Extraction NoInline fbidon. +Extraction fbidon2. +(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) + +(* NB: first argument of fbidon2 has type [True], so it disappears. *) + +(** mutual inductive on many sorts *) + +Inductive test_0 : Prop := + ctest0 : test_0 +with test_1 : Set := + ctest1 : test_0 -> test_1. +Extraction test_0. +(* test0 : logical inductive *) +Extraction test_1. +(* +type test1 = + | Ctest1 +*) + +(** logical singleton *) + +Extraction eq. +(* eq : logical inductive *) +Extraction eq_rect. +(* let eq_rect x f y = + f +*) + +(** No more propagation of type parameters. Obj.t instead. *) + +Inductive tp1 : Type := + T : forall (C:Set) (c:C), tp2 -> tp1 +with tp2 : Type := + T' : tp1 -> tp2. +Extraction tp1. +(* +type tp1 = + | T of __ * tp2 +and tp2 = + | T' of tp1 +*) + +Inductive tp1bis : Type := + Tbis : tp2bis -> tp1bis +with tp2bis : Type := + T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. +Extraction tp1bis. +(* +type tp1bis = + | Tbis of tp2bis +and tp2bis = + | T'bis of __ * tp1bis +*) + + +(** Strange inductive type. *) + +Inductive Truc : Set -> Type := + | chose : forall A:Set, Truc A + | machin : forall A:Set, A -> Truc bool -> Truc A. +Extraction Truc. +(* +type 'x truc = + | Chose + | Machin of 'x * bool truc +*) + + +(** Dependant type over Type *) + +Definition test24 := sigT (fun a:Set => option a). +Extraction test24. +(* type test24 = (__, __ option) sigT *) + + +(** Coq term non strongly-normalizable after extraction *) + +Require Import Gt. +Definition loop (Ax:Acc gt 0) := + (fix F (a:nat) (b:Acc gt a) {struct b} : nat := + F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax. +Extraction loop. +(* let loop _ = + let rec f a = + f (S a) + in f O +*) + +(*** EXAMPLES NEEDING OBJ.MAGIC *) + +(** False conversion of type: *) + +Lemma oups : forall H:nat = list nat, nat -> nat. +intros. +generalize H0; intros. +rewrite H in H1. +case H1. +exact H0. +intros. +exact n. +Defined. +Extraction oups. +(* +let oups h0 = + match Obj.magic h0 with + | Nil -> h0 + | Cons0 (n, l) -> n +*) + + +(** hybrids *) + +Definition horibilis (b:bool) := + if b as b return (if b then Type else nat) then Set else 0. +Extraction horibilis. +(* +let horibilis = function + | True -> Obj.magic __ + | False -> Obj.magic O +*) + +Definition PropSet (b:bool) := if b then Prop else Set. +Extraction PropSet. (* type propSet = __ *) + +Definition natbool (b:bool) := if b then nat else bool. +Extraction natbool. (* type natbool = __ *) + +Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. +Extraction zerotrue. +(* +let zerotrue = function + | True -> Obj.magic O + | False -> Obj.magic True +*) + +Definition natProp (b:bool) := if b return Type then nat else Prop. + +Definition natTrue (b:bool) := if b return Type then nat else True. + +Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. +Extraction zeroTrue. +(* +let zeroTrue = function + | True -> Obj.magic O + | False -> Obj.magic __ +*) + +Definition natTrue2 (b:bool) := if b return Type then nat else True. + +Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. +Extraction zeroprop. +(* +let zeroprop = function + | True -> Obj.magic O + | False -> Obj.magic __ +*) + +(** polymorphic f applied several times *) + +Definition test21 := (id nat 0, id bool true). +Extraction test21. +(* let test21 = Pair ((id O), (id True)) *) + +(** ok *) + +Definition test22 := + (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) + (fun (X:Type) (x:X) => x). +Extraction test22. +(* let test22 = + let f = fun x -> x in Pair ((f O), (f True)) *) + +(* still ok via optim beta -> let *) + +Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). +Extraction test23. +(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) + +(* problem: fun f -> (f 0, f true) not legal in ocaml *) +(* solution: magic ... *) + + +(** Dummy constant __ can be applied.... *) + +Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). +Extraction f. +(* let f x y = + y (x O) +*) + +Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). +Extraction NoInline f. +Extraction f_prop. +(* let f_prop = + f (Obj.magic __) (fun _ -> True) +*) + +Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). +Extraction f_arity. +(* let f_arity = + f (Obj.magic __) (fun _ -> True) +*) + +Definition f_normal := + f nat (fun x => x) (fun x => match x with + | O => true + | _ => false + end). +Extraction f_normal. +(* let f_normal = + f (fun x -> x) (fun x -> match x with + | O -> True + | S n -> False) +*) + + +(* inductive with magic needed *) + +Inductive Boite : Set := + boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. +Extraction Boite. +(* +type boite = + | Boite of bool * __ +*) + + +Definition boite1 := boite true 0. +Extraction boite1. +(* let boite1 = Boite (True, (Obj.magic O)) *) + +Definition boite2 := boite false (0, 0). +Extraction boite2. +(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) + +Definition test_boite (B:Boite) := + match B return nat with + | boite true n => n + | boite false n => fst n + snd n + end. +Extraction test_boite. +(* +let test_boite = function + | Boite (b0, n) -> + (match b0 with + | True -> Obj.magic n + | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) +*) + +(* singleton inductive with magic needed *) + +Inductive Box : Type := + box : forall A:Set, A -> Box. +Extraction Box. +(* type box = __ *) + +Definition box1 := box nat 0. +Extraction box1. (* let box1 = Obj.magic O *) + +(* applied constant, magic needed *) + +Definition idzarb (b:bool) (x:if b then nat else bool) := x. +Definition zarb := idzarb true 0. +Extraction NoInline idzarb. +Extraction zarb. +(* let zarb = Obj.magic idzarb True (Obj.magic O) *) + +(** function of variable arity. *) +(** Fun n = nat -> nat -> ... -> nat *) + +Fixpoint Fun (n:nat) : Set := + match n with + | O => nat + | S n => nat -> Fun n + end. + +Fixpoint Const (k n:nat) {struct n} : Fun n := + match n as x return Fun x with + | O => k + | S n => fun p:nat => Const k n + end. + +Fixpoint proj (k n:nat) {struct n} : Fun n := + match n as x return Fun x with + | O => 0 (* ou assert false ....*) + | S n => + match k with + | O => fun x => Const x n + | S k => fun x => proj k n + end + end. + +Definition test_proj := proj 2 4 0 1 2 3. + +Eval compute in test_proj. + +Recursive Extraction test_proj. + + + +(*** TO SUM UP: ***) + +Module Everything. + Definition idnat := idnat. + Definition id := id. + Definition id' := id'. + Definition test2 := test2. + Definition test3 := test3. + Definition test4 := test4. + Definition test5 := test5. + Definition test6 := test6. + Definition test7 := test7. + Definition d := d. + Definition d2 := d2. + Definition d3 := d3. + Definition d4 := d4. + Definition d5 := d5. + Definition d6 := d6. + Definition test8 := test8. + Definition test9 := test9. + Definition test10 := test10. + Definition test11 := test11. + Definition test12 := test12. + Definition test13 := test13. + Definition test19 := test19. + Definition test20 := test20. + Definition nat := nat. + Definition sumbool_rect := sumbool_rect. + Definition c := c. + Definition Finite := Finite. + Definition tree := tree. + Definition tree_size := tree_size. + Definition test14 := test14. + Definition test15 := test15. + Definition eta_c := eta_c. + Definition test16 := test16. + Definition test17 := test17. + Definition test18 := test18. + Definition bidon := bidon. + Definition tb := tb. + Definition fbidon := fbidon. + Definition fbidon2 := fbidon2. + Definition test_0 := test_0. + Definition test_1 := test_1. + Definition eq_rect := eq_rect. + Definition tp1 := tp1. + Definition tp1bis := tp1bis. + Definition Truc := Truc. + Definition oups := oups. + Definition test24 := test24. + Definition loop := loop. + Definition horibilis := horibilis. + Definition PropSet := PropSet. + Definition natbool := natbool. + Definition zerotrue := zerotrue. + Definition zeroTrue := zeroTrue. + Definition zeroprop := zeroprop. + Definition test21 := test21. + Definition test22 := test22. + Definition test23 := test23. + Definition f := f. + Definition f_prop := f_prop. + Definition f_arity := f_arity. + Definition f_normal := f_normal. + Definition Boite := Boite. + Definition boite1 := boite1. + Definition boite2 := boite2. + Definition test_boite := test_boite. + Definition Box := Box. + Definition box1 := box1. + Definition zarb := zarb. + Definition test_proj := test_proj. +End Everything. + +(* Extraction "test_extraction.ml" Everything. *) +Recursive Extraction Everything. +(* Check that the previous OCaml code is compilable *) +Extraction TestCompile Everything. + +Extraction Language Haskell. +(* Extraction "Test_extraction.hs" Everything. *) +Recursive Extraction Everything. + +Extraction Language Scheme. +(* Extraction "test_extraction.scm" Everything. *) +Recursive Extraction Everything. + + +(*** Finally, a test more focused on everyday's life situations ***) + +Require Import ZArith. + +Extraction Language OCaml. +Recursive Extraction Z_modulo_2 Zdiv_eucl_exist. +Extraction TestCompile Z_modulo_2 Zdiv_eucl_exist. diff --git a/test-suite/success/extraction_dep.v b/test-suite/success/extraction_dep.v new file mode 100644 index 0000000000..fb0adabae9 --- /dev/null +++ b/test-suite/success/extraction_dep.v @@ -0,0 +1,51 @@ + +(** Examples of code elimination inside modules during extraction *) + +Require Coq.extraction.Extraction. + +(** NB: we should someday check the produced code instead of + extracting and just compiling. *) + +(** 1) Without signature ... *) + +Module A. + Definition u := 0. + Definition v := 1. + Module B. + Definition w := 2. + Definition x := 3. + End B. +End A. + +Definition testA := A.u + A.B.x. + +Recursive Extraction testA. (* without: v w *) +Extraction TestCompile testA. + +(** 1b) Same with an Include *) + +Module Abis. + Include A. + Definition y := 4. +End Abis. + +Definition testAbis := Abis.u + Abis.y. + +Recursive Extraction testAbis. (* without: A B v w x *) +Extraction TestCompile testAbis. + +(** 2) With signature, we only keep elements mentionned in signature. *) + +Module Type SIG. + Parameter u : nat. + Parameter v : nat. +End SIG. + +Module Ater : SIG. + Include A. +End Ater. + +Definition testAter := Ater.u. + +Recursive Extraction testAter. (* with only: u v *) +Extraction TestCompile testAter. diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v new file mode 100644 index 0000000000..a38a688fb4 --- /dev/null +++ b/test-suite/success/extraction_impl.v @@ -0,0 +1,91 @@ + +(** Examples of extraction with manually-declared implicit arguments *) + +(** NB: we should someday check the produced code instead of + extracting and just compiling. *) + +Require Coq.extraction.Extraction. + +(** Bug #4243, part 1 *) + +Inductive dnat : nat -> Type := +| d0 : dnat 0 +| ds : forall n m, n = m -> dnat n -> dnat (S n). + +Extraction Implicit ds [m]. + +Lemma dnat_nat: forall n, dnat n -> nat. +Proof. + intros n d. + induction d as [| n m Heq d IHn]. + exact 0. exact (S IHn). +Defined. + +Recursive Extraction dnat_nat. +Extraction TestCompile dnat_nat. + +Extraction Implicit dnat_nat [n]. +Recursive Extraction dnat_nat. +Extraction TestCompile dnat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint dnat_nat' n (d:dnat n) := + match d with + | d0 => 0 + | ds n m _ d => S (dnat_nat' n d) + end. + +Recursive Extraction dnat_nat'. +Extraction TestCompile dnat_nat'. + +Extraction Implicit dnat_nat' [n]. +Recursive Extraction dnat_nat'. +Extraction TestCompile dnat_nat'. + +(** Bug #4243, part 2 *) + +Inductive enat: nat -> Type := + e0: enat 0 +| es: forall n, enat n -> enat (S n). + +Lemma enat_nat: forall n, enat n -> nat. +Proof. + intros n e. + induction e as [| n e IHe]. + exact (O). + exact (S IHe). +Defined. + +Extraction Implicit es [n]. +Extraction Implicit enat_nat [n]. +Recursive Extraction enat_nat. +Extraction TestCompile enat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint enat_nat' n (e:enat n) : nat := + match e with + | e0 => 0 + | es n e => S (enat_nat' n e) + end. + +Extraction Implicit enat_nat' [n]. +Recursive Extraction enat_nat'. +Extraction TestCompile enat_nat'. + +(** Bug #4228 *) + +Module Food. +Inductive Course := +| main: nat -> Course +| dessert: nat -> Course. + +Inductive Meal : Course -> Type := +| one_course : forall n:nat, Meal (main n) +| two_course : forall n m, Meal (main n) -> Meal (dessert m). +Extraction Implicit two_course [n]. +End Food. + +Recursive Extraction Food.Meal. +Extraction TestCompile Food.Meal. diff --git a/test-suite/success/extraction_polyprop.v b/test-suite/success/extraction_polyprop.v new file mode 100644 index 0000000000..936d838c50 --- /dev/null +++ b/test-suite/success/extraction_polyprop.v @@ -0,0 +1,13 @@ +(* The current extraction cannot handle this situation, + and shouldn't try, otherwise it might produce some Ocaml + code that segfaults. See Table.error_singleton_become_prop + or S. Glondu's thesis for more details. *) + +Require Coq.extraction.Extraction. + +Definition f {X} (p : (nat -> X) * True) : X * nat := + (fst p 0, 0). + +Definition f_prop := f ((fun _ => I),I). + +Fail Extraction f_prop. diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v new file mode 100644 index 0000000000..ff34840d83 --- /dev/null +++ b/test-suite/success/fix.v @@ -0,0 +1,98 @@ +(* Ancien bug signale par Laurent Thery sur la condition de garde *) + +Require Import Bool. +Require Import ZArith. + +Definition rNat := positive. + +Inductive rBoolOp : Set := + | rAnd : rBoolOp + | rEq : rBoolOp. + +Definition rlt (a b : rNat) : Prop := Pos.compare_cont Eq a b = Lt. + +Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}. +Proof. +intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m); + generalize (nat_of_P_gt_Gt_compare_morphism n m); + generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont Eq n m). +intros H' H'0 H'1; right; right; auto. +intros H' H'0 H'1; left; unfold rlt. +apply nat_of_P_lt_Lt_compare_complement_morphism; auto. +intros H' H'0 H'1; right; left; unfold rlt. +apply nat_of_P_lt_Lt_compare_complement_morphism; auto. +apply H'0; auto. +Defined. + + +Definition rmax : rNat -> rNat -> rNat. +Proof. +intros n m; case (rltDec n m); intros Rlt0. +exact m. +exact n. +Defined. + +Inductive rExpr : Set := + | rV : rNat -> rExpr + | rN : rExpr -> rExpr + | rNode : rBoolOp -> rExpr -> rExpr -> rExpr. + +Fixpoint maxVar (e : rExpr) : rNat := + match e with + | rV n => n + | rN p => maxVar p + | rNode n p q => rmax (maxVar p) (maxVar q) + end. + +(* Check bug #1491 *) + +Require Import Streams. + +Definition decomp (s:Stream nat) : Stream nat := + match s with Cons _ s => s end. + +CoFixpoint bx0 : Stream nat := Cons 0 bx1 +with bx1 : Stream nat := Cons 1 bx0. + +Lemma bx0bx : decomp bx0 = bx1. +simpl. (* used to return bx0 in V8.1 and before instead of bx1 *) +reflexivity. +Qed. + +(* Check mutually inductive statements *) + +Require Import ZArith_base Omega. +Open Scope Z_scope. + +Inductive even: Z -> Prop := +| even_base: even 0 +| even_succ: forall n, odd (n - 1) -> even n +with odd: Z -> Prop := +| odd_succ: forall n, even (n - 1) -> odd n. + +Lemma even_pos_odd_pos: forall n, even n -> n >= 0 +with odd_pos_even_pos : forall n, odd n -> n >= 1. +Proof. + intros. + destruct H. + omega. + apply odd_pos_even_pos in H. + omega. + intros. + destruct H. + apply even_pos_odd_pos in H. + omega. +Qed. + +CoInductive a : Prop := acons : b -> a +with b : Prop := bcons : a -> b. + +Lemma a1 : a +with b1 : b. +Proof. +apply acons. +assumption. + +apply bcons. +assumption. +Qed. diff --git a/test-suite/success/forward.v b/test-suite/success/forward.v new file mode 100644 index 0000000000..4e36dec15b --- /dev/null +++ b/test-suite/success/forward.v @@ -0,0 +1,29 @@ +(* Testing forward reasoning *) + +Goal 0=0. +Fail assert (_ = _). +eassert (_ = _)by reflexivity. +eassumption. +Qed. + +Goal 0=0. +Fail set (S ?[nl]). +eset (S ?[n]). +remember (S ?n) as x. +instantiate (n:=0). +Fail remember (S (S _)). +eremember (S (S ?[x])). +instantiate (x:=0). +reflexivity. +Qed. + +(* Don't know if it is good or not but the compatibility tells that + the asserted goal to prove is subject to beta-iota but not the + asserted hypothesis *) + +Goal True. +assert ((fun x => x) False). +Fail match goal with |- (?f ?a) => idtac end. (* should be beta-iota reduced *) +2:match goal with _: (?f ?a) |- _ => idtac end. (* should not be beta-iota reduced *) +Abort. + diff --git a/test-suite/success/goal_selector.v b/test-suite/success/goal_selector.v new file mode 100644 index 0000000000..0951c5c8d4 --- /dev/null +++ b/test-suite/success/goal_selector.v @@ -0,0 +1,69 @@ +Inductive two : bool -> Prop := +| Zero : two false +| One : two true. + +Ltac dup := + let H := fresh in assert (forall (P : Prop), P -> P -> P) as H by (intros; trivial); + apply H; clear H. + +Lemma transform : two false <-> two true. +Proof. split; intros _; constructor. Qed. + +Goal two false /\ two true /\ two false /\ two true /\ two true /\ two true. +Proof. + do 2 dup. + - repeat split. + 2, 4-99, 100-3:idtac. + 2-5:exact One. + par:exact Zero. + - repeat split. + 3-6:swap 1 4. + 1-5:swap 1 5. + 0-4:exact One. + all:exact Zero. + - repeat split. + 1, 3:exact Zero. + 1, 2, 3, 4: exact One. + - repeat split. + all:apply transform. + 2, 4, 6:apply transform. + all:apply transform. + 1-5:apply transform. + 1-6:exact One. +Qed. + +Goal True -> True. +Proof. + intros y; only 1-2 : repeat idtac. + 1-1:match goal with y : _ |- _ => let x := y in idtac x end. + Fail 1-1:let x := y in idtac x. + 1:let x := y in idtac x. + exact I. +Qed. + +Goal True /\ (True /\ True). +Proof. + dup. + - split; only 2: (split; exact I). + exact I. + - split; only 2: split; exact I. +Qed. + +Goal True -> exists (x : Prop), x. +Proof. + intro H; eexists ?[x]; only [x]: exact True. 1: assumption. +Qed. + +(* Strict focusing! *) +Set Default Goal Selector "!". + +Goal True -> True /\ True /\ True. +Proof. + intro. + split;only 2:split. + Fail exact I. + Fail !:exact I. + 1:exact I. + - !:exact H. + - exact I. +Qed. diff --git a/test-suite/success/guard.v b/test-suite/success/guard.v new file mode 100644 index 0000000000..3a1c6dabeb --- /dev/null +++ b/test-suite/success/guard.v @@ -0,0 +1,28 @@ +(* Specific tests about guard condition *) + +(* f must unfold to x, not F (de Bruijn mix-up!) *) +Check let x (f:nat->nat) k := f k in + fun (y z:nat->nat) => + let f:=x in (* f := Rel 3 *) + fix F (n:nat) : nat := + match n with + | 0 => 0 + | S k => f F k (* here Rel 3 = F ! *) + end. + +(** Commutation of guard condition allows recursive calls on functional arguments, + despite rewriting in their domain types. *) +Inductive foo : Type -> Type := +| End A : foo A +| Next A : (A -> foo A) -> foo A. + +Definition nat : Type := nat. + +Fixpoint bar (A : Type) (e : nat = A) (f : foo A) {struct f} : nat := +match f with +| End _ => fun _ => O +| Next A g => fun e => + match e in (_ = B) return (B -> foo A) -> nat with + | eq_refl => fun (g' : nat -> foo A) => bar A e (g' O) + end g +end e. diff --git a/test-suite/success/hintdb_in_ltac.v b/test-suite/success/hintdb_in_ltac.v new file mode 100644 index 0000000000..f12b4d1f45 --- /dev/null +++ b/test-suite/success/hintdb_in_ltac.v @@ -0,0 +1,14 @@ +Definition x := 0. + +Hint Unfold x : mybase. + +Ltac autounfoldify base := autounfold with base. + +Tactic Notation "autounfoldify_bis" ident(base) := autounfold with base. + +Goal x = 0. + progress autounfoldify mybase. + Undo. + progress autounfoldify_bis mybase. + trivial. +Qed. diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v new file mode 100644 index 0000000000..2bc3f9d22a --- /dev/null +++ b/test-suite/success/hintdb_in_ltac_bis.v @@ -0,0 +1,15 @@ +Parameter Foo : Prop. +Axiom H : Foo. + +Hint Resolve H : mybase. + +Ltac foo base := eauto with base. + +Tactic Notation "bar" ident(base) := + typeclasses eauto with base. + +Goal Foo. + progress foo mybase. + Undo. + progress bar mybase. +Qed. diff --git a/test-suite/success/hyps_inclusion.v b/test-suite/success/hyps_inclusion.v new file mode 100644 index 0000000000..ebd90a40e0 --- /dev/null +++ b/test-suite/success/hyps_inclusion.v @@ -0,0 +1,34 @@ +(* Simplified example for bug #1325 *) + +(* Explanation: the proof engine see section variables as goal + variables; especially, it can change their types so that, at + type-checking, the section variables are not recognized + (Typeops.check_hyps_inclusion raises "types do no match"). It + worked before the introduction of polymorphic inductive types because + tactics were using Typing.type_of and not Typeops.typing; the former + was not checking hyps inclusion so that the discrepancy in the types + of section variables seen as goal variables was not a problem (at the + end, when the proof is completed, the section variable recovers its + original type and all is correct for Typeops) *) + +Section A. +Variable H:not True. +Lemma f:nat->nat. destruct H. exact I. Defined. +Goal f 0=f 1. +red in H. +(* next tactic was failing wrt bug #1325 because type-checking the goal + detected a syntactically different type for the section variable H *) +case 0. +Abort. +End A. + +(* Variant with polymorphic inductive types for bug #1325 *) + +Section B. +Variable H:not True. +Inductive I (n:nat) : Type := C : H=H -> I n. +Goal I 0. +red in H. +case 0. +Abort. +End B. diff --git a/test-suite/success/if.v b/test-suite/success/if.v new file mode 100644 index 0000000000..c81d2b9bf1 --- /dev/null +++ b/test-suite/success/if.v @@ -0,0 +1,12 @@ +(* The synthesis of the elimination predicate may fail if algebric *) +(* universes are not cautiously treated *) + +Check (fun b : bool => if b then Type else nat). + +(* Check correct use of if-then-else predicate annotation (cf BZ#690) *) + +Check fun b : bool => + if b as b0 return (if b0 then b0 = true else b0 = false) + then refl_equal true + else refl_equal false. + diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v new file mode 100644 index 0000000000..23853890d8 --- /dev/null +++ b/test-suite/success/implicit.v @@ -0,0 +1,126 @@ +(* Testing the behavior of implicit arguments *) + +(* Implicit on section variables *) + +Set Implicit Arguments. +Unset Strict Implicit. + +(* Example submitted by David Nowak *) + +Section Spec. +Variable A : Set. +Variable op : forall A : Set, A -> A -> Set. +Infix "#" := op (at level 70). +Check (forall x : A, x # x). + +(* Example submitted by Christine *) + +Record stack : Type := + {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}. + +Check + (forall (type : Set) (elt : type) (empty : type -> bool), + empty elt = true -> stack). + +(* Nested sections and manual/automatic implicit arguments *) + +Variable op' : forall A : Set, A -> A -> Set. +Variable op'' : forall A : Set, A -> A -> Set. + +Section B. + +Definition eq1 := fun (A:Type) (x y:A) => x=y. +Definition eq2 := fun (A:Type) (x y:A) => x=y. +Definition eq3 := fun (A:Type) (x y:A) => x=y. + +Arguments op' : clear implicits. +Global Arguments op'' : clear implicits. + +Arguments eq2 : clear implicits. +Global Arguments eq3 : clear implicits. + +Check (op 0 0). +Check (op' nat 0 0). +Check (op'' nat 0 0). +Check (eq1 0 0). +Check (eq2 nat 0 0). +Check (eq3 nat 0 0). + +End B. + +Check (op 0 0). +Check (op' 0 0). +Check (op'' nat 0 0). +Check (eq1 0 0). +Check (eq2 0 0). +Check (eq3 nat 0 0). + +End Spec. + +Check (eq1 0 0). +Check (eq2 0 0). +Check (eq3 nat 0 0). + +(* Example submitted by Frédéric (interesting in v8 syntax) *) + +Parameter f : nat -> nat * nat. +Notation lhs := fst. +Check (fun x => fst (f x)). +Check (fun x => fst (f x)). +Notation rhs := snd. +Check (fun x => snd (f x)). +Check (fun x => @ rhs _ _ (f x)). + +(* Implicit arguments in fixpoints and inductive declarations *) + +Fixpoint g n := match n with O => true | S n => g n end. + +Inductive P n : nat -> Prop := c : P n n. + +(* Avoid evars in the computation of implicit arguments (cf r9827) *) + +Require Import List. + +Fixpoint plus n m {struct n} := + match n with + | 0 => m + | S p => S (plus p m) + end. + +(* Check multiple implicit arguments signatures *) + +Arguments eq_refl {A x}, {A}. + +Check eq_refl : 0 = 0. + +(* Check that notations preserve implicit (since 8.3) *) + +Parameter p : forall A, A -> forall n, n = 0 -> True. +Arguments p [A] _ [n]. +Notation Q := (p 0). +Check Q eq_refl. + +(* Check implicits with Context *) + +Section C. +Context {A:Set}. +Definition h (a:A) := a. +End C. +Check h 0. + +(* Check implicit arguments in arity of inductive types. The three + following examples used to fail before r13671 *) + +Inductive I {A} (a:A) : forall {n:nat}, Prop := + | C : I a (n:=0). + +Inductive I2 (x:=0) : Prop := + | C2 {p:nat} : p = 0 -> I2. +Check C2 eq_refl. + +Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop := + | C3 : I3 a (n:=0). + +(* Check global implicit declaration over ref not in section *) + +Section D. Global Arguments eq [A] _ _. End D. diff --git a/test-suite/success/import_lib.v b/test-suite/success/import_lib.v new file mode 100644 index 0000000000..fcedb2b1ad --- /dev/null +++ b/test-suite/success/import_lib.v @@ -0,0 +1,202 @@ +Definition le_trans := 0. + + +Module Test_Read. + Module M. + Require Le. (* Reading without importing *) + + Check Le.le_trans. + + Lemma th0 : le_trans = 0. + reflexivity. + Qed. + End M. + + Check Le.le_trans. + + Lemma th0 : le_trans = 0. + reflexivity. + Qed. + + Import M. + + Lemma th1 : le_trans = 0. + reflexivity. + Qed. +End Test_Read. + + +(****************************************************************) + +Definition le_decide := 1. (* from Arith/Compare *) +Definition min := 0. (* from Arith/Min *) + +Module Test_Require. + + Module M. + Require Import Compare. (* Imports Min as well *) + + Lemma th1 : le_decide = le_decide. + reflexivity. + Qed. + + Lemma th2 : min = min. + reflexivity. + Qed. + + End M. + + (* Checks that Compare and List are loaded *) + Check Compare.le_decide. + Check Min.min. + + + (* Checks that Compare and List are _not_ imported *) + Lemma th1 : le_decide = 1. + reflexivity. + Qed. + + Lemma th2 : min = 0. + reflexivity. + Qed. + + (* It should still be the case after Import M *) + Import M. + + Lemma th3 : le_decide = 1. + reflexivity. + Qed. + + Lemma th4 : min = 0. + reflexivity. + Qed. + +End Test_Require. + +(****************************************************************) + +Module Test_Import. + Module M. + Import Compare. (* Imports Min as well *) + + Lemma th1 : le_decide = le_decide. + reflexivity. + Qed. + + Lemma th2 : min = min. + reflexivity. + Qed. + + End M. + + (* Checks that Compare and List are loaded *) + Check Compare.le_decide. + Check Min.min. + + + (* Checks that Compare and List are _not_ imported *) + Lemma th1 : le_decide = 1. + reflexivity. + Qed. + + Lemma th2 : min = 0. + reflexivity. + Qed. + + (* It should still be the case after Import M *) + Import M. + + Lemma th3 : le_decide = 1. + reflexivity. + Qed. + + Lemma th4 : min = 0. + reflexivity. + Qed. +End Test_Import. + +(************************************************************************) + +Module Test_Export. + Module M. + Export Compare. (* Exports Min as well *) + + Lemma th1 : le_decide = le_decide. + reflexivity. + Qed. + + Lemma th2 : min = min. + reflexivity. + Qed. + + End M. + + + (* Checks that Compare and List are _not_ imported *) + Lemma th1 : le_decide = 1. + reflexivity. + Qed. + + Lemma th2 : min = 0. + reflexivity. + Qed. + + + (* After Import M they should be imported as well *) + + Import M. + + Lemma th3 : le_decide = le_decide. + reflexivity. + Qed. + + Lemma th4 : min = min. + reflexivity. + Qed. +End Test_Export. + + +(************************************************************************) + +Module Test_Require_Export. + + Definition mult_sym := 1. (* from Arith/Mult *) + Definition plus_sym := 0. (* from Arith/Plus *) + + Module M. + Require Export Mult. (* Exports Plus as well *) + + Lemma th1 : mult_comm = mult_comm. + reflexivity. + Qed. + + Lemma th2 : plus_comm = plus_comm. + reflexivity. + Qed. + + End M. + + + (* Checks that Mult and Plus are _not_ imported *) + Lemma th1 : mult_sym = 1. + reflexivity. + Qed. + + Lemma th2 : plus_sym = 0. + reflexivity. + Qed. + + + (* After Import M they should be imported as well *) + + Import M. + + Lemma th3 : mult_comm = mult_comm. + reflexivity. + Qed. + + Lemma th4 : plus_comm = plus_comm. + reflexivity. + Qed. + +End Test_Require_Export. diff --git a/test-suite/success/import_mod.v b/test-suite/success/import_mod.v new file mode 100644 index 0000000000..c098c6e890 --- /dev/null +++ b/test-suite/success/import_mod.v @@ -0,0 +1,75 @@ + +Definition p := 0. +Definition m := 0. + +Module Test_Import. + Module P. + Definition p := 1. + End P. + + Module M. + Import P. + Definition m := p. + End M. + + Module N. + Import M. + + Lemma th0 : p = 0. + reflexivity. + Qed. + + End N. + + + (* M and P should be closed *) + Lemma th1 : m = 0 /\ p = 0. + split; reflexivity. + Qed. + + + Import N. + + (* M and P should still be closed *) + Lemma th2 : m = 0 /\ p = 0. + split; reflexivity. + Qed. +End Test_Import. + + +(********************************************************************) + + +Module Test_Export. + Module P. + Definition p := 1. + End P. + + Module M. + Export P. + Definition m := p. + End M. + + Module N. + Export M. + + Lemma th0 : p = 1. + reflexivity. + Qed. + + End N. + + + (* M and P should be closed *) + Lemma th1 : m = 0 /\ p = 0. + split; reflexivity. + Qed. + + + Import N. + + (* M and P should now be opened *) + Lemma th2 : m = 1 /\ p = 1. + split; reflexivity. + Qed. +End Test_Export. diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v new file mode 100644 index 0000000000..a962c29f44 --- /dev/null +++ b/test-suite/success/indelim.v @@ -0,0 +1,61 @@ +Inductive boolP : Prop := +| trueP : boolP +| falseP : boolP. + +Fail Check boolP_rect. + + +Inductive True : Prop := I : True. + +Inductive False : Prop :=. + +Inductive Empty_set : Set :=. + +Fail Inductive Large_set : Set := + large_constr : forall A : Set, A -> Large_set. + +Inductive smallunitProp : Prop := +| onlyProps : True -> smallunitProp. + +Check smallunitProp_rect. + +Inductive nonsmallunitProp : Prop := +| notonlyProps : nat -> nonsmallunitProp. + +Fail Check nonsmallunitProp_rect. +Set Printing Universes. +Inductive inferProp := +| hasonlyProps : True -> nonsmallunitProp -> inferProp. + +Check (inferProp : Prop). + +Inductive inferSet := +| hasaset : nat -> True -> nonsmallunitProp -> inferSet. + +Fail Check (inferSet : Prop). + +Check (inferSet : Set). + +Inductive inferLargeSet := +| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet. + +Fail Check (inferLargeSet : Set). + +Inductive largeProp : Prop := somelargeprop : Set -> largeProp. + + +Inductive comparison : Set := + | Eq : comparison + | Lt : comparison + | Gt : comparison. + +Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := + | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq + | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt + | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. + +Inductive color := Red | Black. + +Inductive option (A : Type) : Type := +| None : option A +| Some : A -> option A. diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v new file mode 100644 index 0000000000..92fd6cb17d --- /dev/null +++ b/test-suite/success/inds_type_sec.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Section S. +Inductive T (U : Type) : Type := + c : U -> T U. +End S. diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v new file mode 100644 index 0000000000..da7df69e62 --- /dev/null +++ b/test-suite/success/induct.v @@ -0,0 +1,198 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Test des definitions inductives imbriquees *) + +Require Import List. + +Inductive X : Set := + cons1 : list X -> X. + +Inductive Y : Set := + cons2 : list (Y * Y) -> Y. + +(* Test inductive types with local definitions *) + +Inductive eq1 : forall A:Type, let B:=A in A -> Prop := + refl1 : eq1 True I. + +Check + fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => + let B := A in + fun (a : A) (e : eq1 A a) => + match e in (eq1 A0 a0) return (P A0 a0) with + | refl1 => f + end. + +Inductive eq2 (A:Type) (a:A) + : forall B C:Type, let D:=(A*B*C)%type in D -> Prop := + refl2 : eq2 A a unit bool (a,tt,true). + +(* Check that induction variables are cleared even with in clause *) + +Lemma foo : forall n m : nat, n + m = n + m. +Proof. + intros; induction m as [|m] in n |- *. + auto. + auto. +Qed. + +(* Check selection of occurrences by pattern *) + +Goal forall x, S x = S (S x). +intros. +induction (S _) in |- * at -2. +now_show (0=1). +Undo 2. +induction (S _) in |- * at 1 3. +now_show (0=1). +Undo 2. +induction (S _) in |- * at 1. +now_show (0=S (S x)). +Undo 2. +induction (S _) in |- * at 2. +now_show (S x=0). +Undo 2. +induction (S _) in |- * at 3. +now_show (S x=1). +Undo 2. +Fail induction (S _) in |- * at 4. +Abort. + +(* Check use of "as" clause *) + +Inductive I := C : forall x, x<0 -> I -> I. + +Goal forall x:I, x=x. +intros. +induction x as [y * IHx]. +change (x = x) in IHx. (* We should have IHx:x=x *) +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros. +induction h. +2:change (n = h 1 -> n = h 2) in IHn. +Abort. + +(* This was not working in 8.4 *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H |- *. +Abort. + +(* "at" was not granted in 8.4 in the next two examples *) + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +induction h in H at 2, H0 at 1. +change (h 0 = 0) in H. +Abort. + +Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. +intros h H H0. +Fail induction h in H at 2 |- *. (* Incompatible occurrences *) +Abort. + +(* Check generalization with dependencies in section variables *) + +Section S3. +Variables x : nat. +Definition cond := x = x. +Goal cond -> x = 0. +intros H. +induction x as [|n IHn]. +2:change (n = 0) in IHn. (* We don't want a generalization over cond *) +Abort. +End S3. + +(* These examples show somehow arbitrary choices of generalization wrt + to indices, when those indices are not linear. We check here 8.4 + compatibility: when an index is a subterm of a parameter of the + inductive type, it is not generalized. *) + +Inductive repr (x:nat) : nat -> Prop := reprc z : repr x z -> repr x z. + +Goal forall x, 0 = x -> repr x x -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Goal forall x, 0 = S x -> repr (S x) (S x) -> True. +intros x H1 H. +induction H. +change True in IHrepr. +Abort. + +Inductive repr' (x:nat) : nat -> Prop := reprc' z : repr' x (S z) -> repr' x z. + +Goal forall x, 0 = x -> repr' x x -> True. +intros x H1 H. +induction H. +change True in IHrepr'. +Abort. + +(* In this case, generalization was done in 8.4 and we preserve it; this + is arbitrary choice *) + +Inductive repr'' : nat -> nat -> Prop := reprc'' x z : repr'' x z -> repr'' x z. + +Goal forall x, 0 = x -> repr'' x x -> True. +intros x H1 H. +induction H. +change (0 = z -> True) in IHrepr''. +Abort. + +(* Test double induction *) + +(* This was failing in 8.5 and before because of a bug in the order of + hypotheses *) + +Inductive I2 : Type := + C2 : forall x:nat, x=x -> I2. +Goal forall a b:I2, a = b. +double induction a b. +Abort. + +(* This was leaving useless hypotheses in 8.5 and before because of + the same bug. This is a change of compatibility. *) + +Inductive I3 : Prop := + C3 : forall x:nat, x=x -> I3. +Goal forall a b:I3, a = b. +double induction a b. +Fail clear H. (* H should have been erased *) +Abort. + +(* This one had quantification in reverse order in 8.5 and before *) +(* This is a change of compatibility. *) + +Goal forall m n, le m n -> le n m -> n=m. +intros m n. double induction 1 2. +3:destruct 1. (* Should be "S m0 <= m0" *) +Abort. + +(* Idem *) + +Goal forall m n p q, le m n -> le p q -> n+p=m+q. +intros *. double induction 1 2. +3:clear H2. (* H2 should have been erased *) +Abort. + +(* This is unchanged *) + +Goal forall m n:nat, n=m. +double induction m n. +Abort. + diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v new file mode 100644 index 0000000000..d37ad9f528 --- /dev/null +++ b/test-suite/success/intros.v @@ -0,0 +1,154 @@ +(* Thinning introduction hypothesis must be done after all introductions *) +(* Submitted by Guillaume Melquiond (BZ#1000) *) + +Goal forall A, A -> True. +intros _ _. +Abort. + +(* This did not work until March 2013, because of underlying "red" *) +Goal (fun x => True -> True) 0. +intro H. +Abort. + +(* This should still work, with "intro" calling "hnf" *) +Goal (fun f => True -> f 0 = f 0) (fun x => x). +intro H. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Somewhat related: This did not work until March 2013 *) +Goal (fun f => f 0 = f 0) (fun x => x). +hnf. +match goal with [ |- 0 = 0 ] => reflexivity end. +Abort. + +(* Fixing behavior of "*" and "**" in branches, so that they do not + introduce more than what the branch expects them to introduce at most *) +Goal forall n p, n + p = 0. +intros [|*]; intro p. +Abort. + +(* Check non-interference of "_" with name generation *) +Goal True -> True -> True. +intros _ ?. +exact H. +Qed. + +(* A short test about introduction pattern pat%c *) +Goal (True -> 0=0) -> True /\ False -> 0=0. +intros H (H1%H,_). +exact H1. +Qed. + +(* A test about bugs in 8.5beta2 *) +Goal (True -> 0=0) -> True /\ False -> False -> 0=0. +intros H H0 H1. +destruct H0 as (a%H,_). +(* Check that H0 is removed (was bugged in 8.5beta2) *) +Fail clear H0. +(* Check position of newly created hypotheses when using pat%c (was + left at top in 8.5beta2) *) +match goal with H:_ |- _ => clear H end. (* clear H1:False *) +match goal with H:_ |- _ => exact H end. (* check that next hyp shows 0=0 *) +Qed. + +Goal (True -> 0=0) -> True -> 0=0. +intros H H1%H. +exact H1. +Qed. + +Goal forall n, n = S n -> 0=0. +intros n H%n_Sn. +destruct H. +Qed. + +(* Another check about generated names and cleared hypotheses with + pat%c patterns *) +Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. +intros H (H1,?)%H. +change (1=1) in H0. +exact H1. +Qed. + +(* Checking iterated pat%c1...%cn introduction patterns and side conditions *) + +Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. +intros * H H0 H1. +intros H2%H%H0. +- exact H2. +- exact H1. +Qed. + +(* Bug found by Enrico *) + +Goal forall x : nat, True. +intros y%(fun x => x). +Abort. + +(* Fixing a bug in the order of side conditions of a "->" step *) + +Goal (True -> 1=0) -> 1=1. +intros ->. +- reflexivity. +- exact I. +Qed. + +Goal forall x, (True -> x=0) -> 0=x. +intros x ->. +- reflexivity. +- exact I. +Qed. + +(* Fixing a bug when destructing a type with let-ins in the constructor *) + +Inductive I := C : let x:=1 in x=1 -> I. +Goal I -> True. +intros [x H]. (* Was failing in 8.5 *) +Abort. + +(* Ensuring that the (pat1,...,patn) intropatterns has the expected size, up + to skipping let-ins *) + +Goal I -> 1=1. +intros (H). (* This skips x *) +exact H. +Qed. + +Goal I -> 1=1. +Fail intros (x,H,H'). +Fail intros [|]. +intros (x,H). +exact H. +Qed. + +Goal Acc le 0 -> True. +Fail induction 1 as (n,H). (* Induction hypothesis is missing *) +induction 1 as (n,H,IH). +exact Logic.I. +Qed. + +(* Make "intro"/"intros" progress on existential variables *) + +Module Evar. + +Goal exists (A:Prop), A. +eexists. +unshelve (intro x). +- exact nat. +- exact (x=x). +- auto. +Qed. + +Goal exists (A:Prop), A. +eexists. +unshelve (intros x). +- exact nat. +- exact (x=x). +- auto. +Qed. + +Definition d := ltac:(intro x; exact (x*x)). + +Definition d' : nat -> _ := ltac:(intros;exact 0). + +End Evar. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v new file mode 100644 index 0000000000..5638a7d3eb --- /dev/null +++ b/test-suite/success/keyedrewrite.v @@ -0,0 +1,62 @@ +Set Keyed Unification. + +Section foo. +Variable f : nat -> nat. + +Definition g := f. + +Variable lem : g 0 = 0. + +Goal f 0 = 0. +Proof. + Fail rewrite lem. +Abort. + +Declare Equivalent Keys @g @f. +(** Now f and g are considered equivalent heads for subterm selection *) +Goal f 0 = 0. +Proof. + rewrite lem. + reflexivity. +Qed. + +Print Equivalent Keys. +End foo. + +Require Import Arith List Omega. + +Definition G {A} (f : A -> A -> A) (x : A) := f x x. + +Lemma list_foo A (l : list A) : G (@app A) (l ++ nil) = G (@app A) l. +Proof. unfold G; rewrite app_nil_r; reflexivity. Qed. + +(* Bundled version of a magma *) +Structure magma := Magma { b_car :> Type; op : b_car -> b_car -> b_car }. +Arguments op {_} _ _. + +(* Instance for lists *) +Canonical Structure list_magma A := Magma (list A) (@app A). + +(* Basically like list_foo, but now uses the op projection instead of app for +the argument of G *) +Lemma test1 A (l : list A) : G op (l ++ nil) = G op l. + +(* Ensure that conversion of terms with evars is allowed once a keyed candidate unifier is found *) +rewrite -> list_foo. +reflexivity. +Qed. + +(* Basically like list_foo, but now uses the op projection for everything *) +Lemma test2 A (l : list A) : G op (op l nil) = G op l. +Proof. +rewrite ->list_foo. +reflexivity. +Qed. + + Require Import Bool. + Set Keyed Unification. + + Lemma test b : b && true = b. + Fail rewrite andb_true_l. + Admitted. + diff --git a/test-suite/success/letproj.v b/test-suite/success/letproj.v new file mode 100644 index 0000000000..2f0d8bf8c4 --- /dev/null +++ b/test-suite/success/letproj.v @@ -0,0 +1,11 @@ +Set Primitive Projections. +Set Nonrecursive Elimination Schemes. +Record Foo (A : Type) := { bar : A -> A; baz : A }. + +Definition test (A : Type) (f : Foo A) := + let (x, y) := f in x. + +Scheme foo_case := Case for Foo Sort Type. + +Definition test' (A : Type) (f : Foo A) := + let 'Build_Foo _ x y := f in x. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v new file mode 100644 index 0000000000..5d53fd2f09 --- /dev/null +++ b/test-suite/success/ltac.v @@ -0,0 +1,406 @@ +(* The tactic language *) + +(* Submitted by Pierre Crégut *) +(* Checks substitution of x *) +Ltac f x := unfold x; idtac. + +Lemma lem1 : 0 + 0 = 0. +f plus. +reflexivity. +Qed. + +(* Submitted by Pierre Crégut *) +(* Check syntactic correctness *) +Ltac F x := idtac; G x + with G y := idtac; F y. + +(* Check that Match Context keeps a closure *) +Ltac U := let a := constr:(I) in + match goal with + | |- _ => apply a + end. + +Lemma lem2 : True. +U. +Qed. + +(* Check that Match giving non-tactic arguments are evaluated at Let-time *) + +Ltac B := let y := (match goal with + | z:_ |- _ => z + end) in + (intro H1; exact y). + +Lemma lem3 : True -> False -> True -> False. +intros H H0. +B. (* y is H0 if at let-time, H1 otherwise *) +Qed. + +(* Checks the matching order of hypotheses *) +Ltac Y := match goal with + | x:_,y:_ |- _ => apply x + end. +Ltac Z := match goal with + | y:_,x:_ |- _ => apply x + end. + +Lemma lem4 : (True -> False) -> (False -> False) -> False. +intros H H0. +Z. (* Apply H0 *) +Y. (* Apply H *) +exact I. +Qed. + +(* Check backtracking *) +Lemma back1 : 0 = 1 -> 0 = 0 -> 1 = 1 -> 0 = 0. +intros; + match goal with + | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) + end. +Qed. + +Lemma back2 : 0 = 0 -> 0 = 1 -> 1 = 1 -> 0 = 0. +intros; + match goal with + | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) + end. +Qed. + +Lemma back3 : 0 = 0 -> 1 = 1 -> 0 = 1 -> 0 = 0. +intros; + match goal with + | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1) + end. +Qed. + +(* Check context binding *) +Ltac sym t := + match constr:(t) with + | context C[(?X1 = ?X2)] => context C [X1 = X2] + end. + +Lemma sym : 0 <> 1 -> 1 <> 0. +intro H. +let t := sym type of H in +assert t. +exact H. +intro H1. +apply H. +symmetry . +assumption. +Qed. + +(* Check context binding in match goal *) +(* This wasn't working in V8.0pl1, as the list of matched hyps wasn't empty *) +Ltac sym' := + match goal with + | _:True |- context C[(?X1 = ?X2)] => + let t := context C [X2 = X1] in + assert t + end. + +Lemma sym' : True -> 0 <> 1 -> 1 <> 0. +intros Ht H. +sym'. +exact H. +intro H1. +apply H. +symmetry . +assumption. +Qed. + +(* Check that fails abort the current match context *) +Lemma decide : True \/ False. +match goal with +| _ => fail 1 +| _ => right +end || left. +exact I. +Qed. + +(* Check that "match c with" backtracks on subterms *) +Lemma refl : 1 = 1. +let t := + (match constr:(1 = 2) with + | context [(S ?X1)] => constr:(refl_equal X1:1 = 1) + end) in +assert (H := t). +assumption. +Qed. + +(* Note that backtracking in "match c with" is only on type-checking not on +evaluation of tactics. E.g., this does not work + +Lemma refl : (1)=(1). +Match (1)=(2) With + [[(S ?1)]] -> Apply (refl_equal nat ?1). +Qed. +*) + + +(* Check the precedences of rel context, ltac context and vars context *) +(* (was wrong in V8.0) *) + +Ltac check_binding y := cut ((fun y => y) = S). +Goal True. +check_binding ipattern:(H). +Abort. + +(* Check that variables explicitly parsed as ltac variables are not + seen as intro pattern or constr (BZ#984) *) + +Ltac afi tac := intros; tac. +Goal 1 = 2. +afi ltac:(auto). +Abort. + +(* Tactic Notation avec listes *) + +Tactic Notation "pat" hyp(id) "occs" integer_list(l) := pattern id at l. + +Goal forall x, x=0 -> x=x. +intro x. +pat x occs 1 3. +Abort. + +Tactic Notation "revert" ne_hyp_list(l) := generalize l; clear l. + +Goal forall a b c, a=0 -> b=c+a. +intros. +revert a b c H. +Abort. + +(* Used to fail until revision 9280 because of a parasitic App node with + empty args *) + +Goal True. +match constr:(@None) with @None => exact I end. +Abort. + +(* Check second-order pattern unification *) + +Ltac to_exist := + match goal with + |- forall x y, @?P x y => + let Q := eval lazy beta in (exists x, forall y, P x y) in + assert (Q->Q) + end. + +Goal forall x y : nat, x = y. +to_exist. exact (fun H => H). +Abort. + +(* Used to fail in V8.1 *) + +Tactic Notation "test" constr(t) integer(n) := + set (k := t) at n. + +Goal forall x : nat, x = 1 -> x + x + x = 3. +intros x H. +test x 2. +Abort. + +(* Utilisation de let rec sans arguments *) + +Ltac is := + let rec i := match goal with |- ?A -> ?B => intro; i | _ => idtac end in + i. + +Goal True -> True -> True. +is. +exact I. +Abort. + +(* Interférence entre espaces des noms *) + +Ltac O := intro. +Ltac Z1 t := set (x:=t). +Ltac Z2 t := t. +Goal True -> True. +Z1 O. +Z2 ltac:(O). +exact I. +Qed. + +(* Illegal application used to make Ltac loop. *) + +Section LtacLoopTest. + Ltac g x := idtac. + Goal True. + Timeout 1 try g()(). + Abort. +End LtacLoopTest. + +(* Test binding of open terms *) + +Ltac test_open_match z := + match z with + (forall y x, ?h = 0) => assert (forall x y, h = x + y) + end. + +Goal True. +test_open_match (forall z y, y + z = 0). +reflexivity. +apply I. +Qed. + +(* Test binding of open terms with non linear matching *) + +Ltac f_non_linear t := + match t with + (forall x y, ?u = 0) -> (forall y x, ?u = 0) => + assert (forall x y:nat, u = u) + end. + +Goal True. +f_non_linear ((forall x y, x+y = 0) -> (forall x y, y+x = 0)). +reflexivity. +f_non_linear ((forall a b, a+b = 0) -> (forall a b, b+a = 0)). +reflexivity. +f_non_linear ((forall a b, a+b = 0) -> (forall x y, y+x = 0)). +reflexivity. +f_non_linear ((forall x y, x+y = 0) -> (forall a b, b+a = 0)). +reflexivity. +f_non_linear ((forall x y, x+y = 0) -> (forall y x, x+y = 0)). +reflexivity. +f_non_linear ((forall x y, x+y = 0) -> (forall y x, y+x = 0)) (* should fail *) +|| exact I. +Qed. + +(* Test regular failure when clear/intro breaks soundness of the + interpretation of terms in current environment *) + +Ltac g y := clear y; assert (y=y). +Goal forall x:nat, True. +intro x. +Fail g x. +Abort. + +Ltac h y := assert (y=y). +Goal forall x:nat, True. +intro x. +Fail clear x; f x. +Abort. + +(* Do not consider evars as unification holes in Ltac matching (and at + least not as holes unrelated to the original evars) + [Example adapted from Ynot code] + *) + +Ltac not_eq e1 e2 := + match e1 with + | e2 => fail 1 + | _ => idtac + end. + +Goal True. +evar(foo:nat). +let evval := eval compute in foo in not_eq evval 1. +let evval := eval compute in foo in not_eq 1 evval. +Abort. + +(* Check instantiation of binders using ltac names *) + +Goal True. +let x := ipattern:(y) in assert (forall x y, x = y + 0). +intro. +destruct y. (* Check that the name is y here *) +Abort. + +(* An example suggested by Jason (see #4317) showing the intended semantics *) +(* Order of binders is reverted because y is just told to depend on x *) + +Goal 1=1. +let T := constr:(fun a b : nat => a) in + lazymatch T with + | (fun x z => ?y) => pose ((fun x x => y) 2 1) + end. +exact (eq_refl n). +Qed. + +(* A variant of #2602 which was wrongly succeeding because "a", bound to + "?m", was then internally turned into a "_" in the second matching *) + +Goal exists m, S m > 0. +eexists. +Fail match goal with + | |- context [ S ?a ] => + match goal with + | |- S a > a => idtac + end +end. +Abort. + +(* Test evar syntax *) + +Goal True. +evar (0=0). +Abort. + +(* Test location of hypothesis in "symmetry in H". This was broken in + 8.6 where H, when the oldest hyp, was moved at the place of most + recent hypothesis *) + +Goal 0=1 -> True -> True. +intros H H0. +symmetry in H. +(* H should be the first hypothesis *) +match goal with h:_ |- _ => assert (h=h) end. (* h should be H0 *) +exact (eq_refl H0). +Abort. + +(* Check that internal names used in "match" compilation to push "term + to match" on the environment are not interpreted as ltac variables *) + +Module ToMatchNames. +Ltac g c := let r := constr:(match c return _ with a => 1 end) in idtac. +Goal True. +g 1. +Abort. +End ToMatchNames. + +(* An example where internal names used to build the return predicate + (here "n" because "a" is bound to "nil" and "n" is the first letter + of "nil") by small inversion should be taken distinct from Ltac names. *) + +Module LtacNames. +Inductive t (A : Type) : nat -> Type := + nil : t A 0 | cons : A -> forall n : nat, t A n -> t A (S n). + +Ltac f a n := + let x := constr:(match a with nil _ => true | cons _ _ _ _ => I end) in + assert (x=x/\n=n). + +Goal forall (y:t nat 0), True. +intros. +f y true. +Abort. + +End LtacNames. + +(* Test binding of the name of existential variables in Ltac *) + +Module EvarNames. + +Ltac pick x := eexists ?[x]. +Goal exists y, y = 0. +pick foo. +[foo]:exact 0. +auto. +Qed. + +Ltac goal x := refine ?[x]. + +Goal forall n, n + 0 = n. +Proof. + induction n; [ goal Base | goal Rec ]. + [Base]: { + easy. + } + [Rec]: { + simpl. + now f_equal. + } +Qed. + +End EvarNames. diff --git a/test-suite/success/ltac_match_pattern_names.v b/test-suite/success/ltac_match_pattern_names.v new file mode 100644 index 0000000000..790cd1b3a7 --- /dev/null +++ b/test-suite/success/ltac_match_pattern_names.v @@ -0,0 +1,28 @@ +(* example from bug 5345 *) +Ltac break_tuple := + match goal with + | [ H: context[let '(n, m) := ?a in _] |- _ ] => + let n := fresh n in + let m := fresh m in + destruct a as [n m] + end. + +(* desugared version of break_tuple *) +Ltac break_tuple' := + match goal with + | [ H: context[match ?a with | pair n m => _ end] |- _ ] => + let n := fresh n in + let m := fresh m in + idtac + end. + +Ltac multiple_branches := + match goal with + | [ H: match _ with + | left P => _ + | right Q => _ + end |- _ ] => + let P := fresh P in + let Q := fresh Q in + idtac + end. diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v new file mode 100644 index 0000000000..01d477bdf9 --- /dev/null +++ b/test-suite/success/ltac_plus.v @@ -0,0 +1,12 @@ +(** Checks that Ltac's '+' tactical works as intended. *) + +Goal forall (A B C D:Prop), (A->C) -> (B->C) -> (D->C) -> B -> C. +Proof. + intros A B C D h0 h1 h2 h3. + (* backtracking *) + (apply h0 + apply h1);apply h3. + Undo. + Fail ((apply h0+apply h2) || apply h1); apply h3. + (* interaction with || *) + ((apply h0+apply h1) || apply h2); apply h3. +Qed. diff --git a/test-suite/success/ltacprof.v b/test-suite/success/ltacprof.v new file mode 100644 index 0000000000..d5552695c4 --- /dev/null +++ b/test-suite/success/ltacprof.v @@ -0,0 +1,8 @@ +(** Some LtacProf tests *) + +Set Ltac Profiling. +Ltac multi := (idtac + idtac). +Goal True. + try (multi; fail). (* Used to result in: Anomaly: Uncaught exception Failure("hd"). Please report. *) +Admitted. +Show Ltac Profile. diff --git a/test-suite/success/module_with_def_univ_poly.v b/test-suite/success/module_with_def_univ_poly.v new file mode 100644 index 0000000000..a547be4c46 --- /dev/null +++ b/test-suite/success/module_with_def_univ_poly.v @@ -0,0 +1,31 @@ + +(* When doing Module Foo with Definition bar := ..., bar must be + generated with the same polymorphism as Foo.bar. *) +Module Mono. + Unset Universe Polymorphism. + Module Type T. + Parameter foo : Type. + End T. + + Module Type F(A:T). End F. + + Set Universe Polymorphism. + Module M : T with Definition foo := Type. + Monomorphic Definition foo := Type. + End M. +End Mono. + +Module Poly. + Set Universe Polymorphism. + + Module Type T. + Parameter foo@{i|Set < i} : Type@{i}. + End T. + + Module Type F(A:T). End F. + + Unset Universe Polymorphism. + Module M : T with Definition foo := Set : Type. + Polymorphic Definition foo := Set : Type. + End M. +End Poly. diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v new file mode 100644 index 0000000000..2c76a13597 --- /dev/null +++ b/test-suite/success/mutual_ind.v @@ -0,0 +1,44 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Definition mutuellement inductive et dependante *) + +Require Export List. + + Record signature : Type := + {sort : Set; + sort_beq : sort -> sort -> bool; + sort_beq_refl : forall f : sort, true = sort_beq f f; + sort_beq_eq : forall f1 f2 : sort, true = sort_beq f1 f2 -> f1 = f2; + fsym :> Set; + fsym_type : fsym -> list sort * sort; + fsym_beq : fsym -> fsym -> bool; + fsym_beq_refl : forall f : fsym, true = fsym_beq f f; + fsym_beq_eq : forall f1 f2 : fsym, true = fsym_beq f1 f2 -> f1 = f2}. + + + Variable F : signature. + + Definition vsym := (sort F * nat)%type. + + Definition vsym_sort := fst (A:=sort F) (B:=nat). + Definition vsym_nat := snd (A:=sort F) (B:=nat). + + + Inductive term : sort F -> Set := + | term_var : forall v : vsym, term (vsym_sort v) + | term_app : + forall f : F, + list_term (fst (fsym_type F f)) -> term (snd (fsym_type F f)) +with list_term : list (sort F) -> Set := + | term_nil : list_term nil + | term_cons : + forall (s : sort F) (l : list (sort F)), + term s -> list_term l -> list_term (s :: l). + diff --git a/test-suite/success/mutual_record.v b/test-suite/success/mutual_record.v new file mode 100644 index 0000000000..77529733be --- /dev/null +++ b/test-suite/success/mutual_record.v @@ -0,0 +1,57 @@ +Module M0. + +Inductive foo (A : Type) := Foo { + foo0 : option (bar A); + foo1 : nat; + foo2 := foo1 = 0; + foo3 : foo2; +} + +with bar (A : Type) := Bar { + bar0 : A; + bar1 := 0; + bar2 : bar1 = 0; + bar3 : nat -> foo A; +}. + +End M0. + +Module M1. + +Set Primitive Projections. + +Inductive foo (A : Type) := Foo { + foo0 : option (bar A); + foo1 : nat; + foo2 := foo1 = 0; + foo3 : foo2; +} + +with bar (A : Type) := Bar { + bar0 : A; + bar1 := 0; + bar2 : bar1 = 0; + bar3 : nat -> foo A; +}. + +End M1. + +Module M2. + +Set Primitive Projections. + +CoInductive foo (A : Type) := Foo { + foo0 : option (bar A); + foo1 : nat; + foo2 := foo1 = 0; + foo3 : foo2; +} + +with bar (A : Type) := Bar { + bar0 : A; + bar1 := 0; + bar2 : bar1 = 0; + bar3 : nat -> foo A; +}. + +End M2. diff --git a/test-suite/success/name_mangling.v b/test-suite/success/name_mangling.v new file mode 100644 index 0000000000..e982414206 --- /dev/null +++ b/test-suite/success/name_mangling.v @@ -0,0 +1,191 @@ +(* -*- coq-prog-args: ("-mangle-names" "_") -*- *) + +(* Check that refine policy of redefining previous names make these names private *) +(* abstract can change names in the environment! See bug #3146 *) + +Goal True -> True. +intro. +Fail exact H. +exact _0. +Abort. + +Unset Mangle Names. +Goal True -> True. +intro; exact H. +Abort. + +Set Mangle Names. +Set Mangle Names Prefix "baz". +Goal True -> True. +intro. +Fail exact H. +Fail exact _0. +exact baz0. +Abort. + +Goal True -> True. +intro; assumption. +Abort. + +Goal True -> True. +intro x; exact x. +Abort. + +Goal forall x y, x+y=0. +intro x. +refine (fun x => _). +Fail Check x0. +Check x. +Abort. + +(* Example from Emilio *) + +Goal forall b : False, b = b. +intro b. +refine (let b := I in _). +Fail destruct b0. +Abort. + +(* Example from Cyprien *) + +Goal True -> True. +Proof. + refine (fun _ => _). + Fail exact t. +Abort. + +(* Example from Jason *) + +Goal False -> False. +intro H. +Fail abstract exact H. +Abort. + +(* Variant *) + +Goal False -> False. +intro. +Fail abstract exact H. +Abort. + +(* Example from Jason *) + +Goal False -> False. +intro H. +(* Name H' is from Ltac here, so it preserves the privacy *) +(* But abstract messes everything up *) +Fail let H' := H in abstract exact H'. +let H' := H in exact H'. +Qed. + +(* Variant *) + +Goal False -> False. +intro. +Fail let H' := H in abstract exact H'. +Abort. + +(* Indirectly testing preservation of names by move (derived from Jason) *) + +Inductive nat2 := S2 (_ _ : nat2). +Goal forall t : nat2, True. + intro t. + let IHt1 := fresh "IHt1" in + let IHt2 := fresh "IHt2" in + induction t as [? IHt1 ? IHt2]. + Fail exact IHt1. +Abort. + +(* Example on "pose proof" (from Jason) *) + +Goal False -> False. +intro; pose proof I as H0. +Fail exact H. +Abort. + +(* Testing the approach for which non alpha-renamed quantified names are user-generated *) + +Section foo. +Context (b : True). +Goal forall b : False, b = b. +Fail destruct b0. +Abort. + +Goal forall b : False, b = b. +now destruct b. +Qed. +End foo. + +(* Test stability of "fix" *) + +Lemma a : forall n, n = 0. +Proof. +fix a 1. +Check a. +Fail fix a 1. +Abort. + +(* Test stability of "induction" *) + +Lemma a : forall n : nat, n = n. +Proof. +intro n; induction n as [ | n IHn ]. +- auto. +- Check n. + Check IHn. +Abort. + +Inductive I := C : I -> I -> I. + +Lemma a : forall n : I, n = n. +Proof. +intro n; induction n as [ n1 IHn1 n2 IHn2 ]. +Check n1. +Check n2. +apply f_equal2. ++ apply IHn1. ++ apply IHn2. +Qed. + +(* Testing remember *) + +Lemma c : 0 = 0. +Proof. +remember 0 as x eqn:Heqx. +Check Heqx. +Abort. + +Lemma c : forall Heqx, Heqx -> 0 = 0. +Proof. +intros Heqx X. +remember 0 as x. +Fail Check Heqx0. (* Heqx0 is not canonical *) +Abort. + +(* An example by Jason from the discussion for PR #268 *) + +Goal nat -> Set -> True. + intros x y. + match goal with + | [ x : _, y : _ |- _ ] + => let z := fresh "z" in + rename y into z, x into y; + let x' := fresh "x" in + rename z into x' + end. + revert y. (* x has been explicitly moved to y *) + Fail revert x. (* x comes from "fresh" *) +Abort. + +Goal nat -> Set -> True. + intros. + match goal with + | [ x : _, y : _ |- _ ] + => let z := fresh "z" in + rename y into z, x into y; + let x' := fresh "x" in + rename z into x' + end. + Fail revert y. (* generated by intros *) + Fail revert x. (* generated by intros *) +Abort. diff --git a/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v new file mode 100644 index 0000000000..f9154ef576 --- /dev/null +++ b/test-suite/success/namedunivs.v @@ -0,0 +1,104 @@ +(* Inductive paths {A} (x : A) : A -> Type := idpath : paths x x where "x = y" := (@paths _ x y) : type_scope. *) +(* Goal forall A B : Set, @paths Type A B -> @paths Set A B. *) +(* intros A B H. *) +(* Fail exact H. *) +(* Section . *) + +Unset Strict Universe Declaration. + +Section lift_strict. +Polymorphic Definition liftlt := + let t := Type@{i} : Type@{k} in + fun A : Type@{i} => A : Type@{k}. + +Polymorphic Definition liftle := + fun A : Type@{i} => A : Type@{k}. +End lift_strict. + + +Set Universe Polymorphism. + +(* Inductive option (A : Type) : Type := *) +(* | None : option A *) +(* | Some : A -> option A. *) + +Inductive option (A : Type@{i}) : Type@{i} := + | None : option A + | Some : A -> option A. + +Definition foo' {A : Type@{i}} (o : option@{i} A) : option@{i} A := + o. + +Definition foo'' {A : Type@{i}} (o : option@{j} A) : option@{k} A := + o. + + +Definition testm (A : Type@{i}) : Type@{max(i,j)} := A. + +(* Inductive prod (A : Type@{i}) (B : Type@{j}) := *) +(* | pair : A -> B -> prod A B. *) + +(* Definition snd {A : Type@{i}} (B : Type@{j}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Definition snd' {A : Type@{i}} (B : Type@{i}) (p : prod A B) : B := *) +(* match p with *) +(* | pair _ _ a b => b *) +(* end. *) + +(* Inductive paths {A : Type} : A -> A -> Type := *) +(* | idpath (a : A) : paths a a. *) + +Inductive paths {A : Type@{i}} : A -> A -> Type@{i} := +| idpath (a : A) : paths a a. + +Definition Funext := + forall (A : Type) (B : A -> Type), + forall f g : (forall a, B a), (forall x : A, paths (f x) (g x)) -> paths f g. + +Definition paths_lift_closed (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftle@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift (A : Type@{i}) (x y : A) : + paths x y -> paths@{j} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_lift_closed_strict (A : Type@{i}) (x y : A) : + paths x y -> @paths (liftlt@{j Type} A) x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_le (A : Type@{i}) (x y : A) : + paths@{j} (A:=liftle@{i j} A) x y -> paths@{i} x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt (A : Type@{i}) (x y : A) : + @paths (liftlt@{j i} A) x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition paths_downward_closed_lt_nolift (A : Type@{i}) (x y : A) : + paths@{j} x y -> paths x y. +Proof. + intros. destruct X. exact (idpath _). +Defined. + +Definition funext_downward_closed (F : Funext@{i' j' k'}) : + Funext@{i j k}. +Proof. + intros A B f g H. red in F. + pose (F A B f g (fun x => paths_lift _ _ _ (H x))). + apply paths_downward_closed_lt_nolift. apply p. +Defined. + diff --git a/test-suite/success/onlyprinting.v b/test-suite/success/onlyprinting.v new file mode 100644 index 0000000000..91a628d792 --- /dev/null +++ b/test-suite/success/onlyprinting.v @@ -0,0 +1,7 @@ +Notation "x ++ y" := (plus x y) (only printing). + +Fail Check 0 ++ 0. + +Notation "x + y" := (max x y) (only printing). + +Check (eq_refl : 42 + 18 = 60). diff --git a/test-suite/success/options.v b/test-suite/success/options.v new file mode 100644 index 0000000000..f43a469405 --- /dev/null +++ b/test-suite/success/options.v @@ -0,0 +1,36 @@ +(* Check that the syntax for options works *) +Set Implicit Arguments. +Unset Strict Implicit. +Set Strict Implicit. +Unset Implicit Arguments. +Test Implicit Arguments. + +Set Printing Coercions. +Unset Printing Coercions. +Test Printing Coercions. + +Set Silent. +Unset Silent. +Test Silent. + +Set Printing Depth 100. +Test Printing Depth. + +Parameter i : bool -> nat. +Coercion i : bool >-> nat. +Add Printing Coercion i. +Remove Printing Coercion i. +Test Printing Coercion for i. + +Test Printing Let. +Test Printing If. +Remove Printing Let sig. +Remove Printing If bool. + +Unset Printing Synth. +Set Printing Synth. +Test Printing Synth. + +Unset Printing Wildcard. +Set Printing Wildcard. +Test Printing Wildcard. diff --git a/test-suite/success/par_abstract.v b/test-suite/success/par_abstract.v new file mode 100644 index 0000000000..7f6f9d6279 --- /dev/null +++ b/test-suite/success/par_abstract.v @@ -0,0 +1,25 @@ +Axiom T : Type. + +Lemma foo : True * Type. +Proof. + split. + par: abstract (exact I || exact T). +Defined. + +(* Yes, these names are generated hence + the test is fragile. I want to assert + that abstract was correctly handled + by par: *) +Check foo_subproof. +Check foo_subproof0. +Check (refl_equal _ : + foo = + pair foo_subproof foo_subproof0). + +Lemma bar : True * Type. +Proof. + split. + par: (exact I || exact T). +Defined. +Check (refl_equal _ : + bar = pair I T). diff --git a/test-suite/success/paralleltac.v b/test-suite/success/paralleltac.v new file mode 100644 index 0000000000..d25fd32a13 --- /dev/null +++ b/test-suite/success/paralleltac.v @@ -0,0 +1,60 @@ +Lemma test_nofail_like_all1 : + True /\ False. +Proof. +split. +all: trivial. +Admitted. + +Lemma test_nofail_like_all2 : + True /\ False. +Proof. +split. +par: trivial. +Admitted. + +Fixpoint fib n := match n with + | O => 1 + | S m => match m with + | O => 1 + | S o => fib o + fib m end end. +Ltac sleep n := + try (assert (fib n = S (fib n)) by reflexivity). +(* Tune that depending on your PC *) +Let time := 18. + +Axiom P : nat -> Prop. +Axiom P_triv : Type -> forall x, P x. +Ltac solve_P := + match goal with |- P (S ?X) => + sleep time; exact (P_triv Type _) + end. + +Lemma test_old x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T1: linear". +Time all: solve [solve_P]. +Qed. + +Lemma test_ok x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T2: parallel". +Time par: solve [solve_P]. +Qed. + +Lemma test_fail x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T3: linear failure". +Fail Time all: solve solve_P. +all: solve [apply (P_triv Type)]. +Qed. + +Lemma test_fail2 x : P (S x) /\ P x /\ P (S x) /\ P (S x). +Proof. +repeat split. +idtac "T4: parallel failure". +Fail Time par: solve [solve_P]. +all: solve [apply (P_triv Type)]. +Qed. diff --git a/test-suite/success/parsing.v b/test-suite/success/parsing.v new file mode 100644 index 0000000000..3d06d1d0f9 --- /dev/null +++ b/test-suite/success/parsing.v @@ -0,0 +1,8 @@ +Section A. +Notation "*" := O (at level 8). +Notation "**" := O (at level 99). +Notation "***" := O (at level 9). +End A. +Notation "*" := O (at level 8). +Notation "**" := O (at level 99). +Notation "***" := O (at level 9). diff --git a/test-suite/success/pattern.v b/test-suite/success/pattern.v new file mode 100644 index 0000000000..72f84052d7 --- /dev/null +++ b/test-suite/success/pattern.v @@ -0,0 +1,49 @@ +(* Test pattern with dependent occurrences; Note that it does not + behave as the succession of three generalize because each + quantification introduces new occurrences that are automatically + abstracted with the numbering still based on the original statement *) + +Goal (id true,id false)=(id true,id true). +generalize bool at 2 4 6 8 10 as B, true at 3 as tt, false as ff. +Abort. + +(* Check use of occurrences in hypotheses for a reduction tactic such + as pattern *) + +(* Did not work in 8.2 *) +Goal 0=0->True. +intro H. +pattern 0 in H at 2. +set (f n := 0 = n) in H. (* check pattern worked correctly *) +Abort. + +(* Syntactic variant which was working in 8.2 *) +Goal 0=0->True. +intro H. +pattern 0 at 2 in H. +set (f n := 0 = n) in H. (* check pattern worked correctly *) +Abort. + +(* Ambiguous occurrence selection *) +Goal 0=0->True. +intro H. +pattern 0 at 1 in H at 2 || exact I. (* check pattern fails *) +Qed. + +(* Ambiguous occurrence selection *) +Goal 0=1->True. +intro H. +pattern 0, 1 in H at 1 2 || exact I. (* check pattern fails *) +Qed. + +(* Occurrence selection shared over hypotheses is difficult to advocate and + hence no longer allowed *) +Goal 0=1->1=0->True. +intros H1 H2. +pattern 0 at 1, 1 in H1, H2 || exact I. (* check pattern fails *) +Qed. + +(* Test catching of reduction tactics errors (was not the case in 8.2) *) +Goal eq_refl 0 = eq_refl 0. +pattern 0 at 1 || reflexivity. +Qed. diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v new file mode 100644 index 0000000000..339f798240 --- /dev/null +++ b/test-suite/success/polymorphism.v @@ -0,0 +1,464 @@ +Unset Strict Universe Declaration. + +Module withoutpoly. + +Inductive empty :=. + +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. +End withoutpoly. + +Set Universe Polymorphism. + +Inductive empty :=. +Inductive emptyt : Type :=. +Inductive singleton : Type := + single. +Inductive singletoninfo : Type := + singleinfo : unit -> singletoninfo. +Inductive singletonset : Set := + singleset. + +Inductive singletonnoninfo : Type := + singlenoninfo : empty -> singletonnoninfo. + +Inductive singletoninfononinfo : Prop := + singleinfononinfo : unit -> singletoninfononinfo. + +Inductive bool : Type := + | true | false. + +Inductive smashedbool : Prop := + | trueP | falseP. + +Section foo. + Let T := Type. + Inductive polybool : T := + | trueT | falseT. +End foo. + +Inductive list (A: Type) : Type := +| nil : list A +| cons : A -> list A -> list A. + +Module ftypSetSet. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. +End ftypSetSet. + + +Module ftypSetProp. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : (* ftyp -> *)area +. +End ftypSetProp. + +Module ftypSetSetForced. +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Set (* Type *) := + | Stored : (* ftyp -> *)area +. +End ftypSetSetForced. + +Unset Universe Polymorphism. + +Set Printing Universes. +Module Easy. + + Polymorphic Inductive prod (A : Type) (B : Type) : Type := + pair : A -> B -> prod A B. + + Check prod nat nat. + Print Universes. + + + Polymorphic Inductive sum (A B:Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. + Print sum. + Check (sum nat nat). + +End Easy. + +Section Hierarchy. + +Definition Type3 := Type. +Definition Type2 := Type : Type3. +Definition Type1 := Type : Type2. + +Definition id1 := ((forall A : Type1, A) : Type2). +Definition id2 := ((forall A : Type2, A) : Type3). +Definition id1' := ((forall A : Type1, A) : Type3). +Fail Definition id1impred := ((forall A : Type1, A) : Type1). + +End Hierarchy. + +Section structures. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}. + +Polymorphic Record dyn : Type := + mkdyn { + dyn_type : Type; + dyn_proof : dyn_type + }. + +Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}. +Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}. + +Definition atypedyn : dyn := typedyn Type. + +Definition projdyn := dyn_type atypedyn. + +Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}. + +Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}. + +Definition projnested2 := dyn_type nested2. + +Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}. + +Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. + +End structures. + + +Module binders. + + Definition mynat@{|} := nat. + + Definition foo@{i j | i < j, i < j} (A : Type@{i}) : Type@{j}. + exact A. + Defined. + + Polymorphic Lemma hidden_strict_type : Type. + Proof. + exact Type. + Qed. + Check hidden_strict_type@{_}. + Fail Check hidden_strict_type@{Set}. + + Fail Definition morec@{i j|} (A : Type@{i}) : Type@{j} := A. + + (* By default constraints are extensible *) + Polymorphic Definition morec@{i j} (A : Type@{i}) : Type@{j} := A. + Check morec@{_ _}. + + (* Handled in proofs as well *) + Lemma bar@{i j | } : Type@{i}. + exact Type@{j}. + Fail Defined. + Abort. + + Fail Lemma bar@{u v | } : let x := (fun x => x) : Type@{u} -> Type@{v} in nat. + + Lemma bar@{i j| i < j} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + + Lemma barext@{i j|+} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + + Monomorphic Universe M. + Fail Definition with_mono@{u|} : Type@{M} := Type@{u}. + Definition with_mono@{u|u < M} : Type@{M} := Type@{u}. + +End binders. + +Section cats. + Local Set Universe Polymorphism. + Require Import Utf8. + Definition fibration (A : Type) := A -> Type. + Definition Hom (A : Type) := A -> A -> Type. + + Record sigma (A : Type) (P : fibration A) := + { proj1 : A; proj2 : P proj1} . + + Class Identity {A} (M : Hom A) := + identity : ∀ x, M x x. + + Class Inverse {A} (M : Hom A) := + inverse : ∀ x y:A, M x y -> M y x. + + Class Composition {A} (M : Hom A) := + composition : ∀ {x y z:A}, M x y -> M y z -> M x z. + + Notation "g ° f" := (composition f g) (at level 50). + + Class Equivalence T (Eq : Hom T):= + { + Equivalence_Identity :> Identity Eq ; + Equivalence_Inverse :> Inverse Eq ; + Equivalence_Composition :> Composition Eq + }. + + Class EquivalenceType (T : Type) : Type := + { + m2: Hom T; + equiv_struct :> Equivalence T m2 }. + + Polymorphic Record cat (T : Type) := + { cat_hom : Hom T; + cat_equiv : forall x y, EquivalenceType (cat_hom x y) }. + + Definition catType := sigma Type cat. + + Notation "[ T ]" := (proj1 T). + + Require Import Program. + + Program Definition small_cat : cat Empty_set := + {| cat_hom x y := unit |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record iso (T U : Set) := + { f : T -> U; + g : U -> T }. + + Program Definition Set_cat : cat Set := + {| cat_hom := iso |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Record isoT (T U : Type) := + { isoT_f : T -> U; + isoT_g : U -> T }. + + Program Definition Type_cat : cat Type := + {| cat_hom := isoT |}. + Next Obligation. + refine ({|m2:=fun x y => True|}). + constructor; red; intros; trivial. + Defined. + + Polymorphic Record cat1 (T : Type) := + { cat1_car : Type; + cat1_hom : Hom cat1_car; + cat1_hom_cat : forall x y, cat (cat1_hom x y) }. +End cats. + +Polymorphic Definition id {A : Type} (a : A) : A := a. + +Definition typeid := (@id Type). + + +Fail Check (Prop : Set). +Fail Check (Set : Set). +Check (Set : Type). +Check (Prop : Type). +Definition setType := ltac:(let t := type of Set in exact t). + +Definition foo (A : Prop) := A. + +Fail Check foo Set. +Check fun A => foo A. +Fail Check fun A : Type => foo A. +Check fun A : Prop => foo A. +Fail Definition bar := fun A : Set => foo A. + +Fail Check (let A := Type in foo (id A)). + +Definition fooS (A : Set) := A. + +Check (let A := nat in fooS (id A)). +Fail Check (let A := Set in fooS (id A)). +Fail Check (let A := Prop in fooS (id A)). + +(* Some tests of sort-polymorphisme *) +Section S. +Polymorphic Variable A:Type. +(* +Definition f (B:Type) := (A * B)%type. +*) +Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B. + +Check I nat. + +End S. +(* +Check f nat nat : Set. +*) +Definition foo' := I nat nat. +Print Universes. Print foo. Set Printing Universes. Print foo. + +(* Polymorphic axioms: *) +Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), + (forall x, f x = g x) -> f = g. + +(* Check @funext. *) +(* Check funext. *) + +Polymorphic Definition fun_ext (A B : Type) := + forall (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Polymorphic Class Funext A B := extensional : fun_ext A B. + +Section foo2. + Context `{forall A B, Funext A B}. + Print Universes. +End foo2. + +Module eta. +Set Universe Polymorphism. + +Set Printing Universes. + +Axiom admit : forall A, A. +Record R := {O : Type}. + +Definition RL (x : R@{i}) : ltac:(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) ) := {|O := @O x|}. +Definition RLRL : forall x : R, RL x = RL (RL x) := fun x => eq_refl. +Definition RLRL' : forall x : R, RL x = RL (RL x). + intros. apply eq_refl. +Qed. + +End eta. + +Module Hurkens'. + Require Import Hurkens. + +Polymorphic Record box (X : Type) (T := Type) : Type := wrap { unwrap : T }. + +Definition unwrap' := fun (X : Type) (b : box X) => let (unw) := b in unw. + +Fail Definition bad : False := TypeNeqSmallType.paradox (unwrap' Type (wrap _ +Type)) eq_refl. + +End Hurkens'. + +Module Anonymous. + Set Universe Polymorphism. + + Definition defaultid := (fun x => x) : Type -> Type. + Definition collapseid := defaultid@{_ _}. + Check collapseid@{_}. + + Definition anonid := (fun x => x) : Type -> Type@{_}. + Check anonid@{_}. + + Definition defaultalg := (fun x : Type => x) (Type : Type). + Definition usedefaultalg := defaultalg@{_ _ _}. + Check usedefaultalg@{_ _}. + + Definition anonalg := (fun x : Type@{_} => x) (Type : Type). + Check anonalg@{_ _}. + + Definition unrelated@{i j} := nat. + Definition useunrelated := unrelated@{_ _}. + Check useunrelated@{_ _}. + + Definition inthemiddle@{i j k} := + let _ := defaultid@{i j} in + anonalg@{k j}. + (* i <= j < k *) + Definition collapsethemiddle := inthemiddle@{i _ j}. + Check collapsethemiddle@{_ _}. + +End Anonymous. + +Module Restrict. + (* Universes which don't appear in the term should be pruned, unless they have names *) + Set Universe Polymorphism. + + Ltac exact0 := let x := constr:(Type) in exact 0. + Definition dummy_pruned@{} : nat := ltac:(exact0). + + Definition named_not_pruned@{u} : nat := 0. + Check named_not_pruned@{_}. + + Definition named_not_pruned_nonstrict : nat := ltac:(let x := constr:(Type@{u}) in exact 0). + Check named_not_pruned_nonstrict@{_}. + + Lemma lemma_restrict_poly@{} : nat. + Proof. exact0. Defined. + + Unset Universe Polymorphism. + Lemma lemma_restrict_mono_qed@{} : nat. + Proof. exact0. Qed. + + Lemma lemma_restrict_abstract@{} : nat. + Proof. abstract exact0. Qed. + +End Restrict. + +Module F. + Context {A B : Type}. + Definition foo : Type := B. +End F. + +Set Universe Polymorphism. + +Cumulative Record box (X : Type) (T := Type) : Type := wrap { unwrap : T }. + +Section test_letin_subtyping. + Universe i j k i' j' k'. + Constraint j < j'. + + Context (W : Type) (X : box@{i j k} W). + Definition Y := X : box@{i' j' k'} W. + + Universe i1 j1 k1 i2 j2 k2. + Constraint i1 < i2. + Constraint k2 < k1. + Context (V : Type). + + Definition Z : box@{i1 j1 k1} V := {| unwrap := V |}. + Definition Z' : box@{i2 j2 k2} V := {| unwrap := V |}. + Lemma ZZ' : @eq (box@{i2 j2 k2} V) Z Z'. + Proof. + Set Printing All. Set Printing Universes. + cbv. + reflexivity. + Qed. + +End test_letin_subtyping. + +Module ObligationRegression. + (** Test for a regression encountered when fixing obligations for + stronger restriction of universe context. *) + Require Import CMorphisms. + Check trans_co_eq_inv_arrow_morphism@{_ _ _ _ _ _ _ _}. +End ObligationRegression. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v new file mode 100644 index 0000000000..299b08bdd1 --- /dev/null +++ b/test-suite/success/primitiveproj.v @@ -0,0 +1,229 @@ +Set Primitive Projections. +Set Nonrecursive Elimination Schemes. +Module Prim. + +Record F := { a : nat; b : a = a }. +Record G (A : Type) := { c : A; d : F }. + +Check c. +End Prim. +Module Univ. +Set Universe Polymorphism. +Set Implicit Arguments. +Record Foo (A : Type) := { foo : A }. + +Record G (A : Type) := { c : A; d : c = c; e : Foo A }. + +Definition Foon : Foo nat := {| foo := 0 |}. + +Definition Foonp : nat := Foon.(foo). + +Definition Gt : G nat := {| c:= 0; d:=eq_refl; e:= Foon |}. + +Check (Gt.(e)). + +Section bla. + + Record bar := { baz : nat; def := 0; baz' : forall x, x = baz \/ x = def }. +End bla. + +End Univ. + +Set Primitive Projections. +Unset Elimination Schemes. +Set Implicit Arguments. + +Check nat. + +Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. + +Parameter x:X nat. +Check (a x : forall _ : @eq nat (k x) (k x), X nat). +Check (b x : X nat). + +Inductive Y := { next : option Y }. + +Check _.(next) : option Y. +Lemma eta_ind (y : Y) : y = Build_Y y.(next). +Proof. Fail reflexivity. Abort. + +Inductive Fdef := { Fa : nat ; Fb := Fa; Fc : Fdef }. + +Fail Scheme Fdef_rec := Induction for Fdef Sort Prop. + +(* + Rules for parsing and printing of primitive projections and their eta expansions. + If r : R A where R is a primitive record with implicit parameter A. + If p : forall {A} (r : R A) {A : Set}, list (A * B). +*) + +Record R {A : Type} := { p : forall {X : Set}, A * X }. +Arguments R : clear implicits. + +Record R' {A : Type} := { p' : forall X : Set, A * X }. +Arguments R' : clear implicits. + +Unset Printing All. + +Parameter r : R nat. + +Check (r.(p)). +Set Printing Projections. +Check (r.(p)). +Unset Printing Projections. +Set Printing All. +Check (r.(p)). +Unset Printing All. + +(* Check (r.(p)). + Elaborates to a primitive application, X arg implicit. + Of type nat * ?ex + No Printing All: p r + Set Printing Projections.: r.(p) + Printing All: r.(@p) ?ex + *) + +Check p r. +Set Printing Projections. +Check p r. +Unset Printing Projections. +Set Printing All. +Check p r. +Unset Printing All. + +Check p r (X:=nat). +Set Printing Projections. +Check p r (X:=nat). +Unset Printing Projections. +Set Printing All. +Check p r (X:=nat). +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r.(@p _). +Set Printing Projections. +Check r.(@p _). +Unset Printing Projections. +Set Printing All. +Check r.(@p _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed using application notation r.(p), r.(@p) in fully explicit form *) +Check r.(@p _) nat. +Set Printing Projections. +Check r.(@p _) nat. +Unset Printing Projections. +Set Printing All. +Check r.(@p _) nat. +Unset Printing All. + +Parameter r' : R' nat. + +Check (r'.(p')). +Set Printing Projections. +Check (r'.(p')). +Unset Printing Projections. +Set Printing All. +Check (r'.(p')). +Unset Printing All. + +(* Check (r'.(p')). + Elaborates to a primitive application, X arg explicit. + Of type forall X : Set, nat * X + No Printing All: p' r' + Set Printing Projections.: r'.(p') + Printing All: r'.(@p') + *) + +Check p' r'. +Set Printing Projections. +Check p' r'. +Unset Printing Projections. +Set Printing All. +Check p' r'. +Unset Printing All. + +(* Same elaboration, printing for p r *) + +(** Explicit version of the primitive projection, under applied w.r.t implicit arguments + can be printed only using projection notation. r.(@p) *) +Check r'.(@p' _). +Set Printing Projections. +Check r'.(@p' _). +Unset Printing Projections. +Set Printing All. +Check r'.(@p' _). +Unset Printing All. + +(** Explicit version of the primitive projection, applied to its implicit arguments + can be printed only using projection notation r.(p), r.(@p) in fully explicit form *) +Check p' r' nat. +Set Printing Projections. +Check p' r' nat. +Unset Printing Projections. +Set Printing All. +Check p' r' nat. +Unset Printing All. + +Check (@p' nat). +Check p'. +Set Printing All. + +Check (@p' nat). +Check p'. +Unset Printing All. + +Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. + +Definition term (x : wrap nat) := x.(unwrap). +Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. + +Require Coq.extraction.Extraction. +Recursive Extraction term term'. +Extraction TestCompile term term'. +(*Unset Printing Primitive Projection Parameters.*) + +(* Primitive projections in the presence of let-ins (was not failing in beta3)*) + +Set Primitive Projections. +Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. +Lemma f : 0=1. +Proof. + Fail apply d. +(* +split. +reflexivity. +Qed. +*) +Abort. + +(* Primitive projection match compilation *) +Require Import List. +Set Primitive Projections. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments pair {_ _} _ _. + +Fixpoint split_at {A} (l : list A) (n : nat) : prod (list A) (list A) := + match n with + | 0 => pair nil l + | S n => + match l with + | nil => pair nil nil + | x :: l => let 'pair l1 l2 := split_at l n in pair (x :: l1) l2 + end + end. + +Time Eval vm_compute in split_at (repeat 0 20) 10. (* Takes 0s *) +Time Eval vm_compute in split_at (repeat 0 40) 20. (* Takes 0.001s *) +Timeout 1 Time Eval vm_compute in split_at (repeat 0 60) 30. (* Used to take 60s, now takes 0.001s *) + +Check (@eq_refl _ 0 <: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <: 0 = snd (pair 0 1)). + +Check (@eq_refl _ 0 <<: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <<: 0 = snd (pair 0 1)). diff --git a/test-suite/success/private_univs.v b/test-suite/success/private_univs.v new file mode 100644 index 0000000000..5c30b33435 --- /dev/null +++ b/test-suite/success/private_univs.v @@ -0,0 +1,50 @@ +Set Universe Polymorphism. Set Printing Universes. + +Definition internal_defined@{i j | i < j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). (* 1 universe for the let body + 1 for the type *) + exact A. + Fail Defined. +Abort. + +Definition internal_defined@{i j +} (A : Type@{i}) : Type@{j}. +pose(foo:=Type). +exact A. +Defined. +Check internal_defined@{_ _ _ _}. + +Module M. +Lemma internal_qed@{i j|i<=j} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. +Qed. +Check internal_qed@{_ _}. +End M. +Include M. +(* be careful to remove const_private_univs in Include! will be coqchk'd *) + +Unset Strict Universe Declaration. +Lemma private_transitivity@{i j} (A:Type@{i}) : Type@{j}. +Proof. + pose (bar := Type : Type@{j}). + pose (foo := Type@{i} : bar). + exact bar. +Qed. + +Definition private_transitivity'@{i j|i < j} := private_transitivity@{i j}. +Fail Definition dummy@{i j|j <= i +} := private_transitivity@{i j}. + +Unset Private Polymorphic Universes. +Lemma internal_noprivate_qed@{i j|i<=j} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. + Fail Qed. +Abort. + +Lemma internal_noprivate_qed@{i j +} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. +Qed. +Check internal_noprivate_qed@{_ _ _ _}. diff --git a/test-suite/success/programequality.v b/test-suite/success/programequality.v new file mode 100644 index 0000000000..05f4a71856 --- /dev/null +++ b/test-suite/success/programequality.v @@ -0,0 +1,13 @@ +Require Import Program. + +Axiom t : nat -> Set. + +Goal forall (x y : nat) (e : x = y) (e' : x = y) (P : t y -> x = y -> Type) + (a : t x), + P (eq_rect _ _ a _ e) e'. +Proof. + intros. + pi_eq_proofs. clear e. + destruct e'. simpl. + change (P a eq_refl). +Abort. diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v new file mode 100644 index 0000000000..adaa05ad06 --- /dev/null +++ b/test-suite/success/proof_using.v @@ -0,0 +1,198 @@ +Require Import TestSuite.admit. +Section Foo. + +Variable a : nat. + +Lemma l1 : True. +Fail Proof using non_existing. +Proof using a. +exact I. +Qed. + +Lemma l2 : True. +Proof using a. +Admitted. + +Lemma l3 : True. +Proof using a. +admit. +Qed. + +End Foo. + +Check (l1 3). +Check (l2 3). +Check (l3 3). + +Section Bar. + +Variable T : Type. +Variable a b : T. +Variable H : a = b. + +Lemma l4 : a = b. +Proof using H. +exact H. +Qed. + +End Bar. + +Check (l4 _ 1 1 _ : 1 = 1). + +Section S1. + +Variable v1 : nat. + +Section S2. + +Variable v2 : nat. + +Lemma deep : v1 = v2. +Proof using v1 v2. +admit. +Qed. + +Lemma deep2 : v1 = v2. +Proof using v1 v2. +Admitted. + +End S2. + +Check (deep 3 : v1 = 3). +Check (deep2 3 : v1 = 3). + +End S1. + +Check (deep 3 4 : 3 = 4). +Check (deep2 3 4 : 3 = 4). + + +Section P1. + +Variable x : nat. +Variable y : nat. +Variable z : nat. + + +Collection TOTO := x y. + +Collection TITI := TOTO - x. + +Lemma t1 : True. Proof using TOTO. trivial. Qed. +Lemma t2 : True. Proof using TITI. trivial. Qed. + + Section P2. + Collection TOTO := x. + Lemma t3 : True. Proof using TOTO. trivial. Qed. + End P2. + +Lemma t4 : True. Proof using TOTO. trivial. Qed. + +End P1. + +Lemma t5 : True. Fail Proof using TOTO. trivial. Qed. + +Check (t1 1 2 : True). +Check (t2 1 : True). +Check (t3 1 : True). +Check (t4 1 2 : True). + + +Section T1. + +Variable x : nat. +Hypothesis px : 1 = x. +Let w := x + 1. + +Set Suggest Proof Using. + +Set Default Proof Using "Type". + +Lemma bla : 2 = w. +Proof. +admit. +Qed. + +End T1. + +Check (bla 7 : 2 = 8). + +Section A. +Variable a : nat. +Variable b : nat. +Variable c : nat. +Variable H1 : a = 3. +Variable H2 : a = 3 -> b = 7. +Variable H3 : c = 3. + +Lemma foo : a = a. +Proof using Type*. +pose H1 as e1. +pose H2 as e2. +reflexivity. +Qed. + +Lemma bar : a = 3 -> b = 7. +Proof using b*. +exact H2. +Qed. + +Lemma baz : c=3. +Proof using c*. +exact H3. +Qed. + +Lemma baz2 : c=3. +Proof using c* a. +exact H3. +Qed. + +End A. + +Check (foo 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (bar 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (baz2 99 3 (refl_equal 3)). +Check (baz 3 (refl_equal 3)). + +Section Let. + +Variables a b : nat. +Let pa : a = a. Proof. reflexivity. Qed. +Unset Default Proof Using. +Set Suggest Proof Using. +Lemma test_let : a = a. +Proof using a. +exact pa. +Qed. + +Let ppa : pa = pa. Proof. reflexivity. Qed. + +Lemma test_let2 : pa = pa. +Proof using Type. +exact ppa. +Qed. + +End Let. + +Check (test_let 3). + +(* Disabled +Section Clear. + +Variable a: nat. +Hypotheses H : a = 4. + +Set Proof Using Clear Unused. + +Lemma test_clear : a = a. +Proof using a. +Fail rewrite H. +trivial. +Qed. + +End Clear. +*) + + diff --git a/test-suite/success/record_syntax.v b/test-suite/success/record_syntax.v new file mode 100644 index 0000000000..07a5bc0606 --- /dev/null +++ b/test-suite/success/record_syntax.v @@ -0,0 +1,55 @@ +Module A. + +Record Foo := { foo : unit; bar : unit }. + +Definition foo_ := {| + foo := tt; + bar := tt +|}. + +Definition foo0 (p : Foo) := match p with {| |} => tt end. +Definition foo1 (p : Foo) := match p with {| foo := f |} => f end. +Definition foo2 (p : Foo) := match p with {| foo := f; |} => f end. +Definition foo3 (p : Foo) := match p with {| foo := f; bar := g |} => (f, g) end. +Definition foo4 (p : Foo) := match p with {| foo := f; bar := g; |} => (f, g) end. + +End A. + +Module B. + +Record Foo := { }. + +End B. + +Module C. + +Record Foo := { foo : unit; bar : unit; }. + +Definition foo_ := {| + foo := tt; + bar := tt; +|}. + +End C. + +Module D. + +Record Foo := { foo : unit }. +Definition foo_ := {| foo := tt |}. + +End D. + +Module E. + +Record Foo := { foo : unit; }. +Definition foo_ := {| foo := tt; |}. + +End E. + +Module F. + +Record Foo := { foo : nat * nat -> nat -> nat }. + +Definition foo_ := {| foo '(x,y) n := x+y+n |}. + +End F. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v new file mode 100644 index 0000000000..40986e57cb --- /dev/null +++ b/test-suite/success/refine.v @@ -0,0 +1,136 @@ + +(* Refine and let-in's *) + +Goal exists x : nat, x = 0. + refine (let y := 0 + 0 in _). +exists y; auto. +Save test1. + +Goal exists x : nat, x = 0. + refine (let y := 0 + 0 in ex_intro _ (y + y) _). +auto. +Save test2. + +Goal nat. + refine (let y := 0 in 0 + _). +exact 1. +Save test3. + +(* Example submitted by Yves on coqdev *) + +Require Import List. + +Goal forall l : list nat, l = l. +Proof. + refine + (fun l => + match l return (l = l) with + | nil => _ + | O :: l0 => _ + | S _ :: l0 => _ + end). +Abort. + +(* Submitted by Roland Zumkeller (BZ#888) *) + +(* The Fix and CoFix rules expect a subgoal even for closed components of the + (co-)fixpoint *) + +Goal nat -> nat. + refine (fix f (n : nat) : nat := S _ + with pred (n : nat) : nat := n + for f). +exact 0. +Qed. + +(* Submitted by Roland Zumkeller (BZ#889) *) + +(* The types of metas were in metamap and they were not updated when + passing through a binder *) + +Goal forall n : nat, nat -> n = 0. + refine + (fun n => fix f (i : nat) : n = 0 := match i with + | O => _ + | S _ => _ + end). +Abort. + +(* Submitted by Roland Zumkeller (BZ#931) *) +(* Don't turn dependent evar into metas *) + +Goal (forall n : nat, n = 0 -> Prop) -> Prop. +intro P. + refine (P _ _). +reflexivity. +Abort. + +(* Submitted by Jacek Chrzaszcz (BZ#1102) *) + +(* le problème a été résolu ici par normalisation des evars présentes + dans les types d'evars, mais le problème reste a priori ouvert dans + le cas plus général d'evars non instanciées dans les types d'autres + evars *) + +Goal exists n:nat, n=n. +refine (ex_intro _ _ _). +Abort. + +(* Used to failed with error not clean *) + +Definition div : + forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> + forall n:nat, {q:nat | x = q*n}. +refine + (fun m div_rec n => + match div_rec m n with + | exist _ _ _ => _ + end). +Abort. + + +(* Use to fail because sigma was not propagated to get_type_of *) +(* Revealed by r9310, fixed in r9359 *) + +Goal + forall f : forall a (H:a=a), Prop, + (forall a (H:a = a :> nat), f a H -> True /\ True) -> + True. +intros. +refine (@proj1 _ _ (H 0 _ _)). +Abort. + +(* Use to fail because let-in with metas in the body where rejected + because a priori considered as dependent *) + +Require Import Peano_dec. + +Definition fact_F : + forall (n:nat), + (forall m, m<n -> nat) -> + nat. +refine + (fun n fact_rec => + if eq_nat_dec n 0 then + 1 + else + let fn := fact_rec (n-1) _ in + n * fn). +Abort. + +(* Wish 1988: that fun forces unfold in refine *) + +Goal (forall A : Prop, A -> ~~A). +Proof. refine(fun A a f => _). Abort. + +(* Checking beta-iota normalization of hypotheses in created evars *) + +Goal {x|x=0} -> True. +refine (fun y => let (x,a) := y in _). +match goal with a:_=0 |- _ => idtac end. +Abort. + +Goal (forall P, {P 0}+{P 1}) -> True. +refine (fun H => if H (fun x => x=x) then _ else _). +match goal with _:0=0 |- _ => idtac end. +Abort. diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v new file mode 100644 index 0000000000..b26a9ff1eb --- /dev/null +++ b/test-suite/success/remember.v @@ -0,0 +1,29 @@ +(* Testing remember and co *) + +Lemma A : forall (P: forall X, X -> Prop), P nat 0 -> P nat 0. +intros. +Fail remember nat as X. +Fail remember nat as X in H. (* This line used to succeed in 8.3 *) +Fail remember nat as X. +Abort. + +(* Testing Ltac interpretation of remember (was not working up to r16181) *) + +Goal (1 + 2 + 3 = 6). +let name := fresh "fresh" in +remember (1 + 2) as x eqn:name. +rewrite fresh. +Abort. + +(* An example which was working in 8.4 but failing in 8.5 and 8.5pl1 *) + +Module A. +Axiom N : nat. +End A. +Module B. +Include A. +End B. +Goal id A.N = B.N. +reflexivity. +Qed. + diff --git a/test-suite/success/replace.v b/test-suite/success/replace.v new file mode 100644 index 0000000000..0b112937e5 --- /dev/null +++ b/test-suite/success/replace.v @@ -0,0 +1,32 @@ +Goal forall x, x = 0 -> S x = 7 -> x = 22 . +Proof. +replace 0 with 33. +Undo. +intros x H H0. +replace x with 0. +Undo. +replace x with 0 in |- *. +Undo. +replace x with 1 in *. +Undo. +replace x with 0 in *|- *. +Undo. +replace x with 0 in *|-. +Undo. +replace x with 0 in H0 . +Undo. +replace x with 0 in H0 |- * . +Undo. + +replace x with 0 in H,H0 |- * . +Undo. +Admitted. + +(* This failed at some point when "replace" started to support arguments + with evars but "abstract" did not supported any evars even defined ones *) + +Class U. +Lemma l (u : U) (f : U -> nat) (H : 0 = f u) : f u = 0. +replace (f _) with 0 by abstract apply H. +reflexivity. +Qed. diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v new file mode 100644 index 0000000000..baf089796f --- /dev/null +++ b/test-suite/success/rewrite.v @@ -0,0 +1,175 @@ +(* Check that dependent rewrite applies on arbitrary terms *) + +Inductive listn : nat -> Set := + | niln : listn 0 + | consn : forall n : nat, nat -> listn n -> listn (S n). + +Axiom + ax : + forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)), + existT _ (n + n') l = existT _ (n' + n) l'. + +Lemma lem : + forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)), + n + n' = n' + n /\ existT _ (n + n') l = existT _ (n' + n) l'. +Proof. +intros n n' l l'. + dependent rewrite (ax n n' l l'). +split; reflexivity. +Qed. + +(* Used to raise an anomaly instead of an error in 8.1 *) +(* Submitted by Y. Makarov *) + +Parameter N : Set. +Parameter E : N -> N -> Prop. + +Axiom e : forall (A : Set) (EA : A -> A -> Prop) (a : A), EA a a. + +Theorem th : forall x : N, E x x. +intro x. try rewrite e. +Abort. + +(* Behavior of rewrite wrt conversion *) + +Require Import Arith. + +Goal forall n, 0 + n = n -> True. +intros n H. +rewrite plus_0_l in H. +Abort. + +(* Rewrite dependent proofs from left-to-right *) + +Lemma l1 : + forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H. +intros x y H P H0. +rewrite H. +rewrite H in H0. +assumption. +Qed. + +(* Rewrite dependent proofs from right-to-left *) + +Lemma l2 : + forall x y (H:x = y:>nat) (P:forall x y, x=y -> Type), P x y H -> P x y H. +intros x y H P H0. +rewrite <- H. +rewrite <- H in H0. +assumption. +Qed. + +(* Check rewriting dependent proofs with non-symmetric equalities *) + +Lemma l3:forall x (H:eq_true x) (P:forall x, eq_true x -> Type), P x H -> P x H. +intros x H P H0. +rewrite H. +rewrite H in H0. +assumption. +Qed. + +(* Dependent rewrite *) + +Require Import JMeq. + +Goal forall A B (a:A) (b:B), JMeq a b -> JMeq b a -> True. +inversion 1; (* Goal is now [JMeq a a -> True] *) dependent rewrite H3. +Undo. +intros; inversion H; dependent rewrite H4 in H0. +Undo. +intros; inversion H; dependent rewrite <- H4 in H0. +Abort. + +(* Test conversion between terms with evars that both occur in K-redexes and + are elsewhere solvable. + + This is quite an artificial example, but it used to work in 8.2. + + Since rewrite supports conversion on terms without metas, it + was successively unifying (id 0 ?y) and 0 where ?y was not a + meta but, because coming from a "_", an evar. + + After commit r12440 which unified the treatment of metas and + evars, it stopped to work. Chung-Kil Hur's Heq package used + this feature. Solved in r13... +*) + +Parameter g : nat -> nat -> nat. +Definition K (x y:nat) := x. + +Goal (forall y, g y (K 0 y) = 0) -> g 0 0 = 0. +intros. +rewrite (H _). +reflexivity. +Qed. + +Goal (forall y, g (K 0 y) y = 0) -> g 0 0 = 0. +intros. +rewrite (H _). +reflexivity. +Qed. + +(* Example of rewriting of a degenerated pattern using the right-most + argument of the goal. This is sometimes used in contribs, even if + ad hoc. Here, we have the extra requirement that checking types + needs delta-conversion *) + +Axiom s : forall (A B : Type) (p : A * B), p = (fst p, snd p). +Definition P := (nat * nat)%type. +Goal forall x:P, x = x. +intros. rewrite s. +Abort. + +(* Test second-order unification and failure of pattern-unification *) + +Goal forall (P: forall Y, Y -> Prop) Y a, Y = nat -> (True -> P Y a) -> False. +intros. +(* The next line used to succeed between June and November 2011 *) +(* causing ill-typed rewriting *) +Fail rewrite H in H0. +Abort. + +(* Test subst in the presence of a dependent let-in *) +(* Was not working prior to May 2014 *) + +Goal forall x y, x=y+0 -> let z := x+1 in x+1=y -> z=z -> z=x. +intros. +subst x. (* was failing *) +subst z. +rewrite H0. +auto with arith. +Qed. + +(* Check that evars are instantiated when the term to rewrite is + closed, like in the case it is open *) + +Goal exists x, S 0 = 0 -> S x = 0. +eexists. intro H. +rewrite H. +reflexivity. +Abort. + +(* Check that rewriting within evars still work (was broken in 8.5beta1) *) + +Goal forall (a: unit) (H: a = tt), exists x y:nat, x = y. +intros; eexists; eexists. +rewrite H. +Undo. +subst. +Abort. + +(* Check that iterated rewriting does not rewrite in the side conditions *) +(* Example from Sigurd Schneider, extracted from contrib containers *) + +Lemma EQ + : forall (e e' : nat), True -> e = e'. +Admitted. + +Lemma test (v1 v2 v3: nat) (v' : v1 = v2) : v2 = v1. +Proof. + rewrite <- (EQ v1 v2) in *. + exact v'. + (* There should be only two side conditions *) + exact I. + exact I. +Qed. diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v new file mode 100644 index 0000000000..d73864e4e0 --- /dev/null +++ b/test-suite/success/rewrite_dep.v @@ -0,0 +1,34 @@ +Require Import TestSuite.admit. +Require Import Setoid. +Require Import Morphisms. +Require Vector. +Notation vector := Vector.t. +Notation Vcons n t := (@Vector.cons _ n _ t). + +Class Equiv A := equiv : A -> A -> Prop. +Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv). + +Instance vecequiv A `{Equiv A} n : Equiv (vector A n). +admit. +Qed. + +Global Instance vcons_proper A `{Equiv A} `{!Setoid A} : + Proper (equiv ==> forall_relation (fun k => equiv ==> equiv)) + (@Vector.cons A). +Proof. Admitted. + +Instance vecseotid A `{Setoid A} n : Setoid (vector A n). +Proof. Admitted. + +(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *) +(* apply setoid_equiv. *) +(* Qed. *) +(* Typeclasses Transparent Equiv. *) + +Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n), + equiv (Vcons a v) (Vcons b v). +Proof. + intros. + rewrite H0. + reflexivity. +Qed. diff --git a/test-suite/success/rewrite_evar.v b/test-suite/success/rewrite_evar.v new file mode 100644 index 0000000000..3bfd3c674a --- /dev/null +++ b/test-suite/success/rewrite_evar.v @@ -0,0 +1,9 @@ +Require Import Coq.Setoids.Setoid. + +Goal forall (T2 MT1 MT2 : Type) (x : T2) (M2 m2 : MT2) (M1 m1 : MT1) (F : T2 -> MT1 -> MT2 -> Prop), + (forall (defaultB : T2) (m3 : MT1) (m4 : MT2), F defaultB m3 m4 <-> True) -> F x M1 M2 -> F x m1 m2. + intros ????????? H' H. + rewrite (H' _) in *. + (** The above rewrite should also rewrite in H. *) + Fail progress rewrite H' in H. +Abort. diff --git a/test-suite/success/rewrite_in.v b/test-suite/success/rewrite_in.v new file mode 100644 index 0000000000..29fe915ff4 --- /dev/null +++ b/test-suite/success/rewrite_in.v @@ -0,0 +1,8 @@ +Require Import Setoid. + +Goal forall (P Q : Prop) (f:P->Prop) (p:P), (P<->Q) -> f p -> True. + intros P Q f p H. + rewrite H in p || trivial. +Qed. + + diff --git a/test-suite/success/rewrite_iterated.v b/test-suite/success/rewrite_iterated.v new file mode 100644 index 0000000000..962dada35a --- /dev/null +++ b/test-suite/success/rewrite_iterated.v @@ -0,0 +1,30 @@ +Require Import Arith Omega. + +Lemma test : forall p:nat, p<>0 -> p-1+1=p. +Proof. + intros; omega. +Qed. + +(** Test of new syntax for rewrite : ! ? and so on... *) + +Lemma but : forall a b c, a<>0 -> b<>0 -> c<>0 -> + (a-1+1)+(b-1+1)+(c-1+1)=a+b+c. +Proof. +intros. +rewrite test. +Undo. +rewrite test,test. +Undo. +rewrite 2 test. (* or rewrite 2test or rewrite 2!test *) +Undo. +rewrite 2!test,2?test. +Undo. +(*rewrite 4!test. --> error *) +rewrite 3!test. +Undo. +rewrite <- 3?test. +Undo. +(*rewrite <-?test. --> loops*) +rewrite !test by auto. +reflexivity. +Qed. diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v new file mode 100644 index 0000000000..a6e59fdda0 --- /dev/null +++ b/test-suite/success/rewrite_strat.v @@ -0,0 +1,53 @@ +Require Import Setoid. + +Variable X : Set. + +Variable f : X -> X. +Variable g : X -> X -> X. +Variable h : nat -> X -> X. + +Variable lem0 : forall x, f (f x) = f x. +Variable lem1 : forall x, g x x = f x. +Variable lem2 : forall n x, h (S n) x = g (h n x) (h n x). +Variable lem3 : forall x, h 0 x = x. + +Hint Rewrite lem0 lem1 lem2 lem3 : rew. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time autorewrite with rew. (* 0.586 *) + reflexivity. +Time Qed. (* 0.53 *) + +Goal forall x, h 6 x = f x. +intros. + Time rewrite_strat topdown lem2. + Time rewrite_strat topdown lem1. + Time rewrite_strat topdown lem0. + Time rewrite_strat topdown lem3. + reflexivity. +Undo 5. + Time rewrite_strat topdown (choice lem2 lem1). + Time rewrite_strat topdown (choice lem0 lem3). + reflexivity. +Undo 3. + Time rewrite_strat (topdown (choice lem2 lem1); topdown (choice lem0 lem3)). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Undo 2. + Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). + reflexivity. +Qed. + +Goal forall x, h 10 x = f x. +Proof. + intros. + Time rewrite_strat topdown (hints rew). (* 0.38 *) + reflexivity. +Time Qed. (* 0.06 s *) + +Set Printing All. +Set Printing Depth 100000. diff --git a/test-suite/success/searchabout.v b/test-suite/success/searchabout.v new file mode 100644 index 0000000000..9edfd82556 --- /dev/null +++ b/test-suite/success/searchabout.v @@ -0,0 +1,60 @@ + +(** Test of the different syntaxes of SearchAbout, in particular + with and without the [ ... ] delimiters *) + +SearchAbout plus. +SearchAbout plus mult. +SearchAbout "plus_n". +SearchAbout plus "plus_n". +SearchAbout "*". +SearchAbout "*" "+". + +SearchAbout plus inside Peano. +SearchAbout plus mult inside Peano. +SearchAbout "plus_n" inside Peano. +SearchAbout plus "plus_n" inside Peano. +SearchAbout "*" inside Peano. +SearchAbout "*" "+" inside Peano. + +SearchAbout plus outside Peano Logic. +SearchAbout plus mult outside Peano Logic. +SearchAbout "plus_n" outside Peano Logic. +SearchAbout plus "plus_n" outside Peano Logic. +SearchAbout "*" outside Peano Logic. +SearchAbout "*" "+" outside Peano Logic. + +SearchAbout -"*" "+" outside Logic. +SearchAbout -"*"%nat "+"%nat outside Logic. + +SearchAbout [plus]. +SearchAbout [plus mult]. +SearchAbout ["plus_n"]. +SearchAbout [plus "plus_n"]. +SearchAbout ["*"]. +SearchAbout ["*" "+"]. + +SearchAbout [plus] inside Peano. +SearchAbout [plus mult] inside Peano. +SearchAbout ["plus_n"] inside Peano. +SearchAbout [plus "plus_n"] inside Peano. +SearchAbout ["*"] inside Peano. +SearchAbout ["*" "+"] inside Peano. + +SearchAbout [plus] outside Peano Logic. +SearchAbout [plus mult] outside Peano Logic. +SearchAbout ["plus_n"] outside Peano Logic. +SearchAbout [plus "plus_n"] outside Peano Logic. +SearchAbout ["*"] outside Peano Logic. +SearchAbout ["*" "+"] outside Peano Logic. + +SearchAbout [-"*" "+"] outside Logic. +SearchAbout [-"*"%nat "+"%nat] outside Logic. + + +(** The example in the Reference Manual *) + +Require Import ZArith. + +SearchAbout Z.mul Z.add "distr". +SearchAbout "+"%Z "*"%Z "distr" -positive -Prop. +SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas. diff --git a/test-suite/success/set.v b/test-suite/success/set.v new file mode 100644 index 0000000000..8116e89751 --- /dev/null +++ b/test-suite/success/set.v @@ -0,0 +1,19 @@ +(* This used to fail in 8.0pl1 *) + +Goal forall n, n+n=0->0=n+n. +intros. +set n in * |-. +Abort. + +(* This works from 8.4pl1, since merging of different instances of the + same metavariable in a pattern is done modulo conversion *) + +Notation "p .+1" := (S p) (at level 1, left associativity, format "p .+1"). + +Goal forall (f:forall n, n=0 -> Prop) n (H:(n+n).+1=0), f (n.+1+n) H. +intros. +set (f _ _). +Abort. + + + diff --git a/test-suite/success/setoid_ring_module.v b/test-suite/success/setoid_ring_module.v new file mode 100644 index 0000000000..2d9e85b54e --- /dev/null +++ b/test-suite/success/setoid_ring_module.v @@ -0,0 +1,40 @@ +Require Import Setoid Ring Ring_theory. + +Module abs_ring. + +Parameters (Coef:Set)(c0 c1 : Coef) +(cadd cmul csub: Coef -> Coef -> Coef) +(copp : Coef -> Coef) +(ceq : Coef -> Coef -> Prop) +(ceq_sym : forall x y, ceq x y -> ceq y x) +(ceq_trans : forall x y z, ceq x y -> ceq y z -> ceq x z) +(ceq_refl : forall x, ceq x x). + + +Add Relation Coef ceq + reflexivity proved by ceq_refl symmetry proved by ceq_sym + transitivity proved by ceq_trans + as ceq_relation. + +Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism. +Admitted. + +Add Morphism cmul with signature ceq ==> ceq ==> ceq as cmul_Morphism. +Admitted. + +Add Morphism copp with signature ceq ==> ceq as copp_Morphism. +Admitted. + +Definition cRth : ring_theory c0 c1 cadd cmul csub copp ceq. +Admitted. + +Add Ring CoefRing : cRth. + +End abs_ring. +Import abs_ring. + +Theorem check_setoid_ring_modules : + forall a b, ceq (cadd a b) (cadd b a). +intros. +ring. +Qed. diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v new file mode 100644 index 0000000000..c8dfcd2cbf --- /dev/null +++ b/test-suite/success/setoid_test.v @@ -0,0 +1,181 @@ +Require Import TestSuite.admit. +Require Import Setoid. + +Parameter A : Set. + +Axiom eq_dec : forall a b : A, {a = b} + {a <> b}. + +Inductive set : Set := + | Empty : set + | Add : A -> set -> set. + +Fixpoint In (a : A) (s : set) {struct s} : Prop := + match s with + | Empty => False + | Add b s' => a = b \/ In a s' + end. + +Definition same (s t : set) : Prop := forall a : A, In a s <-> In a t. + +Lemma setoid_set : Setoid_Theory set same. + +unfold same; split ; red. +red; auto. + +red. +intros. +elim (H a); auto. + +intros. +elim (H a); elim (H0 a). +split; auto. +Qed. + +Add Setoid set same setoid_set as setsetoid. + +Add Morphism In with signature (eq ==> same ==> iff) as In_ext. +Proof. +unfold same; intros a s t H; elim (H a); auto. +Qed. + +Lemma add_aux : + forall s t : set, + same s t -> forall a b : A, In a (Add b s) -> In a (Add b t). +unfold same; simple induction 2; intros. +rewrite H1. +simpl; left; reflexivity. + +elim (H a). +intros. +simpl; right. +apply (H2 H1). +Qed. + +Add Morphism Add with signature (eq ==> same ==> same) as Add_ext. +split; apply add_aux. +assumption. +rewrite H. +reflexivity. +Qed. + +Fixpoint remove (a : A) (s : set) {struct s} : set := + match s with + | Empty => Empty + | Add b t => + match eq_dec a b with + | left _ => remove a t + | right _ => Add b (remove a t) + end + end. + +Lemma in_rem_not : forall (a : A) (s : set), ~ In a (remove a (Add a Empty)). + +intros. +setoid_replace (remove a (Add a Empty)) with Empty. + +auto. + +unfold same. +split. +simpl. +case (eq_dec a a). +intros e ff; elim ff. + +intros; absurd (a = a); trivial. + +simpl. +intro H; elim H. +Qed. + +Parameter P : set -> Prop. +Parameter P_ext : forall s t : set, same s t -> P s -> P t. + +Add Morphism P with signature (same ==> iff) as P_extt. +intros; split; apply P_ext; (assumption || apply (Seq_sym _ _ setoid_set); assumption). +Qed. + +Lemma test_rewrite : + forall (a : A) (s t : set), same s t -> P (Add a s) -> P (Add a t). +intros. +rewrite <- H. +rewrite H. +setoid_rewrite <- H. +setoid_rewrite H. +setoid_rewrite <- H. +trivial. +Qed. + +(* Unifying the domain up to delta-conversion (example from emakarov) *) + +Definition id: Set -> Set := fun A => A. +Definition rel : forall A : Set, relation (id A) := @eq. +Definition f: forall A : Set, A -> A := fun A x => x. + +Add Relation (id A) (rel A) as eq_rel. + +Add Morphism (@f A) with signature (eq ==> eq) as f_morph. +Proof. +unfold rel, f. trivial. +Qed. + +(* Submitted by Nicolas Tabareau *) +(* Needs unification.ml to support environments with de Bruijn *) + +Goal forall + (f : Prop -> Prop) + (Q : (nat -> Prop) -> Prop) + (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True) + (h:nat -> Prop), + Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True. +intros f0 Q H. +setoid_rewrite H. +tauto. +Qed. + +(** Check proper refreshing of the lemma application for multiple + different instances in a single setoid rewrite. *) + +Section mult. + Context (fold : forall {A} {B}, (A -> B) -> A -> B). + Context (add : forall A, A -> A). + Context (fold_lemma : forall {A B f} {eqA : relation B} x, eqA (fold A B f (add A x)) (fold _ _ f x)). + Context (ab : forall B, A -> B). + Context (anat : forall A, nat -> A). + +Goal forall x, (fold _ _ (fun x => ab A x) (add A x) = anat _ (fold _ _ (ab nat) (add _ x))). +Proof. intros. + setoid_rewrite fold_lemma. + change (fold A A (fun x0 : A => ab A x0) x = anat A (fold A nat (ab nat) x)). +Abort. + +End mult. + +(** Current semantics for rewriting with typeclass constraints in the lemma + does not fix the instance at the first unification, use [at], or simply rewrite for + this semantics. *) + +Parameter beq_nat : forall x y : nat, bool. + +Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}. +Instance: Foo nat. admit. Defined. +Instance: Foo bool. admit. Defined. + +Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. +Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort. + +Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. +Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort. + +(* This should not raise an anomaly as it did for some time in early 2016 *) + +Definition t := nat -> bool. +Definition h (a b : t) := forall n, a n = b n. + +Instance subrelh : subrelation h (Morphisms.pointwise_relation nat eq). +Proof. intros x y H; assumption. Qed. + +Goal forall a b, h a b -> a 0 = b 0. +intros. +setoid_rewrite H. (* Fallback on ordinary rewrite without anomaly *) +reflexivity. +Qed. diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v new file mode 100644 index 0000000000..79467e549c --- /dev/null +++ b/test-suite/success/setoid_test2.v @@ -0,0 +1,246 @@ +Require Export Setoid. + +(* Testare: + +1. due setoidi con ugualianza diversa sullo stesso tipo + +2. due setoidi sulla stessa uguaglianza + +3. due morfismi sulla stessa funzione ma setoidi diversi + +4. due morfismi sulla stessa funzione e stessi setoidi + +5. setoid_replace + +6. solo cammini mal tipati + +7. esempio (f (g (h E1))) + dove h:(T1,=1) -> T2, g:T2->(T3,=3), f:(T3,=3)->Prop + +8. test con occorrenze non lineari del pattern + +9. test in cui setoid_replace fa direttamente fallback su replace + 10. sezioni + +11. goal con impl + +12. testare *veramente* setoid_replace (ora testato solamente il caso + di fallback su replace) + + Incompatibilita': + 1. full_trivial in setoid_replace + 2. "as ..." per "Add Setoid" + 3. ipotesi permutate in lemma di "Add Morphism" + 4. iff invece di if in "Add Morphism" nel caso di predicati + 5. setoid_replace poteva riscrivere sia c1 in c2 che c2 in c1 + (???? o poteva farlo da destra a sinitra o viceversa? ????) + +### Come evitare di dover fare "Require Setoid" prima di usare la + tattica? + +??? scelta: quando ci sono piu' scelte dare un warning oppure fallire? + difficile quando la tattica e' rewrite ed e' usata in tattiche + automatiche + +??? in test4.v il setoid_rewrite non si puo' sostituire con rewrite + perche' questo ultimo fallisce per via dell'unificazione + +??? ??? <-> non e' sottorelazione di ->. Quindi ora puo' capitare + di non riuscire a provare goal del tipo A /\ B dove (A, <->) e + (B, ->) (per esempio) + +### Nota: il parsing e pretty printing delle relazioni non e' in synch! + eq contro (ty,eq). Uniformare + +### diminuire la taglia dei proof term + +??? il messaggio di errore non e' assolutamente significativo quando + nessuna marcatura viene trovata + +### fare in modo che uscendo da una sezione vengano quantificate le + relazioni e i morfismi. Hugo: paciugare nel discharge.ml + +### implementare relazioni/morfismi quantificati con dei LetIn (che palle...) + decompose_prod da far diventare simile a un Reduction.dest_arity? + (ma senza riduzione??? e perche' li' c'e' riduzione?) + Soluzione da struzzo: fare zeta-conversione. + +### fare in modo che impl sia espanso nel lemma di compatibilita' del + morfismo (richiesta di Marco per poter fare Add Hing) + +??? snellire la sintassi omettendo "proved by" come proposto da Marco? ;-( + +### non capisce piu' le riscritture con uguaglianze quantificate (almeno + nell'esempio di Marco) +### Bas Spitters: poter dichiarare che ogni variabile nel contesto di tipo + un setoid_function e' un morfismo + +### unificare le varie check_... +### sostituire a Use_* una sola eccezione Optimize + + Implementare: + -2. user-defined subrelations && user-proved subrelations + -1. trucco di Bruno + + Sorgenti di inefficacia: + 1. scelta del setoide di default per un sostegno: per farlo velocemente + ci vorrebbe una tabella hash; attualmente viene fatta una ricerca + lineare sul range della setoid_table + + Vantaggi rispetto alla vecchia tattica: + 1. permette di avere setoidi differenti con lo stesso sostegno, + ma equivalenza differente + 2. accetta setoidi differenti con lo stesso sostegno e stessa + equivalenza, scegliendo a caso quello da usare (proof irrelevance) + 3. permette di avere morfismi differenti sulla stessa funzione + se hanno dominio o codominio differenti + 4. accetta di avere morfismi differenti sulla stessa funzione e con + lo stesso dominio e codominio, scegliendo a caso quello da usare + (proof irrelevance) + 5. quando un morfismo viene definito, se la scelta del dominio o del + codominio e' ambigua l'utente puo' esplicitamente disambiguare + la scelta fornendo esplicitamente il "tipo" del morfismo + 6. permette di gestire riscritture ove ad almeno una funzione venga + associato piu' di un morfismo. Vengono automaticamente calcolate + le scelte globali che rispettano il tipaggio. + 7. se esistono piu' scelte globali che rispettano le regole di tipaggio + l'utente puo' esplicitamente disambiguare la scelta globale fornendo + esplicitamente la scelta delle side conditions generate. + 8. nel caso in cui la setoid_replace sia stata invocata al posto + della replace la setoid_replace invoca direttamente la replace. + Stessa cosa per la setoid_rewrite. + 9. permette di gestire termini in cui il prefisso iniziale dell'albero + (fino a trovare il termine da riscrivere) non sia formato esclusivamente + da morfismi il cui dominio e codominio sia un setoide. + Ovvero ammette anche morfismi il cui dominio e/o codominio sia + l'uguaglianza di Leibniz. (Se entrambi sono uguaglianze di Leibniz + allora il setoide e' una semplice funzione). + 10. [setoid_]rewrite ... in ... + setoid_replace ... in ... + [setoid_]reflexivity + [setoid_]transitivity ... + [setoid_]symmetry + [setoid_]symmetry in ... + 11. permette di dichiarare dei setoidi/relazioni/morfismi in un module + type + 12. relazioni, morfismi e setoidi quantificati +*) + +Axiom S1: Set. +Axiom eqS1: S1 -> S1 -> Prop. +Axiom SetoidS1 : Setoid_Theory S1 eqS1. +Add Setoid S1 eqS1 SetoidS1 as S1setoid. + +Instance eqS1_default : DefaultRelation eqS1. + +Axiom eqS1': S1 -> S1 -> Prop. +Axiom SetoidS1' : Setoid_Theory S1 eqS1'. +Axiom SetoidS1'_bis : Setoid_Theory S1 eqS1'. +Add Setoid S1 eqS1' SetoidS1' as S1setoid'. +Add Setoid S1 eqS1' SetoidS1'_bis as S1setoid''. + +Axiom S2: Set. +Axiom eqS2: S2 -> S2 -> Prop. +Axiom SetoidS2 : Setoid_Theory S2 eqS2. +Add Setoid S2 eqS2 SetoidS2 as S2setoid. + +Axiom f : S1 -> nat -> S2. +Add Morphism f with signature (eqS1 ==> eq ==> eqS2) as f_compat. Admitted. +Add Morphism f with signature (eqS1 ==> eq ==> eqS2) as f_compat2. Admitted. + +Theorem test1: forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). + intros. + rewrite H. + reflexivity. +Qed. + +Theorem test1': forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)). + intros. + setoid_replace x with y. + reflexivity. + assumption. +Qed. + +Axiom g : S1 -> S2 -> nat. +Add Morphism g with signature (eqS1 ==> eqS2 ==> eq) as g_compat. Admitted. + +Axiom P : nat -> Prop. +Theorem test2: + forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (P (g x' y')) -> (P (g x y)). + intros. + rewrite H. + rewrite H0. + assumption. +Qed. + +Theorem test3: + forall x x' y y', + (eqS1 x x') -> (eqS2 y y') -> (P (S (g x' y'))) -> (P (S (g x y))). + intros. + rewrite H. + rewrite H0. + assumption. +Qed. + +Theorem test4: + forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')). + intros. + rewrite H. + rewrite H0. + reflexivity. +Qed. + +Theorem test5: + forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')). + intros. + setoid_replace (g x y) with (g x' y'). + reflexivity. + rewrite <- H0. + rewrite H. + reflexivity. +Qed. + +Axiom f_test6 : S2 -> Prop. +Add Morphism f_test6 with signature (eqS2 ==> iff) as f_test6_compat. Admitted. + +Axiom g_test6 : bool -> S2. +Add Morphism g_test6 with signature (eq ==> eqS2) as g_test6_compat. Admitted. + +Axiom h_test6 : S1 -> bool. +Add Morphism h_test6 with signature (eqS1 ==> eq) as h_test6_compat. Admitted. + +Theorem test6: + forall E1 E2, (eqS1 E1 E2) -> (f_test6 (g_test6 (h_test6 E2))) -> + (f_test6 (g_test6 (h_test6 E1))). + intros. + rewrite H. + assumption. +Qed. + +Theorem test7: + forall E1 E2 y y', (eqS1 E1 E2) -> (eqS2 y y') -> + (f_test6 (g_test6 (h_test6 E2))) -> + (f_test6 (g_test6 (h_test6 E1))) /\ (S (g E1 y')) = (S (g E2 y')). + intros. + rewrite H. + split; [assumption | reflexivity]. +Qed. + +Axiom S1_test8: Set. +Axiom eqS1_test8: S1_test8 -> S1_test8 -> Prop. +Axiom SetoidS1_test8 : Setoid_Theory S1_test8 eqS1_test8. +Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid. + +Instance eqS1_test8_default : DefaultRelation eqS1_test8. + +Axiom f_test8 : S2 -> S1_test8. +Add Morphism f_test8 with signature (eqS2 ==> eqS1_test8) as f_compat_test8. Admitted. + +Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop. +Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'. +Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'. + +(*CSC: for test8 to be significant I want to choose the setoid + (S1_test8, eqS1_test8'). However this does not happen and + there is still no syntax for it ;-( *) +Axiom g_test8 : S1_test8 -> S2. +Add Morphism g_test8 with signature (eqS1_test8 ==> eqS2) as g_compat_test8. Admitted. + +Theorem test8: + forall x x': S2, (eqS2 x x') -> + (eqS2 (g_test8 (f_test8 x)) (g_test8 (f_test8 x'))). + intros. + rewrite H. +Abort. + +(*Print Setoids.*) + diff --git a/test-suite/success/setoid_test_function_space.v b/test-suite/success/setoid_test_function_space.v new file mode 100644 index 0000000000..381cda2cd6 --- /dev/null +++ b/test-suite/success/setoid_test_function_space.v @@ -0,0 +1,45 @@ +Require Export Setoid. +Set Implicit Arguments. +Section feq. +Variables A B:Type. +Definition feq (f g: A -> B):=forall a, (f a)=(g a). +Infix "=f":= feq (at level 80, right associativity). +Hint Unfold feq. + +Lemma feq_refl: forall f, f =f f. +intuition. +Qed. + +Lemma feq_sym: forall f g, f =f g-> g =f f. +intuition. +Qed. + +Lemma feq_trans: forall f g h, f =f g-> g =f h -> f =f h. +unfold feq. intuition. +rewrite H. +auto. +Qed. +End feq. +Infix "=f":= feq (at level 80, right associativity). +Hint Unfold feq. Hint Resolve feq_refl feq_sym feq_trans. + +Variable K:(nat -> nat)->Prop. +Variable K_ext:forall a b, (K a)->(a =f b)->(K b). + +Add Parametric Relation (A B : Type) : (A -> B) (@feq A B) + reflexivity proved by (@feq_refl A B) + symmetry proved by (@feq_sym A B) + transitivity proved by (@feq_trans A B) as funsetoid. + +Add Morphism K with signature (@feq nat nat) ==> iff as K_ext1. +intuition. apply (K_ext H0 H). +intuition. assert (y =f x);auto. apply (K_ext H0 H1). +Qed. + +Lemma three:forall n, forall a, (K a)->(a =f (fun m => (a (n+m))))-> (K (fun m +=> (a (n+m)))). +intuition. +setoid_rewrite <- H0. +assumption. +Qed. + diff --git a/test-suite/success/setoid_unif.v b/test-suite/success/setoid_unif.v new file mode 100644 index 0000000000..d579911323 --- /dev/null +++ b/test-suite/success/setoid_unif.v @@ -0,0 +1,28 @@ +(* An example of unification in rewrite which uses eager substitution + of metas (provided by Pierre-Marie). + + Put in the test suite as an indication of what the use metas + eagerly flag provides, even though the concrete cases that use it + are seldom. Today supported thanks to a new flag for using evars + eagerly, after this variant of setoid rewrite started to use clause + environments based on evars (fbbe491cfa157da627) *) + +Require Import Setoid. + +Parameter elt : Type. +Parameter T : Type -> Type. +Parameter empty : forall A, T A. +Parameter MapsTo : forall A : Type, elt -> A -> T A -> Prop. + +(* Definition In A x t := exists e, MapsTo A x e t. *) +Axiom In : forall A, A -> T A -> Prop. +Axiom foo : forall A x, In A x (empty A) <-> False. + +Record R := { t : T unit; s : unit }. +Definition Empty := {| t := empty unit; s := tt |}. + +Goal forall x, ~ In _ x (t Empty). +Proof. +intros x. +rewrite foo. +Abort. diff --git a/test-suite/success/shrink_abstract.v b/test-suite/success/shrink_abstract.v new file mode 100644 index 0000000000..916bb846a9 --- /dev/null +++ b/test-suite/success/shrink_abstract.v @@ -0,0 +1,11 @@ +Definition foo : forall (n m : nat), bool. +Proof. +pose (p := 0). +intros n. +pose (q := n). +intros m. +pose (r := m). +abstract (destruct m; [left|right]). +Defined. + +Check (foo_subproof : nat -> bool). diff --git a/test-suite/success/shrink_obligations.v b/test-suite/success/shrink_obligations.v new file mode 100644 index 0000000000..676b97878f --- /dev/null +++ b/test-suite/success/shrink_obligations.v @@ -0,0 +1,28 @@ +Require Program. + +Obligation Tactic := idtac. + +Set Shrink Obligations. + +Program Definition foo (m : nat) (p := S m) (n : nat) (q := S n) : unit := +let bar : {r | n < r} := _ in +let qux : {r | p < r} := _ in +let quz : m = n -> True := _ in +tt. +Next Obligation. +intros m p n q. +exists (S n); constructor. +Qed. +Next Obligation. +intros m p n q. +exists (S (S m)); constructor. +Qed. +Next Obligation. +intros m p n q ? ? H. +destruct H. +constructor. +Qed. + +Check (foo_obligation_1 : forall n, {r | n < r}). +Check (foo_obligation_2 : forall m, {r | (S m) < r}). +Check (foo_obligation_3 : forall m n, m = n -> True). diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v new file mode 100644 index 0000000000..b9a1273b1a --- /dev/null +++ b/test-suite/success/sideff.v @@ -0,0 +1,14 @@ +Definition idw (A : Type) := A. +Lemma foobar : unit. +Proof. + Require Import Program. + apply (const tt tt). +Qed. + +Set Nested Proofs Allowed. + +Lemma foobar' : unit. + Lemma aux : forall A : Type, A -> unit. + Proof. intros. pose (foo := idw A). exact tt. Show Universes. Qed. + apply (@aux unit tt). +Qed. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v new file mode 100644 index 0000000000..1bfb8580b3 --- /dev/null +++ b/test-suite/success/simpl.v @@ -0,0 +1,107 @@ +Require Import TestSuite.admit. +(* Check that inversion of names of mutual inductive fixpoints works *) +(* (cf BZ#1031) *) + +Inductive tree : Set := +| node : nat -> forest -> tree +with forest : Set := +| leaf : forest +| cons : tree -> forest -> forest + . +Definition copy_of_compute_size_forest := +fix copy_of_compute_size_forest (f:forest) : nat := + match f with + | leaf => 1 + | cons t f0 => copy_of_compute_size_forest f0 + copy_of_compute_size_tree t + end +with copy_of_compute_size_tree (t:tree) : nat := + match t with + | node _ f => 1 + copy_of_compute_size_forest f + end for copy_of_compute_size_forest +. +Eval simpl in (copy_of_compute_size_forest leaf). + + +(* Another interesting case: Hrec has to occurrences: one cannot be folded + back to f while the second can. *) +Parameter g : (nat->nat)->nat->nat->nat. + +Definition f (n n':nat) := + nat_rec (fun _ => nat -> nat) + (fun x => x) + (fun k Hrec => g Hrec (Hrec k)) + n n'. + +Goal forall a b, f (S a) b = b. +intros. +simpl. +admit. +Qed. (* Qed will fail if simpl performs eta-expansion *) + +(* Yet another example. *) + +Require Import List. + +Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i. +simpl. +admit. +Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *) + +(* Check that maximally inserted arguments do not break interpretation + of references in simpl, vm_compute etc. *) + +Arguments fst {A} {B} p. + +Goal fst (0,0) = 0. +simpl fst. +Fail set (fst _). +Abort. + +Goal fst (0,0) = 0. +vm_compute fst. +Fail set (fst _). +Abort. + +Goal let f x := x + 0 in f 0 = 0. +intro. +vm_compute f. +Fail set (f _). +Abort. + +(* This is a change wrt 8.4 (waiting to know if it breaks script a lot or not)*) + +Goal 0+0=0. +Fail simpl @eq. +Abort. + +(* Check reference by notation in simpl *) + +Goal 0+0 = 0. +simpl "+". +Fail set (_ + _). +Abort. + +(* Check occurrences *) + +Record box A := Box { unbox : A }. + +Goal unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) = + unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))). +simpl (unbox _ (unbox _ _)) at 1. +match goal with |- True = unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 5. +simpl (unbox _ (unbox _ _)) at 1 4. +match goal with |- True = unbox _ (Box _ True) => idtac end. +Undo 2. +Fail simpl (unbox _ (unbox _ _)) at 3 4. (* Nested and even overlapping *) +simpl (unbox _ (unbox _ _)) at 2 4. +match goal with |- unbox _ (Box _ True) = unbox _ (Box _ True) => idtac end. +Abort. + +(* Check interpretation of ltac variables (was broken in 8.5 beta 1 and 2 *) + +Goal 2=1+1. +match goal with |- (_ = ?c) => simpl c end. +match goal with |- 2 = 2 => idtac end. (* Check that it reduced *) +Abort. diff --git a/test-suite/success/simpl_tuning.v b/test-suite/success/simpl_tuning.v new file mode 100644 index 0000000000..2728672f30 --- /dev/null +++ b/test-suite/success/simpl_tuning.v @@ -0,0 +1,149 @@ +(* as it is dynamically inferred by simpl *) +Arguments minus !n / m. + +Lemma foo x y : S (S x) - S y = 0. +simpl. +match goal with |- (match y with O => S x | S _ => _ end = 0) => idtac end. +Abort. + +(* we avoid exposing a match *) +Arguments minus n m : simpl nomatch. + +Lemma foo x : minus 0 x = 0. +simpl. +match goal with |- (0 = 0) => idtac end. +Abort. + +Lemma foo x y : S (S x) - S y = 0. +simpl. +match goal with |- (S x - y = 0) => idtac end. +Abort. + +Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. +simpl. +match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. +Abort. + +(* we unfold as soon as we have 1 args, but we avoid exposing a match *) +Arguments minus n / m : simpl nomatch. + +Lemma foo : minus 0 = fun x => 0. +simpl. +match goal with |- minus 0 = _ => idtac end. +Abort. +(* This does not work as one may expect. The point is that simpl is implemented + as "strong (whd_simpl_state)" and after unfolding minus you have + (fun m => match 0 => 0 | S n => ...) that is already in whd and exposes + a match, that of course "strong" would reduce away but at that stage + we don't know, and reducing by hand under the lambda is against whd *) + +(* extra tuning for the usual heuristic *) +Arguments minus !n / m : simpl nomatch. + +Lemma foo x y : S (S x) - S y = 0. +simpl. +match goal with |- (S x - y = 0) => idtac end. +Abort. + +Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. +simpl. +match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. +Abort. + +(* full control *) +Arguments minus !n !m /. + +Lemma foo x y : S (S x) - S y = 0. +simpl. +match goal with |- (S x - y = 0) => idtac end. +Abort. + +Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. +simpl. +match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. +Abort. + +(* omitting /, that being immediately after the last ! is irrelevant *) +Arguments minus !n !m. + +Lemma foo x y : S (S x) - S y = 0. +simpl. +match goal with |- (S x - y = 0) => idtac end. +Abort. + +Lemma foo x y : S (S x) - (S (match y with O => O | S z => S z end)) = 0. +simpl. +match goal with |-(S x - (match y with O => _ | S _ => _ end) = 0) => idtac end. +Abort. + +Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := + fun x => (f (fst x), g (snd x)). + +Delimit Scope foo_scope with F. +Notation "@@" := nat (only parsing) : foo_scope. +Notation "@@" := (fun x => x) (only parsing). + +Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never. + +Lemma foo x : @pf @@ nat @@ nat nat @@ x = pf @@ @@ x. +Abort. + +Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). + +(* fcomp is unfolded if applied to 6 args *) +Arguments fcomp {A B C}%type f g x /. + +Notation "f \o g" := (fcomp f g) (at level 50). + +Lemma foo (f g h : nat -> nat) x : pf (f \o g) h x = pf f h (g (fst x), snd x). +simpl. +match goal with |- (pf (f \o g) h x = _) => idtac end. +case x; intros x1 x2. +simpl. +match goal with |- (pf (f \o g) h _ = pf f h _) => idtac end. +unfold pf; simpl. +match goal with |- (f (g x1), h x2) = (f (g x1), h x2) => idtac end. +Abort. + +Definition volatile := fun x : nat => x. +Arguments volatile / _. + +Lemma foo : volatile = volatile. +simpl. +match goal with |- (fun _ => _) = _ => idtac end. +Abort. + +Set Implicit Arguments. + +Section S1. + +Variable T1 : Type. + +Section S2. + +Variable T2 : Type. + +Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat := + match n, m with + | 0,_ => 0 + | S _, 0 => n + | S n', S m' => f x y n' v m' end. + +Global Arguments f x y !n !v !m. + +Lemma foo x y n m : f x y (S n) tt m = f x y (S n) tt (S m). +simpl. +match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end. +Abort. + +End S2. + +Lemma foo T x y n m : @f T x y (S n) tt m = @f T x y (S n) tt (S m). +simpl. +match goal with |- (f _ _ _ _ _ = f _ _ _ _ _) => idtac end. +Abort. + +End S1. + +Arguments f : clear implicits and scopes. + diff --git a/test-suite/success/somatching.v b/test-suite/success/somatching.v new file mode 100644 index 0000000000..5ed833ecc3 --- /dev/null +++ b/test-suite/success/somatching.v @@ -0,0 +1,64 @@ +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + match type of p with + | forall x y, @?F x y => pose F as C1 + end. + match type of p with + | forall x y, @?F y x => pose F as C2 + end. + assert (C1 x y) as ?. + assert (C2 y x) as ?. +Abort. + +Goal forall A B C D (p : forall (x : A) (y : B) (z : C), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall x y z, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +Goal forall A B C D (p : forall (z : C) (x : A) (y : B), D x y) (x : A) (y : B), True. +Proof. + intros A B C D p x y. + match type of p with + | forall z x y, @?F x y => pose F as C1 + end. + assert (C1 x y) as ?. +Abort. + +(** Those should fail *) + +Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True. +Proof. + intros A B C p x y. + Fail match type of p with + | forall x, @?F x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x x y => pose F as C1 + end. + Fail match type of p with + | forall x y, @?F x => pose F as C1 + end. +Abort. + +(** This one is badly typed *) + +Goal forall A (B : A -> Type) (C : forall x, B x -> Type), (forall x y, C x y) -> True. +Proof. +intros A B C p. +Fail match type of p with +| forall x y, @?F y x => idtac +end. +Abort. + +Goal forall A (B : A -> Type) (C : Type) (D : forall x, B x -> Type), (forall x (z : C) y, D x y) -> True. +Proof. +intros A B C D p. +match type of p with +| forall x z y, @?F x y => idtac +end. +Abort. diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v new file mode 100644 index 0000000000..f12db8b081 --- /dev/null +++ b/test-suite/success/specialize.v @@ -0,0 +1,126 @@ + +Goal forall a b c : nat, a = b -> b = c -> forall d, a+d=c+d. +intros. + +(* "compatibility" mode: specializing a global name + means a kind of generalize *) + +specialize eq_trans. intros _. +specialize eq_trans with (1:=H)(2:=H0). intros _. +specialize eq_trans with (x:=a)(y:=b)(z:=c). intros _. +specialize eq_trans with (1:=H)(z:=c). intros _. +specialize eq_trans with nat a b c. intros _. +specialize (@eq_trans nat). intros _. +specialize (@eq_trans _ a b c). intros _. +specialize (eq_trans (x:=a)). intros _. +specialize (eq_trans (x:=a)(y:=b)). intros _. +specialize (eq_trans H H0). intros _. +specialize (eq_trans H0 (z:=b)). intros _. + +(* incomplete bindings: y is left quantified and z is instantiated. *) +specialize eq_trans with (x:=a)(z:=c). +intro h. +(* y can be instantiated now *) +specialize h with (y:=b). +(* z was instantiated above so this must fail. *) +Fail specialize h with (z:=c). +clear h. + +(* incomplete bindings: 1st dep hyp is instantiated thus A, x and y + instantiated too. *) +specialize eq_trans with (1:=H). +intro h. +(* 2nd dep hyp can be instantiated now, which instatiates z too. *) +specialize h with (1:=H0). +(* checking that there is no more products in h. *) +match type of h with +| _ = _ => idtac +| _ => fail "specialize test failed: hypothesis h should be an equality at this point" +end. +clear h. + + +(* local "in place" specialization *) +assert (Eq:=eq_trans). + +specialize Eq. +specialize Eq with (1:=H)(2:=H0). Undo. +specialize Eq with (x:=a)(y:=b)(z:=c). Undo. +specialize Eq with (1:=H)(z:=c). Undo. +specialize Eq with nat a b c. Undo. +specialize (Eq nat). Undo. +specialize (Eq _ a b c). Undo. +(* no implicit argument for Eq, hence no (Eq (x:=a)) *) +specialize (Eq _ _ _ _ H H0). Undo. +specialize (Eq _ _ _ b H0). Undo. + +(* incomplete binding *) +specialize Eq with (y:=b). +(* A and y have been instantiated so this works *) +specialize (Eq _ _ H H0). +Undo 2. + +(* incomplete binding (dependent) *) +specialize Eq with (1:=H). +(* A, x and y have been instantiated so this works *) +specialize (Eq _ H0). +Undo 2. + +(* incomplete binding (dependent) *) +specialize Eq with (1:=H) (2:=H0). +(* A, x and y have been instantiated so this works *) +match type of Eq with +| _ = _ => idtac +| _ => fail "specialize test failed: hypothesis Eq should be an equality at this point" +end. +Undo 2. + +(* +(** strange behavior to inspect more precisely *) + +(* 1) proof aspect : let H:= ... in (fun H => ..) H + presque ok... *) + +(* 2) echoue moins lorsque zero premise de mangé *) +specialize eq_trans with (1:=Eq). (* mal typé !! *) + +(* 3) Seems fixed.*) +specialize eq_trans with _ a b c. intros _. +(* Anomaly: Evar ?88 was not declared. Please report. *) +*) + +Abort. + +(* Test use of pose proof and assert as a specialize *) + +Goal True -> (True -> 0=0) -> False -> 0=0. +intros H0 H H1. +pose proof (H I) as H. +(* Check that the hypothesis is in 2nd position by removing the top one *) +match goal with H:_ |- _ => clear H end. +match goal with H:_ |- _ => exact H end. +Qed. + +Goal True -> (True -> 0=0) -> False -> 0=0. +intros H0 H H1. +assert (H:=H I). +(* Check that the hypothesis is in 2nd position by removing the top one *) +match goal with H:_ |- _ => clear H end. +match goal with H:_ |- _ => exact H end. +Qed. + +(* Test specialize as *) + +Goal (forall x, x=0) -> 1=0. +intros. +specialize (H 1) as ->. +reflexivity. +Qed. + +(* A test from corn *) + +Goal (forall x y, x=0 -> y=0 -> True) -> True. +intros. +specialize (fun z => H 0 z eq_refl). +exact (H 0 eq_refl). +Qed. diff --git a/test-suite/success/ssrpattern.v b/test-suite/success/ssrpattern.v new file mode 100644 index 0000000000..96f0bbac92 --- /dev/null +++ b/test-suite/success/ssrpattern.v @@ -0,0 +1,22 @@ +Require Import ssrmatching. + +(*Set Debug SsrMatching.*) + +Tactic Notation "at" "[" ssrpatternarg(pat) "]" tactic(t) := + let name := fresh in + let def_name := fresh in + ssrpattern pat; + intro name; + pose proof (refl_equal name) as def_name; + unfold name at 1 in def_name; + t def_name; + [ rewrite <- def_name | idtac.. ]; + clear name def_name. + +Lemma test (H : True -> True -> 3 = 7) : 28 = 3 * 4. +Proof. +at [ X in X * 4 ] ltac:(fun place => rewrite -> H in place). +- reflexivity. +- trivial. +- trivial. +Qed. diff --git a/test-suite/success/subst.v b/test-suite/success/subst.v new file mode 100644 index 0000000000..25ee81b587 --- /dev/null +++ b/test-suite/success/subst.v @@ -0,0 +1,42 @@ +(* Test various subtleties of the "subst" tactics *) + +(* Should proceed from left to right (see #4222) *) +Goal forall x y, x = y -> x = 3 -> y = 2 -> x = y. +intros. +subst. +change (3 = 2) in H1. +change (3 = 3). +Abort. + +(* Should work with "x = y" and "x = t" equations (see #4214, failed in 8.4) *) +Goal forall x y, x = y -> x = 3 -> x = y. +intros. +subst. +change (3 = 3). +Abort. + +(* Should substitute cycles once, until a recursive equation is obtained *) +(* (failed in 8.4) *) +Goal forall x y, x = S y -> y = S x -> x = y. +intros. +subst. +change (y = S (S y)) in H0. +change (S y = y). +Abort. + +(* A bug revealed by OCaml 4.03 warnings *) +(* fixes in 4e3d464 and 89ec88f for v8.5, 4e3d4646 and 89ec88f1e for v8.6 *) +Goal forall y, let x:=0 in y=x -> y=y. +intros * H; +(* This worked as expected *) +subst. +Fail clear H. +Abort. + +Goal forall y, let x:=0 in x=y -> y=y. +intros * H; +(* Before the fix, this unfolded x instead of + substituting y and erasing H *) +subst. +Fail clear H. +Abort. diff --git a/test-suite/success/telescope_canonical.v b/test-suite/success/telescope_canonical.v new file mode 100644 index 0000000000..73df5ca993 --- /dev/null +++ b/test-suite/success/telescope_canonical.v @@ -0,0 +1,72 @@ +Structure Inner := mkI { is :> Type }. +Structure Outer := mkO { os :> Inner }. +Canonical Structure natInner := mkI nat. +Canonical Structure natOuter := mkO natInner. +Definition hidden_nat := nat. +Axiom P : forall S : Outer, is (os S) -> Prop. +Lemma test1 (n : hidden_nat) : P _ n. +Admitted. + +Structure Pnat := mkP { getp : nat }. +Definition my_getp := getp. +Axiom W : nat -> Prop. + +(* Fix *) +Canonical Structure add1Pnat n := mkP (plus n 1). +Definition test_fix n := (refl_equal _ : W (my_getp _) = W (n + 1)). + +(* Case *) +Definition pred n := match n with 0 => 0 | S m => m end. +Canonical Structure predSS n := mkP (pred n). +Definition test_case x := (refl_equal _ : W (my_getp _) = W (pred x)). +Fail Definition test_case' := (refl_equal _ : W (my_getp _) = W (pred 0)). + +Canonical Structure letPnat' := mkP 0. +Definition letin := (let n := 0 in n). +Definition test4 := (refl_equal _ : W (getp _) = W letin). +Definition test41 := (refl_equal _ : W (my_getp _) = W letin). +Definition letin2 (x : nat) := (let n := x in n). +Canonical Structure letPnat'' x := mkP (letin2 x). +Definition test42 x := (refl_equal _ : W (my_getp _) = W (letin2 x)). +Fail Definition test42' x := (refl_equal _ : W (my_getp _) = W x). + +Structure Morph := mkM { f :> nat -> nat }. +Definition my_f := f. +Axiom Q : (nat -> nat) -> Prop. + +(* Lambda *) +Canonical Structure addMorh x := mkM (plus x). +Definition test_lam x := (refl_equal _ : Q (my_f _) = Q (plus x)). +Definition test_lam' := (refl_equal _ : Q (my_f _) = Q (plus 0)). + +(* Simple tests to justify Sort and Prod as "named". + They are already normal, so they cannot loose their names, + but still... *) +Structure Sot := mkS { T : Type }. +Axiom R : Type -> Prop. +Canonical Structure tsot := mkS (Type). +Definition test_sort := (refl_equal _ : R (T _) = R Type). +Canonical Structure tsot2 := mkS (nat -> nat). +Definition test_prod := (refl_equal _ : R (T _) = R (nat -> nat)). + +(* Var *) +Section Foo. +Variable v : nat. +Definition my_v := v. +Canonical Structure vP := mkP my_v. +Definition test_var := (refl_equal _ : W (getp _) = W my_v). +Canonical Structure vP' := mkP v. +Definition test_var' := (refl_equal _ : W (my_getp _) = W my_v). +End Foo. + +(* Rel *) +Definition test_rel v := (refl_equal _ : W (my_getp _) = W (my_v v)). +Goal True. +pose (x := test_rel 2). +match goal with x := _ : W (my_getp (vP 2)) = _ |- _ => idtac end. +apply I. +Qed. + + + + diff --git a/test-suite/success/transparent_abstract.v b/test-suite/success/transparent_abstract.v new file mode 100644 index 0000000000..ff4509c4a8 --- /dev/null +++ b/test-suite/success/transparent_abstract.v @@ -0,0 +1,21 @@ +Class by_transparent_abstract {T} (x : T) := make_by_transparent_abstract : T. +Hint Extern 0 (@by_transparent_abstract ?T ?x) => change T; transparent_abstract exact_no_check x : typeclass_instances. + +Goal True /\ True. +Proof. + split. + transparent_abstract exact I using foo. + let x := (eval hnf in foo) in constr_eq x I. + let x := constr:(ltac:(constructor) : True) in + let T := type of x in + let x := constr:(_ : by_transparent_abstract x) in + let x := (eval cbv delta [by_transparent_abstract] in (let y : T := x in y)) in + pose x as x'. + simpl in x'. + let v := eval cbv [x'] in x' in tryif constr_eq v I then fail 0 else idtac. + hnf in x'. + let v := eval cbv [x'] in x' in tryif constr_eq v I then idtac else fail 0. + exact x'. +Defined. +Check eq_refl : I = foo. +Eval compute in foo. diff --git a/test-suite/success/tryif.v b/test-suite/success/tryif.v new file mode 100644 index 0000000000..4394bddb3d --- /dev/null +++ b/test-suite/success/tryif.v @@ -0,0 +1,50 @@ +Require Import TestSuite.admit. + +(** [not tac] is equivalent to [fail tac "succeeds"] if [tac] succeeds, and is equivalent to [idtac] if [tac] fails *) +Tactic Notation "not" tactic3(tac) := + (tryif tac then fail 0 tac "succeeds" else idtac); (* error if the tactic solved all goals *) []. + +(** Test if a tactic succeeds, but always roll-back the results *) +Tactic Notation "test" tactic3(tac) := tryif not tac then fail 0 tac "fails" else idtac. + +Goal Set. +Proof. + not fail. + not not idtac. + not fail 0. + (** Would be nice if we could get [not fail 1] to pass, maybe *) + not not admit. + not not test admit. + not progress test admit. + (* test grouping *) + not (not idtac; fail). + assert True. + all:not fail. + 2:not fail. + all:admit. +Defined. + +Goal Set. +Proof. + test idtac. + test try fail. + test admit. + test match goal with |- Set => idtac end. + test (idtac; match goal with |- Set => idtac end). + (* test grouping *) + first [ (test idtac; fail); fail 1 | idtac ]. + try test fail. + try test test fail. + test test idtac. + test test admit. + Fail test fail. + test (idtac; []). + test (assert True; [|]). + (* would be nice, perhaps, if we could catch [fail 1] and not just [fail 0] this *) + try ((test fail); fail 1). + assert True. + all:test idtac. + all:test admit. + 2:test admit. + all:admit. +Defined. diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v new file mode 100644 index 0000000000..72f0d94dea --- /dev/null +++ b/test-suite/success/unfold.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(* Test le Hint Unfold sur des var locales *) + +Section toto. +Let EQ := @eq. +Goal EQ nat 0 0. +Hint Unfold EQ. +auto. +Qed. + +(* Check regular failure when statically existing ref does not exist + any longer at run time *) + +Goal let x := 0 in True. +intro x. +Fail (clear x; unfold x). +Abort. +End toto. diff --git a/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v new file mode 100644 index 0000000000..50a65310d1 --- /dev/null +++ b/test-suite/success/unicode_utf8.v @@ -0,0 +1,105 @@ +(** PARSER TESTS *) + +(** Check correct separation of identifiers followed by unicode symbols *) +Notation "x ⊕ w" := (plus x w) (at level 30). +Check fun x => x⊕x. + +(** Check Greek letters *) +Definition test_greek : nat -> nat := fun Δ => Δ. +Parameter ℝ : Set. +Parameter π : ℝ. + +(** Check indices *) +Definition test_indices : nat -> nat := fun x₁ => x₁. +Definition π₂ := @snd. + +(** More unicode in identifiers *) +Definition αβ_áà_אב := 0. + +Notation "C 'ᵒᵖ'" := C (at level 30). + +(** UNICODE IN STRINGS *) + +Require Import List Ascii String. +Open Scope string_scope. + +Definition test_string := "azertyαβ∀ééé". +Eval compute in length test_string. + (** last six "chars" are unicode, hence represented by 2 bytes, + except the forall which is 3 bytes *) + +Fixpoint string_to_list s := + match s with + | EmptyString => nil + | String c s => c :: string_to_list s + end. + +Eval compute in (string_to_list test_string). + (** for instance, α is \206\177 whereas ∀ is \226\136\128 *) +Close Scope string_scope. + + + +(** INTERFACE TESTS *) + +Require Import Utf8. + +(** Printing of unicode notation, in *goals* *) +Lemma test : forall A:Prop, A -> A. +Proof. +auto. +Qed. + +(** Parsing of unicode notation, in *goals* *) +Lemma test2 : ∀A:Prop, A → A. +Proof. +intro. +intro. +auto. +Qed. + +(** Printing of unicode notation, in *response* *) +Check fun (X:Type)(x:X) => x. + +(** Parsing of unicode notation, in *response* *) +Check ∀Δ, Δ → Δ. +Check ∀x, x=0 ∨ x=0 → x=0. + + +(** ISSUES: *) + +Notation "x ≠ y" := (x<>y) (at level 70). + +Notation "x ≤ y" := (x<=y) (at level 70, no associativity). + +(** First Issue : ≤ is attached to "le" of nat, not to notation <= *) + +Require Import ZArith. +Open Scope Z_scope. +Locate "≤". (* still le, not Z.le *) +Notation "x ≤ y" := (x<=y) (at level 70, no associativity). +Locate "≤". +Close Scope Z_scope. + +(** ==> How to proceed modularly ? *) + + +(** Second Issue : notation for -> generates useless parenthesis + if followed by a binder *) + +Check 0≠0 → ∀x:nat,x=x. + +(** Example of real situation : *) + +Definition pred : ∀x, x≠0 → ∃y, x = S y. +Proof. +destruct x. +destruct 1; auto. +intros _. +exists x; auto. +Defined. + +Print pred. + + + diff --git a/test-suite/success/unidecls.v b/test-suite/success/unidecls.v new file mode 100644 index 0000000000..1bc565cbb5 --- /dev/null +++ b/test-suite/success/unidecls.v @@ -0,0 +1,122 @@ +(* -*- coq-prog-args: ("-top" "unidecls"); -*- *) +Set Printing Universes. + +Module decls. + Universes a b. +End decls. + +Universe a. + +Constraint a < decls.a. + +Print Universes. + +(** These are different universes *) +Check Type@{a}. +Check Type@{decls.a}. + +Check Type@{decls.b}. + +Fail Check Type@{decls.c}. + +Fail Check Type@{i}. +Universe foo. +Module Foo. + (** Already declared globaly: but universe names are scoped at the module level *) + Universe foo. + Universe bar. + + Check Type@{Foo.foo}. + Definition bar := 0. +End Foo. + +(** Already declared in the module *) +Universe bar. + +(** Accessible outside the module: universe declarations are global *) +Check Type@{bar}. +Check Type@{Foo.bar}. + +Check Type@{Foo.foo}. +(** The same *) +Check Type@{foo}. +Check Type@{unidecls.foo}. + +Universe secfoo. +Section Foo'. + Fail Universe secfoo. + Universe secfoo2. + Fail Check Type@{Foo'.secfoo2}. + Check Type@{secfoo2}. + Constraint secfoo2 < a. +End Foo'. + +Check Type@{secfoo2}. +Fail Check eq_refl : Type@{secfoo2} = Type@{a}. + +(** Below, u and v are global, fixed universes *) +Module Type Arg. + Universe u. + Parameter T: Type@{u}. +End Arg. + +Module Fn(A : Arg). + Universes v. + + Check Type@{A.u}. + Constraint A.u < v. + + Definition foo : Type@{v} := nat. + Definition bar : Type@{A.u} := nat. + + Fail Definition foo(A : Type@{v}) : Type@{A.u} := A. +End Fn. + +Module ArgImpl : Arg. + Definition T := nat. +End ArgImpl. + +Module ArgImpl2 : Arg. + Definition T := bool. +End ArgImpl2. + +(** Two applications of the functor result in the exact same universes *) +Module FnApp := Fn(ArgImpl). + +Check Type@{FnApp.v}. +Check FnApp.foo. +Check FnApp.bar. + +Check (eq_refl : Type@{ArgImpl.u} = Type@{ArgImpl2.u}). + +Module FnApp2 := Fn(ArgImpl). +Check Type@{FnApp2.v}. +Check FnApp2.foo. +Check FnApp2.bar. + +Import ArgImpl2. +(** Now u refers to ArgImpl.u and ArgImpl2.u *) +Check FnApp2.bar. + +(** It can be shadowed *) +Universe u. + +(** This refers to the qualified name *) +Check FnApp2.bar. + +Constraint u = ArgImpl.u. +Print Universes. + +Set Universe Polymorphism. + +Section PS. + Universe poly. + + Definition id (A : Type@{poly}) (a : A) : A := a. +End PS. +(** The universe is polymorphic and discharged, does not persist *) +Fail Check Type@{poly}. + +Print Universes. +Check id nat. +Check id@{Set}. diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v new file mode 100644 index 0000000000..1ffc026730 --- /dev/null +++ b/test-suite/success/unification.v @@ -0,0 +1,201 @@ +Let test_stack_unification_interaction_with_delta A + : (if negb _ then true else false) = if orb false (negb A) then true else false + := eq_refl. + +(* Test patterns unification *) + +Lemma l1 : (forall P, (exists x:nat, P x) -> False) + -> forall P, (exists x:nat, P x /\ P x) -> False. +Proof. +intros; apply (H _ H0). +Qed. + +Lemma l2 : forall A:Set, forall Q:A->Set, + (forall (P: forall x:A, Q x -> Prop), + (exists x:A, exists y:Q x, P x y) -> False) + -> forall (P: forall x:A, Q x -> Prop), + (exists x:A, exists y:Q x, P x y /\ P x y) -> False. +Proof. +intros; apply (H _ H0). +Qed. + +Lemma l3 : (forall P, ~(exists x:nat, P x)) + -> forall P:nat->Prop, ~(exists x:nat, P x -> P x). +Proof. +intros; apply H. +Qed. + + (* Feature introduced June 2011 *) + +Lemma l7 : forall x (P:nat->Prop), (forall f, P (f x)) -> P (x+x). +Proof. +intros x P H; apply H. +Qed. + +(* Example submitted for Zenon *) + +Axiom zenon_noteq : forall T : Type, forall t : T, ((t <> t) -> False). +Axiom zenon_notall : forall T : Type, forall P : T -> Prop, + (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). + + (* Must infer "P := fun x => x=x" in zenon_notall *) +Check (fun _h1 => (zenon_notall nat _ (fun _T_0 => + (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)). + + +(* Core of an example submitted by Ralph Matthes (BZ#849) + + It used to fail because of the K-variable x in the type of "sum_rec ..." + which was not in the scope of the evar ?B. Solved by a head + beta-reduction of the type "(fun _ : unit + unit => L unit) x" of + "sum_rec ...". Shall we used more reduction when solving evars (in + real_clean)?? Is there a risk of starting too long reductions? + + Note that the example originally came from a non re-typable + pretty-printed term (the checked term is actually re-printed the + same form it is checked). +*) + +Set Implicit Arguments. +Inductive L (A:Set) : Set := c : A -> L A. +Parameter f: forall (A:Set)(B:Set), (A->B) -> L A -> L B. +Parameter t: L (unit + unit). + +Check (f (fun x : unit + unit => + sum_rec (fun _ : unit + unit => L unit) + (fun y => c y) (fun y => c y) x) t). + + +(* Test patterns unification in apply *) + +Require Import Arith. +Parameter x y : nat. +Parameter G:x=y->x=y->Prop. +Parameter K:x<>y->x<>y->Prop. +Lemma l4 : (forall f:x=y->Prop, forall g:x<>y->Prop, + match eq_nat_dec x y with left a => f a | right a => g a end) + -> match eq_nat_dec x y with left a => G a a | right a => K a a end. +Proof. +intros. +apply H. +Qed. + + +(* Test unification modulo eta-expansion (if possible) *) + +(* In this example, two instances for ?P (argument of hypothesis H) can be + inferred (one is by unifying the type [Q true] and [?P true] of the + goal and type of [H]; the other is by unifying the argument of [f]); + we need to unify both instances up to allowed eta-expansions of the + instances (eta is allowed if the meta was applied to arguments) + + This used to fail before revision 9389 in trunk +*) + +Lemma l5 : + forall f : (forall P, P true), (forall P, f P = f P) -> + forall Q, f (fun x => Q x) = f (fun x => Q x). +Proof. +intros. +apply H. +Qed. + +(* Feature deactivated in commit 14189 (see commit log) +(* Test instantiation of evars by unification *) + +Goal (forall x, 0 + x = 0 -> True) -> True. +intros; eapply H. +rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *) +Abort. +*) + +(* Check handling of identity equation between evars *) +(* The example failed to pass until revision 10623 *) + +Lemma l6 : + (forall y, (forall x, (forall z, y = 0 -> y + z = 0) -> y + x = 0) -> True) + -> True. +intros. +eapply H. +intros. +apply H0. (* Check that equation ?n[H] = ?n[H] is correctly considered true *) +reflexivity. +Qed. + +(* Check treatment of metas erased by K-redexes at the time of turning + them to evas *) + +Inductive nonemptyT (t : Type) : Prop := nonemptyT_intro : t -> nonemptyT t. +Goal True. +try case nonemptyT_intro. (* check that it fails w/o anomaly *) +Abort. + +(* Test handling of return type and when it is decided to make the + predicate dependent or not - see "bug" BZ#1851 *) + +Goal forall X (a:X) (f':nat -> X), (exists f : nat -> X, True). +intros. +exists (fun n => match n with O => a | S n' => f' n' end). +constructor. +Qed. + +(* Check use of types in unification (see Andrej Bauer's mail on + coq-club, June 1 2009; it did not work in 8.2, probably started to + work after Sozeau improved support for the use of types in unification) *) + +Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) -> + forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f. +Proof. + intros. + rewrite H with (f:=f0). +Abort. + +(* Three tests provided by Dan Grayson as part of a custom patch he + made for a more powerful "destruct" for handling Voevodsky's + Univalent Foundations. The test checks if second-order matching in + tactic unification is able to guess by itself on which dependent + terms to abstract so that the elimination predicate is well-typed *) + +Definition test1 (X : Type) (x : X) (fxe : forall x1 : X, identity x1 x1) : + identity (fxe x) (fxe x). +Proof. destruct (fxe x). apply identity_refl. Defined. + +(* a harder example *) + +Definition UU := Type . +Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t. +Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := newfoo : foo x0 x0. +Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo x0 x1 -> foo x0 x1. +Proof. intros t. exact t. Defined. + +Lemma test2 (T:UU) (t:T) (k : foo t t) : paths k (idonfoo k). +Proof. + destruct k. + apply idpath. +Defined. + +(* an example with two constructors *) + +Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := +| newfoo1 : foo' x0 x0 +| newfoo2 : foo' x0 x0 . +Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} : + foo' x0 x1 -> foo' x0 x1. +Proof. intros t. exact t. Defined. +Lemma test3 (T:UU) (t:T) (k : foo' t t) : paths k (idonfoo' k). +Proof. + destruct k. + apply idpath. + apply idpath. +Defined. + +(* An example where it is necessary to evar-normalize the instance of + an evar to evaluate if it is a pattern *) + +Check + let a := ?[P] in + fun (H : forall y (P : nat -> Prop), y = 0 -> P y) + x (p:x=0) => + H ?[y] a p : x = 0. +(* We have to solve "?P ?y[x] == x = 0" knowing from + "p : (x=0) == (?y[x] = 0)" that "?y := x" *) diff --git a/test-suite/success/uniform_inductive_parameters.v b/test-suite/success/uniform_inductive_parameters.v new file mode 100644 index 0000000000..42236a5313 --- /dev/null +++ b/test-suite/success/uniform_inductive_parameters.v @@ -0,0 +1,13 @@ +Set Uniform Inductive Parameters. + +Inductive list (A : Type) := + | nil : list + | cons : A -> list -> list. +Check (list : Type -> Type). +Check (cons : forall A, A -> list A -> list A). + +Inductive list2 (A : Type) (A' := prod A A) := + | nil2 : list2 + | cons2 : A' -> list2 -> list2. +Check (list2 : Type -> Type). +Check (cons2 : forall A (A' := prod A A), A' -> list2 A -> list2 A). diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v new file mode 100644 index 0000000000..28426b5700 --- /dev/null +++ b/test-suite/success/univers.v @@ -0,0 +1,78 @@ +(* This requires cumulativity *) + +Definition Type2 := Type. +Definition Type1 : Type2 := Type. + +Lemma lem1 : (True -> Type1) -> Type2. +intro H. +apply H. +exact I. +Qed. + +Lemma lem2 : + forall (A : Type) (P : A -> Type) (x : A), + (forall y : A, x = y -> P y) -> P x. +auto. +Qed. + +Lemma lem3 : forall P : Prop, P. +intro P; pattern P. +apply lem2. +Abort. + +(* Check managing of universe constraints in inversion (BZ#855) *) + +Inductive dep_eq : forall X : Type, X -> X -> Prop := + | intro_eq : forall (X : Type) (f : X), dep_eq X f f + | intro_feq : + forall (A : Type) (B : A -> Type), + let T := forall x : A, B x in + forall (f g : T) (x : A), dep_eq (B x) (f x) (g x) -> dep_eq T f g. + +Require Import Relations. + +Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X). +Proof. + unfold transitive. + intros X f g h H1 H2. + inversion H1. +Abort. + + +(* Submitted by Bas Spitters (BZ#935) *) + +(* This is a problem with the status of the type in LetIn: is it a + user-provided one or an inferred one? At the current time, the + kernel type-check the type in LetIn, which means that it must be + considered as user-provided when calling the kernel. However, in + practice it is inferred so that a universe refresh is needed to set + its status as "user-provided". + + Especially, universe refreshing was not done for "set/pose" *) + +Lemma ind_unsec : forall Q : nat -> Type, True. +intro. +set (C := forall m, Q m -> Q m). +exact I. +Qed. + +(* Submitted by Danko Ilik (bug report #1507); related to LetIn *) + +Record U : Type := { A:=Type; a:A }. + +(** Check assignment of sorts to inductives and records. *) + +Variable sh : list nat. + +Definition is_box_in_shape (b :nat * nat) := True. +Definition myType := Type. + +Module Ind. +Inductive box_in : myType := + myBox (coord : nat * nat) (_ : is_box_in_shape coord) : box_in. +End Ind. + +Module Rec. +Record box_in : myType := + BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. +End Rec. diff --git a/test-suite/success/universes_coercion.v b/test-suite/success/universes_coercion.v new file mode 100644 index 0000000000..272d3ec74a --- /dev/null +++ b/test-suite/success/universes_coercion.v @@ -0,0 +1,22 @@ +(* This example used to emphasize the absence of LEGO-style universe + polymorphism; Matthieu's improvements of typing on 2011/3/11 now + makes (apparently) that Amokrane's automatic eta-expansion in the + coercion mechanism works; this makes its illustration as a "weakness" + of universe polymorphism obsolete (example submitted by Randy Pollack). + + Note that this example is not an evidence that the current + non-kernel eta-expansion behavior is the most expected one. +*) + +Parameter K : forall T : Type, T -> T. +Check (K (forall T : Type, T -> T) K). + +(* + note that the inferred term is + "(K (forall T (* u1 *) : Type, T -> T) (fun T:Type (* u1 *) => K T))" + which is not eta-equivalent to + "(K (forall T : Type, T -> T) K" + because the eta-expansion of the latter + "(K (forall T : Type, T -> T) (fun T:Type (* u2 *) => K T)" + assuming K of type "forall T (* u2 *) : Type, T -> T" +*) diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v new file mode 100644 index 0000000000..fe3b8c1d7c --- /dev/null +++ b/test-suite/success/univnames.v @@ -0,0 +1,37 @@ +Set Universe Polymorphism. + +Definition foo@{i j} (A : Type@{i}) (B : Type@{j}) := A. + +Set Printing Universes. + +Fail Definition bar@{i} (A : Type@{i}) (B : Type) := A. + +Definition baz@{i j} (A : Type@{i}) (B : Type@{j}) := (A * B)%type. + +Fail Definition bad@{i j} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Fail Definition bad@{i} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Definition shuffle@{i j} (A : Type@{j}) (B : Type@{i}) := (A * B)%type. + +Definition nothing (A : Type) := A. + +Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. + +Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. + + +Class Wrap A := wrap : A. + +Fail Instance bad@{} : Wrap Type := Type. + +Instance bad@{} : Wrap Type. +Fail Proof Type. +Abort. + +Instance bar@{u} : Wrap@{u} Set. Proof nat. + + +Monomorphic Universe g. + +Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'. diff --git a/test-suite/success/univscompute.v b/test-suite/success/univscompute.v new file mode 100644 index 0000000000..1d60ab360c --- /dev/null +++ b/test-suite/success/univscompute.v @@ -0,0 +1,32 @@ +Set Universe Polymorphism. + +Polymorphic Definition id {A : Type} (a : A) := a. + +Eval vm_compute in id 1. + +Polymorphic Inductive ind (A : Type) := cons : A -> ind A. + +Eval vm_compute in ind unit. + +Check ind unit. + +Eval vm_compute in ind unit. + +Definition bar := Eval vm_compute in ind unit. +Definition bar' := Eval vm_compute in id (cons _ tt). + +Definition bar'' := Eval native_compute in id 1. +Definition bar''' := Eval native_compute in id (cons _ tt). + +Definition barty := Eval native_compute in id (cons _ Set). + +Definition one := @id. + +Monomorphic Definition sec := one. + +Eval native_compute in sec. +Definition sec' := Eval native_compute in sec. +Eval vm_compute in sec. +Definition sec'' := Eval vm_compute in sec. + + diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v new file mode 100644 index 0000000000..a4fa544cd9 --- /dev/null +++ b/test-suite/success/unshelve.v @@ -0,0 +1,19 @@ +Axiom F : forall (b : bool), b = true -> + forall (i : unit), i = i -> True. + +Goal True. +Proof. +unshelve (refine (F _ _ _ _)). ++ exact true. ++ exact tt. ++ exact (@eq_refl bool true). ++ exact (@eq_refl unit tt). +Qed. + +(* This was failing in 8.6, because of ?a:nat being wrongly duplicated *) + +Goal (forall a : nat, a = 0 -> True) -> True. +intros F. +unshelve (eapply (F _);clear F). +2:reflexivity. +Qed. diff --git a/test-suite/success/vm_evars.v b/test-suite/success/vm_evars.v new file mode 100644 index 0000000000..2c8b099ef0 --- /dev/null +++ b/test-suite/success/vm_evars.v @@ -0,0 +1,23 @@ +Fixpoint iter {A} (n : nat) (f : A -> A) (x : A) := +match n with +| 0 => x +| S n => iter n f (f x) +end. + +Goal nat -> True. +Proof. +intros n. +evar (f : nat -> nat). +cut (iter 10 f 0 = 0). +vm_compute. +intros; constructor. +instantiate (f := (fun x => x)). +reflexivity. +Qed. + +Goal exists x, x = 5 + 5. +Proof. + eexists. + vm_compute. + reflexivity. +Qed. diff --git a/test-suite/success/vm_records.v b/test-suite/success/vm_records.v new file mode 100644 index 0000000000..8a1544c8ea --- /dev/null +++ b/test-suite/success/vm_records.v @@ -0,0 +1,40 @@ +Set Primitive Projections. + +Module M. + +CoInductive foo := Foo { + foo0 : foo; + foo1 : bar; +} +with bar := Bar { + bar0 : foo; + bar1 : bar; +}. + +CoFixpoint f : foo := Foo f g +with g : bar := Bar f g. + +Check (@eq_refl _ g.(bar0) <: f.(foo0).(foo0) = g.(bar0)). +Check (@eq_refl _ g <: g.(bar1).(bar0).(foo1) = g). + +End M. + +Module N. + +Inductive foo := Foo { + foo0 : option foo; + foo1 : list bar; +} +with bar := Bar { + bar0 : option bar; + bar1 : list foo; +}. + +Definition f_0 := Foo None nil. +Definition g_0 := Bar None nil. + +Definition f := Foo (Some f_0) (cons g_0 nil). + +Check (@eq_refl _ f.(foo1) <: f.(foo1) = cons g_0 nil). + +End N. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 0000000000..62df96c0b8 --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption T +| PNone : poption T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist T -> plist T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap ls) + end. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree T) -> Tree T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 0000000000..abe6d0fe07 --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. |