" \
> $$tmpoutput; \
diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \
if [ $$R = 0 ]; then \
diff --git a/test-suite/_CoqProject b/test-suite/_CoqProject
new file mode 100644
index 00000000..dc121311
--- /dev/null
+++ b/test-suite/_CoqProject
@@ -0,0 +1 @@
+-Q prerequisite TestSuite
diff --git a/test-suite/bugs/closed/1704.v b/test-suite/bugs/closed/1704.v
index 4b02d5f9..7d8ba5b8 100644
--- a/test-suite/bugs/closed/1704.v
+++ b/test-suite/bugs/closed/1704.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import Setoid.
Parameter E : nat -> nat -> Prop.
diff --git a/test-suite/bugs/closed/2378.v b/test-suite/bugs/closed/2378.v
index 35c69db2..85ad41d1 100644
--- a/test-suite/bugs/closed/2378.v
+++ b/test-suite/bugs/closed/2378.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* test with Coq 8.3rc1 *)
Require Import Program.
diff --git a/test-suite/bugs/closed/2406.v b/test-suite/bugs/closed/2406.v
index 1bd66ffc..3766e795 100644
--- a/test-suite/bugs/closed/2406.v
+++ b/test-suite/bugs/closed/2406.v
@@ -1,6 +1,6 @@
(* Check correct handling of unsupported notations *)
Notation "''" := (fun x => x) (at level 20).
-(* This fails with a syntax error but it is not catched by Fail
+(* This fails with a syntax error but it is not caught by Fail
Fail Definition crash_the_rooster f := .
*)
diff --git a/test-suite/bugs/closed/2456.v b/test-suite/bugs/closed/2456.v
deleted file mode 100644
index 56f046c4..00000000
--- a/test-suite/bugs/closed/2456.v
+++ /dev/null
@@ -1,53 +0,0 @@
-
-Require Import Equality.
-
-Parameter Patch : nat -> nat -> Set.
-
-Inductive Catch (from to : nat) : Type
- := MkCatch : forall (p : Patch from to),
- Catch from to.
-Implicit Arguments MkCatch [from to].
-
-Inductive CatchCommute5
- : forall {from mid1 mid2 to : nat},
- Catch from mid1
- -> Catch mid1 to
- -> Catch from mid2
- -> Catch mid2 to
- -> Prop
- := MkCatchCommute5 :
- forall {from mid1 mid2 to : nat}
- (p : Patch from mid1)
- (q : Patch mid1 to)
- (q' : Patch from mid2)
- (p' : Patch mid2 to),
- CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p').
-
-Inductive CatchCommute {from mid1 mid2 to : nat}
- (p : Catch from mid1)
- (q : Catch mid1 to)
- (q' : Catch from mid2)
- (p' : Catch mid2 to)
- : Prop
- := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'),
- CatchCommute p q q' p'.
-Notation "<< p , q >> <~> << q' , p' >>"
- := (CatchCommute p q q' p')
- (at level 60, no associativity).
-
-Lemma CatchCommuteUnique2 :
- forall {from mid mid' to : nat}
- {p : Catch from mid} {q : Catch mid to}
- {q' : Catch from mid'} {p' : Catch mid' to}
- {q'' : Catch from mid'} {p'' : Catch mid' to}
- (commute1 : <> <~> <>)
- (commute2 : <> <~> <>),
- (p' = p'') /\ (q' = q'').
-Proof with auto.
-intros.
-set (X := commute2).
-dependent destruction commute1;
-dependent destruction catchCommuteDetails;
-dependent destruction commute2;
-dependent destruction catchCommuteDetails generalizing X.
-Admitted.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/2473.v b/test-suite/bugs/closed/2473.v
index 4c302512..fb676c7e 100644
--- a/test-suite/bugs/closed/2473.v
+++ b/test-suite/bugs/closed/2473.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import Relations Program Setoid Morphisms.
diff --git a/test-suite/bugs/closed/2590.v b/test-suite/bugs/closed/2590.v
new file mode 100644
index 00000000..4300de16
--- /dev/null
+++ b/test-suite/bugs/closed/2590.v
@@ -0,0 +1,20 @@
+Require Import TestSuite.admit.
+Require Import Relation_Definitions RelationClasses Setoid SetoidClass.
+
+Section Bug.
+
+ Context {A : Type} (R : relation A).
+ Hypothesis pre : PreOrder R.
+ Context `{SA : Setoid A}.
+
+ Goal True.
+ set (SA' := SA).
+ assert ( forall SA0 : Setoid A,
+ @PartialOrder A (@equiv A SA0) (@setoid_equiv A SA0) R pre ).
+ rename SA into SA0.
+ intro SA.
+ admit.
+ admit.
+Qed.
+End Bug.
+
diff --git a/test-suite/bugs/closed/2602.v b/test-suite/bugs/closed/2602.v
new file mode 100644
index 00000000..f0744788
--- /dev/null
+++ b/test-suite/bugs/closed/2602.v
@@ -0,0 +1,8 @@
+Goal exists m, S m > 0.
+eexists.
+match goal with
+ | |- context [ S ?a ] =>
+ match goal with
+ | |- S a > 0 => idtac
+ end
+end.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/2613.v b/test-suite/bugs/closed/2613.v
index 4f0470b1..15f3bf52 100644
--- a/test-suite/bugs/closed/2613.v
+++ b/test-suite/bugs/closed/2613.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *)
Require Import ZArith.
diff --git a/test-suite/bugs/closed/2615.v b/test-suite/bugs/closed/2615.v
index dde6a6a5..38c1cfc8 100644
--- a/test-suite/bugs/closed/2615.v
+++ b/test-suite/bugs/closed/2615.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* This failed with an anomaly in pre-8.4 because of let-in not
properly taken into account in the test for unification pattern *)
diff --git a/test-suite/bugs/closed/2775.v b/test-suite/bugs/closed/2775.v
new file mode 100644
index 00000000..f1f384bd
--- /dev/null
+++ b/test-suite/bugs/closed/2775.v
@@ -0,0 +1,6 @@
+Inductive typ : forall (T:Type), list T -> Type -> Prop :=
+ | Get : forall (T:Type) (l:list T), typ T l T.
+
+
+Derive Inversion inv with
+(forall (X: Type) (y: list nat), typ nat y X) Sort Prop.
diff --git a/test-suite/bugs/closed/2830.v b/test-suite/bugs/closed/2830.v
index b72c821d..bb607b78 100644
--- a/test-suite/bugs/closed/2830.v
+++ b/test-suite/bugs/closed/2830.v
@@ -123,6 +123,7 @@ Module C.
Reserved Notation "a ~> b" (at level 70, right associativity).
Reserved Notation "a ≈ b" (at level 54).
+Reserved Notation "a ∘ b" (at level 50, left associativity).
Generalizable All Variables.
Class Category (Object:Type) (Hom:Object -> Object -> Type) := {
diff --git a/test-suite/bugs/closed/2883.v b/test-suite/bugs/closed/2883.v
index 5a5d90a4..f027b5eb 100644
--- a/test-suite/bugs/closed/2883.v
+++ b/test-suite/bugs/closed/2883.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import List.
Require Import Coq.Program.Equality.
diff --git a/test-suite/bugs/closed/2946.v b/test-suite/bugs/closed/2946.v
new file mode 100644
index 00000000..d8138e14
--- /dev/null
+++ b/test-suite/bugs/closed/2946.v
@@ -0,0 +1,8 @@
+Lemma toto (E : nat -> nat -> Prop) (x y : nat)
+ (Ex_ : forall z, E x z) (E_y : forall z, E z y) : True.
+
+(* OK *)
+assert (pairE1 := let Exy := _ in (Ex_ y, E_y _) : Exy * Exy).
+
+(* FAIL *)
+assert (pairE2 := let Exy := _ in (Ex_ _, E_y x) : Exy * Exy).
diff --git a/test-suite/bugs/closed/2951.v b/test-suite/bugs/closed/2951.v
new file mode 100644
index 00000000..87d54441
--- /dev/null
+++ b/test-suite/bugs/closed/2951.v
@@ -0,0 +1,2 @@
+Record C (A: Type) : Type := { f: A }.
+Existing Class C.
diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v
index ff75a1f3..a03adbd7 100644
--- a/test-suite/bugs/closed/2969.v
+++ b/test-suite/bugs/closed/2969.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* Check that Goal.V82.byps and Goal.V82.env are consistent *)
(* This is a shorten variant of the initial bug which raised anomaly *)
diff --git a/test-suite/bugs/closed/2996.v b/test-suite/bugs/closed/2996.v
index 440cda61..d5409289 100644
--- a/test-suite/bugs/closed/2996.v
+++ b/test-suite/bugs/closed/2996.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* Test on definitions referring to section variables that are not any
longer in the current context *)
diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v
index 03e5af61..ced6d959 100644
--- a/test-suite/bugs/closed/3068.v
+++ b/test-suite/bugs/closed/3068.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Section Counted_list.
Variable A : Type.
diff --git a/test-suite/bugs/closed/3071.v b/test-suite/bugs/closed/3071.v
new file mode 100644
index 00000000..53c2ef7b
--- /dev/null
+++ b/test-suite/bugs/closed/3071.v
@@ -0,0 +1,5 @@
+Definition foo := True.
+
+Section foo.
+ Global Arguments foo / .
+End foo.
diff --git a/test-suite/bugs/closed/3199.v b/test-suite/bugs/closed/3199.v
new file mode 100644
index 00000000..08bf6249
--- /dev/null
+++ b/test-suite/bugs/closed/3199.v
@@ -0,0 +1,18 @@
+Axiom P : nat -> Prop.
+Axiom admit : forall n : nat, P n -> P n -> n = S n.
+Axiom foo : forall n, P n.
+
+Create HintDb bar.
+Hint Extern 3 => symmetry : bar.
+Hint Resolve admit : bar.
+Hint Immediate foo : bar.
+
+Lemma qux : forall n : nat, n = S n.
+Proof.
+intros n.
+eauto with bar.
+Defined.
+
+Goal True.
+pose (e := eq_refl (qux 0)); unfold qux in e.
+match type of e with context [eq_sym] => fail 1 | _ => idtac end.
diff --git a/test-suite/bugs/closed/3210.v b/test-suite/bugs/closed/3210.v
new file mode 100644
index 00000000..bb673f38
--- /dev/null
+++ b/test-suite/bugs/closed/3210.v
@@ -0,0 +1,22 @@
+(* Test support of let-in in arity of inductive types *)
+
+Inductive Foo : let X := Set in X :=
+| I : Foo.
+
+Definition foo (x : Foo) : bool :=
+ match x with
+ I => true
+ end.
+
+Definition foo' (x : Foo) : x = x.
+case x.
+match goal with |- I = I => idtac end. (* check form of the goal *)
+Undo 2.
+elim x.
+match goal with |- I = I => idtac end. (* check form of the goal *)
+Undo 2.
+induction x.
+match goal with |- I = I => idtac end. (* check form of the goal *)
+Undo 2.
+destruct x.
+match goal with |- I = I => idtac end. (* check form of the goal *)
diff --git a/test-suite/bugs/closed/3249.v b/test-suite/bugs/closed/3249.v
new file mode 100644
index 00000000..d41d2317
--- /dev/null
+++ b/test-suite/bugs/closed/3249.v
@@ -0,0 +1,11 @@
+Set Implicit Arguments.
+
+Ltac ret_and_left T :=
+ let t := type of T in
+ lazymatch eval hnf in t with
+ | ?a /\ ?b => constr:(proj1 T)
+ | forall x : ?T', @?f x =>
+ constr:(fun x : T' => $(let fx := constr:(T x) in
+ let t := ret_and_left fx in
+ exact t)$)
+ end.
diff --git a/test-suite/bugs/closed/3258.v b/test-suite/bugs/closed/3258.v
index a1390e30..b263c6ba 100644
--- a/test-suite/bugs/closed/3258.v
+++ b/test-suite/bugs/closed/3258.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid.
Global Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/3259.v b/test-suite/bugs/closed/3259.v
index 0306c686..aa91fc3d 100644
--- a/test-suite/bugs/closed/3259.v
+++ b/test-suite/bugs/closed/3259.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Goal forall m n, n+n = m+m -> m+m = m+m.
Proof.
intros.
diff --git a/test-suite/bugs/closed/3298.v b/test-suite/bugs/closed/3298.v
new file mode 100644
index 00000000..f07ee1e6
--- /dev/null
+++ b/test-suite/bugs/closed/3298.v
@@ -0,0 +1,22 @@
+Require Import TestSuite.admit.
+Module JGross.
+ Hint Extern 1 => match goal with |- match ?E with end => case E end.
+
+ Goal forall H : False, match H return Set with end.
+ Proof.
+ intros.
+ solve [ eauto ].
+ Qed.
+End JGross.
+
+Section BenDelaware.
+ Hint Extern 0 => admit.
+ Goal forall (H : False), id (match H return Set with end).
+ Proof.
+ eauto.
+ Qed.
+ Goal forall (H : False), match H return Set with end.
+ Proof.
+ solve [ eauto ] .
+ Qed.
+End BenDelaware.
diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v
index fcebdec7..98043157 100644
--- a/test-suite/bugs/closed/3309.v
+++ b/test-suite/bugs/closed/3309.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *)
(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *)
Set Universe Polymorphism.
@@ -321,6 +322,13 @@ Definition ispartlbinopabmonoidfracrel_type : Type :=
forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ),
@abmonoidfracrel X A ( ( admit + z ) )admit.
-Axiom ispartlbinopabmonoidfracrel : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in
+Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in
+ ispartlbinopabmonoidfracrel_type in exact t)$.
+
+Unset Kernel Term Sharing.
+
+Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit.
+
+Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in
ispartlbinopabmonoidfracrel_type in exact t)$.
diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v
index 64786263..e63c46da 100644
--- a/test-suite/bugs/closed/3314.v
+++ b/test-suite/bugs/closed/3314.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Universe Polymorphism.
Definition Lift
: $(let U1 := constr:(Type) in
diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v
index bb5853dd..3b37e39e 100644
--- a/test-suite/bugs/closed/3319.v
+++ b/test-suite/bugs/closed/3319.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5353 lines to 4545 lines, then from 4513 lines to 4504 lines, then from 4515 lines to 4508 lines, then from 4519 lines to 132 lines, then from 111 lines to 66 lines, then from 68 lines to 35 lines *)
Set Implicit Arguments.
Inductive paths {A : Type} (a : A) : A -> Type :=
diff --git a/test-suite/bugs/closed/3321.v b/test-suite/bugs/closed/3321.v
index 07e3b3cb..b6f10e53 100644
--- a/test-suite/bugs/closed/3321.v
+++ b/test-suite/bugs/closed/3321.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 103 lines to 83 lines, then from 86 lines to 36 lines, then from 37 lines to 17 lines *)
Axiom admit : forall {T}, T.
diff --git a/test-suite/bugs/closed/3322.v b/test-suite/bugs/closed/3322.v
index 925f22a2..ab3025a6 100644
--- a/test-suite/bugs/closed/3322.v
+++ b/test-suite/bugs/closed/3322.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 11971 lines to 11753 lines, then from 7702 lines to 564 lines, then from 571 lines to 61 lines *)
Set Asymmetric Patterns.
Axiom admit : forall {T}, T.
diff --git a/test-suite/bugs/closed/3323.v b/test-suite/bugs/closed/3323.v
index fb5a8a7e..22b1603b 100644
--- a/test-suite/bugs/closed/3323.v
+++ b/test-suite/bugs/closed/3323.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *)
diff --git a/test-suite/bugs/closed/3324.v b/test-suite/bugs/closed/3324.v
index 9cd6e4c2..45dbb57a 100644
--- a/test-suite/bugs/closed/3324.v
+++ b/test-suite/bugs/closed/3324.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Module ETassi.
Axiom admit : forall {T}, T.
Class IsHProp (A : Type) : Type := {}.
diff --git a/test-suite/bugs/closed/3329.v b/test-suite/bugs/closed/3329.v
index f7e368f8..ecb09e84 100644
--- a/test-suite/bugs/closed/3329.v
+++ b/test-suite/bugs/closed/3329.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 12095 lines to 869 lines, then from 792 lines to 504 lines, then from 487 lines to 353 lines, then from 258 lines to 174 lines, then from 164 lines to 132 lines, then from 129 lines to 99 lines *)
Set Universe Polymorphism.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v
index 15303cca..4cd7c39e 100644
--- a/test-suite/bugs/closed/3330.v
+++ b/test-suite/bugs/closed/3330.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *)
Set Universe Polymorphism.
Definition setleq (A : Type@{i}) (B : Type@{j}) := A : Type@{j}.
diff --git a/test-suite/bugs/closed/3344.v b/test-suite/bugs/closed/3344.v
index 8255fd6c..880851c5 100644
--- a/test-suite/bugs/closed/3344.v
+++ b/test-suite/bugs/closed/3344.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *)
Require Import Coq.Sets.Ensembles.
Require Import Coq.Strings.String.
diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v
index 37c0d87e..63d5c7a5 100644
--- a/test-suite/bugs/closed/3347.v
+++ b/test-suite/bugs/closed/3347.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *)
Set Universe Polymorphism.
Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing).
diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v
index 30fdf169..c041c401 100644
--- a/test-suite/bugs/closed/3350.v
+++ b/test-suite/bugs/closed/3350.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Coq.Vectors.Fin.
Require Coq.Vectors.Vector.
diff --git a/test-suite/bugs/closed/3373.v b/test-suite/bugs/closed/3373.v
index 5ecf2801..051e6952 100644
--- a/test-suite/bugs/closed/3373.v
+++ b/test-suite/bugs/closed/3373.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5968 lines to
11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446
lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then
diff --git a/test-suite/bugs/closed/3374.v b/test-suite/bugs/closed/3374.v
index 3c67703a..d8e72f4f 100644
--- a/test-suite/bugs/closed/3374.v
+++ b/test-suite/bugs/closed/3374.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 331 lines to 59 lines *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/3375.v b/test-suite/bugs/closed/3375.v
index fe323fcb..d7ce02ea 100644
--- a/test-suite/bugs/closed/3375.v
+++ b/test-suite/bugs/closed/3375.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-impredicative-set") -*- *)
(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 330 lines to 45 lines *)
diff --git a/test-suite/bugs/closed/3382.v b/test-suite/bugs/closed/3382.v
index 1d8e9167..3e374d90 100644
--- a/test-suite/bugs/closed/3382.v
+++ b/test-suite/bugs/closed/3382.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then from 7245 lines to 476 lines, then from 417 lines to 249 lines, then from 171 lines to 127 lines, then from 139 lines to 114 lines, then from 93 lines to 77 lines *)
Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v
index 29ee1487..3a598695 100644
--- a/test-suite/bugs/closed/3392.v
+++ b/test-suite/bugs/closed/3392.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 12105 lines to 142 lines, then from 83 lines to 57 lines *)
Generalizable All Variables.
Axiom admit : forall {T}, T.
@@ -24,9 +25,8 @@ Proof.
intros.
refine (isequiv_adjointify (functor_forall f g)
(functor_forall (f^-1)
- (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f _ x # (g (f^-1 x))^-1 y
- )) _ _);
- intros h.
+ (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f H x # (g (f^-1 x))^-1 y
+ )) _ _); intros h.
- abstract (
apply path_forall; intros b; unfold functor_forall;
rewrite eisadj;
@@ -37,4 +37,4 @@ Proof.
rewrite eissect;
apply apD
).
-Defined.
+Defined.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3393.v b/test-suite/bugs/closed/3393.v
index ec25e682..f7ab5f76 100644
--- a/test-suite/bugs/closed/3393.v
+++ b/test-suite/bugs/closed/3393.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/3422.v b/test-suite/bugs/closed/3422.v
index d984f623..460ae8f1 100644
--- a/test-suite/bugs/closed/3422.v
+++ b/test-suite/bugs/closed/3422.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Generalizable All Variables.
Set Implicit Arguments.
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/3427.v b/test-suite/bugs/closed/3427.v
index 8483a4ec..374a5392 100644
--- a/test-suite/bugs/closed/3427.v
+++ b/test-suite/bugs/closed/3427.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 0 lines to 7171 lines, then from 7184 lines to 558 lines, then from 556 lines to 209 lines *)
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v
index bba6140f..1ea24bf1 100644
--- a/test-suite/bugs/closed/3439.v
+++ b/test-suite/bugs/closed/3439.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 3154 lines to 149 lines, then from 89 lines to 55 lines, then from 44 lines to 20 lines *)
Set Primitive Projections.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/3467.v b/test-suite/bugs/closed/3467.v
new file mode 100644
index 00000000..7e371162
--- /dev/null
+++ b/test-suite/bugs/closed/3467.v
@@ -0,0 +1,6 @@
+Module foo.
+ Notation x := $(exact I)$.
+End foo.
+Module bar.
+ Include foo.
+End bar.
diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v
index 99ac2efa..a81837e7 100644
--- a/test-suite/bugs/closed/3480.v
+++ b/test-suite/bugs/closed/3480.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Primitive Projections.
Axiom admit : forall {T}, T.
Notation "( x ; y )" := (existT _ x y) : fibration_scope.
diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v
index 6c40a426..dc88a332 100644
--- a/test-suite/bugs/closed/3484.v
+++ b/test-suite/bugs/closed/3484.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 14259 lines to 305 lines, then from 237 lines to 120 lines, then from 100 lines to 30 lines *)
Set Primitive Projections.
Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/3490.v b/test-suite/bugs/closed/3490.v
new file mode 100644
index 00000000..e7a5caa1
--- /dev/null
+++ b/test-suite/bugs/closed/3490.v
@@ -0,0 +1,27 @@
+Inductive T : Type :=
+| Var : nat -> T
+| Arr : T -> T -> T.
+
+Inductive Tele : list T -> Type :=
+| Tnil : @Tele nil
+| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls).
+
+Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t}
+ : { x : Type & x -> nat -> Type } :=
+ match t return { x : Type & x -> nat -> Type } with
+ | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit)
+ | Tcons ls t' l =>
+ let (result, get) := TeleD ls t' in
+ @existT Type (fun x => x -> nat -> Type)
+ { v : result & (fix TD (t : T) {struct t} :=
+ match t with
+ | Var n =>
+ get v n
+ | Arr a b => TD a -> TD b
+ end) l }
+ (fun x n =>
+ match n return Type with
+ | 0 => projT2 x
+ | S n => get (projT1 x) n
+ end)
+ end.
diff --git a/test-suite/bugs/closed/3491.v b/test-suite/bugs/closed/3491.v
new file mode 100644
index 00000000..fd394ddb
--- /dev/null
+++ b/test-suite/bugs/closed/3491.v
@@ -0,0 +1,4 @@
+(* Was failing while building the _rect scheme, due to wrong computation of *)
+(* the number of non recursively uniform parameters in the presence of let-ins*)
+Inductive list (A : Type) (T := A) : Type :=
+ nil : list A | cons : T -> list T -> list A.
diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v
new file mode 100644
index 00000000..fcdfa005
--- /dev/null
+++ b/test-suite/bugs/closed/3513.v
@@ -0,0 +1,76 @@
+Require Import TestSuite.admit.
+(* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines *)
+Require Coq.Setoids.Setoid.
+Import Coq.Setoids.Setoid.
+Generalizable All Variables.
+Axiom admit : forall {T}, T.
+Class Equiv (A : Type) := equiv : relation A.
+Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv.
+Class ILogicOps Frm := { lentails: relation Frm;
+ ltrue: Frm;
+ land: Frm -> Frm -> Frm;
+ lor: Frm -> Frm -> Frm }.
+Infix "|--" := lentails (at level 79, no associativity).
+Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }.
+Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P.
+Infix "-|-" := lequiv (at level 85, no associativity).
+Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit.
+Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }.
+Section ILogic_Fun.
+ Context (T: Type) `{TType: type T}.
+ Context `{IL: ILogic Frm}.
+ Local Instance ILFun_Ops : ILogicOps (@ILFunFrm T _ Frm _) := admit.
+ Definition ILFun_ILogic : ILogic (@ILFunFrm T _ Frm _) := admit.
+End ILogic_Fun.
+Implicit Arguments ILFunFrm [[ILOps] [e]].
+Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| lentails P Q := (P : Prop) -> Q;
+ ltrue := True;
+ land P Q := P /\ Q;
+ lor P Q := P \/ Q |}.
+Axiom Action : Set.
+Definition Actions := list Action.
+Instance ActionsEquiv : Equiv Actions := { equiv a1 a2 := a1 = a2 }.
+Definition OPred := ILFunFrm Actions Prop.
+Local Existing Instance ILFun_Ops.
+Local Existing Instance ILFun_ILogic.
+Definition catOP (P Q: OPred) : OPred := admit.
+Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m.
+admit.
+Defined.
+Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit.
+Class IsPointed (T : Type) := point : T.
+Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)).
+Record PointedOPred := mkPointedOPred {
+ OPred_pred :> OPred;
+ OPred_inhabited: IsPointed_OPred OPred_pred
+ }.
+Existing Instance OPred_inhabited.
+Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred
+ := {| OPred_pred := O ; OPred_inhabited := _ |}.
+Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q) := admit.
+Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred)
+ (tr : T -> T) (O2 : PointedOPred) (x : T)
+ (H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0),
+ exists e1 e2,
+ catOP (O0 e1) (OPred_pred e2) |-- catOP (O1 x) O2.
+ intros; do 2 esplit.
+ rewrite <- catOPA.
+ lazymatch goal with
+ | |- ?R (?f ?a ?b) (?f ?a' ?b') =>
+ let P := constr:(fun H H' => @Morphisms.proper_prf (OPred -> OPred -> OPred)
+ (@Morphisms.respectful OPred (OPred -> OPred)
+ (@lentails OPred
+ (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))
+ (@lentails OPred
+ (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop) ==>
+ @lentails OPred
+ (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))) catOP
+ catOP_entails_m_Proper a a' H b b' H') in
+ pose P;
+ refine (P _ _)
+ end; unfold Basics.flip.
+ 2: solve [ apply reflexivity ].
+ Undo.
+ 2: reflexivity. (* Toplevel input, characters 18-29:
+Error:
+Tactic failure: The relation lentails is not a declared reflexive relation. Maybe you need to require the Setoid library. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v
index fd080a6b..764a7334 100644
--- a/test-suite/bugs/closed/3531.v
+++ b/test-suite/bugs/closed/3531.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 270 lines to
198 lines, then from 178 lines to 82 lines, then from 88 lines to 59 lines *)
(* coqc version trunk (August 2014) compiled on Aug 19 2014 14:40:15 with OCaml
diff --git a/test-suite/bugs/closed/3560.v b/test-suite/bugs/closed/3560.v
new file mode 100644
index 00000000..65ce4fb6
--- /dev/null
+++ b/test-suite/bugs/closed/3560.v
@@ -0,0 +1,15 @@
+
+(* File reduced by coq-bug-finder from original input, then from 6236 lines to 1049 lines, then from 920 lines to 209 lines, then from 179 lines to 30 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0
+ coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *)
+
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv : forall P, P equiv_fun }.
+Goal forall (A B : Type) (C : Type), Equiv (A -> B -> C) (A * B -> C).
+Proof.
+ intros.
+ exists (fun u => fun x => u (fst x) (snd x)).
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v
index b4dfd17f..f6cbc929 100644
--- a/test-suite/bugs/closed/3561.v
+++ b/test-suite/bugs/closed/3561.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 6343 lines to 2362 lines, then from 2115 lines to 303 lines, then from 321 lines to 90 lines, then from 95 lines to 41 lines *)
(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0
coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *)
diff --git a/test-suite/bugs/closed/3590.v b/test-suite/bugs/closed/3590.v
new file mode 100644
index 00000000..3ef9270d
--- /dev/null
+++ b/test-suite/bugs/closed/3590.v
@@ -0,0 +1,12 @@
+Set Implicit Arguments.
+Record prod A B := pair { fst : A ; snd : B }.
+Definition idS := Set.
+Goal forall x y : prod Set Set, forall H : fst x = fst y, fst x = fst y.
+ intros.
+ change (@fst _ _ ?z) with (@fst Set idS z) at 2.
+ apply H.
+Qed.
+
+(* Toplevel input, characters 20-58:
+Error: Failed to get enough information from the left-hand side to type the
+right-hand side. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3593.v b/test-suite/bugs/closed/3593.v
deleted file mode 100644
index 25f9db6b..00000000
--- a/test-suite/bugs/closed/3593.v
+++ /dev/null
@@ -1,10 +0,0 @@
-Set Universe Polymorphism.
-Set Printing All.
-Set Implicit Arguments.
-Record prod A B := pair { fst : A ; snd : B }.
-Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x.
-simpl; intros.
- constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x).
- Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x).
- reflexivity.
-Qed.
diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v
index d6c1c949..49dd7be5 100644
--- a/test-suite/bugs/closed/3596.v
+++ b/test-suite/bugs/closed/3596.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Record foo := { fx : nat }.
Set Primitive Projections.
diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v
new file mode 100644
index 00000000..9125ab16
--- /dev/null
+++ b/test-suite/bugs/closed/3612.v
@@ -0,0 +1,47 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-nois") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 3595 lines to 3518 lines, then from 3133 lines to 2950 lines, then from 2911 lines to 415 lines, then from 431 lines to 407 \
+lines, then from 421 lines to 428 lines, then from 444 lines to 429 lines, then from 434 lines to 66 lines, then from 163 lines to 48 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 11 2014 14:48:8 with OCaml 4.01.0
+ coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (580b25e05c7cc9e7a31430b3d9edb14ae12b7598) *)
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity).
+Reserved Notation "x = y" (at level 70, no associativity).
+Open Scope type_scope.
+Global Set Universe Polymorphism.
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Generalizable All Variables.
+Local Set Primitive Projections.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Arguments projT1 {A P} _ / .
+Arguments projT2 {A P} _ / .
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation pr1 := projT1.
+Notation pr2 := projT2.
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y .
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
+Local Open Scope path_scope.
+Axiom pr1_path : forall `{P : A -> Type} {u v : sigT P} (p : u = v), u.1 = v.1.
+Notation "p ..1" := (pr1_path p) (at level 3) : fibration_scope.
+Axiom pr2_path : forall `{P : A -> Type} {u v : sigT P} (p : u = v), p..1 # u.2 = v.2.
+Notation "p ..2" := (pr2_path p) (at level 3) : fibration_scope.
+Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P)
+ (p q : u = v)
+ (r : p..1 = q..1)
+ (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2),
+p = q.
+Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x))
+ (xx : @paths (@sigT A (fun x0 : A => B x0)) x x),
+ @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx
+ (@idpath (@sigT A (fun x0 : A => B x0)) x).
+ intros A B x xx.
+ Set Printing All.
+ change (fun x => B x) with B in xx.
+ pose (path_path_sigma B x x xx) as x''.
+ clear x''.
+ Check (path_path_sigma B x x xx).
diff --git a/test-suite/bugs/closed/3625.v b/test-suite/bugs/closed/3625.v
index 3d30b62f..d4b2cc5c 100644
--- a/test-suite/bugs/closed/3625.v
+++ b/test-suite/bugs/closed/3625.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Set Primitive Projections.
Record prod A B := pair { fst : A ; snd : B }.
diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v
index cd542c8a..495e67e0 100644
--- a/test-suite/bugs/closed/3647.v
+++ b/test-suite/bugs/closed/3647.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Coq.Setoids.Setoid.
Axiom BITS : nat -> Set.
diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v
new file mode 100644
index 00000000..06188e7b
--- /dev/null
+++ b/test-suite/bugs/closed/3649.v
@@ -0,0 +1,57 @@
+(* -*- coq-prog-args: ("-emacs" "-nois") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0
+ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *)
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Reserved Notation "x = y" (at level 70, no associativity).
+Open Scope type_scope.
+Axiom admit : forall {T}, T.
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Reserved Infix "o" (at level 40, left associativity).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Ltac constr_eq a b := let test := constr:(@idpath _ _ : a = b) in idtac.
+Global Set Primitive Projections.
+Delimit Scope morphism_scope with morphism.
+Record PreCategory :=
+ { object :> Type;
+ morphism : object -> object -> Type;
+
+ identity : forall x, morphism x x;
+ compose : forall s d d',
+ morphism d d'
+ -> morphism s d
+ -> morphism s d'
+ where "f 'o' g" := (compose f g) }.
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+Set Implicit Arguments.
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+ { object_of :> C -> D;
+ morphism_of : forall s d, morphism C s d
+ -> morphism D (object_of s) (object_of d) }.
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) :=
+ { morphism_inverse : morphism C d s }.
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+Definition composeT C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F')
+: NaturalTransformation F F''.
+ exact admit.
+Defined.
+Definition functor_category (C D : PreCategory) : PreCategory.
+ exact (@Build_PreCategory (Functor C D)
+ (@NaturalTransformation C D)
+ admit
+ (@composeT C D)).
+Defined.
+Goal forall (C D : PreCategory) (G G' : Functor C D)
+ (T : @NaturalTransformation C D G G')
+ (H : @IsIsomorphism (@functor_category C D) G G' T)
+ (x : C),
+ @paths (morphism D (G x) (G x))
+ (@compose D (G x) (G' x) (G x)
+ ((@morphism_inverse (@functor_category C D) G G' T H) x)
+ (T x)) (@identity D (G x)).
+ intros.
+ (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *)
+ let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in
+ let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in
+ progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3653.v b/test-suite/bugs/closed/3653.v
index 947b3601..b9768967 100644
--- a/test-suite/bugs/closed/3653.v
+++ b/test-suite/bugs/closed/3653.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Setoid.
Variables P Q : forall {T : Set}, T -> Prop.
diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v
index b1158b9a..622c3c94 100644
--- a/test-suite/bugs/closed/3658.v
+++ b/test-suite/bugs/closed/3658.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 12178 lines to 457 lines, then from 500 lines to 147 lines, then from 175 lines to 56 lines *)
(* coqc version trunk (September 2014) compiled on Sep 21 2014 16:34:4 with OCaml 4.01.0
coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (eaf864354c3fda9ddc1f03f0b1c7807b6fd44322) *)
diff --git a/test-suite/bugs/closed/3660.v b/test-suite/bugs/closed/3660.v
index ed8964ce..39eb89c4 100644
--- a/test-suite/bugs/closed/3660.v
+++ b/test-suite/bugs/closed/3660.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Generalizable All Variables.
Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v
index 41de74ff..63a81b6d 100644
--- a/test-suite/bugs/closed/3664.v
+++ b/test-suite/bugs/closed/3664.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Module NonPrim.
Unset Primitive Projections.
Record c := { d : Set }.
diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v
index 547159b9..da01ed00 100644
--- a/test-suite/bugs/closed/3668.v
+++ b/test-suite/bugs/closed/3668.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 6329 lines to 110 lines, then from 115 lines to 88 lines, then from 93 lines to 72 lines *)
(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)
diff --git a/test-suite/bugs/closed/3681.v b/test-suite/bugs/closed/3681.v
new file mode 100644
index 00000000..194113c6
--- /dev/null
+++ b/test-suite/bugs/closed/3681.v
@@ -0,0 +1,20 @@
+Module Type FOO.
+ Parameters P Q : Type -> Type.
+End FOO.
+
+Module Type BAR.
+ Declare Module Import foo : FOO.
+ Parameter f : forall A, P A -> Q A -> A.
+End BAR.
+
+Module Type BAZ.
+ Declare Module Export foo : FOO.
+ Parameter g : forall A, P A -> Q A -> A.
+End BAZ.
+
+Module BAR_FROM_BAZ (baz : BAZ) : BAR.
+ Import baz.
+ Module foo <: FOO := foo.
+ Import foo.
+ Definition f : forall A, P A -> Q A -> A := g.
+End BAR_FROM_BAZ.
diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v
index b8c5b4d5..2a282d22 100644
--- a/test-suite/bugs/closed/3682.v
+++ b/test-suite/bugs/closed/3682.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Class Foo.
Definition bar `{Foo} (x : Set) := Set.
Instance: Foo.
diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v
index 94ce4a60..f7b13738 100644
--- a/test-suite/bugs/closed/3684.v
+++ b/test-suite/bugs/closed/3684.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Definition foo : Set.
Proof.
refine ($(abstract admit)$).
diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v
index ee6b334b..b650920b 100644
--- a/test-suite/bugs/closed/3686.v
+++ b/test-suite/bugs/closed/3686.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Universe Polymorphism.
Set Implicit Arguments.
Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v
new file mode 100644
index 00000000..4069e380
--- /dev/null
+++ b/test-suite/bugs/closed/3690.v
@@ -0,0 +1,52 @@
+Set Printing Universes.
+Set Universe Polymorphism.
+Definition foo (a := Type) (b := Type) (c := Type) := Type.
+Print foo.
+(* foo =
+let a := Type@{Top.1} in
+let b := Type@{Top.2} in let c := Type@{Top.3} in Type@{Top.4}
+ : Type@{Top.4+1}
+(* Top.1
+ Top.2
+ Top.3
+ Top.4 |= *) *)
+Check @foo. (* foo@{Top.5 Top.6 Top.7
+Top.8}
+ : Type@{Top.8+1}
+(* Top.5
+ Top.6
+ Top.7
+ Top.8 |= *) *)
+Definition bar := $(let t := eval compute in foo in exact t)$.
+Check @bar. (* bar@{Top.13 Top.14 Top.15
+Top.16}
+ : Type@{Top.16+1}
+(* Top.13
+ Top.14
+ Top.15
+ Top.16 |= *) *)
+(* The following should fail, since [bar] should only need one universe. *)
+Check @bar@{i j}.
+Definition baz (a := Type) (b := Type : a) (c := Type : b) := a -> c.
+Definition qux := Eval compute in baz.
+Check @qux. (* qux@{Top.24 Top.25
+Top.26}
+ : Type@{max(Top.24+1, Top.26+1)}
+(* Top.24
+ Top.25
+ Top.26 |= Top.25 < Top.24
+ Top.26 < Top.25
+ *) *)
+Print qux. (* qux =
+Type@{Top.21} -> Type@{Top.23}
+ : Type@{max(Top.21+1, Top.23+1)}
+(* Top.21
+ Top.22
+ Top.23 |= Top.22 < Top.21
+ Top.23 < Top.22
+ *) *)
+Fail Check @qux@{Set Set}.
+Fail Check @qux@{Set Set Set}.
+(* [qux] should only need two universes *)
+Check @qux@{i j k}. (* Error: The command has not failed!, but I think this is suboptimal *)
+Fail Check @qux@{i j}.
diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v
index 3c53d243..31de8ec4 100644
--- a/test-suite/bugs/closed/3698.v
+++ b/test-suite/bugs/closed/3698.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5479 lines to 4682 lines, then from 4214 lines to 86 lines, then from 60 lines to 25 lines *)
(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0
coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *)
diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v
index 99b3d79e..62137f0c 100644
--- a/test-suite/bugs/closed/3699.v
+++ b/test-suite/bugs/closed/3699.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 9593 lines to 104 lines, then from 187 lines to 103 lines, then from 113 lines to 90 lines *)
(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0
coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *)
diff --git a/test-suite/bugs/closed/3703.v b/test-suite/bugs/closed/3703.v
new file mode 100644
index 00000000..72825007
--- /dev/null
+++ b/test-suite/bugs/closed/3703.v
@@ -0,0 +1,32 @@
+Require Import TestSuite.admit.
+(* File reduced by coq-bug-finder from original input, then from 6746 lines to 4190 lines, then from 29 lines to 18 lines, then fro\
+m 30 lines to 19 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 7 2014 12:42:41 with OCaml 4.01.0
+ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (2313bde0116a5916912bebbaca77d291f7b2760a) *)
+Record PreCategory := { identity : forall x, x -> x }.
+Definition set_cat : PreCategory := @Build_PreCategory (fun T x => x).
+Module UnKeyed.
+ Global Unset Keyed Unification.
+ Goal forall (T : Type) (g0 g1 : T) (k : T) (H' : forall x : T, k = @identity set_cat T x),
+ ((fun x : T => x) g0) = ((fun x : T => x) g1).
+ intros T g0 g1 k H'.
+ change (identity _ _) with (fun y : T => y) in H';
+ rewrite <- H' || fail "too early".
+ Undo.
+ rewrite <- H'.
+ admit.
+ Defined.
+End UnKeyed.
+Module Keyed.
+ Global Set Keyed Unification.
+ Declare Equivalent Keys (fun x => _) identity.
+ Goal forall (T : Type) (g0 g1 : T) (k : T) (H' : forall x : T, k = @identity set_cat T x),
+ ((fun x : T => x) g0) = ((fun x : T => x) g1).
+ intros T g0 g1 k H'.
+ change (identity _ _) with (fun y : T => y) in H';
+ rewrite <- H' || fail "too early".
+ Undo.
+ rewrite <- H'.
+ admit.
+ Defined.
+End Keyed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3709.v b/test-suite/bugs/closed/3709.v
index 7f01be7a..815f5b95 100644
--- a/test-suite/bugs/closed/3709.v
+++ b/test-suite/bugs/closed/3709.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Module NonPrim.
Unset Primitive Projections.
Record hProp := hp { hproptype :> Type }.
diff --git a/test-suite/bugs/closed/3732.v b/test-suite/bugs/closed/3732.v
new file mode 100644
index 00000000..76beedf6
--- /dev/null
+++ b/test-suite/bugs/closed/3732.v
@@ -0,0 +1,105 @@
+Require Import TestSuite.admit.
+(* File reduced by coq-bug-finder from original input, then from 2073 lines to 358 lines, then from 359 lines to 218 lines, then from 107 lines to 92 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 11 2014 1:13:41 with OCaml 4.01.0
+ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *)
+Require Coq.Lists.List.
+
+Import Coq.Lists.List.
+
+Set Implicit Arguments.
+Global Set Asymmetric Patterns.
+
+Section machine.
+ Variables pc state : Type.
+
+ Inductive propX (i := pc) (j := state) : list Type -> Type :=
+ | Inj : forall G, Prop -> propX G
+ | ExistsX : forall G A, propX (A :: G) -> propX G.
+
+ Implicit Arguments Inj [G].
+
+ Definition PropX := propX nil.
+ Fixpoint last (G : list Type) : Type.
+ exact (match G with
+ | nil => unit
+ | T :: nil => T
+ | _ :: G' => last G'
+ end).
+ Defined.
+ Fixpoint eatLast (G : list Type) : list Type.
+ exact (match G with
+ | nil => nil
+ | _ :: nil => nil
+ | x :: G' => x :: eatLast G'
+ end).
+ Defined.
+
+ Fixpoint subst G (p : propX G) : (last G -> PropX) -> propX (eatLast G) :=
+ match p with
+ | Inj _ P => fun _ => Inj P
+ | ExistsX G A p1 => fun p' =>
+ match G return propX (A :: G) -> propX (eatLast (A :: G)) -> propX (eatLast G) with
+ | nil => fun p1 _ => ExistsX p1
+ | _ :: _ => fun _ rc => ExistsX rc
+ end p1 (subst p1 (match G return (last G -> PropX) -> last (A :: G) -> PropX with
+ | nil => fun _ _ => Inj True
+ | _ => fun p' => p'
+ end p'))
+ end.
+
+ Definition spec := state -> PropX.
+ Definition codeSpec := pc -> option spec.
+
+ Inductive valid (specs : codeSpec) (G : list PropX) : PropX -> Prop := Env : forall P, In P G -> valid specs G P.
+ Definition interp specs := valid specs nil.
+End machine.
+Notation "'ExX' : A , P" := (ExistsX (A := A) P) (at level 89) : PropX_scope.
+Bind Scope PropX_scope with PropX propX.
+Variables pc state : Type.
+
+Inductive subs : list Type -> Type :=
+| SNil : subs nil
+| SCons : forall T Ts, (last (T :: Ts) -> PropX pc state) -> subs (eatLast (T :: Ts)) -> subs (T :: Ts).
+
+Fixpoint SPush G T (s : subs G) (f : T -> PropX pc state) : subs (T :: G) :=
+ match s in subs G return subs (T :: G) with
+ | SNil => SCons _ nil f SNil
+ | SCons T' Ts f' s' => SCons T (T' :: Ts) f' (SPush s' f)
+ end.
+
+Fixpoint Substs G (s : subs G) : propX pc state G -> PropX pc state :=
+ match s in subs G return propX pc state G -> PropX pc state with
+ | SNil => fun p => p
+ | SCons _ _ f s' => fun p => Substs s' (subst p f)
+ end.
+Variable specs : codeSpec pc state.
+
+Lemma simplify_fwd_ExistsX : forall G A s (p : propX pc state (A :: G)),
+ interp specs (Substs s (ExX : A, p))
+ -> exists a, interp specs (Substs (SPush s a) p).
+admit.
+Defined.
+
+Goal forall (G : list Type) (A : Type) (p : propX pc state (@cons Type A G))
+ (s : subs G)
+ (_ : @interp pc state specs (@Substs G s (@ExistsX pc state G A p)))
+ (P : forall _ : subs (@cons Type A G), Prop)
+ (_ : forall (s0 : subs (@cons Type A G))
+ (_ : @interp pc state specs (@Substs (@cons Type A G) s0 p)),
+ P s0),
+ @ex (forall _ : A, PropX pc state)
+ (fun a : forall _ : A, PropX pc state => P (@SPush G A s a)).
+ intros ? ? ? ? H ? H'.
+ apply simplify_fwd_ExistsX in H.
+ firstorder.
+Qed.
+ (* Toplevel input, characters 15-19:
+Error: Illegal application:
+The term "cons" of type "forall A : Type, A -> list A -> list A"
+cannot be applied to the terms
+ "Type" : "Type"
+ "T" : "Type"
+ "G0" : "list Type"
+The 2nd term has type "Type@{Top.53}" which should be coercible to
+ "Type@{Top.12}".
+ *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3755.v b/test-suite/bugs/closed/3755.v
new file mode 100644
index 00000000..77427ace
--- /dev/null
+++ b/test-suite/bugs/closed/3755.v
@@ -0,0 +1,16 @@
+(* File reduced by coq-bug-finder from original input, then from 6729 lines to
+411 lines, then from 148 lines to 115 lines, then from 99 lines to 70 lines,
+then from 85 lines to 63 lines, then from 76 lines to 55 lines, then from 61
+lines to 17 lines *)
+(* coqc version trunk (January 2015) compiled on Jan 17 2015 21:58:5 with OCaml
+4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk
+(9e6b28c04ad98369a012faf3bd4d630cf123a473) *)
+Set Printing Universes.
+Section param.
+ Variable typeD : Set -> Set.
+ Variable STex : forall (T : Type) (p : T -> Set), Set.
+ Definition existsEach_cons' v (P : @sigT _ typeD -> Set) :=
+ @STex _ (fun x => P (@existT _ _ v x)).
+
+ Check @existT _ _ STex STex.
diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v
index 08d456fc..2dc50c17 100644
--- a/test-suite/bugs/closed/3782.v
+++ b/test-suite/bugs/closed/3782.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 2674 lines to 136 lines, then from 115 lines to 61 lines *)
(* coqc version trunk (October 2014) compiled on Oct 28 2014 14:33:38 with OCaml 4.01.0
coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,(no branch) (53bfe9cf58a3c40e6eb7120d25c1633a9cea3126) *)
diff --git a/test-suite/bugs/closed/3783.v b/test-suite/bugs/closed/3783.v
new file mode 100644
index 00000000..e2171296
--- /dev/null
+++ b/test-suite/bugs/closed/3783.v
@@ -0,0 +1,33 @@
+Require Import TestSuite.admit.
+Fixpoint exp (n : nat) (T : Set)
+ := match n with
+ | 0 => T
+ | S n' => exp n' (T * T)
+ end.
+Definition big := Eval compute in exp 13 nat.
+Module NonPrim.
+ Unset Primitive Projections.
+ Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+ Definition x : sigT (fun x => x).
+ Proof.
+ exists big; admit.
+ Defined.
+ Goal True.
+ pose ((fun y => y = y) (projT1 _ x)) as y.
+ Time cbv beta in y. (* 0s *)
+ admit.
+ Defined.
+End NonPrim.
+Module Prim.
+ Set Primitive Projections.
+ Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+ Definition x : sigT (fun x => x).
+ Proof.
+ exists big; admit.
+ Defined.
+ Goal True.
+ pose ((fun y => y = y) (projT1 _ x)) as y.
+ Timeout 1 cbv beta in y. (* takes around 2s. Grows with the value passed to [exp] above *)
+ admit.
+ Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3786.v b/test-suite/bugs/closed/3786.v
new file mode 100644
index 00000000..23d19e94
--- /dev/null
+++ b/test-suite/bugs/closed/3786.v
@@ -0,0 +1,33 @@
+Require Import TestSuite.admit.
+Require Coq.Lists.List.
+Require Coq.Sets.Ensembles.
+Import Coq.Sets.Ensembles.
+Global Set Implicit Arguments.
+Delimit Scope comp_scope with comp.
+Inductive Comp : Type -> Type :=
+| Return : forall A, A -> Comp A
+| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B
+| Pick : forall A, Ensemble A -> Comp A.
+Notation ret := Return.
+Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
+ (at level 81, right associativity,
+ format "'[v' x <- y ; '/' z ']'") : comp_scope.
+Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.
+Open Scope comp.
+Axiom elements : forall {A} (ls : list A), Ensemble A.
+Axiom to_list : forall {A} (S : Ensemble A), Comp (list A).
+Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0).
+Definition sumUniqueSpec (ls : list nat) : Comp nat.
+ exact (ls' <- to_list (elements ls);
+ List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls').
+Defined.
+Axiom admit : forall {T}, T.
+Definition sumUniqueImpl (ls : list nat)
+: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type.
+Proof.
+ eexists.
+ match goal with
+ | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b)
+ end.
+ try setoid_rewrite (@finite_set_handle_cardinal).
+Abort.
diff --git a/test-suite/bugs/closed/3798.v b/test-suite/bugs/closed/3798.v
new file mode 100644
index 00000000..b9f0daa7
--- /dev/null
+++ b/test-suite/bugs/closed/3798.v
@@ -0,0 +1,12 @@
+Require Import TestSuite.admit.
+Require Setoid.
+
+Parameter f : nat -> nat.
+Axiom a : forall n, 0 < n -> f n = 0.
+Hint Rewrite a using ( simpl; admit ).
+
+Goal f 1 = 0.
+Proof.
+ rewrite_strat (topdown (hints core)).
+ reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v
new file mode 100644
index 00000000..6e19ddf8
--- /dev/null
+++ b/test-suite/bugs/closed/3808.v
@@ -0,0 +1,2 @@
+Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i})
+ := foo : Foo.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3815.v b/test-suite/bugs/closed/3815.v
new file mode 100644
index 00000000..5fb48398
--- /dev/null
+++ b/test-suite/bugs/closed/3815.v
@@ -0,0 +1,9 @@
+Require Import Setoid Coq.Program.Basics.
+Global Open Scope program_scope.
+Axiom foo : forall A (f : A -> A), f ∘ f = f.
+Require Import Coq.Program.Combinators.
+Hint Rewrite foo.
+Theorem t {A B C D} (f : A -> A) (g : B -> C) (h : C -> D)
+: f ∘ f = f.
+Proof.
+ rewrite_strat topdown (hints core).
diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v
deleted file mode 100644
index b66aecca..00000000
--- a/test-suite/bugs/closed/3848.v
+++ /dev/null
@@ -1,21 +0,0 @@
-Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
-Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
-Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
-Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
-Arguments eisretr {A B} f {_} _.
-Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
-Generalizable Variables A B f g e n.
-Definition functor_forall `{P : A -> Type} `{Q : B -> Type}
- (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b)
-: (forall a:A, P a) -> (forall b:B, Q b).
- admit.
-Defined.
-
-Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type}
- `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)}
-: (forall b : B, Q b) -> forall a : A, P a.
-Proof.
- refine (functor_forall
- (f^-1)
- (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)).
-Defined. (* Error: Attempt to save an incomplete proof *)
diff --git a/test-suite/bugs/closed/3854.v b/test-suite/bugs/closed/3854.v
index f8329cdd..7e915f20 100644
--- a/test-suite/bugs/closed/3854.v
+++ b/test-suite/bugs/closed/3854.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Definition relation (A : Type) := A -> A -> Type.
Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x.
Axiom IsHProp : Type -> Type.
diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v
new file mode 100644
index 00000000..4408ab88
--- /dev/null
+++ b/test-suite/bugs/closed/3881.v
@@ -0,0 +1,35 @@
+(* -*- coq-prog-args: ("-emacs" "-nois" "-R" "../theories" "Coq") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 2236 lines to 1877 lines, then from 1652 lines to 160 lines, then from 102 lines to 34 lines *)
+(* coqc version trunk (December 2014) compiled on Dec 23 2014 22:6:43 with OCaml 4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *)
+Generalizable All Variables.
+Require Import Coq.Init.Notations.
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Axiom admit : forall {T}, T.
+Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity).
+Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *)
+Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope.
+Arguments eq_refl {_ _}.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }.
+Arguments eisretr {A B} f {_} _.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
+Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (g o f) | 1000 := admit.
+Definition isequiv_homotopic {A B} (f : A -> B) (g : A -> B) `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g := admit.
+Global Instance isequiv_inverse {A B} (f : A -> B) {feq : IsEquiv f} : IsEquiv f^-1 | 10000 := admit.
+Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C} `{IsEquiv A B f} `{IsEquiv A C (g o f)} : IsEquiv g.
+Proof.
+ pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H
+ (fun b => ap g (eisretr f b))) as k.
+ revert k.
+ let x := match goal with |- let k := ?x in _ => constr:x end in
+ intro k; clear k;
+ pose (x _).
+ pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _
+ (fun b => ap g (eisretr f b))).
+ Undo.
+ apply (@isequiv_homotopic _ _ ((g o f) o f^-1) g _
+ (fun b => ap g (eisretr f b))).
+Qed.
+
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3900.v b/test-suite/bugs/closed/3900.v
new file mode 100644
index 00000000..6be2161c
--- /dev/null
+++ b/test-suite/bugs/closed/3900.v
@@ -0,0 +1,13 @@
+Global Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Variable A : PreCategory.
+Variable Pobj : A -> Type.
+Local Notation obj := (sigT Pobj).
+Variable Pmor : forall s d : obj, morphism A (projT1 s) (projT1 d) -> Type.
+Class Foo (x : Type) := { _ : forall y, y }.
+Local Instance ishset_pmor {s d m} : Foo (Pmor s d m).
+Proof.
+SearchAbout ((forall _ _, _) -> Foo _).
+Abort.
diff --git a/test-suite/bugs/closed/3916.v b/test-suite/bugs/closed/3916.v
new file mode 100644
index 00000000..55c3a35c
--- /dev/null
+++ b/test-suite/bugs/closed/3916.v
@@ -0,0 +1,3 @@
+Require Import List.
+Fail Hint Resolve -> in_map.
+
diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v
new file mode 100644
index 00000000..93208489
--- /dev/null
+++ b/test-suite/bugs/closed/3922.v
@@ -0,0 +1,84 @@
+Require Import TestSuite.admit.
+Set Universe Polymorphism.
+Notation Type0 := Set.
+
+Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+Notation compose := (fun g f x => g (f x)).
+
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
+ := forall x:A, f x = g x.
+
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+
+Class Contr_internal (A : Type) := BuildContr {
+ center : A ;
+ contr : (forall y : A, center = y)
+}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
+Local Open Scope trunc_scope.
+Notation "-2" := minus_two (at level 0) : trunc_scope.
+Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+ match n with
+ | -2 => Contr_internal A
+ | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
+ end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+ Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation Contr := (IsTrunc -2).
+Notation IsHProp := (IsTrunc -1).
+
+Monomorphic Axiom dummy_funext_type : Type0.
+Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
+
+Inductive Unit : Type1 :=
+ tt : Unit.
+
+Record TruncType (n : trunc_index) := BuildTruncType {
+ trunctype_type : Type ;
+ istrunc_trunctype_type : IsTrunc n trunctype_type
+}.
+
+Arguments BuildTruncType _ _ {_}.
+
+Coercion trunctype_type : TruncType >-> Sortclass.
+
+Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
+Notation hProp := (-1)-Type.
+
+Notation BuildhProp := (BuildTruncType -1).
+
+Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
+ tr : A -> Trunc n A.
+Arguments tr {n A} a.
+
+Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
+: IsTrunc@{j} n (Trunc@{i} n A).
+Admitted.
+
+Definition Trunc_ind {n A}
+ (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
+ : (forall a, P (tr a)) -> (forall aa, P aa)
+:= (fun f aa => match aa with tr a => fun _ => f a end Pt).
+Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A).
+Definition cconst_factors_contr `{Funext} {X Y : Type} (f : X -> Y)
+ (P : Type) `{Pc : X -> Contr P}
+ (g : X -> P) (h : P -> Y) (p : h o g == f)
+: Unit.
+Proof.
+ assert (merely X -> IsHProp P) by admit.
+ refine (let g' := Trunc_ind (fun _ => P) g : merely X -> P in _);
+ [ assumption.. | ].
+ pose (g'' := Trunc_ind (fun _ => P) g : merely X -> P).
diff --git a/test-suite/bugs/closed/3938.v b/test-suite/bugs/closed/3938.v
new file mode 100644
index 00000000..859e9f01
--- /dev/null
+++ b/test-suite/bugs/closed/3938.v
@@ -0,0 +1,8 @@
+Require Import TestSuite.admit.
+Require Import Coq.Arith.PeanoNat.
+Hint Extern 1 => admit : typeclass_instances.
+Require Import Setoid.
+Goal forall a b (f : nat -> Set) (R : nat -> nat -> Prop),
+ Equivalence R -> R a b -> f a = f b.
+ intros a b f H.
+ intros. Fail rewrite H1.
diff --git a/test-suite/bugs/closed/3944.v b/test-suite/bugs/closed/3944.v
new file mode 100644
index 00000000..58e60f4f
--- /dev/null
+++ b/test-suite/bugs/closed/3944.v
@@ -0,0 +1,5 @@
+Require Import Setoid.
+Definition C (T : Type) := T.
+Goal forall T (i : C T) (v : T), True.
+Proof.
+Fail setoid_rewrite plus_n_Sm.
diff --git a/test-suite/bugs/closed/3953.v b/test-suite/bugs/closed/3953.v
new file mode 100644
index 00000000..167cecea
--- /dev/null
+++ b/test-suite/bugs/closed/3953.v
@@ -0,0 +1,5 @@
+(* Checking subst on instances of evars (was bugged in 8.5 beta 1) *)
+Goal forall (a b : unit), a = b -> exists c, b = c.
+ intros.
+ eexists.
+ subst.
diff --git a/test-suite/bugs/closed/3960.v b/test-suite/bugs/closed/3960.v
new file mode 100644
index 00000000..e56dcef7
--- /dev/null
+++ b/test-suite/bugs/closed/3960.v
@@ -0,0 +1,26 @@
+Require Program.Tactics.
+
+Axiom foo : nat -> Prop.
+
+Axiom fooP : forall n, foo n.
+
+Class myClass (A: Type) :=
+ {
+ bar : A -> Prop
+ }.
+
+Program Instance myInstance : myClass nat :=
+ {
+ bar := foo
+ }.
+
+Class myClassP (A : Type) :=
+ {
+ super :> myClass A;
+ barP : forall (a : A), bar a
+ }.
+
+Instance myInstanceP : myClassP nat :=
+ {
+ barP := fooP
+ }.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3978.v b/test-suite/bugs/closed/3978.v
new file mode 100644
index 00000000..26e021e7
--- /dev/null
+++ b/test-suite/bugs/closed/3978.v
@@ -0,0 +1,27 @@
+Require Import Structures.OrderedType.
+Require Import Structures.OrderedTypeEx.
+
+Module Type M. Parameter X : Type.
+
+Declare Module Export XOrd : OrderedType
+ with Definition t := X
+ with Definition eq := @Logic.eq X.
+End M.
+
+Module M' : M.
+ Definition X := nat.
+
+ Module XOrd := Nat_as_OT.
+End M'.
+
+Module Type MyOt.
+ Parameter t : Type.
+ Parameter eq : t -> t -> Prop.
+End MyOt.
+
+Module Type M2. Parameter X : Type.
+
+Declare Module Export XOrd : MyOt
+ with Definition t := X
+ with Definition eq := @Logic.eq X.
+End M2.
diff --git a/test-suite/bugs/closed/3993.v b/test-suite/bugs/closed/3993.v
new file mode 100644
index 00000000..086d8dd0
--- /dev/null
+++ b/test-suite/bugs/closed/3993.v
@@ -0,0 +1,3 @@
+(* Test smooth failure on not fully applied term to destruct with eqn: given *)
+Goal True.
+Fail induction S eqn:H.
diff --git a/test-suite/bugs/closed/4001.v b/test-suite/bugs/closed/4001.v
new file mode 100644
index 00000000..25d78f4b
--- /dev/null
+++ b/test-suite/bugs/closed/4001.v
@@ -0,0 +1,18 @@
+(* Computing the type constraints to be satisfied when building the
+ return clause of a match with a match *)
+
+Set Implicit Arguments.
+Set Asymmetric Patterns.
+
+Variable A : Type.
+Variable typ : A -> Type.
+
+Inductive t : list A -> Type :=
+| snil : t nil
+| scons : forall (x : A) (e : typ x) (lx : list A) (le : t lx), t (x::lx).
+
+Definition car (x:A) (lx : list A) (s: t (x::lx)) : typ x :=
+ match s in t l' with
+ | snil => False
+ | scons _ e _ _ => e
+ end.
diff --git a/test-suite/bugs/closed/4012.v b/test-suite/bugs/closed/4012.v
new file mode 100644
index 00000000..1748e3ba
--- /dev/null
+++ b/test-suite/bugs/closed/4012.v
@@ -0,0 +1,5 @@
+Goal (forall T : Type, T = T) -> Type.
+Proof.
+ intro H.
+ Fail specialize (H _).
+Abort.
diff --git a/test-suite/bugs/closed/4016.v b/test-suite/bugs/closed/4016.v
new file mode 100644
index 00000000..41cb1a88
--- /dev/null
+++ b/test-suite/bugs/closed/4016.v
@@ -0,0 +1,12 @@
+Require Import Setoid.
+
+Parameter eq : relation nat.
+Declare Instance Equivalence_eq : Equivalence eq.
+
+Lemma foo : forall z, eq z 0 -> forall x, eq x 0 -> eq z x.
+Proof.
+intros z Hz x Hx.
+rewrite <- Hx in Hz.
+destruct z.
+Abort.
+
diff --git a/test-suite/bugs/closed/4017.v b/test-suite/bugs/closed/4017.v
new file mode 100644
index 00000000..aa810f4f
--- /dev/null
+++ b/test-suite/bugs/closed/4017.v
@@ -0,0 +1,8 @@
+Set Implicit Arguments.
+
+(* Use of implicit arguments was lost in multiple variable declarations *)
+Variables
+ (A1 : Type)
+ (A2 : forall (x1 : A1), Type)
+ (A3 : forall (x1 : A1) (x2 : A2 x1), Type)
+ (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
diff --git a/test-suite/bugs/closed/4018.v b/test-suite/bugs/closed/4018.v
new file mode 100644
index 00000000..8895e09e
--- /dev/null
+++ b/test-suite/bugs/closed/4018.v
@@ -0,0 +1,3 @@
+(* Catching PatternMatchingFailure was lost at some point *)
+Goal nat -> True.
+Fail intros [=].
diff --git a/test-suite/bugs/closed/4031.v b/test-suite/bugs/closed/4031.v
new file mode 100644
index 00000000..2b8641eb
--- /dev/null
+++ b/test-suite/bugs/closed/4031.v
@@ -0,0 +1,14 @@
+Definition something (P:Type) (e:P) := e.
+
+Inductive myunit : Set := mytt.
+ (* Proof below works when definition is in Type,
+ however builtin types such as unit are in Set. *)
+
+Lemma demo_hide_generic :
+ let x := mytt in x = x.
+Proof.
+ intros.
+ change mytt with (@something _ mytt) in x.
+ subst x. (* Proof works if this line is removed *)
+ reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4035.v b/test-suite/bugs/closed/4035.v
new file mode 100644
index 00000000..ec246d09
--- /dev/null
+++ b/test-suite/bugs/closed/4035.v
@@ -0,0 +1,13 @@
+(* Supporting tactic notations within Ltac in the presence of an
+ "ident" entry which does not expect a fresh ident *)
+(* Of course, this is a matter of convention of what "ident" is
+ supposed to denote, but in practice, it seems more convenient to
+ have less constraints on ident at interpretation time, as
+ otherwise more ad hoc entries would be necessary (as e.g. a special
+ "quantified_hypothesis" entry for dependent destruction). *)
+Require Import Program.
+Goal nat -> Type.
+ intro x.
+ lazymatch goal with
+ | [ x : nat |- _ ] => dependent destruction x
+ end.
diff --git a/test-suite/bugs/closed/4046.v b/test-suite/bugs/closed/4046.v
new file mode 100644
index 00000000..8f8779b7
--- /dev/null
+++ b/test-suite/bugs/closed/4046.v
@@ -0,0 +1,6 @@
+Module Import Foo.
+ Class Foo := { foo : Type }.
+End Foo.
+
+Instance f : Foo := { foo := nat }. (* works fine *)
+Instance f' : Foo.Foo := { Foo.foo := nat }.
diff --git a/test-suite/bugs/closed/4078.v b/test-suite/bugs/closed/4078.v
new file mode 100644
index 00000000..236cd2fb
--- /dev/null
+++ b/test-suite/bugs/closed/4078.v
@@ -0,0 +1,14 @@
+Module Type S.
+
+Axiom foo : nat.
+
+End S.
+
+Module M : S.
+
+Definition bar := 0.
+Definition foo := bar.
+
+End M.
+
+Print All Dependencies M.foo.
diff --git a/test-suite/bugs/closed/4089.v b/test-suite/bugs/closed/4089.v
new file mode 100644
index 00000000..1449f242
--- /dev/null
+++ b/test-suite/bugs/closed/4089.v
@@ -0,0 +1,374 @@
+Require Import TestSuite.admit.
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 6522 lines to 318 lines, then from 1139 lines to 361 lines *)
+(* coqc version 8.5beta1 (February 2015) compiled on Feb 23 2015 18:32:3 with OCaml 4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ebfc19d792492417b129063fb511aa423e9d9e08) *)
+Open Scope type_scope.
+
+Global Set Universe Polymorphism.
+Module Export Datatypes.
+
+Set Implicit Arguments.
+
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+
+End Datatypes.
+Module Export Specif.
+
+Set Implicit Arguments.
+
+Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }.
+
+Notation sigT := sig (only parsing).
+Notation existT := exist (only parsing).
+
+Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope.
+
+Notation projT1 := proj1_sig (only parsing).
+Notation projT2 := proj2_sig (only parsing).
+
+End Specif.
+
+Ltac rapply p :=
+ refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _ _) ||
+ refine (p _ _ _ _ _) ||
+ refine (p _ _ _ _) ||
+ refine (p _ _ _) ||
+ refine (p _ _) ||
+ refine (p _) ||
+ refine p.
+
+Local Unset Elimination Schemes.
+
+Definition relation (A : Type) := A -> A -> Type.
+
+Class Symmetric {A} (R : relation A) :=
+ symmetry : forall x y, R x y -> R y x.
+
+Class Transitive {A} (R : relation A) :=
+ transitivity : forall x y z, R x y -> R y z -> R x z.
+
+Tactic Notation "etransitivity" open_constr(y) :=
+ let R := match goal with |- ?R ?x ?z => constr:(R) end in
+ let x := match goal with |- ?R ?x ?z => constr:(x) end in
+ let z := match goal with |- ?R ?x ?z => constr:(z) end in
+ let pre_proof_term_head := constr:(@transitivity _ R _) in
+ let proof_term_head := (eval cbn in pre_proof_term_head) in
+ refine (proof_term_head x y z _ _); [ change (R x y) | change (R y z) ].
+
+Ltac transitivity x := etransitivity x.
+
+Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.
+
+Notation idmap := (fun x => x).
+Delimit Scope function_scope with function.
+Delimit Scope path_scope with path.
+Delimit Scope fibration_scope with fibration.
+Open Scope fibration_scope.
+Open Scope function_scope.
+
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+
+Notation pr1 := projT1.
+Notation pr2 := projT2.
+
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.
+
+Notation compose := (fun g f x => g (f x)).
+
+Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+ idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Scheme paths_ind := Induction for paths Sort Type.
+
+Definition paths_rect := paths_ind.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Local Open Scope path_scope.
+
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
+ := match p with idpath => idpath end.
+
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
+ match p, q with idpath, idpath => idpath end.
+
+Arguments concat {A x y z} p q : simpl nomatch.
+
+Notation "1" := idpath : path_scope.
+
+Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.
+
+Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+ match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+ := match p with idpath => idpath end.
+
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
+ := forall x:A, f x = g x.
+
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+ : f == g
+ := fun x => match h with idpath => 1 end.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+ forall x : A, r (s x) = x.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+ equiv_inv : B -> A ;
+ eisretr : Sect equiv_inv f;
+ eissect : Sect f equiv_inv;
+ eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Arguments eisretr {A B}%type_scope f%function_scope {_} _.
+Arguments eissect {A B}%type_scope f%function_scope {_} _.
+Arguments eisadj {A B}%type_scope f%function_scope {_} _.
+
+Record Equiv A B := BuildEquiv {
+ equiv_fun : A -> B ;
+ equiv_isequiv : IsEquiv equiv_fun
+}.
+
+Coercion equiv_fun : Equiv >-> Funclass.
+
+Global Existing Instance equiv_isequiv.
+
+Bind Scope equiv_scope with Equiv.
+
+Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope.
+
+Inductive Unit : Type1 :=
+ tt : Unit.
+
+Ltac done :=
+ trivial; intros; solve
+ [ repeat first
+ [ solve [trivial]
+ | solve [symmetry; trivial]
+ | reflexivity
+
+ | contradiction
+ | split ]
+ | match goal with
+ H : ~ _ |- _ => solve [destruct H; trivial]
+ end ].
+Tactic Notation "by" tactic(tac) :=
+ tac; done.
+
+Definition concat_p1 {A : Type} {x y : A} (p : x = y) :
+ p @ 1 = p
+ :=
+ match p with idpath => 1 end.
+
+Definition concat_1p {A : Type} {x y : A} (p : x = y) :
+ 1 @ p = p
+ :=
+ match p with idpath => 1 end.
+
+Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) :
+ ap f (p @ q) = (ap f p) @ (ap f q)
+ :=
+ match q with
+ idpath =>
+ match p with idpath => 1 end
+ end.
+
+Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
+ ap (g o f) p = ap g (ap f p)
+ :=
+ match p with idpath => 1 end.
+
+Definition concat_A1p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) :
+ (ap f q) @ (p y) = (p x) @ q
+ :=
+ match q with
+ | idpath => concat_1p _ @ ((concat_p1 _) ^)
+ end.
+
+Definition concat2 {A} {x y z : A} {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q')
+ : p @ q = p' @ q'
+:= match h, h' with idpath, idpath => 1 end.
+
+Notation "p @@ q" := (concat2 p q)%path (at level 20) : path_scope.
+
+Definition whiskerL {A : Type} {x y z : A} (p : x = y)
+ {q r : y = z} (h : q = r) : p @ q = p @ r
+:= 1 @@ h.
+
+Definition ap02 {A B : Type} (f:A->B) {x y:A} {p q:x=y} (r:p=q) : ap f p = ap f q
+ := match r with idpath => 1 end.
+Module Export Equivalences.
+
+Generalizable Variables A B C f g.
+
+Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 :=
+ BuildIsEquiv A A idmap idmap (fun _ => 1) (fun _ => 1) (fun _ => 1).
+
+Definition equiv_idmap (A : Type) : A <~> A := BuildEquiv A A idmap _.
+
+Arguments equiv_idmap {A} , A.
+
+Notation "1" := equiv_idmap : equiv_scope.
+
+Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
+ : IsEquiv (compose g f) | 1000
+ := BuildIsEquiv A C (compose g f)
+ (compose f^-1 g^-1)
+ (fun c => ap g (eisretr f (g^-1 c)) @ eisretr g c)
+ (fun a => ap (f^-1) (eissect g (f a)) @ eissect f a)
+ (fun a =>
+ (whiskerL _ (eisadj g (f a))) @
+ (ap_pp g _ _)^ @
+ ap02 g
+ ( (concat_A1p (eisretr f) (eissect g (f a)))^ @
+ (ap_compose f^-1 f _ @@ eisadj f a) @
+ (ap_pp f _ _)^
+ ) @
+ (ap_compose f g _)^
+ ).
+
+Definition equiv_compose {A B C : Type} (g : B -> C) (f : A -> B)
+ `{IsEquiv B C g} `{IsEquiv A B f}
+ : A <~> C
+ := BuildEquiv A C (compose g f) _.
+
+Global Instance transitive_equiv : Transitive Equiv | 0 :=
+ fun _ _ _ f g => equiv_compose g f.
+
+Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A).
+admit.
+Defined.
+
+Global Instance symmetric_equiv : Symmetric Equiv | 0 := @equiv_inverse.
+
+End Equivalences.
+
+Definition path_prod_uncurried {A B : Type} (z z' : A * B)
+ (pq : (fst z = fst z') * (snd z = snd z'))
+ : (z = z').
+admit.
+Defined.
+
+Global Instance isequiv_path_prod {A B : Type} {z z' : A * B}
+: IsEquiv (path_prod_uncurried z z') | 0.
+admit.
+Defined.
+
+Definition equiv_path_prod {A B : Type} (z z' : A * B)
+ : (fst z = fst z') * (snd z = snd z') <~> (z = z')
+ := BuildEquiv _ _ (path_prod_uncurried z z') _.
+
+Generalizable Variables X A B C f g n.
+
+Definition functor_sigma `{P : A -> Type} `{Q : B -> Type}
+ (f : A -> B) (g : forall a, P a -> Q (f a))
+: sigT P -> sigT Q
+ := fun u => (f u.1 ; g u.1 u.2).
+
+Global Instance isequiv_functor_sigma `{P : A -> Type} `{Q : B -> Type}
+ `{IsEquiv A B f} `{forall a, @IsEquiv (P a) (Q (f a)) (g a)}
+: IsEquiv (functor_sigma f g) | 1000.
+admit.
+Defined.
+
+Definition equiv_functor_sigma `{P : A -> Type} `{Q : B -> Type}
+ (f : A -> B) `{IsEquiv A B f}
+ (g : forall a, P a -> Q (f a))
+ `{forall a, @IsEquiv (P a) (Q (f a)) (g a)}
+: sigT P <~> sigT Q
+ := BuildEquiv _ _ (functor_sigma f g) _.
+
+Definition equiv_functor_sigma' `{P : A -> Type} `{Q : B -> Type}
+ (f : A <~> B)
+ (g : forall a, P a <~> Q (f a))
+: sigT P <~> sigT Q
+ := equiv_functor_sigma f g.
+
+Definition equiv_functor_sigma_id `{P : A -> Type} `{Q : A -> Type}
+ (g : forall a, P a <~> Q a)
+: sigT P <~> sigT Q
+ := equiv_functor_sigma' 1 g.
+
+Definition Bip : Type := { C : Type & C * C }.
+
+Definition BipMor (X Y : Bip) : Type :=
+ match X, Y with (C;(c0,c1)), (D;(d0,d1)) =>
+ { f : C -> D & (f c0 = d0) * (f c1 = d1) }
+ end.
+
+Definition bipmor2map {X Y : Bip} : BipMor X Y -> X.1 -> Y.1 :=
+ match X, Y with (C;(c0,c1)), (D;(d0,d1)) => fun i =>
+ match i with (f;_) => f end
+ end.
+
+Definition bipidmor {X : Bip} : BipMor X X :=
+ match X with (C;(c0,c1)) => (idmap; (1, 1)) end.
+
+Definition bipcompmor {X Y Z : Bip} : BipMor X Y -> BipMor Y Z -> BipMor X Z :=
+ match X, Y, Z with (C;(c0,c1)), (D;(d0,d1)), (E;(e0,e1)) => fun i j =>
+ match i, j with (f;(f0,f1)), (g;(g0,g1)) =>
+ (g o f; (ap g f0 @ g0, ap g f1 @ g1))
+ end
+ end.
+
+Definition isbipequiv {X Y : Bip} (i : BipMor X Y) : Type :=
+ { l : BipMor Y X & bipcompmor i l = bipidmor } *
+ { r : BipMor Y X & bipcompmor r i = bipidmor }.
+
+Lemma bipequivEQequiv : forall {X Y : Bip} (i : BipMor X Y),
+ isbipequiv i <~> IsEquiv (bipmor2map i).
+Proof.
+assert (equivcompmor : forall {X Y : Bip} (i : BipMor X Y) j,
+(bipcompmor i j = bipidmor) <~> Unit).
+ intros; set (U := X); set (V := Y); destruct X as [C [c0 c1]], Y as [D [d0 d1]].
+ transitivity { n : (bipcompmor i j).1 = (@bipidmor U).1 &
+ (bipcompmor i j).2 = transport (fun h => (h c0 = c0) * (h c1 = c1)) n^ (@bipidmor U).2}.
+ admit.
+ destruct i as [f [f0 f1]]; destruct j as [g [g0 g1]].
+
+ transitivity { n : g o f = idmap & (ap g f0 @ g0 = apD10 n c0 @ 1) *
+ (ap g f1 @ g1 = apD10 n c1 @ 1)}.
+ apply equiv_functor_sigma_id; intro n.
+ assert (Ggen : forall (h0 h1 : C -> C) (p : h0 = h1) u0 u1 v0 v1,
+ ((u0, u1) = transport (fun h => (h c0 = c0) * (h c1 = c1)) p^ (v0, v1)) <~>
+ (u0 = apD10 p c0 @ v0) * (u1 = apD10 p c1 @ v1)).
+ induction p; intros; simpl; rewrite !concat_1p; apply symmetry.
+ by apply (equiv_path_prod (u0,u1) (v0,v1)).
+ rapply Ggen.
+ pose (@paths C).
+ Check (@paths C).
+ Undo.
+ Check (@paths C). (* Toplevel input, characters 0-17:
+Error: Illegal application:
+The term "@paths" of type "forall A : Type, A -> A -> Type"
+cannot be applied to the term
+ "C" : "Type"
+This term has type "Type@{Top.892}" which should be coercible to
+ "Type@{Top.882}".
+*)
diff --git a/test-suite/bugs/closed/4097.v b/test-suite/bugs/closed/4097.v
new file mode 100644
index 00000000..02aa25e0
--- /dev/null
+++ b/test-suite/bugs/closed/4097.v
@@ -0,0 +1,65 @@
+Require Import TestSuite.admit.
+(* File reduced by coq-bug-finder from original input, then from 6082 lines to 81 lines, then from 436 lines to 93 lines *)
+(* coqc version 8.5beta1 (February 2015) compiled on Feb 27 2015 15:10:37 with OCaml 4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (fc1b3ef9d7270938cd83c524aae0383093b7a4b5) *)
+Global Set Primitive Projections.
+Record sigT {A} (P : A -> Type) := exist { projT1 : A ; projT2 : P projT1 }.
+Arguments projT1 {A P} _ / .
+Arguments projT2 {A P} _ / .
+Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope.
+Delimit Scope path_scope with path.
+Delimit Scope fibration_scope with fibration.
+Open Scope path_scope.
+Open Scope fibration_scope.
+Notation "( x ; y )" := (exist _ _ x y) : fibration_scope.
+Notation pr1 := projT1.
+Notation pr2 := projT2.
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
+ := match p with idpath => idpath end.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
+ match p, q with idpath, idpath => idpath end.
+Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.
+Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+ match p with idpath => u end.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+ := match p with idpath => idpath end.
+Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y):
+ p # (f x) = f y
+ :=
+ match p with idpath => idpath end.
+Lemma transport_compose {A B} {x y : A} (P : B -> Type) (f : A -> B)
+ (p : x = y) (z : P (f x))
+ : transport (fun x => P (f x)) p z = transport P (ap f p) z.
+admit.
+Defined.
+Generalizable Variables X A B C f g n.
+Definition pr1_path `{P : A -> Type} {u v : sigT P} (p : u = v)
+: u.1 = v.1
+ := ap pr1 p.
+Notation "p ..1" := (pr1_path p) (at level 3) : fibration_scope.
+Definition pr2_path `{P : A -> Type} {u v : sigT P} (p : u = v)
+: p..1 # u.2 = v.2
+ := (transport_compose P pr1 p u.2)^
+ @ (@apD {x:A & P x} _ pr2 _ _ p).
+Notation "p ..2" := (pr2_path p) (at level 3) : fibration_scope.
+Definition path_path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+ (p q : u = v)
+ (rs : {r : p..1 = q..1 & transport (fun x => transport P x u.2 = v.2) r p..2 = q..2})
+: p = q.
+admit.
+Defined.
+Set Debug Unification.
+Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sigT P)
+ (p q : u = v)
+ (r : p..1 = q..1)
+ (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2)
+: p = q
+ := path_path_sigma_uncurried P u v p q (r; s).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4101.v b/test-suite/bugs/closed/4101.v
new file mode 100644
index 00000000..a38b0509
--- /dev/null
+++ b/test-suite/bugs/closed/4101.v
@@ -0,0 +1,19 @@
+(* File reduced by coq-bug-finder from original input, then from 10940 lines to 152 lines, then from 509 lines to 163 lines, then from 178 lines to 66 lines *)
+(* coqc version 8.5beta1 (March 2015) compiled on Mar 2 2015 18:53:10 with OCaml 4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (e77f178e60918f14eacd1ec0364a491d4cfd0f3f) *)
+
+Global Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x),
+ (forall x, f x = g x) -> f = g.
+Lemma sigT_obj_eq
+: forall (T : Type) (T0 : T -> Type)
+ (s s0 : forall s : sigT T0,
+ sigT (fun _ : T0 (projT1 s) => unit) ->
+ sigT (fun _ : T0 (projT1 s) => unit)),
+ s0 = s.
+Proof.
+ intros.
+ Set Debug Tactic Unification.
+ apply path_forall.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4103.v b/test-suite/bugs/closed/4103.v
new file mode 100644
index 00000000..92cc0279
--- /dev/null
+++ b/test-suite/bugs/closed/4103.v
@@ -0,0 +1,12 @@
+Set Primitive Projections.
+
+CoInductive stream A := { hd : A; tl : stream A }.
+
+CoFixpoint ticks (n : nat) : stream unit := {| hd := tt; tl := ticks n |}.
+
+Lemma expand : exists n : nat, (ticks n) = (ticks n).(tl _).
+Proof.
+ eexists.
+ (* Set Debug Tactic Unification. *)
+ (* Set Debug RAKAM. *)
+ reflexivity.
diff --git a/test-suite/bugs/closed/4120.v b/test-suite/bugs/closed/4120.v
new file mode 100644
index 00000000..00db8f7f
--- /dev/null
+++ b/test-suite/bugs/closed/4120.v
@@ -0,0 +1,5 @@
+Definition id {T} (x : T) := x.
+Goal sigT (fun x => id x)%type.
+ change (fun x => ?f x) with f.
+ exists Type. exact Set.
+Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v
new file mode 100644
index 00000000..5f8c411c
--- /dev/null
+++ b/test-suite/bugs/closed/4121.v
@@ -0,0 +1,15 @@
+(* -*- coq-prog-args: ("-emacs" "-nois") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *)
+(* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0
+ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *)
+
+Set Universe Polymorphism.
+Class Contr_internal (A : Type) := BuildContr { center : A }.
+Arguments center A {_}.
+Class Contr (A : Type) : Type := Contr_is_trunc : Contr_internal A.
+Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A |}.
+Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}.
+Check @contr_paths_contr0@{i}.
+Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *)
+(** It should have length 1, just like contr_paths_contr0 *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/4165.v b/test-suite/bugs/closed/4165.v
new file mode 100644
index 00000000..8e0a62d3
--- /dev/null
+++ b/test-suite/bugs/closed/4165.v
@@ -0,0 +1,7 @@
+Lemma foo : True.
+Proof.
+pose (fun x : nat => (let H:=true in x)) as s.
+match eval cbv delta [s] in s with
+| context C[true] =>
+ let C':=context C[false] in pose C' as s'
+end.
diff --git a/test-suite/bugs/closed/4190.v b/test-suite/bugs/closed/4190.v
new file mode 100644
index 00000000..2843488b
--- /dev/null
+++ b/test-suite/bugs/closed/4190.v
@@ -0,0 +1,15 @@
+Module Type A .
+ Tactic Notation "bar" := idtac "ITSME".
+End A.
+
+Module Type B.
+ Tactic Notation "foo" := fail "NOTME".
+End B.
+
+Module Type C := A <+ B.
+
+Module Type F (Import M : C).
+
+Lemma foo : True.
+Proof.
+bar.
diff --git a/test-suite/bugs/closed/4193.v b/test-suite/bugs/closed/4193.v
new file mode 100644
index 00000000..885d04a9
--- /dev/null
+++ b/test-suite/bugs/closed/4193.v
@@ -0,0 +1,7 @@
+Module Type E.
+End E.
+
+Module Type A (M : E).
+End A.
+
+Fail Module Type F (Import X : A).
diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v
index 8592c729..0b8bb235 100644
--- a/test-suite/bugs/closed/HoTT_coq_007.v
+++ b/test-suite/bugs/closed/HoTT_coq_007.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Module Comment1.
Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v
index 63548a64..ae3e50d7 100644
--- a/test-suite/bugs/closed/HoTT_coq_014.v
+++ b/test-suite/bugs/closed/HoTT_coq_014.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
Set Universe Polymorphism.
@@ -121,6 +122,7 @@ Section GraphObj.
Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) :
GraphIndex_Morphism s d'.
+ Proof using. (* This makes no sense, but it makes this test behave as before the no admit commit *)
Admitted.
Definition GraphIndexingCategory : @SpecializedCategory GraphIndex.
diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v
index b16c1df2..4938b80f 100644
--- a/test-suite/bugs/closed/HoTT_coq_020.v
+++ b/test-suite/bugs/closed/HoTT_coq_020.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_029.v b/test-suite/bugs/closed/HoTT_coq_029.v
index 4fd54b56..161c4d21 100644
--- a/test-suite/bugs/closed/HoTT_coq_029.v
+++ b/test-suite/bugs/closed/HoTT_coq_029.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Module FirstComment.
Set Implicit Arguments.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_030.v b/test-suite/bugs/closed/HoTT_coq_030.v
index fa5ee25c..9f892483 100644
--- a/test-suite/bugs/closed/HoTT_coq_030.v
+++ b/test-suite/bugs/closed/HoTT_coq_030.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
diff --git a/test-suite/bugs/closed/HoTT_coq_035.v b/test-suite/bugs/closed/HoTT_coq_035.v
index 4ad2fc02..133bf6c7 100644
--- a/test-suite/bugs/closed/HoTT_coq_035.v
+++ b/test-suite/bugs/closed/HoTT_coq_035.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Fail Check Prop : Prop. (* Prop:Prop
: Prop *)
Fail Check Set : Prop. (* Set:Prop
diff --git a/test-suite/bugs/closed/HoTT_coq_042.v b/test-suite/bugs/closed/HoTT_coq_042.v
index 6b206a2f..432cf705 100644
--- a/test-suite/bugs/closed/HoTT_coq_042.v
+++ b/test-suite/bugs/closed/HoTT_coq_042.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Set Universe Polymorphism.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_055.v b/test-suite/bugs/closed/HoTT_coq_055.v
index 92d70ad1..a2509877 100644
--- a/test-suite/bugs/closed/HoTT_coq_055.v
+++ b/test-suite/bugs/closed/HoTT_coq_055.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v
index 6e65320d..3e3a987a 100644
--- a/test-suite/bugs/closed/HoTT_coq_056.v
+++ b/test-suite/bugs/closed/HoTT_coq_056.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 10455 lines to 8350 lines, then from 7790 lines to 710 lines, then from 7790 lines to 710 lines, then from 566 lines to 340 lines, then from 191 lines to 171 lines, then from 191 lines to 171 lines. *)
Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v
index 9ce7dba9..5e5d5ab3 100644
--- a/test-suite/bugs/closed/HoTT_coq_058.v
+++ b/test-suite/bugs/closed/HoTT_coq_058.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 10044 lines to 493 lines, then from 425 lines to 160 lines. *)
Set Universe Polymorphism.
Notation idmap := (fun x => x).
diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v
index 26c1f963..19551dc9 100644
--- a/test-suite/bugs/closed/HoTT_coq_061.v
+++ b/test-suite/bugs/closed/HoTT_coq_061.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* There are some problems in materialize_evar with local definitions,
as CO below; this is not completely sorted out yet, but at least
it fails in a smooth way at the time of today [HH] *)
diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v
index db895316..b7db22a6 100644
--- a/test-suite/bugs/closed/HoTT_coq_062.v
+++ b/test-suite/bugs/closed/HoTT_coq_062.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v
index 5f0a541b..b4c74537 100644
--- a/test-suite/bugs/closed/HoTT_coq_064.v
+++ b/test-suite/bugs/closed/HoTT_coq_064.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 279 lines to 219 lines. *)
Set Implicit Arguments.
diff --git a/test-suite/bugs/closed/HoTT_coq_067.v b/test-suite/bugs/closed/HoTT_coq_067.v
index ad32a60c..84a5bc02 100644
--- a/test-suite/bugs/closed/HoTT_coq_067.v
+++ b/test-suite/bugs/closed/HoTT_coq_067.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Universe Polymorphism.
Inductive paths {A : Type} (a : A) : A -> Type :=
idpath : paths a a.
diff --git a/test-suite/bugs/closed/HoTT_coq_088.v b/test-suite/bugs/closed/HoTT_coq_088.v
index b3e1df57..0428af0d 100644
--- a/test-suite/bugs/closed/HoTT_coq_088.v
+++ b/test-suite/bugs/closed/HoTT_coq_088.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Inductive paths {A : Type} (a : A) : A -> Type :=
idpath : paths a a.
diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v
index 5c704147..5fa16703 100644
--- a/test-suite/bugs/closed/HoTT_coq_090.v
+++ b/test-suite/bugs/closed/HoTT_coq_090.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(** I'm not sure if this tests what I want it to test... *)
Set Implicit Arguments.
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_098.v b/test-suite/bugs/closed/HoTT_coq_098.v
index fc99daab..bdcd8ba9 100644
--- a/test-suite/bugs/closed/HoTT_coq_098.v
+++ b/test-suite/bugs/closed/HoTT_coq_098.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_099.v b/test-suite/bugs/closed/HoTT_coq_099.v
index 9b6ace82..cd5b0c8f 100644
--- a/test-suite/bugs/closed/HoTT_coq_099.v
+++ b/test-suite/bugs/closed/HoTT_coq_099.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 138 lines to 78 lines. *)
Set Implicit Arguments.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_100.v b/test-suite/bugs/closed/HoTT_coq_100.v
index c39b7093..663b6280 100644
--- a/test-suite/bugs/closed/HoTT_coq_100.v
+++ b/test-suite/bugs/closed/HoTT_coq_100.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 335 lines to 115 lines. *)
Set Implicit Arguments.
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_101.v b/test-suite/bugs/closed/HoTT_coq_101.v
index 9c89a6ab..3ef56892 100644
--- a/test-suite/bugs/closed/HoTT_coq_101.v
+++ b/test-suite/bugs/closed/HoTT_coq_101.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_102.v b/test-suite/bugs/closed/HoTT_coq_102.v
index 71becfd2..996aaaa4 100644
--- a/test-suite/bugs/closed/HoTT_coq_102.v
+++ b/test-suite/bugs/closed/HoTT_coq_102.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 64 lines to 30 lines. *)
Set Implicit Arguments.
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v
index c3a83627..7c1ab8dc 100644
--- a/test-suite/bugs/closed/HoTT_coq_107.v
+++ b/test-suite/bugs/closed/HoTT_coq_107.v
@@ -1,4 +1,4 @@
-(* -*- mode: coq; coq-prog-args: ("-nois" "-emacs") -*- *)
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-R" "../theories" "Coq") -*- *)
(* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *)
(** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *)
Require Import Coq.Init.Logic.
@@ -59,7 +59,7 @@ Instance trunc_sigma `{P : A -> Type}
Proof.
generalize dependent A.
- induction n; [ | admit ]; simpl; intros A P ac Pc.
+ induction n; [ | apply admit ]; simpl; intros A P ac Pc.
(exists (existT _ (center A) (center (P (center A))))).
intros [a ?].
refine (path_sigma' P (contr a) (path_contr _ _)).
@@ -102,5 +102,5 @@ The term
| false => B
end))" (Universe inconsistency: Cannot enforce Top.197 = Set)).
*)
- admit.
+ apply admit.
Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v
index cc304802..4f5ef997 100644
--- a/test-suite/bugs/closed/HoTT_coq_108.v
+++ b/test-suite/bugs/closed/HoTT_coq_108.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
(* NOTE: This bug is only triggered with -load-vernac-source / in interactive mode. *)
(* File reduced by coq-bug-finder from 139 lines to 124 lines. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_112.v b/test-suite/bugs/closed/HoTT_coq_112.v
index 150f2ecc..5bee69fc 100644
--- a/test-suite/bugs/closed/HoTT_coq_112.v
+++ b/test-suite/bugs/closed/HoTT_coq_112.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 4464 lines to 4137 lines, then from 3683 lines to 118 lines, then from 124 lines to 75 lines. *)
Set Universe Polymorphism.
Definition admit {T} : T.
diff --git a/test-suite/bugs/closed/HoTT_coq_113.v b/test-suite/bugs/closed/HoTT_coq_113.v
index 3ef531bc..05e76784 100644
--- a/test-suite/bugs/closed/HoTT_coq_113.v
+++ b/test-suite/bugs/closed/HoTT_coq_113.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 3329 lines to 153 lines, then from 118 lines to 49 lines, then from 55 lines to 38 lines, then from 46 lines to 16 lines *)
Generalizable All Variables.
diff --git a/test-suite/bugs/closed/HoTT_coq_118.v b/test-suite/bugs/closed/HoTT_coq_118.v
index 14ad0e49..e41689cb 100644
--- a/test-suite/bugs/closed/HoTT_coq_118.v
+++ b/test-suite/bugs/closed/HoTT_coq_118.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 5631 lines to 557 lines, then from 526 lines to 181 lines, then from 189 lines to 154 lines, then from 153 lines to 107 lines, then from 97 lines to 56 lines, then from 50 lines to 37 lines *)
Generalizable All Variables.
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_121.v b/test-suite/bugs/closed/HoTT_coq_121.v
index cce288cf..90493a53 100644
--- a/test-suite/bugs/closed/HoTT_coq_121.v
+++ b/test-suite/bugs/closed/HoTT_coq_121.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines, then from 146 lines to 72 lines, then from 82 lines to 70 lines, then from 79 lines to 49 lines, then from 59 lines to 16 lines *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v
index 994dff63..6ee6e653 100644
--- a/test-suite/bugs/closed/HoTT_coq_123.v
+++ b/test-suite/bugs/closed/HoTT_coq_123.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") *)
(* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *)
Set Universe Polymorphism.
diff --git a/test-suite/bugs/opened/2456.v b/test-suite/bugs/opened/2456.v
new file mode 100644
index 00000000..6cca5c9f
--- /dev/null
+++ b/test-suite/bugs/opened/2456.v
@@ -0,0 +1,53 @@
+
+Require Import Equality.
+
+Parameter Patch : nat -> nat -> Set.
+
+Inductive Catch (from to : nat) : Type
+ := MkCatch : forall (p : Patch from to),
+ Catch from to.
+Implicit Arguments MkCatch [from to].
+
+Inductive CatchCommute5
+ : forall {from mid1 mid2 to : nat},
+ Catch from mid1
+ -> Catch mid1 to
+ -> Catch from mid2
+ -> Catch mid2 to
+ -> Prop
+ := MkCatchCommute5 :
+ forall {from mid1 mid2 to : nat}
+ (p : Patch from mid1)
+ (q : Patch mid1 to)
+ (q' : Patch from mid2)
+ (p' : Patch mid2 to),
+ CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p').
+
+Inductive CatchCommute {from mid1 mid2 to : nat}
+ (p : Catch from mid1)
+ (q : Catch mid1 to)
+ (q' : Catch from mid2)
+ (p' : Catch mid2 to)
+ : Prop
+ := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'),
+ CatchCommute p q q' p'.
+Notation "<< p , q >> <~> << q' , p' >>"
+ := (CatchCommute p q q' p')
+ (at level 60, no associativity).
+
+Lemma CatchCommuteUnique2 :
+ forall {from mid mid' to : nat}
+ {p : Catch from mid} {q : Catch mid to}
+ {q' : Catch from mid'} {p' : Catch mid' to}
+ {q'' : Catch from mid'} {p'' : Catch mid' to}
+ (commute1 : <> <~> <>)
+ (commute2 : <> <~> <>),
+ (p' = p'') /\ (q' = q'').
+Proof with auto.
+intros.
+set (X := commute2).
+Fail dependent destruction commute1;
+dependent destruction catchCommuteDetails;
+dependent destruction commute2;
+dependent destruction catchCommuteDetails generalizing X.
+Admitted.
diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v
deleted file mode 100644
index 3739247b..00000000
--- a/test-suite/bugs/opened/2951.v
+++ /dev/null
@@ -1 +0,0 @@
-Class C (A: Type) : Type := { f: A }.
diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/opened/3071.v
deleted file mode 100644
index 611ac606..00000000
--- a/test-suite/bugs/opened/3071.v
+++ /dev/null
@@ -1,5 +0,0 @@
-Definition foo := True.
-
-Section foo.
- Global Arguments foo / .
-Fail End foo.
diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v
index 6de13f74..f0c707bd 100644
--- a/test-suite/bugs/opened/3263.v
+++ b/test-suite/bugs/opened/3263.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *)
Generalizable All Variables.
Set Implicit Arguments.
diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/opened/3298.v
deleted file mode 100644
index bce7c3f2..00000000
--- a/test-suite/bugs/opened/3298.v
+++ /dev/null
@@ -1,23 +0,0 @@
-Module JGross.
- Hint Extern 1 => match goal with |- match ?E with end => case E end.
-
- Goal forall H : False, match H return Set with end.
- Proof.
- intros.
- Fail solve [ eauto ]. (* No applicable tactic *)
- admit.
- Qed.
-End JGross.
-
-Section BenDelaware.
- Hint Extern 0 => admit.
- Goal forall (H : False), id (match H return Set with end).
- Proof.
- eauto.
- Qed.
- Goal forall (H : False), match H return Set with end.
- Proof.
- Fail solve [ eauto ] .
- admit.
- Qed.
-End BenDelaware.
diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v
index b61174a8..3e3da6df 100644
--- a/test-suite/bugs/opened/3345.v
+++ b/test-suite/bugs/opened/3345.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *)
Global Set Implicit Arguments.
Require Import Coq.Lists.List Program.
diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v
index ff0dbf97..5ca48fc9 100644
--- a/test-suite/bugs/opened/3395.v
+++ b/test-suite/bugs/opened/3395.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *)
Generalizable All Variables.
Set Implicit Arguments.
diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/opened/3467.v
deleted file mode 100644
index 900bfc34..00000000
--- a/test-suite/bugs/opened/3467.v
+++ /dev/null
@@ -1,6 +0,0 @@
-Module foo.
- Notation x := $(exact I)$.
-End foo.
-Module bar.
- Fail Include foo.
-End bar.
diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/opened/3490.v
deleted file mode 100644
index e7a5caa1..00000000
--- a/test-suite/bugs/opened/3490.v
+++ /dev/null
@@ -1,27 +0,0 @@
-Inductive T : Type :=
-| Var : nat -> T
-| Arr : T -> T -> T.
-
-Inductive Tele : list T -> Type :=
-| Tnil : @Tele nil
-| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls).
-
-Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t}
- : { x : Type & x -> nat -> Type } :=
- match t return { x : Type & x -> nat -> Type } with
- | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit)
- | Tcons ls t' l =>
- let (result, get) := TeleD ls t' in
- @existT Type (fun x => x -> nat -> Type)
- { v : result & (fix TD (t : T) {struct t} :=
- match t with
- | Var n =>
- get v n
- | Arr a b => TD a -> TD b
- end) l }
- (fun x n =>
- match n return Type with
- | 0 => projT2 x
- | S n => get (projT1 x) n
- end)
- end.
diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v
deleted file mode 100644
index 9837b0ec..00000000
--- a/test-suite/bugs/opened/3491.v
+++ /dev/null
@@ -1,2 +0,0 @@
-Fail Inductive list (A : Type) (T := A) : Type :=
- nil : list A | cons : T -> list T -> list A.
diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v
index 02e47a8b..3913bbb4 100644
--- a/test-suite/bugs/opened/3509.v
+++ b/test-suite/bugs/opened/3509.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Lemma match_bool_fn b A B xT xF
: match b as b return forall x : A, B b x with
| true => xT
diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v
index 25285636..daf26507 100644
--- a/test-suite/bugs/opened/3510.v
+++ b/test-suite/bugs/opened/3510.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Lemma match_option_fn T (b : option T) A B s n
: match b as b return forall x : A, B b x with
| Some k => s k
diff --git a/test-suite/bugs/opened/3593.v b/test-suite/bugs/opened/3593.v
new file mode 100644
index 00000000..d83b9006
--- /dev/null
+++ b/test-suite/bugs/opened/3593.v
@@ -0,0 +1,10 @@
+Set Universe Polymorphism.
+Set Printing All.
+Set Implicit Arguments.
+Record prod A B := pair { fst : A ; snd : B }.
+Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x.
+simpl; intros.
+ constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x).
+ Fail Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x).
+ reflexivity.
+Qed.
diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/opened/3681.v
deleted file mode 100644
index 194113c6..00000000
--- a/test-suite/bugs/opened/3681.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Module Type FOO.
- Parameters P Q : Type -> Type.
-End FOO.
-
-Module Type BAR.
- Declare Module Import foo : FOO.
- Parameter f : forall A, P A -> Q A -> A.
-End BAR.
-
-Module Type BAZ.
- Declare Module Export foo : FOO.
- Parameter g : forall A, P A -> Q A -> A.
-End BAZ.
-
-Module BAR_FROM_BAZ (baz : BAZ) : BAR.
- Import baz.
- Module foo <: FOO := foo.
- Import foo.
- Definition f : forall A, P A -> Q A -> A := g.
-End BAR_FROM_BAZ.
diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v
index d647b5a8..b2b5db6b 100644
--- a/test-suite/bugs/opened/3685.v
+++ b/test-suite/bugs/opened/3685.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Set Universe Polymorphism.
Class Funext := { }.
Delimit Scope category_scope with category.
diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v
index c7441882..9b3f94d9 100644
--- a/test-suite/bugs/opened/3754.v
+++ b/test-suite/bugs/opened/3754.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *)
(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1
coqtop version trunk (October 2014) *)
diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/opened/3786.v
deleted file mode 100644
index 5a124115..00000000
--- a/test-suite/bugs/opened/3786.v
+++ /dev/null
@@ -1,40 +0,0 @@
-Require Coq.Lists.List.
-Require Coq.Sets.Ensembles.
-Import Coq.Sets.Ensembles.
-Global Set Implicit Arguments.
-Delimit Scope comp_scope with comp.
-Inductive Comp : Type -> Type :=
-| Return : forall A, A -> Comp A
-| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B
-| Pick : forall A, Ensemble A -> Comp A.
-Notation ret := Return.
-Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
- (at level 81, right associativity,
- format "'[v' x <- y ; '/' z ']'") : comp_scope.
-Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.
-Open Scope comp.
-Axiom elements : forall {A} (ls : list A), Ensemble A.
-Axiom to_list : forall {A} (S : Ensemble A), Comp (list A).
-Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0).
-Definition sumUniqueSpec (ls : list nat) : Comp nat.
- exact (ls' <- to_list (elements ls);
- List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls').
-Defined.
-Axiom admit : forall {T}, T.
-Definition sumUniqueImpl (ls : list nat)
-: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type.
-Proof.
- eexists.
- match goal with
- | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b)
- end;
- try setoid_rewrite (@finite_set_handle_cardinal).
- Undo.
- match goal with
- | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b)
- end.
- try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise").
-Please report. *)
- instantiate (1 := admit).
- admit.
-Defined.
diff --git a/test-suite/bugs/opened/3794.v b/test-suite/bugs/opened/3794.v
new file mode 100644
index 00000000..99ca6cb3
--- /dev/null
+++ b/test-suite/bugs/opened/3794.v
@@ -0,0 +1,7 @@
+Hint Extern 10 ((?X = ?Y) -> False) => intros; discriminate.
+Hint Unfold not : core.
+
+Goal true<>false.
+Set Typeclasses Debug.
+Fail typeclasses eauto with core.
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/3848.v b/test-suite/bugs/opened/3848.v
new file mode 100644
index 00000000..a03e8ffd
--- /dev/null
+++ b/test-suite/bugs/opened/3848.v
@@ -0,0 +1,22 @@
+Require Import TestSuite.admit.
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
+Arguments eisretr {A B} f {_} _.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
+Generalizable Variables A B f g e n.
+Definition functor_forall `{P : A -> Type} `{Q : B -> Type}
+ (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b)
+: (forall a:A, P a) -> (forall b:B, Q b).
+ admit.
+Defined.
+
+Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type}
+ `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)}
+: (forall b : B, Q b) -> forall a : A, P a.
+Proof.
+ refine (functor_forall
+ (f^-1)
+ (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)).
+Fail Defined. (* Error: Attempt to save an incomplete proof *)
diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v
index 7847c5e4..05ee6c7b 100644
--- a/test-suite/bugs/opened/HoTT_coq_120.v
+++ b/test-suite/bugs/opened/HoTT_coq_120.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *)
Set Universe Polymorphism.
Generalizable All Variables.
diff --git a/test-suite/complexity/bug4076.v b/test-suite/complexity/bug4076.v
new file mode 100644
index 00000000..3cf9e8b0
--- /dev/null
+++ b/test-suite/complexity/bug4076.v
@@ -0,0 +1,29 @@
+(* Check behavior of evar-evar subtyping problems in the presence of
+ nested let-ins *)
+(* Expected time < 2.00s *)
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Parameter f : forall P, forall (i : nat), P i -> P i.
+Parameter P : nat -> Type.
+
+Time Definition g (n : nat) (a0 : P n) : P n :=
+ let a1 := f a0 in
+ let a2 := f a1 in
+ let a3 := f a2 in
+ let a4 := f a3 in
+ let a5 := f a4 in
+ let a6 := f a5 in
+ let a7 := f a6 in
+ let a8 := f a7 in
+ let a9 := f a8 in
+ let a10 := f a9 in
+ let a11 := f a10 in
+ let a12 := f a11 in
+ let a13 := f a12 in
+ let a14 := f a13 in
+ let a15 := f a14 in
+ let a16 := f a15 in
+ let a17 := f a16 in
+ a17.
diff --git a/test-suite/complexity/bug4076bis.v b/test-suite/complexity/bug4076bis.v
new file mode 100644
index 00000000..f3996e6a
--- /dev/null
+++ b/test-suite/complexity/bug4076bis.v
@@ -0,0 +1,31 @@
+(* Another check of evar-evar subtyping problems in the presence of
+ nested let-ins *)
+(* Expected time < 2.00s *)
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Parameter f : forall P, forall (i j : nat), P i j -> P i j.
+Parameter P : nat -> nat -> Type.
+
+Time Definition g (n : nat) (a0 : P n n) : P n n :=
+ let a1 := f a0 in
+ let a2 := f a1 in
+ let a3 := f a2 in
+ let a4 := f a3 in
+ let a5 := f a4 in
+ let a6 := f a5 in
+ let a7 := f a6 in
+ let a8 := f a7 in
+ let a9 := f a8 in
+ let a10 := f a9 in
+ let a11 := f a10 in
+ let a12 := f a11 in
+ let a13 := f a12 in
+ let a14 := f a13 in
+ let a15 := f a14 in
+ let a16 := f a15 in
+ let a17 := f a16 in
+ let a18 := f a17 in
+ let a19 := f a18 in
+ a19.
diff --git a/test-suite/ide/undo020.fake b/test-suite/ide/undo020.fake
index 2adde908..aa1d9bb2 100644
--- a/test-suite/ide/undo020.fake
+++ b/test-suite/ide/undo020.fake
@@ -12,8 +12,8 @@ ADD { Qed. }
# second proof
ADD { Lemma b : False. }
ADD { Proof using. }
-ADD { admit. }
-ADD last { Qed. }
+ADD { give_up. }
+ADD last { Admitted. }
# We join and expect some proof to fail
WAIT
# Going back to the error
diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out
index 629a1ab6..2c7b04c6 100644
--- a/test-suite/output/Arguments.out
+++ b/test-suite/output/Arguments.out
@@ -1,13 +1,11 @@
Nat.sub : nat -> nat -> nat
-Nat.sub is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
The reduction tactics unfold Nat.sub but avoid exposing match constructs
Nat.sub is transparent
Expands to: Constant Coq.Init.Nat.sub
Nat.sub : nat -> nat -> nat
-Nat.sub is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
The reduction tactics unfold Nat.sub when applied to 1 argument
but avoid exposing match constructs
@@ -15,7 +13,6 @@ Nat.sub is transparent
Expands to: Constant Coq.Init.Nat.sub
Nat.sub : nat -> nat -> nat
-Nat.sub is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
The reduction tactics unfold Nat.sub
when the 1st argument evaluates to a constructor and
@@ -24,7 +21,6 @@ Nat.sub is transparent
Expands to: Constant Coq.Init.Nat.sub
Nat.sub : nat -> nat -> nat
-Nat.sub is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
The reduction tactics unfold Nat.sub when the 1st and
2nd arguments evaluate to a constructor and when applied to 2 arguments
@@ -32,7 +28,6 @@ Nat.sub is transparent
Expands to: Constant Coq.Init.Nat.sub
Nat.sub : nat -> nat -> nat
-Nat.sub is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
The reduction tactics unfold Nat.sub when the 1st and
2nd arguments evaluate to a constructor
@@ -42,7 +37,6 @@ pf :
forall D1 C1 : Type,
(D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2
-pf is not universe polymorphic
Arguments D2, C2 are implicit
Arguments D1, C1 are implicit and maximally inserted
Argument scopes are [foo_scope type_scope _ _ _ _ _]
@@ -51,7 +45,6 @@ pf is transparent
Expands to: Constant Top.pf
fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C
-fcomp is not universe polymorphic
Arguments A, B, C are implicit and maximally inserted
Argument scopes are [type_scope type_scope type_scope _ _ _]
The reduction tactics unfold fcomp when applied to 6 arguments
@@ -59,20 +52,17 @@ fcomp is transparent
Expands to: Constant Top.fcomp
volatile : nat -> nat
-volatile is not universe polymorphic
Argument scope is [nat_scope]
The reduction tactics always unfold volatile
volatile is transparent
Expands to: Constant Top.volatile
f : T1 -> T2 -> nat -> unit -> nat -> nat
-f is not universe polymorphic
Argument scopes are [_ _ nat_scope _ nat_scope]
f is transparent
Expands to: Constant Top.S1.S2.f
f : T1 -> T2 -> nat -> unit -> nat -> nat
-f is not universe polymorphic
Argument scopes are [_ _ nat_scope _ nat_scope]
The reduction tactics unfold f when the 3rd, 4th and
5th arguments evaluate to a constructor
@@ -80,7 +70,6 @@ f is transparent
Expands to: Constant Top.S1.S2.f
f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
-f is not universe polymorphic
Argument T2 is implicit
Argument scopes are [type_scope _ _ nat_scope _ nat_scope]
The reduction tactics unfold f when the 4th, 5th and
@@ -89,7 +78,6 @@ f is transparent
Expands to: Constant Top.S1.f
f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
-f is not universe polymorphic
Arguments T1, T2 are implicit
Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope]
The reduction tactics unfold f when the 5th, 6th and
@@ -102,7 +90,6 @@ Expands to: Constant Top.f
: Prop
f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
-f is not universe polymorphic
The reduction tactics unfold f when the 5th, 6th and
7th arguments evaluate to a constructor
f is transparent
@@ -110,8 +97,8 @@ Expands to: Constant Top.f
forall w : r, w 3 true = tt
: Prop
The command has indeed failed with message:
-=> Error: Unknown interpretation for notation "$".
+Error: Unknown interpretation for notation "$".
w 3 true = tt
: Prop
The command has indeed failed with message:
-=> Error: Extra argument _.
+Error: Extra argument _.
diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out
index 71d5fc78..6643c142 100644
--- a/test-suite/output/ArgumentsScope.out
+++ b/test-suite/output/ArgumentsScope.out
@@ -1,70 +1,56 @@
a : bool -> bool
-a is not universe polymorphic
Argument scope is [bool_scope]
Expands to: Variable a
b : bool -> bool
-b is not universe polymorphic
Argument scope is [bool_scope]
Expands to: Variable b
negb'' : bool -> bool
-negb'' is not universe polymorphic
Argument scope is [bool_scope]
negb'' is transparent
Expands to: Constant Top.A.B.negb''
negb' : bool -> bool
-negb' is not universe polymorphic
Argument scope is [bool_scope]
negb' is transparent
Expands to: Constant Top.A.negb'
negb : bool -> bool
-negb is not universe polymorphic
Argument scope is [bool_scope]
negb is transparent
Expands to: Constant Coq.Init.Datatypes.negb
a : bool -> bool
-a is not universe polymorphic
Expands to: Variable a
b : bool -> bool
-b is not universe polymorphic
Expands to: Variable b
negb : bool -> bool
-negb is not universe polymorphic
negb is transparent
Expands to: Constant Coq.Init.Datatypes.negb
negb' : bool -> bool
-negb' is not universe polymorphic
negb' is transparent
Expands to: Constant Top.A.negb'
negb'' : bool -> bool
-negb'' is not universe polymorphic
negb'' is transparent
Expands to: Constant Top.A.B.negb''
a : bool -> bool
-a is not universe polymorphic
Expands to: Variable a
negb : bool -> bool
-negb is not universe polymorphic
negb is transparent
Expands to: Constant Coq.Init.Datatypes.negb
negb' : bool -> bool
-negb' is not universe polymorphic
negb' is transparent
Expands to: Constant Top.negb'
negb'' : bool -> bool
-negb'' is not universe polymorphic
negb'' is transparent
Expands to: Constant Top.negb''
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
index c29f5649..1e3cc37d 100644
--- a/test-suite/output/Arguments_renaming.out
+++ b/test-suite/output/Arguments_renaming.out
@@ -1,8 +1,8 @@
The command has indeed failed with message:
-=> Error: To rename arguments the "rename" flag must be specified.
+Error: To rename arguments the "rename" flag must be specified.
Argument A renamed to B.
The command has indeed failed with message:
-=> Error: To rename arguments the "rename" flag must be specified.
+Error: To rename arguments the "rename" flag must be specified.
Argument A renamed to T.
@eq_refl
: forall (B : Type) (y : B), y = y
@@ -20,7 +20,6 @@ For eq: Argument scopes are [type_scope _ _]
For eq_refl: Argument scopes are [type_scope _]
eq_refl : forall (A : Type) (x : A), x = x
-eq_refl is not universe polymorphic
Arguments are renamed to B, y
When applied to no arguments:
Arguments B, y are implicit and maximally inserted
@@ -36,7 +35,6 @@ For myEq: Argument scopes are [type_scope _ _]
For myrefl: Argument scopes are [type_scope _ _]
myrefl : forall (B : Type) (x : A), B -> myEq B x x
-myrefl is not universe polymorphic
Arguments are renamed to C, x, _
Argument C is implicit and maximally inserted
Argument scopes are [type_scope _ _]
@@ -49,13 +47,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
end
: forall T : Type, T -> nat -> nat -> nat
-myplus is not universe polymorphic
Arguments are renamed to Z, t, n, m
Argument Z is implicit and maximally inserted
Argument scopes are [type_scope _ nat_scope nat_scope]
myplus : forall T : Type, T -> nat -> nat -> nat
-myplus is not universe polymorphic
Arguments are renamed to Z, t, n, m
Argument Z is implicit and maximally inserted
Argument scopes are [type_scope _ nat_scope nat_scope]
@@ -74,7 +70,6 @@ For myEq: Argument scopes are [type_scope type_scope _ _]
For myrefl: Argument scopes are [type_scope type_scope _ _]
myrefl : forall (A B : Type) (x : A), B -> myEq A B x x
-myrefl is not universe polymorphic
Arguments are renamed to A, C, x, _
Argument C is implicit and maximally inserted
Argument scopes are [type_scope type_scope _ _]
@@ -89,13 +84,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
end
: forall T : Type, T -> nat -> nat -> nat
-myplus is not universe polymorphic
Arguments are renamed to Z, t, n, m
Argument Z is implicit and maximally inserted
Argument scopes are [type_scope _ nat_scope nat_scope]
myplus : forall T : Type, T -> nat -> nat -> nat
-myplus is not universe polymorphic
Arguments are renamed to Z, t, n, m
Argument Z is implicit and maximally inserted
Argument scopes are [type_scope _ nat_scope nat_scope]
@@ -106,15 +99,15 @@ Expands to: Constant Top.myplus
@myplus
: forall Z : Type, Z -> nat -> nat -> nat
The command has indeed failed with message:
-=> Error: All arguments lists must declare the same names.
+Error: All arguments lists must declare the same names.
The command has indeed failed with message:
-=> Error: The following arguments are not declared: x.
+Error: The following arguments are not declared: x.
The command has indeed failed with message:
-=> Error: Arguments names must be distinct.
+Error: Arguments names must be distinct.
The command has indeed failed with message:
-=> Error: Argument z cannot be declared implicit.
+Error: Argument z cannot be declared implicit.
The command has indeed failed with message:
-=> Error: Extra argument y.
+Error: Extra argument y.
The command has indeed failed with message:
-=> Error: To rename arguments the "rename" flag must be specified.
+Error: To rename arguments the "rename" flag must be specified.
Argument A renamed to R.
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out
index d5903483..09f032d4 100644
--- a/test-suite/output/Cases.out
+++ b/test-suite/output/Cases.out
@@ -6,8 +6,6 @@ fix F (t : t) : P t :=
end
: forall P : t -> Type,
(let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t
-
-t_rect is not universe polymorphic
= fun d : TT => match d with
| @CTT _ _ b => b
end
@@ -26,7 +24,6 @@ match Nat.eq_dec x y with
end
: forall (x y : nat) (P : nat -> Type), P x -> P y -> P y
-proj is not universe polymorphic
Argument scopes are [nat_scope nat_scope _ _ _]
foo =
fix foo (A : Type) (l : list A) {struct l} : option A :=
@@ -37,7 +34,6 @@ fix foo (A : Type) (l : list A) {struct l} : option A :=
end
: forall A : Type, list A -> option A
-foo is not universe polymorphic
Argument scopes are [type_scope list_scope]
uncast =
fun (A : Type) (x : I A) => match x with
@@ -45,12 +41,9 @@ fun (A : Type) (x : I A) => match x with
end
: forall A : Type, I A -> A
-uncast is not universe polymorphic
Argument scopes are [type_scope _]
foo' = if A 0 then true else false
: bool
-
-foo' is not universe polymorphic
f =
fun H : B =>
match H with
@@ -61,5 +54,3 @@ match H with
else fun _ : P false => Logic.I) x
end
: B -> True
-
-f is not universe polymorphic
diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out
index bcc37b63..6354ad46 100644
--- a/test-suite/output/Errors.out
+++ b/test-suite/output/Errors.out
@@ -1,7 +1,7 @@
The command has indeed failed with message:
-=> Error: The field t is missing in Top.M.
+The field t is missing in Top.M.
The command has indeed failed with message:
-=> Error: Unable to unify "nat" with "True".
+Unable to unify "nat" with "True".
The command has indeed failed with message:
-=> In nested Ltac calls to "f" and "apply x", last call failed.
-Error: Unable to unify "nat" with "True".
+In nested Ltac calls to "f" and "apply x", last call failed.
+Unable to unify "nat" with "True".
diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out
index 0b0f501f..3b65003c 100644
--- a/test-suite/output/Implicit.out
+++ b/test-suite/output/Implicit.out
@@ -5,7 +5,6 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I
d2 = fun x : nat => d1 (y:=x)
: forall x x0 : nat, x0 = x -> x0 = x
-d2 is not universe polymorphic
Arguments x, x0 are implicit
Argument scopes are [nat_scope nat_scope _]
map id (1 :: nil)
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 60ee72b3..6efd671a 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0
-4
: Z
The command has indeed failed with message:
-=> Error: x should not be bound in a recursive pattern of the right-hand side.
+Error: x should not be bound in a recursive pattern of the right-hand side.
The command has indeed failed with message:
-=> Error: in the right-hand side, y and z should appear in
+Error: in the right-hand side, y and z should appear in
term position as part of a recursive pattern.
The command has indeed failed with message:
-=> Error: The reference w was not found in the current environment.
+The reference w was not found in the current environment.
The command has indeed failed with message:
-=> Error: in the right-hand side, y and z should appear in
+Error: in the right-hand side, y and z should appear in
term position as part of a recursive pattern.
The command has indeed failed with message:
-=> Error: z is expected to occur in binding position in the right-hand side.
+Error: z is expected to occur in binding position in the right-hand side.
The command has indeed failed with message:
-=> Error: as y is a non-closed binder, no such "," is allowed to occur.
+Error: as y is a non-closed binder, no such "," is allowed to occur.
The command has indeed failed with message:
-=> Error: Cannot find where the recursive pattern starts.
+Error: Cannot find where the recursive pattern starts.
The command has indeed failed with message:
-=> Error: Cannot find where the recursive pattern starts.
+Error: Cannot find where the recursive pattern starts.
The command has indeed failed with message:
-=> Error: Cannot find where the recursive pattern starts.
+Error: Cannot find where the recursive pattern starts.
The command has indeed failed with message:
-=> Error: Cannot find where the recursive pattern starts.
+Error: Cannot find where the recursive pattern starts.
The command has indeed failed with message:
-=> Error: Both ends of the recursive pattern are the same.
+Error: Both ends of the recursive pattern are the same.
SUM (nat * nat) nat
: Set
FST (0; 1)
diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out
index 0457c860..ba076f05 100644
--- a/test-suite/output/PrintInfos.out
+++ b/test-suite/output/PrintInfos.out
@@ -25,7 +25,6 @@ For eq: Argument scopes are [type_scope _ _]
For eq_refl: Argument scopes are [type_scope _]
eq_refl : forall (A : Type) (x : A), x = x
-eq_refl is not universe polymorphic
When applied to no arguments:
Arguments A, x are implicit and maximally inserted
When applied to 1 argument:
@@ -46,11 +45,9 @@ fix add (n m : nat) {struct n} : nat :=
end
: nat -> nat -> nat
-Nat.add is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
Nat.add : nat -> nat -> nat
-Nat.add is not universe polymorphic
Argument scopes are [nat_scope nat_scope]
Nat.add is transparent
Expands to: Constant Coq.Init.Nat.add
@@ -58,7 +55,6 @@ Nat.add : nat -> nat -> nat
plus_n_O : forall n : nat, n = n + 0
-plus_n_O is not universe polymorphic
Argument scope is [nat_scope]
plus_n_O is opaque
Expands to: Constant Coq.Init.Peano.plus_n_O
@@ -80,13 +76,11 @@ For le_n: Argument scope is [nat_scope]
For le_S: Argument scopes are [nat_scope nat_scope _]
comparison : Set
-comparison is not universe polymorphic
Expands to: Inductive Coq.Init.Datatypes.comparison
Inductive comparison : Set :=
Eq : comparison | Lt : comparison | Gt : comparison
bar : foo
-bar is not universe polymorphic
Expanded type for implicit arguments
bar : forall x : nat, x = 0
@@ -94,14 +88,12 @@ Argument x is implicit and maximally inserted
Expands to: Constant Top.bar
*** [ bar : foo ]
-bar is not universe polymorphic
Expanded type for implicit arguments
bar : forall x : nat, x = 0
Argument x is implicit and maximally inserted
bar : foo
-bar is not universe polymorphic
Expanded type for implicit arguments
bar : forall x : nat, x = 0
@@ -109,7 +101,6 @@ Argument x is implicit and maximally inserted
Expands to: Constant Top.bar
*** [ bar : foo ]
-bar is not universe polymorphic
Expanded type for implicit arguments
bar : forall x : nat, x = 0
diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out
index 67b65d4b..f94ed642 100644
--- a/test-suite/output/TranspModtype.out
+++ b/test-suite/output/TranspModtype.out
@@ -1,15 +1,7 @@
TrM.A = M.A
: Set
-
-TrM.A is not universe polymorphic
OpM.A = M.A
: Set
-
-OpM.A is not universe polymorphic
TrM.B = M.B
: Set
-
-TrM.B is not universe polymorphic
*** [ OpM.B : Set ]
-
-OpM.B is not universe polymorphic
diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out
index d69baaec..b1952aec 100644
--- a/test-suite/output/inference.out
+++ b/test-suite/output/inference.out
@@ -4,8 +4,6 @@ fun e : option L => match e with
| None => None
end
: option L -> option L
-
-P is not universe polymorphic
fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H
: forall m n p : nat, S m <= S n + p -> m <= n + p
fun n : nat => let x := A n in ?y ?y0:T n
diff --git a/test-suite/output/names.out b/test-suite/output/names.out
index 2892dfd5..9471b892 100644
--- a/test-suite/output/names.out
+++ b/test-suite/output/names.out
@@ -1,5 +1,4 @@
The command has indeed failed with message:
-=> Error:
In environment
y : nat
The term "a y" has type "{y0 : nat | y = y0}"
diff --git a/test-suite/output/rewrite-2172.out b/test-suite/output/rewrite-2172.out
index 30385072..27b0dc1b 100644
--- a/test-suite/output/rewrite-2172.out
+++ b/test-suite/output/rewrite-2172.out
@@ -1,2 +1,2 @@
The command has indeed failed with message:
-=> Error: Unable to find an instance for the variable E.
+Unable to find an instance for the variable E.
diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v
index 89638eed..5f1926f1 100644
--- a/test-suite/output/simpl.v
+++ b/test-suite/output/simpl.v
@@ -4,10 +4,10 @@ Goal forall x, 0+x = 1+x.
intro x.
simpl (_ + x).
Show.
-Undo 2.
+Undo.
simpl (_ + x) at 2.
Show.
-Undo 2.
+Undo.
simpl (0 + _).
Show.
-Undo 2.
+Undo.
diff --git a/test-suite/prerequisite/admit.v b/test-suite/prerequisite/admit.v
new file mode 100644
index 00000000..fb327663
--- /dev/null
+++ b/test-suite/prerequisite/admit.v
@@ -0,0 +1,2 @@
+Axiom proof_admitted : False.
+Ltac admit := case proof_admitted.
diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v
index d819dc47..56333973 100644
--- a/test-suite/success/AdvancedCanonicalStructure.v
+++ b/test-suite/success/AdvancedCanonicalStructure.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Section group_morphism.
(* An example with default canonical structures *)
diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v
index 4eb2dbe9..ce9050d4 100644
--- a/test-suite/success/Case22.v
+++ b/test-suite/success/Case22.v
@@ -5,3 +5,15 @@ Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => 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.
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 3d425754..9661b3bf 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -121,3 +121,44 @@ 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.
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
index 6a488244..25e464d6 100644
--- a/test-suite/success/Injection.v
+++ b/test-suite/success/Injection.v
@@ -1,3 +1,5 @@
+Require Eqdep_dec.
+
(* Check the behaviour of Injection *)
(* Check that Injection tries Intro until *)
diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v
index d316e4a0..e38affd7 100644
--- a/test-suite/success/Nsatz.v
+++ b/test-suite/success/Nsatz.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* compile en user 3m39.915s sur cachalot *)
Require Import Nsatz.
diff --git a/test-suite/success/TacticNotation1.v b/test-suite/success/TacticNotation1.v
new file mode 100644
index 00000000..289f2816
--- /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/apply.v b/test-suite/success/apply.v
index 21b829aa..a4ed76c5 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -536,3 +536,13 @@ 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; case H.
+apply (foo ?y).
+Grab Existential Variables.
+exact 0.
+Qed.
diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v
new file mode 100644
index 00000000..4e0b7bf5
--- /dev/null
+++ b/test-suite/success/coindprim.v
@@ -0,0 +1,52 @@
+Set Primitive Projections.
+
+CoInductive stream A := { hd : A; tl : stream A }.
+
+CoFixpoint ticks : stream unit :=
+ {| hd := tt; tl := ticks |}.
+
+Arguments hd [ A ] s.
+Arguments tl [ A ] s.
+
+CoInductive bisim {A} : stream A -> stream A -> Prop :=
+ | bisims s s' : hd s = hd s' -> bisim (tl s) (tl s') -> bisim s s'.
+
+Lemma bisim_refl {A} (s : stream A) : bisim s s.
+Proof.
+ revert s.
+ cofix aux. intros. constructor. reflexivity. apply aux.
+Defined.
+
+Lemma constr : forall (A : Type) (s : stream A),
+ bisim s (Build_stream _ s.(hd) s.(tl)).
+Proof.
+ intros. constructor. reflexivity. simpl. apply bisim_refl.
+Defined.
+
+Lemma constr' : forall (A : Type) (s : stream A),
+ s = Build_stream _ s.(hd) s.(tl).
+Proof.
+ intros.
+ Fail destruct s.
+Abort.
+
+Eval compute in constr _ ticks.
+
+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 *)
\ No newline at end of file
diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v
index dbbd57ae..61e73f85 100644
--- a/test-suite/success/proof_using.v
+++ b/test-suite/success/proof_using.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Section Foo.
Variable a : nat.
diff --git a/test-suite/success/qed_export.v b/test-suite/success/qed_export.v
new file mode 100644
index 00000000..b3e41ab1
--- /dev/null
+++ b/test-suite/success/qed_export.v
@@ -0,0 +1,18 @@
+Lemma a : True.
+Proof.
+assert True as H.
+ abstract (trivial) using exported_seff.
+exact H.
+Fail Qed exporting a_subproof.
+Qed exporting exported_seff.
+Check ( exported_seff : True ).
+
+Lemma b : True.
+Proof.
+assert True as H.
+ abstract (trivial) using exported_seff2.
+exact H.
+Qed.
+
+Fail Check ( exported_seff2 : True ).
+
diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v
index 6dcd6592..62249666 100644
--- a/test-suite/success/rewrite.v
+++ b/test-suite/success/rewrite.v
@@ -148,3 +148,13 @@ 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.
diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v
index fe250ae8..d0aafd38 100644
--- a/test-suite/success/rewrite_dep.v
+++ b/test-suite/success/rewrite_dep.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import Setoid.
Require Import Morphisms.
Require Vector.
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index be0d49e0..0465c4b3 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
Require Import Setoid.
Parameter A : Set.
diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v
index b5330779..e540ae5f 100644
--- a/test-suite/success/simpl.v
+++ b/test-suite/success/simpl.v
@@ -1,3 +1,4 @@
+Require Import TestSuite.admit.
(* Check that inversion of names of mutual inductive fixpoints works *)
(* (cf bug #1031) *)
diff --git a/test-suite/success/tryif.v b/test-suite/success/tryif.v
new file mode 100644
index 00000000..4394bddb
--- /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/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v
index 073cd5e9..048faa91 100644
--- a/theories/Classes/CMorphisms.v
+++ b/theories/Classes/CMorphisms.v
@@ -31,7 +31,7 @@ Set Universe Polymorphism.
The relation [R] will be instantiated by [respectful] and [A] by an arrow
type for usual morphisms. *)
Section Proper.
- Context {A B : Type}.
+ Context {A : Type}.
Class Proper (R : crelation A) (m : A) :=
proper_prf : R m m.
@@ -71,7 +71,7 @@ Section Proper.
(** The non-dependent version is an instance where we forget dependencies. *)
- Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
+ Definition respectful {B} (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').
End Proper.
@@ -143,7 +143,7 @@ Ltac f_equiv :=
end.
Section Relations.
- Context {A B : Type}.
+ Context {A : Type}.
(** [forall_def] reifies the dependent product as a definition. *)
@@ -156,10 +156,10 @@ Section Relations.
fun f g => forall a, sig a (f a) (g a).
(** Non-dependent pointwise lifting *)
- Definition pointwise_relation (R : crelation B) : crelation (A -> B) :=
+ Definition pointwise_relation {B} (R : crelation B) : crelation (A -> B) :=
fun f g => forall a, R (f a) (g a).
- Lemma pointwise_pointwise (R : crelation B) :
+ Lemma pointwise_pointwise {B} (R : crelation B) :
relation_equivalence (pointwise_relation R) (@eq A ==> R).
Proof. intros. split. simpl_crelation. firstorder. Qed.
@@ -252,7 +252,7 @@ Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)
Section GenericInstances.
(* Share universes *)
- Context {A B C : Type}.
+ Implicit Types A B C : Type.
(** We can build a PER on the Coq function space if we have PERs on the domain and
codomain. *)
@@ -379,7 +379,7 @@ Section GenericInstances.
Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R).
Proof. firstorder. Qed.
- Global Program Instance compose_proper RA RB RC :
+ Global Program Instance compose_proper A B C RA RB RC :
Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C).
Next Obligation.
@@ -396,12 +396,12 @@ Section GenericInstances.
Proof. simpl_crelation. Qed.
(** [respectful] is a morphism for crelation equivalence . *)
- Set Printing All. Set Printing Universes.
+
Global Instance respectful_morphism :
Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence)
(@respectful A B).
Proof.
- intros R R' HRR' S S' HSS' f g.
+ intros A B R R' HRR' S S' HSS' f g.
unfold respectful , relation_equivalence in *; simpl in *.
split ; intros H x y Hxy.
apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)).
@@ -414,9 +414,9 @@ Section GenericInstances.
Proper R' (m x).
Proof. simpl_crelation. Qed.
- Class Params (of : A) (arity : nat).
+ Class Params {A} (of : A) (arity : nat).
- Lemma flip_respectful (R : crelation A) (R' : crelation B) :
+ Lemma flip_respectful {A B} (R : crelation A) (R' : crelation B) :
relation_equivalence (flip (R ==> R')) (flip R ==> flip R').
Proof.
intros.
@@ -449,7 +449,7 @@ Section GenericInstances.
Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x.
Proof. firstorder. Qed.
- Lemma proper_eq (x : A) : Proper (@eq A) x.
+ Lemma proper_eq {A} (x : A) : Proper (@eq A) x.
Proof. intros. apply reflexive_proper. Qed.
End GenericInstances.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index d2971552..50f853f0 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -22,9 +22,6 @@ Inductive True : Prop :=
(** [False] is the always false proposition *)
Inductive False : Prop :=.
-(** [proof_admitted] is used to implement the admit tactic *)
-Axiom proof_admitted : False.
-
(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Prop) := A -> False.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 424ca0c8..a7bdba90 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -59,7 +59,7 @@ Reserved Notation "( x , y , .. , z )" (at level 0).
(** Notation "{ x }" is reserved and has a special status as component
of other notations such as "{ A } + { B }" and "A + { B }" (which
- are at the same level than "x + y");
+ are at the same level as "x + y");
"{ x }" is at level 0 to factor with "{ x : A | P }" *)
Reserved Notation "{ x }" (at level 0, x at level 99).
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 4894eba4..0efb8744 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -23,4 +23,4 @@ Declare ML Module "cc_plugin".
Declare ML Module "ground_plugin".
Declare ML Module "recdef_plugin".
(* Default substrings not considered by queries like SearchAbout *)
-Add Search Blacklist "_admitted" "_subproof" "Private_".
+Add Search Blacklist "_subproof" "Private_".
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 9e828e6e..a7d3f806 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -180,12 +180,14 @@ Ltac easy :=
| H : _ |- _ => solve [inversion H]
| _ => idtac
end in
- let rec do_atom :=
- solve [reflexivity | symmetry; trivial] ||
- contradiction ||
- (split; do_atom)
- with do_ccl := trivial with eq_true; repeat do_intro; do_atom in
- (use_hyps; do_ccl) || fail "Cannot solve this goal".
+ let do_atom :=
+ solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in
+ let rec do_ccl :=
+ try do_atom;
+ repeat (do_intro; try do_atom);
+ solve [ split; do_ccl ] in
+ solve [ do_atom | use_hyps; do_ccl ] ||
+ fail "Cannot solve this goal".
Tactic Notation "now" tactic(t) := t; easy.
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index 3cba090f..ea07a849 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1014,11 +1014,17 @@ Proof.
rewrite IHl; auto.
Qed.
+Lemma map_ext_in :
+ forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l.
+Proof.
+ induction l; simpl; auto.
+ intros; rewrite H by intuition; rewrite IHl; auto.
+Qed.
+
Lemma map_ext :
forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
- induction l; simpl; auto.
- rewrite H; rewrite IHl; auto.
+ intros; apply map_ext_in; auto.
Qed.
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index b57c3f04..c95fb4d5 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -613,18 +613,18 @@ induction s1; simpl; auto; intros.
Qed.
Lemma fold_right_equivlistA_restr2 :
- forall s s' (i j:B) (heqij: eqB i j),
+ forall s s' i j,
NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
- eqB i j ->
- equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
+ equivlistA s s' -> eqB i j ->
+ eqB (fold_right f i s) (fold_right f j s').
Proof.
simple induction s.
destruct s'; simpl.
intros. assumption.
unfold equivlistA; intros.
- destruct (H3 a).
+ destruct (H2 a).
assert (InA a nil) by auto; inv.
- intros x l Hrec s' i j heqij N N' F eqij E; simpl in *.
+ intros x l Hrec s' i j N N' F E eqij; simpl in *.
assert (InA x s') by (rewrite <- (E x); auto).
destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
subst s'.
@@ -649,7 +649,6 @@ Proof.
red; intros; rewrite E; auto.
Qed.
-
Lemma fold_right_add_restr2 :
forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v
index afc7c25b..cea3e839 100644
--- a/theories/Lists/SetoidPermutation.v
+++ b/theories/Lists/SetoidPermutation.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-Require Import SetoidList.
+Require Import Permutation SetoidList.
(* Set Universe Polymorphism. *)
Set Implicit Arguments.
@@ -123,4 +123,76 @@ Proof.
apply equivlistA_NoDupA_split with x y; intuition.
Qed.
+Lemma Permutation_eqlistA_commute l₁ l₂ l₃ :
+ eqlistA eqA l₁ l₂ -> Permutation l₂ l₃ ->
+ exists l₂', Permutation l₁ l₂' /\ eqlistA eqA l₂' l₃.
+Proof.
+ intros E P. revert l₁ E.
+ induction P; intros.
+ - inversion_clear E. now exists nil.
+ - inversion_clear E.
+ destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP.
+ exists (x0::l0'). split; auto.
+ - inversion_clear E. inversion_clear H0.
+ exists (x1::x0::l1). now repeat constructor.
+ - clear P1 P2.
+ destruct (IHP1 _ E) as (l₁',(P₁,E₁)).
+ destruct (IHP2 _ E₁) as (l₂',(P₂,E₂)).
+ exists l₂'. split; trivial. econstructor; eauto.
+Qed.
+
+Lemma PermutationA_decompose l₁ l₂ :
+ PermutationA l₁ l₂ ->
+ exists l, Permutation l₁ l /\ eqlistA eqA l l₂.
+Proof.
+ induction 1.
+ - now exists nil.
+ - destruct IHPermutationA as (l,(P,E)). exists (x₁::l); auto.
+ - exists (x::y::l). split. constructor. reflexivity.
+ - destruct IHPermutationA1 as (l₁',(P,E)).
+ destruct IHPermutationA2 as (l₂',(P',E')).
+ destruct (@Permutation_eqlistA_commute l₁' l₂ l₂') as (l₁'',(P'',E''));
+ trivial.
+ exists l₁''. split. now transitivity l₁'. now transitivity l₂'.
+Qed.
+
+Lemma Permutation_PermutationA l₁ l₂ :
+ Permutation l₁ l₂ -> PermutationA l₁ l₂.
+Proof.
+ induction 1.
+ - constructor.
+ - now constructor.
+ - apply permA_swap.
+ - econstructor; eauto.
+Qed.
+
+Lemma eqlistA_PermutationA l₁ l₂ :
+ eqlistA eqA l₁ l₂ -> PermutationA l₁ l₂.
+Proof.
+ induction 1; now constructor.
+Qed.
+
+Lemma NoDupA_equivlistA_decompose l1 l2 :
+ NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 ->
+ exists l, Permutation l1 l /\ eqlistA eqA l l2.
+Proof.
+ intros. apply PermutationA_decompose.
+ now apply NoDupA_equivlistA_PermutationA.
+Qed.
+
+Lemma PermutationA_preserves_NoDupA l₁ l₂ :
+ PermutationA l₁ l₂ -> NoDupA eqA l₁ -> NoDupA eqA l₂.
+Proof.
+ induction 1; trivial.
+ - inversion_clear 1; constructor; auto.
+ apply PermutationA_equivlistA in H0. contradict H2.
+ now rewrite H, H0.
+ - inversion_clear 1. inversion_clear H1. constructor.
+ + contradict H. inversion_clear H; trivial.
+ elim H0. now constructor.
+ + constructor; trivial.
+ contradict H0. now apply InA_cons_tl.
+ - eauto.
+Qed.
+
End Permutation.
diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v
new file mode 100644
index 00000000..d840f1f3
--- /dev/null
+++ b/theories/MMaps/MMapAVL.v
@@ -0,0 +1,2158 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* key -> elt -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** * Basic functions on trees: height and cardinal *)
+
+Definition height (m : t) : int :=
+ match m with
+ | Leaf => 0
+ | Node _ _ _ _ h => h
+ end.
+
+Fixpoint cardinal (m : t) : nat :=
+ match m with
+ | Leaf => 0%nat
+ | Node l _ _ r _ => S (cardinal l + cardinal r)
+ end.
+
+(** * Empty Map *)
+
+Definition empty := Leaf.
+
+(** * Emptyness test *)
+
+Definition is_empty m := match m with Leaf => true | _ => false end.
+
+(** * Membership *)
+
+(** The [mem] function is deciding membership. It exploits the [Bst] property
+ to achieve logarithmic complexity. *)
+
+Fixpoint mem x m : bool :=
+ match m with
+ | Leaf => false
+ | Node l y _ r _ =>
+ match X.compare x y with
+ | Eq => true
+ | Lt => mem x l
+ | Gt => mem x r
+ end
+ end.
+
+Fixpoint find x m : option elt :=
+ match m with
+ | Leaf => None
+ | Node l y d r _ =>
+ match X.compare x y with
+ | Eq => Some d
+ | Lt => find x l
+ | Gt => find x r
+ end
+ end.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+ to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x e r :=
+ Node l x e r (max (height l) (height r) + 1).
+
+(** [bal l x e r] acts as [create], but performs one step of
+ rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition assert_false := create.
+
+Fixpoint bal l x d r :=
+ let hl := height l in
+ let hr := height r in
+ if (hr+2) hl then
+ match l with
+ | Leaf => assert_false l x d r
+ | Node ll lx ld lr _ =>
+ if (height lr) <=? (height ll) then
+ create ll lx ld (create lr x d r)
+ else
+ match lr with
+ | Leaf => assert_false l x d r
+ | Node lrl lrx lrd lrr _ =>
+ create (create ll lx ld lrl) lrx lrd (create lrr x d r)
+ end
+ end
+ else
+ if (hl+2) hr then
+ match r with
+ | Leaf => assert_false l x d r
+ | Node rl rx rd rr _ =>
+ if (height rl) <=? (height rr) then
+ create (create l x d rl) rx rd rr
+ else
+ match rl with
+ | Leaf => assert_false l x d r
+ | Node rll rlx rld rlr _ =>
+ create (create l x d rll) rlx rld (create rlr rx rd rr)
+ end
+ end
+ else
+ create l x d r.
+
+(** * Insertion *)
+
+Fixpoint add x d m :=
+ match m with
+ | Leaf => Node Leaf x d Leaf 1
+ | Node l y d' r h =>
+ match X.compare x y with
+ | Eq => Node l y d r h
+ | Lt => bal (add x d l) y d' r
+ | Gt => bal l y d' (add x d r)
+ end
+ end.
+
+(** * Extraction of minimum binding
+
+ Morally, [remove_min] is to be applied to a non-empty tree
+ [t = Node l x e r h]. Since we can't deal here with [assert false]
+ for [t=Leaf], we pre-unpack [t] (and forget about [h]).
+*)
+
+Fixpoint remove_min l x d r : t*(key*elt) :=
+ match l with
+ | Leaf => (r,(x,d))
+ | Node ll lx ld lr lh =>
+ let (l',m) := remove_min ll lx ld lr in
+ (bal l' x d r, m)
+ end.
+
+(** * Merging two trees
+
+ [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements
+ of [t1] to be smaller than all elements of [t2], and
+ [|height t1 - height t2| <= 2].
+*)
+
+Definition merge0 s1 s2 :=
+ match s1,s2 with
+ | Leaf, _ => s2
+ | _, Leaf => s1
+ | _, Node l2 x2 d2 r2 h2 =>
+ let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in
+ bal s1 x d s2'
+ end.
+
+(** * Deletion *)
+
+Fixpoint remove x m := match m with
+ | Leaf => Leaf
+ | Node l y d r h =>
+ match X.compare x y with
+ | Eq => merge0 l r
+ | Lt => bal (remove x l) y d r
+ | Gt => bal l y d (remove x r)
+ end
+ end.
+
+(** * join
+
+ Same as [bal] but does not assume anything regarding heights of [l]
+ and [r].
+*)
+
+Fixpoint join l : key -> elt -> t -> t :=
+ match l with
+ | Leaf => add
+ | Node ll lx ld lr lh => fun x d =>
+ fix join_aux (r:t) : t := match r with
+ | Leaf => add x d l
+ | Node rl rx rd rr rh =>
+ if rh+2 lh then bal ll lx ld (join lr x d r)
+ else if lh+2 rh then bal (join_aux rl) rx rd rr
+ else create l x d r
+ end
+ end.
+
+(** * Splitting
+
+ [split x m] returns a triple [(l, o, r)] where
+ - [l] is the set of elements of [m] that are [< x]
+ - [r] is the set of elements of [m] that are [> x]
+ - [o] is the result of [find x m].
+*)
+
+Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.
+Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9).
+
+Fixpoint split x m : triple := match m with
+ | Leaf => 〚 Leaf, None, Leaf 〛
+ | Node l y d r h =>
+ match X.compare x y with
+ | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛
+ | Eq => 〚 l, Some d, r 〛
+ | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛
+ end
+ end.
+
+(** * Concatenation
+
+ Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat m1 m2 :=
+ match m1, m2 with
+ | Leaf, _ => m2
+ | _ , Leaf => m1
+ | _, Node l2 x2 d2 r2 _ =>
+ let (m2',xd) := remove_min l2 x2 d2 r2 in
+ join m1 xd#1 xd#2 m2'
+ end.
+
+(** * Bindings *)
+
+(** [bindings_aux acc t] catenates the bindings of [t] in infix
+ order to the list [acc] *)
+
+Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) :=
+ match m with
+ | Leaf => acc
+ | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l
+ end.
+
+(** then [bindings] is an instantiation with an empty [acc] *)
+
+Definition bindings := bindings_aux nil.
+
+(** * Fold *)
+
+Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A :=
+ fun a => match m with
+ | Leaf => a
+ | Node l x d r _ => fold f r (f x d (fold f l a))
+ end.
+
+(** * Comparison *)
+
+Variable cmp : elt->elt->bool.
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : key -> elt -> t -> enumeration -> enumeration.
+
+(** [cons m e] adds the elements of tree [m] on the head of
+ enumeration [e]. *)
+
+Fixpoint cons m e : enumeration :=
+ match m with
+ | Leaf => e
+ | Node l x d r h => cons l (More x d r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
+ match e2 with
+ | End => false
+ | More x2 d2 r2 e2 =>
+ match X.compare x1 x2 with
+ | Eq => cmp d1 d2 &&& cont (cons r2 e2)
+ | _ => false
+ end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
+ match m1 with
+ | Leaf => cont e2
+ | Node l1 x1 d1 r1 _ =>
+ equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2
+ end.
+
+(** Initial continuation *)
+
+Definition equal_end e2 := match e2 with End => true | _ => false end.
+
+(** The complete comparison *)
+
+Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).
+
+End Elt.
+Notation t := tree.
+Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9).
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
+Notation "t #o" := (t_opt t) (at level 9, format "t '#o'").
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
+
+
+(** * Map *)
+
+Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
+ match m with
+ | Leaf _ => Leaf _
+ | Node l x d r h => Node (map f l) x (f d) (map f r) h
+ end.
+
+(* * Mapi *)
+
+Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
+ match m with
+ | Leaf _ => Leaf _
+ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
+ end.
+
+(** * Map with removal *)
+
+Fixpoint mapo (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
+ : t elt' :=
+ match m with
+ | Leaf _ => Leaf _
+ | Node l x d r h =>
+ match f x d with
+ | Some d' => join (mapo f l) x d' (mapo f r)
+ | None => concat (mapo f l) (mapo f r)
+ end
+ end.
+
+(** * Generalized merge
+
+ Suggestion by B. Gregoire: a [merge] function with specialized
+ arguments that allows bypassing some tree traversal. Instead of one
+ [f0] of type [key -> option elt -> option elt' -> option elt''],
+ we ask here for:
+ - [f] which is a specialisation of [f0] when first option isn't [None]
+ - [mapl] treats a [tree elt] with [f0] when second option is [None]
+ - [mapr] treats a [tree elt'] with [f0] when first option is [None]
+
+ The idea is that [mapl] and [mapr] can be instantaneous (e.g.
+ the identity or some constant function).
+*)
+
+Section GMerge.
+Variable elt elt' elt'' : Type.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+
+Fixpoint gmerge m1 m2 :=
+ match m1, m2 with
+ | Leaf _, _ => mapr m2
+ | _, Leaf _ => mapl m1
+ | Node l1 x1 d1 r1 h1, _ =>
+ let (l2',o2,r2') := split x1 m2 in
+ match f x1 d1 o2 with
+ | Some e => join (gmerge l1 l2') x1 e (gmerge r1 r2')
+ | None => concat (gmerge l1 l2') (gmerge r1 r2')
+ end
+ end.
+
+End GMerge.
+
+(** * Merge
+
+ The [merge] function of the Map interface can be implemented
+ via [gmerge] and [mapo].
+*)
+
+Section Merge.
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition merge : t elt -> t elt' -> t elt'' :=
+ gmerge
+ (fun k d o => f k (Some d) o)
+ (mapo (fun k d => f k (Some d) None))
+ (mapo (fun k d' => f k None (Some d'))).
+
+End Merge.
+
+
+
+(** * Invariants *)
+
+Section Invariants.
+Variable elt : Type.
+
+(** ** Occurrence in a tree *)
+
+Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
+ | MapsRoot : forall l r h y,
+ X.eq x y -> MapsTo x e (Node l y e r h)
+ | MapsLeft : forall l r h y e',
+ MapsTo x e l -> MapsTo x e (Node l y e' r h)
+ | MapsRight : forall l r h y e',
+ MapsTo x e r -> MapsTo x e (Node l y e' r h).
+
+Inductive In (x : key) : t elt -> Prop :=
+ | InRoot : forall l r h y e,
+ X.eq x y -> In x (Node l y e r h)
+ | InLeft : forall l r h y e',
+ In x l -> In x (Node l y e' r h)
+ | InRight : forall l r h y e',
+ In x r -> In x (Node l y e' r h).
+
+Definition In0 k m := exists e:elt, MapsTo k e m.
+
+(** ** Binary search trees *)
+
+(** [Above x m] : [x] is strictly greater than any key in [m].
+ [Below x m] : [x] is strictly smaller than any key in [m]. *)
+
+Inductive Above (x:key) : t elt -> Prop :=
+ | AbLeaf : Above x (Leaf _)
+ | AbNode l r h y e : Above x l -> X.lt y x -> Above x r ->
+ Above x (Node l y e r h).
+
+Inductive Below (x:key) : t elt -> Prop :=
+ | BeLeaf : Below x (Leaf _)
+ | BeNode l r h y e : Below x l -> X.lt x y -> Below x r ->
+ Below x (Node l y e r h).
+
+Definition Apart (m1 m2 : t elt) : Prop :=
+ forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2.
+
+(** Alternative statements, equivalent with [LtTree] and [GtTree] *)
+
+Definition lt_tree x m := forall y, In y m -> X.lt y x.
+Definition gt_tree x m := forall y, In y m -> X.lt x y.
+
+(** [Bst t] : [t] is a binary search tree *)
+
+Inductive Bst : t elt -> Prop :=
+ | BSLeaf : Bst (Leaf _)
+ | BSNode : forall x e l r h, Bst l -> Bst r ->
+ Above x l -> Below x r -> Bst (Node l x e r h).
+
+End Invariants.
+
+
+(** * Correctness proofs, isolated in a sub-module *)
+
+Module Proofs.
+ Module MX := OrderedTypeFacts X.
+ Module PX := KeyOrderedType X.
+ Module L := MMapList.Raw X.
+
+Local Infix "∈" := In (at level 70).
+Local Infix "==" := X.eq (at level 70).
+Local Infix "<" := X.lt (at level 70).
+Local Infix "<<" := Below (at level 70).
+Local Infix ">>" := Above (at level 70).
+Local Infix "<<<" := Apart (at level 70).
+
+Scheme tree_ind := Induction for tree Sort Prop.
+Scheme Bst_ind := Induction for Bst Sort Prop.
+Scheme MapsTo_ind := Induction for MapsTo Sort Prop.
+Scheme In_ind := Induction for In Sort Prop.
+Scheme Above_ind := Induction for Above Sort Prop.
+Scheme Below_ind := Induction for Below Sort Prop.
+
+Functional Scheme mem_ind := Induction for mem Sort Prop.
+Functional Scheme find_ind := Induction for find Sort Prop.
+Functional Scheme bal_ind := Induction for bal Sort Prop.
+Functional Scheme add_ind := Induction for add Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge0_ind := Induction for merge0 Sort Prop.
+Functional Scheme remove_ind := Induction for remove Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme split_ind := Induction for split Sort Prop.
+Functional Scheme mapo_ind := Induction for mapo Sort Prop.
+Functional Scheme gmerge_ind := Induction for gmerge Sort Prop.
+
+(** * Automation and dedicated tactics. *)
+
+Local Hint Constructors tree MapsTo In Bst Above Below.
+Local Hint Unfold lt_tree gt_tree Apart.
+Local Hint Immediate MX.eq_sym.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans.
+
+Tactic Notation "factornode" ident(s) :=
+ try clear s;
+ match goal with
+ | |- context [Node ?l ?x ?e ?r ?h] =>
+ set (s:=Node l x e r h) in *; clearbody s; clear l x e r h
+ | _ : context [Node ?l ?x ?e ?r ?h] |- _ =>
+ set (s:=Node l x e r h) in *; clearbody s; clear l x e r h
+ end.
+
+(** A tactic for cleaning hypothesis after use of functional induction. *)
+
+Ltac cleanf :=
+ match goal with
+ | H : X.compare _ _ = Eq |- _ =>
+ rewrite ?H; apply MX.compare_eq in H; cleanf
+ | H : X.compare _ _ = Lt |- _ =>
+ rewrite ?H; apply MX.compare_lt_iff in H; cleanf
+ | H : X.compare _ _ = Gt |- _ =>
+ rewrite ?H; apply MX.compare_gt_iff in H; cleanf
+ | _ => idtac
+ end.
+
+
+(** A tactic to repeat [inversion_clear] on all hyps of the
+ form [(f (Node ...))] *)
+
+Ltac inv f :=
+ match goal with
+ | H:f (Leaf _) |- _ => inversion_clear H; inv f
+ | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
+ | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
+ | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
+ | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+ | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+ | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+ | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+ | _ => idtac
+ end.
+
+Ltac inv_all f :=
+ match goal with
+ | H: f _ |- _ => inversion_clear H; inv f
+ | H: f _ _ |- _ => inversion_clear H; inv f
+ | H: f _ _ _ |- _ => inversion_clear H; inv f
+ | H: f _ _ _ _ |- _ => inversion_clear H; inv f
+ | _ => idtac
+ end.
+
+Ltac intuition_in := repeat (intuition; inv In; inv MapsTo).
+
+(* Function/Functional Scheme can't deal with internal fix.
+ Let's do its job by hand: *)
+
+Ltac join_tac l x d r :=
+ revert x d r;
+ induction l as [| ll _ lx ld lr Hlr lh];
+ [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join;
+ [ | destruct (rh+2 lh) eqn:LT;
+ [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+ replace (bal u v w z)
+ with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto]
+ end
+ | destruct (lh+2 rh) eqn:LT';
+ [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+ replace (bal u v w z)
+ with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto]
+ end
+ | ] ] ] ]; intros.
+
+Ltac cleansplit :=
+ simpl; cleanf; inv Bst;
+ match goal with
+ | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ =>
+ change l with (〚l,o,r〛#l); rewrite <- ?E;
+ change o with (〚l,o,r〛#o); rewrite <- ?E;
+ change r with (〚l,o,r〛#r); rewrite <- ?E
+ | _ => idtac
+ end.
+
+(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *)
+
+(** Facts about [MapsTo] and [In]. *)
+
+Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m.
+Proof.
+ induction 1; auto.
+Qed.
+Local Hint Resolve MapsTo_In.
+
+Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m.
+Proof.
+ induction 1; try destruct IHIn as (e,He); exists e; auto.
+Qed.
+
+Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m.
+Proof.
+ split.
+ intros (e,H); eauto.
+ unfold In0; apply In_MapsTo; auto.
+Qed.
+
+Lemma MapsTo_1 {elt} m x y (e:elt) :
+ x == y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate MapsTo_1.
+
+Instance MapsTo_compat {elt} :
+ Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt).
+Proof.
+ intros x x' Hx e e' He m m' Hm. subst.
+ split; now apply MapsTo_1.
+Qed.
+
+Instance In_compat {elt} :
+ Proper (X.eq==>Logic.eq==>iff) (@In elt).
+Proof.
+ intros x x' H m m' <-.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+
+Lemma In_node_iff {elt} l x (e:elt) r h y :
+ y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [Above] and [Below] *)
+
+Lemma above {elt} (m:t elt) x :
+ x >> m <-> forall y, y ∈ m -> y < x.
+Proof.
+ split.
+ - induction 1; intuition_in; MX.order.
+ - induction m; constructor; auto.
+Qed.
+
+Lemma below {elt} (m:t elt) x :
+ x << m <-> forall y, y ∈ m -> x < y.
+Proof.
+ split.
+ - induction 1; intuition_in; MX.order.
+ - induction m; constructor; auto.
+Qed.
+
+Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x.
+Proof.
+ rewrite above; intuition.
+Qed.
+
+Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y.
+Proof.
+ rewrite below; intuition.
+Qed.
+
+Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m.
+Proof.
+ induction 1; intuition_in; MX.order.
+Qed.
+
+Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m.
+Proof.
+ induction 1; intuition_in; MX.order.
+Qed.
+
+Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m.
+Proof.
+ induction 2; constructor; trivial; MX.order.
+Qed.
+
+Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m.
+Proof.
+ induction 2; constructor; trivial; MX.order.
+Qed.
+
+Local Hint Resolve
+ AboveLt Above_not_In Above_trans
+ BelowGt Below_not_In Below_trans.
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: _ >> ?m, V: _ ∈ ?m |- _ =>
+ generalize (AboveLt U V); clear U; order
+ | U: _ << ?m, V: _ ∈ ?m |- _ =>
+ generalize (BelowGt U V); clear U; order
+ | U: _ >> ?m, V: MapsTo _ _ ?m |- _ =>
+ generalize (AboveLt U (MapsTo_In V)); clear U; order
+ | U: _ << ?m, V: MapsTo _ _ ?m |- _ =>
+ generalize (BelowGt U (MapsTo_In V)); clear U; order
+ | _ => MX.order
+end.
+
+Lemma between {elt} (m m':t elt) x :
+ x >> m -> x << m' -> m <<< m'.
+Proof.
+ intros H H' y y' Hy Hy'. order.
+Qed.
+
+Section Elt.
+Variable elt:Type.
+Implicit Types m r : t elt.
+
+(** * Membership *)
+
+Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e.
+Proof.
+ functional induction (find x m); cleanf;
+ intros; inv Bst; intuition_in; order.
+Qed.
+
+Lemma find_2 m x e : find x m = Some e -> MapsTo x e m.
+Proof.
+ functional induction (find x m); cleanf; subst; intros; auto.
+ - discriminate.
+ - injection H as ->. auto.
+Qed.
+
+Lemma find_spec m x e : Bst m ->
+ (find x m = Some e <-> MapsTo x e m).
+Proof.
+ split; auto using find_1, find_2.
+Qed.
+
+Lemma find_in m x : find x m <> None -> x ∈ m.
+Proof.
+ destruct (find x m) eqn:F; intros H.
+ - apply MapsTo_In with e. now apply find_2.
+ - now elim H.
+Qed.
+
+Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None.
+Proof.
+ intros H H'.
+ destruct (In_MapsTo H') as (d,Hd).
+ now rewrite (find_1 H Hd).
+Qed.
+
+Lemma find_in_iff m x : Bst m ->
+ (find x m <> None <-> x ∈ m).
+Proof.
+ split; auto using find_in, in_find.
+Qed.
+
+Lemma not_find_iff m x : Bst m ->
+ (find x m = None <-> ~ x ∈ m).
+Proof.
+ intros H. rewrite <- find_in_iff; trivial.
+ destruct (find x m); split; try easy. now destruct 1.
+Qed.
+
+Lemma eq_option_alt (o o':option elt) :
+ o=o' <-> (forall e, o=Some e <-> o'=Some e).
+Proof.
+split; intros.
+- now subst.
+- destruct o, o'; rewrite ?H; auto. symmetry; now apply H.
+Qed.
+
+Lemma find_mapsto_equiv : forall m m' x, Bst m -> Bst m' ->
+ (find x m = find x m' <->
+ (forall d, MapsTo x d m <-> MapsTo x d m')).
+Proof.
+ intros m m' x Hm Hm'. rewrite eq_option_alt.
+ split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec.
+Qed.
+
+Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' ->
+ find x m = find x m' ->
+ (x ∈ m <-> x ∈ m').
+Proof.
+ split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ];
+ apply in_find; auto.
+Qed.
+
+Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m.
+Proof.
+ intros B E.
+ destruct (find x' m) eqn:H.
+ - apply find_1; trivial. rewrite E. now apply find_2.
+ - rewrite not_find_iff in *; trivial. now rewrite E.
+Qed.
+
+Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m.
+Proof.
+ functional induction (mem x m); auto; intros; cleanf;
+ inv Bst; intuition_in; try discriminate; order.
+Qed.
+
+(** * Empty map *)
+
+Lemma empty_bst : Bst (empty elt).
+Proof.
+ constructor.
+Qed.
+
+Lemma empty_spec x : find x (empty elt) = None.
+Proof.
+ reflexivity.
+Qed.
+
+(** * Emptyness test *)
+
+Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m as [|r x e l h]; simpl; split; try easy.
+ intros H. specialize (H x). now rewrite MX.compare_refl in H.
+Qed.
+
+(** * Helper functions *)
+
+Lemma create_bst l x e r :
+ Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_in l x e r y :
+ y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+Lemma bal_bst l x e r : Bst l -> Bst r ->
+ x >> l -> x << r -> Bst (bal l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ inv Bst; inv Above; inv Below;
+ repeat apply create_bst; auto; unfold create; constructor; eauto.
+Qed.
+Hint Resolve bal_bst.
+
+Lemma bal_in l x e r y :
+ y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ rewrite !create_in; intuition_in.
+Qed.
+
+Lemma bal_mapsto l x e r y e' :
+ MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ unfold assert_false, create; intuition_in.
+Qed.
+
+Lemma bal_find l x e r y :
+ Bst l -> Bst r -> x >> l -> x << r ->
+ find y (bal l x e r) = find y (create l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf; trivial;
+ inv Bst; inv Above; inv Below;
+ simpl; repeat case X.compare_spec; intuition; order.
+Qed.
+
+(** * Insertion *)
+
+Lemma add_in m x y e :
+ y ∈ (add x e m) <-> y == x \/ y ∈ m.
+Proof.
+ functional induction (add x e m); auto; intros; cleanf;
+ rewrite ?bal_in; intuition_in. setoid_replace y with x; auto.
+Qed.
+
+Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m.
+Proof.
+ intros. apply above. intros z. rewrite add_in. destruct 1; order.
+Qed.
+
+Lemma add_gt m x e y : y << m -> y < x -> y << add x e m.
+Proof.
+ intros. apply below. intros z. rewrite add_in. destruct 1; order.
+Qed.
+
+Lemma add_bst m x e : Bst m -> Bst (add x e m).
+Proof.
+ functional induction (add x e m); intros; cleanf;
+ inv Bst; try apply bal_bst; auto using add_lt, add_gt.
+Qed.
+Hint Resolve add_lt add_gt add_bst.
+
+Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e.
+Proof.
+ functional induction (add x e m); simpl; intros; cleanf; trivial.
+ - now rewrite MX.compare_refl.
+ - inv Bst. rewrite bal_find; auto.
+ simpl. case X.compare_spec; try order; auto.
+ - inv Bst. rewrite bal_find; auto.
+ simpl. case X.compare_spec; try order; auto.
+Qed.
+
+Lemma add_spec2 m x y e : Bst m -> ~ x == y ->
+ find y (add x e m) = find y m.
+Proof.
+ functional induction (add x e m); simpl; intros; cleanf; trivial.
+ - case X.compare_spec; trivial; order.
+ - case X.compare_spec; trivial; order.
+ - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt.
+ - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt.
+Qed.
+
+Lemma add_find m x y e : Bst m ->
+ find y (add x e m) =
+ match X.compare y x with Eq => Some e | _ => find y m end.
+Proof.
+ intros.
+ case X.compare_spec; intros.
+ - apply find_spec; auto. rewrite H0. apply find_spec; auto.
+ now apply add_spec1.
+ - apply add_spec2; trivial; order.
+ - apply add_spec2; trivial; order.
+Qed.
+
+(** * Extraction of minimum binding *)
+
+Definition RemoveMin m res :=
+ match m with
+ | Leaf _ => False
+ | Node l x e r h => remove_min l x e r = res
+ end.
+
+Lemma RemoveMin_step l x e r h m' p :
+ RemoveMin (Node l x e r h) (m',p) ->
+ (l = Leaf _ /\ m' = r /\ p = (x,e) \/
+ exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r).
+Proof.
+ simpl. destruct l as [|ll lx le lr lh]; simpl.
+ - intros [= -> ->]. now left.
+ - destruct (remove_min ll lx le lr) as (l',p').
+ intros [= <- <-]. right. now exists l'.
+Qed.
+
+Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) ->
+ forall y e,
+ MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x d r _ h]; [destruct 1|].
+ intros m' R. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl.
+ - intuition_in. subst. now constructor.
+ - rewrite bal_mapsto. unfold create. specialize (IH _ R y e).
+ intuition_in.
+Qed.
+
+Lemma remove_min_in m m' p : RemoveMin m (m',p) ->
+ forall y, y ∈ m <-> y == p#1 \/ y ∈ m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R y. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]].
+ + intuition_in.
+ + rewrite bal_in, In_node_iff, (IH _ R); intuition.
+Qed.
+
+Lemma remove_min_lt m m' p : RemoveMin m (m',p) ->
+ forall y, y >> m -> y >> m'.
+Proof.
+ intros R y L. apply above. intros z Hz.
+ apply (AboveLt L).
+ apply (remove_min_in R). now right.
+Qed.
+
+Lemma remove_min_gt m m' p : RemoveMin m (m',p) ->
+ Bst m -> p#1 << m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R H. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(_,(->,->))|[m0 (R,->)]]; auto.
+ assert (p#1 << m0) by now apply IH.
+ assert (In p#1 l) by (apply (remove_min_in R); now left).
+ apply below. intros z. rewrite bal_in.
+ intuition_in; order.
+Qed.
+
+Lemma remove_min_bst m m' p : RemoveMin m (m',p) ->
+ Bst m -> Bst m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R H. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(_,(->,->))|[m0 (R,->)]]; auto.
+ apply bal_bst; eauto using remove_min_lt.
+Qed.
+
+Lemma remove_min_find m m' p : RemoveMin m (m',p) ->
+ Bst m ->
+ forall y,
+ find y m =
+ match X.compare y p#1 with
+ | Eq => Some p#2
+ | Lt => None
+ | Gt => find y m'
+ end.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R B y. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]]; auto.
+ assert (Bst m0) by now apply (remove_min_bst R).
+ assert (p#1 << m0) by now apply (remove_min_gt R).
+ assert (x >> m0) by now apply (remove_min_lt R).
+ assert (In p#1 l) by (apply (remove_min_in R); now left).
+ simpl in *.
+ rewrite (IH _ R), bal_find by trivial. clear IH. simpl.
+ do 2 case X.compare_spec; trivial; try order.
+Qed.
+
+(** * Merging two trees *)
+
+Ltac factor_remove_min m R := match goal with
+ | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ =>
+ assert (R:RemoveMin (Node l x e r h) p) by exact H;
+ set (m:=Node l x e r h) in *; clearbody m; clear H l x e r
+end.
+
+Lemma merge0_in m1 m2 y :
+ y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2.
+Proof.
+ functional induction (merge0 m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min l R. rewrite bal_in, (remove_min_in R).
+ simpl; intuition.
+Qed.
+
+Lemma merge0_mapsto m1 m2 y e :
+ MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2.
+Proof.
+ functional induction (merge0 m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R).
+ simpl. unfold create; intuition_in. subst. now constructor.
+Qed.
+
+Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ Bst (merge0 m1 m2).
+Proof.
+ functional induction (merge0 m1 m2); intros B1 B2 B12; trivial.
+ factornode m1. factor_remove_min l R.
+ apply bal_bst; auto.
+ - eapply remove_min_bst; eauto.
+ - apply above. intros z Hz. apply B12; trivial.
+ rewrite (remove_min_in R). now left.
+ - now apply (remove_min_gt R).
+Qed.
+Hint Resolve merge0_bst.
+
+(** * Deletion *)
+
+Lemma remove_in m x y : Bst m ->
+ (y ∈ remove x m <-> ~ y == x /\ y ∈ m).
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst;
+ rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m.
+Proof.
+ intros. apply above. intro. rewrite remove_in by trivial.
+ destruct 1; order.
+Qed.
+
+Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m.
+Proof.
+ intros. apply below. intro. rewrite remove_in by trivial.
+ destruct 1; order.
+Qed.
+
+Lemma remove_bst m x : Bst m -> Bst (remove x m).
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst.
+ - trivial.
+ - apply merge0_bst; eauto.
+ - apply bal_bst; auto using remove_lt.
+ - apply bal_bst; auto using remove_gt.
+Qed.
+Hint Resolve remove_bst remove_gt remove_lt.
+
+Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None.
+Proof.
+ intros. apply not_find_iff; auto. rewrite remove_in; intuition.
+Qed.
+
+Lemma remove_spec2 m x y : Bst m -> ~ x == y ->
+ find y (remove x m) = find y m.
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst.
+ - trivial.
+ - case X.compare_spec; intros; try order;
+ rewrite find_mapsto_equiv; auto.
+ + intros. rewrite merge0_mapsto; intuition; order.
+ + apply merge0_bst; auto. red; intros; transitivity y0; order.
+ + intros. rewrite merge0_mapsto; intuition; order.
+ + apply merge0_bst; auto. now apply between with y0.
+ - rewrite bal_find by auto. simpl. case X.compare_spec; auto.
+ - rewrite bal_find by auto. simpl. case X.compare_spec; auto.
+Qed.
+
+(** * join *)
+
+Lemma join_in l x d r y :
+ y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ join_tac l x d r.
+ - simpl join. rewrite add_in. intuition_in.
+ - rewrite add_in. intuition_in.
+ - rewrite bal_in, Hlr. clear Hlr Hrl. intuition_in.
+ - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in.
+ - apply create_in.
+Qed.
+
+Lemma join_bst l x d r :
+ Bst (create l x d r) -> Bst (join l x d r).
+Proof.
+ join_tac l x d r; unfold create in *;
+ inv Bst; inv Above; inv Below; auto.
+ - simpl. auto.
+ - apply bal_bst; auto.
+ apply below. intro. rewrite join_in. intuition_in; order.
+ - apply bal_bst; auto.
+ apply above. intro. rewrite join_in. intuition_in; order.
+Qed.
+Hint Resolve join_bst.
+
+Lemma join_find l x d r y :
+ Bst (create l x d r) ->
+ find y (join l x d r) = find y (create l x d r).
+Proof.
+ unfold create at 1.
+ join_tac l x d r; trivial.
+ - simpl in *. inv Bst.
+ rewrite add_find; trivial.
+ case X.compare_spec; intros; trivial.
+ apply not_find_iff; auto. intro. order.
+ - clear Hlr. factornode l. simpl. inv Bst.
+ rewrite add_find by auto.
+ case X.compare_spec; intros; trivial.
+ apply not_find_iff; auto. intro. order.
+ - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below.
+ rewrite bal_find; auto; simpl.
+ + rewrite Hlr; auto; simpl.
+ repeat (case X.compare_spec; trivial; try order).
+ + apply below. intro. rewrite join_in. intuition_in; order.
+ - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below.
+ rewrite bal_find; auto; simpl.
+ + rewrite Hrl; auto; simpl.
+ repeat (case X.compare_spec; trivial; try order).
+ + apply above. intro. rewrite join_in. intuition_in; order.
+Qed.
+
+(** * split *)
+
+Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m.
+Proof.
+ functional induction (split x m); cleansplit;
+ rewrite ?join_in; intuition.
+Qed.
+
+Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m.
+Proof.
+ functional induction (split x m); cleansplit;
+ rewrite ?join_in; intuition.
+Qed.
+
+Lemma split_in_l m x y : Bst m ->
+ (y ∈ (split x m)#l <-> y ∈ m /\ y < x).
+Proof.
+ functional induction (split x m); intros; cleansplit;
+ rewrite ?join_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_r m x y : Bst m ->
+ (y ∈ (split x m)#r <-> y ∈ m /\ x < y).
+Proof.
+ functional induction (split x m); intros; cleansplit;
+ rewrite ?join_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_o m x : (split x m)#o = find x m.
+Proof.
+ functional induction (split x m); intros; cleansplit; auto.
+Qed.
+
+Lemma split_lt_l m x : Bst m -> x >> (split x m)#l.
+Proof.
+ intro. apply above. intro. rewrite split_in_l; intuition; order.
+Qed.
+
+Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r.
+Proof.
+ intro. apply above. intros z Hz. apply split_in_r0 in Hz. order.
+Qed.
+
+Lemma split_gt_r m x : Bst m -> x << (split x m)#r.
+Proof.
+ intro. apply below. intro. rewrite split_in_r; intuition; order.
+Qed.
+
+Lemma split_gt_l m x y : y << m -> y << (split x m)#l.
+Proof.
+ intro. apply below. intros z Hz. apply split_in_l0 in Hz. order.
+Qed.
+Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r.
+
+Lemma split_bst_l m x : Bst m -> Bst (split x m)#l.
+Proof.
+ functional induction (split x m); intros; cleansplit; intuition;
+ auto using join_bst.
+Qed.
+
+Lemma split_bst_r m x : Bst m -> Bst (split x m)#r.
+Proof.
+ functional induction (split x m); intros; cleansplit; intuition;
+ auto using join_bst.
+Qed.
+Hint Resolve split_bst_l split_bst_r.
+
+Lemma split_find m x y : Bst m ->
+ find y m = match X.compare y x with
+ | Eq => (split x m)#o
+ | Lt => find y (split x m)#l
+ | Gt => find y (split x m)#r
+ end.
+Proof.
+ functional induction (split x m); intros; cleansplit.
+ - now case X.compare.
+ - repeat case X.compare_spec; trivial; order.
+ - simpl in *. rewrite join_find, IHt; auto.
+ simpl. repeat case X.compare_spec; trivial; order.
+ - rewrite join_find, IHt; auto.
+ simpl; repeat case X.compare_spec; trivial; order.
+Qed.
+
+(** * Concatenation *)
+
+Lemma concat_in m1 m2 y :
+ y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2.
+Proof.
+ functional induction (concat m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min m2 R.
+ rewrite join_in, (remove_min_in R); simpl; intuition.
+Qed.
+
+Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ Bst (concat m1 m2).
+Proof.
+ functional induction (concat m1 m2); intros B1 B2 LT; auto;
+ try factornode m1.
+ factor_remove_min m2 R.
+ apply join_bst, create_bst; auto.
+ - now apply (remove_min_bst R).
+ - apply above. intros y Hy. apply LT; trivial.
+ rewrite (remove_min_in R); now left.
+ - now apply (remove_min_gt R).
+Qed.
+Hint Resolve concat_bst.
+
+Definition oelse {A} (o1 o2:option A) :=
+ match o1 with
+ | Some x => Some x
+ | None => o2
+ end.
+
+Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ find y (concat m1 m2) = oelse (find y m2) (find y m1).
+Proof.
+ functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1.
+ - destruct (find y m2); auto.
+ - factor_remove_min m2 R.
+ assert (xd#1 >> m1).
+ { apply above. intros z Hz. apply B; trivial.
+ rewrite (remove_min_in R). now left. }
+ rewrite join_find; simpl; auto.
+ + rewrite (remove_min_find R B2 y).
+ case X.compare_spec; intros; auto.
+ destruct (find y m2'); trivial.
+ simpl. symmetry. apply not_find_iff; eauto.
+ + apply create_bst; auto.
+ * now apply (remove_min_bst R).
+ * now apply (remove_min_gt R).
+Qed.
+
+
+(** * Elements *)
+
+Notation eqk := (PX.eqk (elt:= elt)).
+Notation eqke := (PX.eqke (elt:= elt)).
+Notation ltk := (PX.ltk (elt:= elt)).
+
+Lemma bindings_aux_mapsto : forall (s:t elt) acc x e,
+ InA eqke (x,e) (bindings_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc.
+Proof.
+ induction s as [ | l Hl x e r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0 e0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+ compute in H0. destruct H0; simpl in *; subst; intuition.
+Qed.
+
+Lemma bindings_mapsto : forall (s:t elt) x e,
+ InA eqke (x,e) (bindings s) <-> MapsTo x e s.
+Proof.
+ intros; generalize (bindings_aux_mapsto s nil x e); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s.
+Proof.
+ intros.
+ unfold L.PX.In.
+ rewrite <- In_alt; unfold In0.
+ split; intros (y,H); exists y.
+ - now rewrite <- bindings_mapsto.
+ - unfold L.PX.MapsTo; now rewrite bindings_mapsto.
+Qed.
+
+Lemma bindings_aux_sort : forall (s:t elt) acc,
+ Bst s -> sort ltk acc ->
+ (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) ->
+ sort ltk (bindings_aux acc s).
+Proof.
+ induction s as [ | l Hl y e r Hr h]; simpl; intuition.
+ inv Bst.
+ apply Hl; auto.
+ - constructor.
+ + apply Hr; eauto.
+ + clear Hl Hr.
+ apply InA_InfA with (eqA:=eqke); auto with *.
+ intros (y',e') Hy'.
+ apply bindings_aux_mapsto in Hy'. compute. intuition; eauto.
+ - clear Hl Hr. intros x e' y' Hx Hy'.
+ inversion_clear Hx.
+ + compute in H. destruct H; simpl in *. order.
+ + apply bindings_aux_mapsto in H. intuition eauto.
+Qed.
+
+Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s).
+Proof.
+ intros; unfold bindings; apply bindings_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve bindings_sort.
+
+Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s).
+Proof.
+ intros; apply PX.Sort_NoDupA; auto.
+Qed.
+
+Lemma bindings_aux_cardinal m acc :
+ (length acc + cardinal m)%nat = length (bindings_aux acc m).
+Proof.
+ revert acc. induction m; simpl; intuition.
+ rewrite <- IHm1; simpl.
+ rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc.
+ f_equal. f_equal. apply Nat.add_comm.
+Qed.
+
+Lemma bindings_cardinal m : cardinal m = length (bindings m).
+Proof.
+ exact (bindings_aux_cardinal m nil).
+Qed.
+
+Lemma bindings_app :
+ forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold bindings; simpl.
+ rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
+Qed.
+
+Lemma bindings_node :
+ forall (t1 t2:t elt) x e z l,
+ bindings t1 ++ (x,e) :: bindings t2 ++ l =
+ bindings (Node t1 x e t2 z) ++ l.
+Proof.
+ unfold bindings; simpl; intros.
+ rewrite !bindings_app, !app_nil_r, !app_ass; auto.
+Qed.
+
+(** * Fold *)
+
+Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) :=
+ L.fold f (bindings s).
+
+Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc :
+ L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ revert a acc.
+ induction s; simpl; trivial.
+ intros. rewrite IHs1. simpl. apply IHs2.
+Qed.
+
+Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) :
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', bindings. now rewrite fold_equiv_aux.
+Qed.
+
+Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) :
+ fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i.
+Proof.
+ rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec.
+Qed.
+
+(** * Comparison *)
+
+(** [flatten_e e] returns the list of bindings of the enumeration [e]
+ i.e. the list of bindings actually compared *)
+
+Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
+ | End _ => nil
+ | More x e t r => (x,e) :: bindings t ++ flatten_e r
+ end.
+
+Lemma flatten_e_bindings :
+ forall (l:t elt) r x d z e,
+ bindings l ++ flatten_e (More x d r e) =
+ bindings (Node l x d r z) ++ flatten_e e.
+Proof.
+ intros; apply bindings_node.
+Qed.
+
+Lemma cons_1 : forall (s:t elt) e,
+ flatten_e (cons s e) = bindings s ++ flatten_e e.
+Proof.
+ induction s; auto; intros.
+ simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto.
+Qed.
+
+(** Proof of correction for the comparison *)
+
+Variable cmp : elt->elt->bool.
+
+Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b.
+
+Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2,
+ X.eq x1 x2 -> cmp d1 d2 = true ->
+ IfEq b l1 l2 ->
+ IfEq b ((x1,d1)::l1) ((x2,d2)::l2).
+Proof.
+ unfold IfEq; destruct b; simpl; intros; case X.compare_spec; simpl;
+ try rewrite H0; auto; order.
+Qed.
+
+Lemma equal_end_IfEq : forall e2,
+ IfEq (equal_end e2) nil (flatten_e e2).
+Proof.
+ destruct e2; red; auto.
+Qed.
+
+Lemma equal_more_IfEq :
+ forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l,
+ IfEq (cont (cons r2 e2)) l (bindings r2 ++ flatten_e e2) ->
+ IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l)
+ (flatten_e (More x2 d2 r2 e2)).
+Proof.
+ unfold IfEq; simpl; intros; destruct X.compare; simpl; auto.
+ rewrite <-andb_lazy_alt; f_equal; auto.
+Qed.
+
+Lemma equal_cont_IfEq : forall m1 cont e2 l,
+ (forall e, IfEq (cont e) l (flatten_e e)) ->
+ IfEq (equal_cont cmp m1 cont e2) (bindings m1 ++ l) (flatten_e e2).
+Proof.
+ induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
+ rewrite <- bindings_node; simpl.
+ apply Hl1; auto.
+ clear e2; intros [|x2 d2 r2 e2].
+ simpl; red; auto.
+ apply equal_more_IfEq.
+ rewrite <- cons_1; auto.
+Qed.
+
+Lemma equal_IfEq : forall (m1 m2:t elt),
+ IfEq (equal cmp m1 m2) (bindings m1) (bindings m2).
+Proof.
+ intros; unfold equal.
+ rewrite <- (app_nil_r (bindings m1)).
+ replace (bindings m2) with (flatten_e (cons m2 (End _)))
+ by (rewrite cons_1; simpl; rewrite app_nil_r; auto).
+ apply equal_cont_IfEq.
+ intros.
+ apply equal_end_IfEq; auto.
+Qed.
+
+Definition Equivb m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma Equivb_bindings : forall s s',
+ Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s').
+Proof.
+unfold Equivb, L.Equivb; split; split; intros.
+do 2 rewrite bindings_in; firstorder.
+destruct H.
+apply (H2 k); rewrite <- bindings_mapsto; auto.
+do 2 rewrite <- bindings_in; firstorder.
+destruct H.
+apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_mapsto; auto.
+Qed.
+
+Lemma equal_Equivb : forall (s s': t elt), Bst s -> Bst s' ->
+ (equal cmp s s' = true <-> Equivb s s').
+Proof.
+ intros s s' B B'.
+ rewrite Equivb_bindings, <- equal_IfEq.
+ split; [apply L.equal_2|apply L.equal_1]; auto.
+Qed.
+
+End Elt.
+
+Section Map.
+Variable elt elt' : Type.
+Variable f : elt -> elt'.
+
+Lemma map_spec m x :
+ find x (map f m) = option_map f (find x m).
+Proof.
+induction m; simpl; trivial. case X.compare_spec; auto.
+Qed.
+
+Lemma map_in m x : x ∈ (map f m) <-> x ∈ m.
+Proof.
+induction m; simpl; intuition_in.
+Qed.
+
+Lemma map_bst m : Bst m -> Bst (map f m).
+Proof.
+induction m; simpl; auto. intros; inv Bst; constructor; auto.
+- apply above. intro. rewrite map_in. intros. order.
+- apply below. intro. rewrite map_in. intros. order.
+Qed.
+
+End Map.
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'.
+
+Lemma mapi_spec m x :
+ exists y:key,
+ X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m; simpl.
+ - now exists x.
+ - case X.compare_spec; simpl; auto. intros. now exists k.
+Qed.
+
+Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m.
+Proof.
+induction m; simpl; intuition_in.
+Qed.
+
+Lemma mapi_bst m : Bst m -> Bst (mapi f m).
+Proof.
+induction m; simpl; auto. intros; inv Bst; constructor; auto.
+- apply above. intro. rewrite mapi_in. intros. order.
+- apply below. intro. rewrite mapi_in. intros. order.
+Qed.
+
+End Mapi.
+
+Section Mapo.
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+
+Lemma mapo_in m x :
+ x ∈ (mapo f m) ->
+ exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None.
+Proof.
+functional induction (mapo f m); simpl; auto; intro H.
+- inv In.
+- rewrite join_in in H; destruct H as [H|[H|H]].
+ + exists x0, d. do 2 (split; auto). congruence.
+ + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto.
+ + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto.
+- rewrite concat_in in H; destruct H as [H|H].
+ + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto.
+ + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto.
+Qed.
+
+Lemma mapo_lt m x : x >> m -> x >> mapo f m.
+Proof.
+ intros H. apply above. intros y Hy.
+ destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order.
+Qed.
+
+Lemma mapo_gt m x : x << m -> x << mapo f m.
+Proof.
+ intros H. apply below. intros y Hy.
+ destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order.
+Qed.
+Hint Resolve mapo_lt mapo_gt.
+
+Lemma mapo_bst m : Bst m -> Bst (mapo f m).
+Proof.
+functional induction (mapo f m); simpl; auto; intro H; inv Bst.
+- apply join_bst, create_bst; auto.
+- apply concat_bst; auto. apply between with x; auto.
+Qed.
+Hint Resolve mapo_bst.
+
+Ltac nonify e :=
+ replace e with (@None elt) by
+ (symmetry; rewrite not_find_iff; auto; intro; order).
+
+Definition obind {A B} (o:option A) (f:A->option B) :=
+ match o with Some a => f a | None => None end.
+
+Lemma mapo_find m x :
+ Bst m ->
+ exists y, X.eq y x /\
+ find x (mapo f m) = obind (find x m) (f y).
+Proof.
+functional induction (mapo f m); simpl; auto; intros B;
+ inv Bst.
+- now exists x.
+- rewrite join_find; auto.
+ + simpl. case X.compare_spec; simpl; intros.
+ * now exists x0.
+ * destruct IHt as (y' & ? & ?); auto.
+ exists y'; split; trivial.
+ * destruct IHt0 as (y' & ? & ?); auto.
+ exists y'; split; trivial.
+ + constructor; auto using mapo_lt, mapo_gt.
+- rewrite concat_find; auto.
+ + destruct IHt0 as (y' & ? & ->); auto.
+ destruct IHt as (y'' & ? & ->); auto.
+ case X.compare_spec; simpl; intros.
+ * nonify (find x r). nonify (find x l). simpl. now exists x0.
+ * nonify (find x r). now exists y''.
+ * nonify (find x l). exists y'. split; trivial.
+ destruct (find x r); simpl; trivial.
+ now destruct (f y' e).
+ + apply between with x0; auto.
+Qed.
+
+End Mapo.
+
+Section Gmerge.
+Variable elt elt' elt'' : Type.
+Variable f0 : key -> option elt -> option elt' -> option elt''.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o.
+Hypothesis mapl_bst : forall m, Bst m -> Bst (mapl m).
+Hypothesis mapr_bst : forall m', Bst m' -> Bst (mapr m').
+Hypothesis mapl_f0 : forall x m, Bst m ->
+ exists y, X.eq y x /\
+ find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None).
+Hypothesis mapr_f0 : forall x m, Bst m ->
+ exists y, X.eq y x /\
+ find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)).
+
+Notation gmerge := (gmerge f mapl mapr).
+
+Lemma gmerge_in m m' y : Bst m -> Bst m' ->
+ y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'.
+Proof.
+ functional induction (gmerge m m'); intros B1 B2 H;
+ try factornode m2; inv Bst.
+ - right. apply find_in.
+ generalize (in_find (mapr_bst B2) H).
+ destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial.
+ intros A B. rewrite B in A. now elim A.
+ - left. apply find_in.
+ generalize (in_find (mapl_bst B1) H).
+ destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial.
+ intros A B. rewrite B in A. now elim A.
+ - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit.
+ generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite split_in_r, split_in_l; intuition_in.
+ - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit.
+ generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite split_in_r, split_in_l; intuition_in.
+Qed.
+
+Lemma gmerge_lt m m' x : Bst m -> Bst m' ->
+ x >> m -> x >> m' -> x >> gmerge m m'.
+Proof.
+ intros. apply above. intros y Hy.
+ apply gmerge_in in Hy; intuition_in; order.
+Qed.
+
+Lemma gmerge_gt m m' x : Bst m -> Bst m' ->
+ x << m -> x << m' -> x << gmerge m m'.
+Proof.
+ intros. apply below. intros y Hy.
+ apply gmerge_in in Hy; intuition_in; order.
+Qed.
+Hint Resolve gmerge_lt gmerge_gt.
+Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r.
+
+Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m').
+Proof.
+ functional induction (gmerge m m'); intros B1 B2; auto;
+ factornode m2; inv Bst;
+ (apply join_bst, create_bst || apply concat_bst);
+ revert IHt1 IHt0; cleansplit; intuition.
+ apply between with x1; auto.
+Qed.
+Hint Resolve gmerge_bst.
+
+Lemma oelse_none_r {A} (o:option A) : oelse o None = o.
+Proof. now destruct o. Qed.
+
+Ltac nonify e :=
+ let E := fresh "E" in
+ assert (E : e = None);
+ [ rewrite not_find_iff; auto; intro U;
+ try apply gmerge_in in U; intuition_in; order
+ | rewrite E; clear E ].
+
+Lemma gmerge_find m m' x : Bst m -> Bst m' ->
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (gmerge m m') = f0 y (find x m) (find x m').
+Proof.
+ functional induction (gmerge m m'); intros B1 B2 H;
+ try factornode m2; inv Bst.
+ - destruct H; [ intuition_in | ].
+ destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial.
+ exists y; split; trivial.
+ rewrite E. simpl. apply in_find in H; trivial.
+ destruct (find x m2); simpl; intuition.
+ - destruct H; [ | intuition_in ].
+ destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial.
+ exists y; split; trivial.
+ rewrite E. simpl. apply in_find in H; trivial.
+ destruct (find x m2); simpl; intuition.
+ - generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite (split_find x1 x B2).
+ rewrite e1 in *; simpl in *. intros.
+ rewrite join_find by (cleansplit; constructor; auto).
+ simpl. case X.compare_spec; intros.
+ + exists x1. split; auto. now rewrite <- e3, f0_f.
+ + apply IHt1; auto. clear IHt1 IHt0.
+ cleansplit; rewrite split_in_l; trivial.
+ intuition_in; order.
+ + apply IHt0; auto. clear IHt1 IHt0.
+ cleansplit; rewrite split_in_r; trivial.
+ intuition_in; order.
+ - generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite (split_find x1 x B2).
+ pose proof (split_lt_l x1 B2).
+ pose proof (split_gt_r x1 B2).
+ rewrite e1 in *; simpl in *. intros.
+ rewrite concat_find by (try apply between with x1; auto).
+ case X.compare_spec; intros.
+ + clear IHt0 IHt1.
+ exists x1. split; auto. rewrite <- f0_f, e2.
+ nonify (find x (gmerge r1 r2')).
+ nonify (find x (gmerge l1 l2')). trivial.
+ + nonify (find x (gmerge r1 r2')).
+ simpl. apply IHt1; auto. clear IHt1 IHt0.
+ intuition_in; try order.
+ right. cleansplit. now apply split_in_l.
+ + nonify (find x (gmerge l1 l2')). simpl.
+ rewrite oelse_none_r.
+ apply IHt0; auto. clear IHt1 IHt0.
+ intuition_in; try order.
+ right. cleansplit. now apply split_in_r.
+Qed.
+
+End Gmerge.
+
+Section Merge.
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m').
+Proof.
+unfold merge; intros.
+apply gmerge_bst with f;
+ auto using mapo_bst, mapo_find.
+Qed.
+
+Lemma merge_spec1 m m' x : Bst m -> Bst m' ->
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+Proof.
+ unfold merge; intros.
+ edestruct (gmerge_find (f0:=f)) as (y,(Hy,E));
+ eauto using mapo_bst.
+ - reflexivity.
+ - intros. now apply mapo_find.
+ - intros. now apply mapo_find.
+Qed.
+
+Lemma merge_spec2 m m' x : Bst m -> Bst m' ->
+ In x (merge f m m') -> In x m \/ In x m'.
+Proof.
+unfold merge; intros.
+eapply gmerge_in with (f0:=f); try eassumption;
+ auto using mapo_bst, mapo_find.
+Qed.
+
+End Merge.
+End Proofs.
+End Raw.
+
+(** * Encapsulation
+
+ Now, in order to really provide a functor implementing [S], we
+ need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X.
+ Import Raw.Proofs.
+
+ Record tree (elt:Type) :=
+ Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}.
+
+ Definition t := tree.
+ Definition key := E.t.
+
+ Section Elt.
+ Variable elt elt' elt'': Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Mk (empty_bst elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)).
+ Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition map f m : t elt' := Mk (map_bst f m.(is_bst)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (mapi_bst f m.(is_bst)).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (merge_bst f m.(is_bst) m'.(is_bst)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := Raw.cardinal m.(this).
+ Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.In0 x m.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt.
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl.
+ now rewrite Hk, He, Hm.
+ Qed.
+
+ Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m.
+ Proof. apply find_spec. apply is_bst. Qed.
+
+ Lemma mem_spec m x : mem x m = true <-> In x m.
+ Proof.
+ unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst.
+ Qed.
+
+ Lemma empty_spec x : find x empty = None.
+ Proof. apply empty_spec. Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
+ Proof. apply is_empty_spec. Qed.
+
+ Lemma add_spec1 m x e : find x (add x e m) = Some e.
+ Proof. apply add_spec1. apply is_bst. Qed.
+ Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m.
+ Proof. apply add_spec2. apply is_bst. Qed.
+
+ Lemma remove_spec1 m x : find x (remove x m) = None.
+ Proof. apply remove_spec1. apply is_bst. Qed.
+ Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. apply remove_spec2. apply is_bst. Qed.
+
+ Lemma bindings_spec1 m x e :
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. apply bindings_mapsto. Qed.
+
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof. apply bindings_sort. apply is_bst. Qed.
+
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. apply bindings_nodup. apply is_bst. Qed.
+
+ Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) :
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof. apply fold_spec. apply is_bst. Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. apply bindings_cardinal. Qed.
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp := Equiv (Cmp cmp).
+
+ Lemma Equivb_Equivb cmp m m' :
+ Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
+ Proof.
+ unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ Qed.
+
+ Lemma equal_spec m m' cmp :
+ equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed.
+
+ End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m x :
+ find x (map f m) = option_map f (find x m).
+ Proof. apply map_spec. Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x :
+ exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. apply mapi_spec. Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' x :
+ In x m \/ In x m' ->
+ exists y:key, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+ Proof.
+ unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst.
+ Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key -> option elt->option elt'->option elt'') m m' x :
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof.
+ unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst.
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+ Sord with Module Data := D
+ with Module MapS.E := X.
+
+ Module Data := D.
+ Module Import MapS := IntMake(I)(X).
+ Module LO := MMapList.Make_ord(X)(D).
+ Module R := Raw.
+ Module P := Raw.Proofs.
+
+ Definition t := MapS.t D.t.
+
+ Definition cmp e e' :=
+ match D.compare e e' with Eq => true | _ => false end.
+
+ (** One step of comparison of bindings *)
+
+ Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 :=
+ match e2 with
+ | R.End _ => Gt
+ | R.More x2 d2 r2 e2 =>
+ match X.compare x1 x2 with
+ | Eq => match D.compare d1 d2 with
+ | Eq => cont (R.cons r2 e2)
+ | Lt => Lt
+ | Gt => Gt
+ end
+ | Lt => Lt
+ | Gt => Gt
+ end
+ end.
+
+ (** Comparison of left tree, middle element, then right tree *)
+
+ Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 :=
+ match s1 with
+ | R.Leaf _ => cont e2
+ | R.Node l1 x1 d1 r1 _ =>
+ compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
+ end.
+
+ (** Initial continuation *)
+
+ Definition compare_end (e2:R.enumeration D.t) :=
+ match e2 with R.End _ => Eq | _ => Lt end.
+
+ (** The complete comparison *)
+
+ Definition compare m1 m2 :=
+ compare_cont m1.(this) compare_end (R.cons m2 .(this) (Raw.End _)).
+
+ (** Correctness of this comparison *)
+
+ Definition Cmp c :=
+ match c with
+ | Eq => LO.eq_list
+ | Lt => LO.lt_list
+ | Gt => (fun l1 l2 => LO.lt_list l2 l1)
+ end.
+
+ Lemma cons_Cmp c x1 x2 d1 d2 l1 l2 :
+ X.eq x1 x2 -> D.eq d1 d2 ->
+ Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
+ Proof.
+ destruct c; simpl; intros; case X.compare_spec; auto; try P.MX.order.
+ intros. right. split; auto. now symmetry.
+ Qed.
+ Hint Resolve cons_Cmp.
+
+ Lemma compare_end_Cmp e2 :
+ Cmp (compare_end e2) nil (P.flatten_e e2).
+ Proof.
+ destruct e2; simpl; auto.
+ Qed.
+
+ Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l :
+ Cmp (cont (R.cons r2 e2)) l (R.bindings r2 ++ P.flatten_e e2) ->
+ Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l)
+ (P.flatten_e (R.More x2 d2 r2 e2)).
+ Proof.
+ simpl; case X.compare_spec; simpl;
+ try case D.compare_spec; simpl; auto;
+ case X.compare_spec; try P.MX.order; auto.
+ Qed.
+
+ Lemma compare_cont_Cmp : forall s1 cont e2 l,
+ (forall e, Cmp (cont e) l (P.flatten_e e)) ->
+ Cmp (compare_cont s1 cont e2) (R.bindings s1 ++ l) (P.flatten_e e2).
+ Proof.
+ induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind;
+ intros; auto.
+ rewrite <- P.bindings_node; simpl.
+ apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2].
+ simpl; auto.
+ apply compare_more_Cmp.
+ rewrite <- P.cons_1; auto.
+ Qed.
+
+ Lemma compare_Cmp m1 m2 :
+ Cmp (compare m1 m2) (bindings m1) (bindings m2).
+ Proof.
+ destruct m1 as (s1,H1), m2 as (s2,H2).
+ unfold compare, bindings; simpl.
+ rewrite <- (app_nil_r (R.bindings s1)).
+ replace (R.bindings s2) with (P.flatten_e (R.cons s2 (R.End _))) by
+ (rewrite P.cons_1; simpl; rewrite app_nil_r; auto).
+ auto using compare_cont_Cmp, compare_end_Cmp.
+ Qed.
+
+ Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2).
+ Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2).
+
+ Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2).
+ Proof.
+ assert (H := compare_Cmp m1 m2).
+ unfold Cmp in H.
+ destruct (compare m1 m2); auto.
+ Qed.
+
+ (* Proofs about [eq] and [lt] *)
+
+ Definition sbindings (m1 : t) :=
+ LO.MapS.Mk (P.bindings_sort m1.(is_bst)).
+
+ Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2).
+ Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2).
+
+ Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+ Proof.
+ unfold eq, seq, sbindings, bindings, LO.eq; intuition.
+ Qed.
+
+ Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+ Proof.
+ unfold lt, slt, sbindings, bindings, LO.lt; intuition.
+ Qed.
+
+ Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'.
+ Proof.
+ rewrite eq_seq; unfold seq.
+ rewrite Equivb_Equivb.
+ rewrite P.Equivb_bindings. apply LO.eq_spec.
+ Qed.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+ constructor; red; [intros x|intros x y| intros x y z];
+ rewrite !eq_seq; apply LO.eq_equiv.
+ Qed.
+
+ Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
+ Proof.
+ intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *.
+ now apply LO.lt_compat.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ constructor; red; [intros x; red|intros x y z];
+ rewrite !lt_slt; apply LO.lt_strorder.
+ Qed.
+
+End IntMake_ord.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+Module Make_ord (X: OrderedType)(D: OrderedType)
+ <: Sord with Module Data := D
+ with Module MapS.E := X
+ :=IntMake_ord(Z_as_Int)(X)(D).
diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v
new file mode 100644
index 00000000..69066a7b
--- /dev/null
+++ b/theories/MMaps/MMapFacts.v
@@ -0,0 +1,2434 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* (b=true <-> b'=true).
+Proof.
+ destruct b, b'; intuition.
+Qed.
+
+Lemma eq_option_alt {elt}(o o':option elt) :
+ o=o' <-> (forall e, o=Some e <-> o'=Some e).
+Proof.
+split; intros.
+- now subst.
+- destruct o, o'; rewrite ?H; auto.
+ symmetry; now apply H.
+Qed.
+
+Lemma option_map_some {A B}(f:A->B) o :
+ option_map f o <> None <-> o <> None.
+Proof.
+ destruct o; simpl. now split. split; now destruct 1.
+Qed.
+
+(** * Properties about weak maps *)
+
+Module WProperties_fun (E:DecidableType)(Import M:WSfun E).
+
+Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m.
+
+(** A few things about E.eq *)
+
+Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed.
+Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed.
+Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z.
+Proof. apply E.eq_equiv. Qed.
+Hint Immediate eq_refl eq_sym : map.
+Hint Resolve eq_trans eq_equivalence E.eq_equiv : map.
+
+Definition eqb x y := if E.eq_dec x y then true else false.
+
+Lemma eqb_eq x y : eqb x y = true <-> E.eq x y.
+Proof.
+ unfold eqb; case E.eq_dec; now intuition.
+Qed.
+
+Lemma eqb_sym x y : eqb x y = eqb y x.
+Proof.
+ apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv.
+Qed.
+
+(** Initial results about MapsTo and In *)
+
+Lemma mapsto_fun {elt} m x (e e':elt) :
+ MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+rewrite <- !find_spec. congruence.
+Qed.
+
+Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None.
+Proof.
+ unfold In. split.
+ - intros (e,H). rewrite <-find_spec in H. congruence.
+ - destruct (find x m) as [e|] eqn:H.
+ + exists e. now apply find_spec.
+ + now destruct 1.
+Qed.
+
+Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None.
+Proof.
+ rewrite in_find. split; auto.
+ intros; destruct (find x m); trivial. now destruct H.
+Qed.
+
+Notation in_find_iff := in_find (only parsing).
+Notation not_find_in_iff := not_in_find (only parsing).
+
+(** * [Equal] is a setoid equality. *)
+
+Infix "==" := Equal (at level 30).
+
+Lemma Equal_refl {elt} (m : t elt) : m == m.
+Proof. red; reflexivity. Qed.
+
+Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m.
+Proof. unfold Equal; auto. Qed.
+
+Lemma Equal_trans {elt} (m m' m'' : t elt) :
+ m == m' -> m' == m'' -> m == m''.
+Proof. unfold Equal; congruence. Qed.
+
+Instance Equal_equiv {elt} : Equivalence (@Equal elt).
+Proof.
+constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans].
+Qed.
+
+Arguments Equal {elt} m m'.
+
+Instance MapsTo_m {elt} :
+ Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt).
+Proof.
+intros k k' Hk e e' <- m m' Hm. rewrite <- Hk.
+now rewrite <- !find_spec, Hm.
+Qed.
+
+Instance In_m {elt} :
+ Proper (E.eq==>Equal==>iff) (@In elt).
+Proof.
+intros k k' Hk m m' Hm. unfold In.
+split; intros (e,H); exists e; revert H;
+ now rewrite Hk, <- !find_spec, Hm.
+Qed.
+
+Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt).
+Proof.
+intros k k' Hk m m' <-.
+rewrite eq_option_alt. intros. now rewrite !find_spec, Hk.
+Qed.
+
+Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt).
+Proof.
+intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm.
+Qed.
+
+Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt).
+Proof.
+intros m m' Hm. unfold Empty. now setoid_rewrite Hm.
+Qed.
+
+Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt).
+Proof.
+intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec.
+ now setoid_rewrite Hm.
+Qed.
+
+Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt).
+Proof.
+intros k k' Hk e e' <- m m' Hm y.
+destruct (E.eq_dec k y) as [H|H].
+- rewrite <-H, add_spec1. now rewrite Hk, add_spec1.
+- rewrite !add_spec2; trivial. now rewrite <- Hk.
+Qed.
+
+Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt).
+Proof.
+intros k k' Hk m m' Hm y.
+destruct (E.eq_dec k y) as [H|H].
+- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1.
+- rewrite !remove_spec2; trivial. now rewrite <- Hk.
+Qed.
+
+Instance map_m {elt elt'} :
+ Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt').
+Proof.
+intros f f' Hf m m' Hm y. rewrite !map_spec, Hm.
+destruct (find y m'); simpl; trivial. f_equal. now apply Hf.
+Qed.
+
+Instance mapi_m {elt elt'} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt').
+Proof.
+intros f f' Hf m m' Hm y.
+destruct (mapi_spec f m y) as (x,(Hx,->)).
+destruct (mapi_spec f' m' y) as (x',(Hx',->)).
+rewrite <- Hm. destruct (find y m); trivial. simpl.
+f_equal. apply Hf; trivial. now rewrite Hx, Hx'.
+Qed.
+
+Instance merge_m {elt elt' elt''} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal)
+ (@merge elt elt' elt'').
+Proof.
+intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y.
+destruct (find y m1) as [e1|] eqn:H1.
+- apply find_spec in H1.
+ assert (H : In y m1 \/ In y m2) by (left; now exists e1).
+ destruct (merge_spec1 f H) as (y1,(Hy1,->)).
+ rewrite Hm1,Hm2 in H.
+ destruct (merge_spec1 f' H) as (y2,(Hy2,->)).
+ rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y.
+- destruct (find y m2) as [e2|] eqn:H2.
+ + apply find_spec in H2.
+ assert (H : In y m1 \/ In y m2) by (right; now exists e2).
+ destruct (merge_spec1 f H) as (y1,(Hy1,->)).
+ rewrite Hm1,Hm2 in H.
+ destruct (merge_spec1 f' H) as (y2,(Hy2,->)).
+ rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y.
+ + apply not_in_find in H1. apply not_in_find in H2.
+ assert (H : ~In y (merge f m1 m2)).
+ { intro H. apply merge_spec2 in H. intuition. }
+ apply not_in_find in H. rewrite H.
+ symmetry. apply not_in_find. intro H'.
+ apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'.
+ intuition.
+Qed.
+
+(* Later: compatibility for cardinal, fold, ... *)
+
+(** ** Earlier specifications (cf. FMaps) *)
+
+Section OldSpecs.
+Variable elt: Type.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ now intros ->.
+Qed.
+
+Lemma find_1 m x e : MapsTo x e m -> find x m = Some e.
+Proof. apply find_spec. Qed.
+
+Lemma find_2 m x e : find x m = Some e -> MapsTo x e m.
+Proof. apply find_spec. Qed.
+
+Lemma mem_1 m x : In x m -> mem x m = true.
+Proof. apply mem_spec. Qed.
+
+Lemma mem_2 m x : mem x m = true -> In x m.
+Proof. apply mem_spec. Qed.
+
+Lemma empty_1 : Empty (@empty elt).
+Proof.
+ intros x e. now rewrite <- find_spec, empty_spec.
+Qed.
+
+Lemma is_empty_1 m : Empty m -> is_empty m = true.
+Proof.
+ unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec.
+ intros H x. specialize (H x).
+ destruct (find x m) as [e|]; trivial.
+ now destruct (H e).
+Qed.
+
+Lemma is_empty_2 m : is_empty m = true -> Empty m.
+Proof.
+ rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H.
+Qed.
+
+Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros <-. rewrite <-find_spec. apply add_spec1.
+Qed.
+
+Lemma add_2 m x y e e' :
+ ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intro. now rewrite <- !find_spec, add_spec2.
+Qed.
+
+Lemma add_3 m x y e e' :
+ ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intro. rewrite <- !find_spec, add_spec2; trivial.
+Qed.
+
+Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m).
+Proof.
+ intros <-. apply not_in_find. apply remove_spec1.
+Qed.
+
+Lemma remove_2 m x y e :
+ ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intro. now rewrite <- !find_spec, remove_spec2.
+Qed.
+
+Lemma remove_3bis m x y e :
+ find y (remove x m) = Some e -> find y m = Some e.
+Proof.
+ destruct (E.eq_dec x y) as [<-|H].
+ - now rewrite remove_spec1.
+ - now rewrite remove_spec2.
+Qed.
+
+Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ rewrite <-!find_spec. apply remove_3bis.
+Qed.
+
+Lemma bindings_1 m x e :
+ MapsTo x e m -> InA eq_key_elt (x,e) (bindings m).
+Proof. apply bindings_spec1. Qed.
+
+Lemma bindings_2 m x e :
+ InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m.
+Proof. apply bindings_spec1. Qed.
+
+Lemma bindings_3w m : NoDupA eq_key (bindings m).
+Proof. apply bindings_spec2w. Qed.
+
+Lemma cardinal_1 m : cardinal m = length (bindings m).
+Proof. apply cardinal_spec. Qed.
+
+Lemma fold_1 m (A : Type) (i : A) (f : key -> elt -> A -> A) :
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+Proof. apply fold_spec. Qed.
+
+Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true.
+Proof. apply equal_spec. Qed.
+
+Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'.
+Proof. apply equal_spec. Qed.
+
+End OldSpecs.
+
+Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') :
+ MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ rewrite <- !find_spec, map_spec. now intros ->.
+Qed.
+
+Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') :
+ In x (map f m) -> In x m.
+Proof.
+ rewrite !in_find, map_spec. apply option_map_some.
+Qed.
+
+Lemma mapi_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:key->elt->elt') :
+ MapsTo x e m ->
+ exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ destruct (mapi_spec f m x) as (y,(Hy,Eq)).
+ intro H. exists y; split; trivial.
+ rewrite <-find_spec in *. now rewrite Eq, H.
+Qed.
+
+Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') :
+ In x (mapi f m) -> In x m.
+Proof.
+ destruct (mapi_spec f m x) as (y,(Hy,Eq)).
+ rewrite !in_find. intro H; contradict H. now rewrite Eq, H.
+Qed.
+
+(** The ancestor [map2] of the current [merge] was dealing with functions
+ on datas only, not on keys. *)
+
+Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'')
+ := merge (fun _ => f).
+
+Lemma map2_1 {elt elt' elt''}(m: t elt)(m': t elt')
+ (x:key)(f:option elt->option elt'->option elt'') :
+ In x m \/ In x m' ->
+ find x (map2 f m m') = f (find x m) (find x m').
+Proof.
+ intros. unfold map2.
+ now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)).
+Qed.
+
+Lemma map2_2 {elt elt' elt''}(m: t elt)(m': t elt')
+ (x:key)(f:option elt->option elt'->option elt'') :
+ In x (map2 f m m') -> In x m \/ In x m'.
+Proof. apply merge_spec2. Qed.
+
+Hint Immediate MapsTo_1 mem_2 is_empty_2
+ map_2 mapi_2 add_3 remove_3 find_2 : map.
+Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
+ remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map.
+
+(** ** Specifications written using equivalences *)
+
+Section IffSpec.
+Variable elt: Type.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m).
+Proof. now intros ->. Qed.
+
+Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof. now intros ->. Qed.
+
+Lemma mem_in_iff m x : In x m <-> mem x m = true.
+Proof. symmetry. apply mem_spec. Qed.
+
+Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false.
+Proof.
+rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma mem_find m x : mem x m = true <-> find x m <> None.
+Proof.
+ rewrite <- mem_in_iff. apply in_find.
+Qed.
+
+Lemma not_mem_find m x : mem x m = false <-> find x m = None.
+Proof.
+ rewrite <- not_mem_in_iff. apply not_in_find.
+Qed.
+
+Lemma In_dec m x : { In x m } + { ~ In x m }.
+Proof.
+ generalize (mem_in_iff m x).
+ destruct (mem x m); [left|right]; intuition.
+Qed.
+
+Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e.
+Proof. symmetry. apply find_spec. Qed.
+
+Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true.
+Proof. symmetry. apply equal_spec. Qed.
+
+Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False.
+Proof.
+rewrite <- find_spec, empty_spec. now split.
+Qed.
+
+Lemma not_in_empty x : ~In x (@empty elt).
+Proof.
+intros (e,H). revert H. apply empty_mapsto_iff.
+Qed.
+
+Lemma empty_in_iff x : In x (@empty elt) <-> False.
+Proof.
+split; [ apply not_in_empty | destruct 1 ].
+Qed.
+
+Lemma is_empty_iff m : Empty m <-> is_empty m = true.
+Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed.
+
+Lemma add_mapsto_iff m x y e e' :
+ MapsTo y e' (add x e m) <->
+ (E.eq x y /\ e=e') \/
+ (~E.eq x y /\ MapsTo y e' m).
+Proof.
+split.
+- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial.
+ + symmetry. apply (mapsto_fun H); auto with map.
+ + now apply add_3 with x e.
+- destruct 1 as [(H,H')|(H,H')]; subst; auto with map.
+Qed.
+
+Lemma add_mapsto_new m x y e e' : ~In x m ->
+ MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m.
+Proof.
+ intros.
+ rewrite add_mapsto_iff. intuition.
+ right; split; trivial. contradict H. exists e'. now rewrite H.
+Qed.
+
+Lemma in_add m x y e : In y m -> In y (add x e m).
+Proof.
+ destruct (E.eq_dec x y) as [<-|H'].
+ - now rewrite !in_find, add_spec1.
+ - now rewrite !in_find, add_spec2.
+Qed.
+
+Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m.
+Proof.
+split.
+- intros H. destruct (E.eq_dec x y); [now left|right].
+ rewrite in_find, add_spec2 in H; trivial. now apply in_find.
+- intros [<-|H].
+ + exists e. now apply add_1.
+ + now apply in_add.
+Qed.
+
+Lemma add_neq_mapsto_iff m x y e e' :
+ ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff m x y e :
+ ~ E.eq x y -> (In y (add x e m) <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+- now apply add_3 with x e.
+- now apply add_2.
+Qed.
+
+Lemma remove_mapsto_iff m x y e :
+ MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof.
+split; [split|destruct 1].
+- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1.
+- now apply remove_3 with x.
+- now apply remove_2.
+Qed.
+
+Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof.
+unfold In; split; [ intros (e,H) | intros (E,(e,H)) ].
+- apply remove_mapsto_iff in H. destruct H; split; trivial.
+ now exists e.
+- exists e. now apply remove_2.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e,
+ ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y,
+ ~ E.eq x y -> (In y (remove x m) <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+- now apply remove_3 with x.
+- now apply remove_2.
+Qed.
+
+Lemma bindings_mapsto_iff m x e :
+ MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m).
+Proof. symmetry. apply bindings_spec1. Qed.
+
+Lemma bindings_in_iff m x :
+ In x m <-> exists e, InA eq_key_elt (x,e) (bindings m).
+Proof.
+unfold In; split; intros (e,H); exists e; now apply bindings_spec1.
+Qed.
+
+End IffSpec.
+
+Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') :
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec.
+destruct (find x m); simpl; split.
+- injection 1. now exists e.
+- intros (a,(->,H)). now injection H as ->.
+- discriminate.
+- intros (a,(_,H)); discriminate.
+Qed.
+
+Lemma map_in_iff {elt elt'} m x (f : elt -> elt') :
+ In x (map f m) <-> In x m.
+Proof.
+rewrite !in_find, map_spec. apply option_map_some.
+Qed.
+
+Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') :
+ In x (mapi f m) <-> In x m.
+Proof.
+rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)).
+apply option_map_some.
+Qed.
+
+(** Unfortunately, we don't have simple equivalences for [mapi]
+ and [MapsTo]. The only correct one needs compatibility of [f]. *)
+
+Lemma mapi_inv {elt elt'} m x b (f : key -> elt -> elt') :
+ MapsTo x b (mapi f m) ->
+ exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+rewrite <- find_spec. setoid_rewrite <- find_spec.
+destruct (mapi_spec f m x) as (y,(E,->)).
+destruct (find x m); simpl.
+- injection 1 as <-. now exists e, y.
+- discriminate.
+Qed.
+
+Lemma mapi_spec' {elt elt'} (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ forall m x,
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+ intros. destruct (mapi_spec f m x) as (y,(Hy,->)).
+ destruct (find x m); simpl; trivial.
+ now rewrite Hy.
+Qed.
+
+Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial.
+Qed.
+
+Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+rewrite <-find_spec. setoid_rewrite <-find_spec.
+intros Pr. rewrite mapi_spec' by trivial.
+destruct (find x m); simpl; split.
+- injection 1 as <-. now exists e.
+- intros (a,(->,H)). now injection H as <-.
+- discriminate.
+- intros (a,(_,H)). discriminate.
+Qed.
+
+(** Things are even worse for [merge] : we don't try to state any
+ equivalence, see instead boolean results below. *)
+
+(** Useful tactic for simplifying expressions like
+ [In y (add x e (remove z m))] *)
+
+Ltac map_iff :=
+ repeat (progress (
+ rewrite add_mapsto_iff || rewrite add_in_iff ||
+ rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+ rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+ rewrite map_mapsto_iff || rewrite map_in_iff ||
+ rewrite mapi_in_iff)).
+
+(** ** Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Lemma mem_find_b {elt}(m:t elt)(x:key) :
+ mem x m = if find x m then true else false.
+Proof.
+apply eq_bool_alt. rewrite mem_find. destruct (find x m).
+- now split.
+- split; (discriminate || now destruct 1).
+Qed.
+
+Variable elt elt' elt'' : Type.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b m x y : E.eq x y -> mem x m = mem y m.
+Proof. now intros ->. Qed.
+
+Lemma find_o m x y : E.eq x y -> find x m = find y m.
+Proof. now intros ->. Qed.
+
+Lemma empty_o x : find x (@empty elt) = None.
+Proof. apply empty_spec. Qed.
+
+Lemma empty_a x : mem x (@empty elt) = false.
+Proof. apply not_mem_find. apply empty_spec. Qed.
+
+Lemma add_eq_o m x y e :
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+ intros <-. apply add_spec1.
+Qed.
+
+Lemma add_neq_o m x y e :
+ ~ E.eq x y -> find y (add x e m) = find y m.
+Proof. apply add_spec2. Qed.
+Hint Resolve add_neq_o : map.
+
+Lemma add_o m x y e :
+ find y (add x e m) = if E.eq_dec x y then Some e else find y m.
+Proof.
+destruct (E.eq_dec x y); auto with map.
+Qed.
+
+Lemma add_eq_b m x y e :
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros <-. apply mem_spec, add_in_iff. now left.
+Qed.
+
+Lemma add_neq_b m x y e :
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros. now rewrite !mem_find_b, add_neq_o.
+Qed.
+
+Lemma add_b m x y e :
+ mem y (add x e m) = eqb x y || mem y m.
+Proof.
+rewrite !mem_find_b, add_o. unfold eqb.
+now destruct (E.eq_dec x y).
+Qed.
+
+Lemma remove_eq_o m x y :
+ E.eq x y -> find y (remove x m) = None.
+Proof. intros ->. apply remove_spec1. Qed.
+
+Lemma remove_neq_o m x y :
+ ~ E.eq x y -> find y (remove x m) = find y m.
+Proof. apply remove_spec2. Qed.
+
+Hint Resolve remove_eq_o remove_neq_o : map.
+
+Lemma remove_o m x y :
+ find y (remove x m) = if E.eq_dec x y then None else find y m.
+Proof.
+destruct (E.eq_dec x y); auto with map.
+Qed.
+
+Lemma remove_eq_b m x y :
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros <-. now rewrite mem_find_b, remove_eq_o.
+Qed.
+
+Lemma remove_neq_b m x y :
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros. now rewrite !mem_find_b, remove_neq_o.
+Qed.
+
+Lemma remove_b m x y :
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+rewrite !mem_find_b, remove_o; unfold eqb.
+now destruct (E.eq_dec x y).
+Qed.
+
+Lemma map_o m x (f:elt->elt') :
+ find x (map f m) = option_map f (find x m).
+Proof. apply map_spec. Qed.
+
+Lemma map_b m x (f:elt->elt') :
+ mem x (map f m) = mem x m.
+Proof.
+rewrite !mem_find_b, map_o. now destruct (find x m).
+Qed.
+
+Lemma mapi_b m x (f:key->elt->elt') :
+ mem x (mapi f m) = mem x m.
+Proof.
+apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff.
+Qed.
+
+Lemma mapi_o m x (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof. intros; now apply mapi_spec'. Qed.
+
+Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f ->
+ forall (m:t elt)(m':t elt') x,
+ In x m \/ In x m' ->
+ find x (merge f m m') = f x (find x m) (find x m').
+Proof.
+ intros Hf m m' x H.
+ now destruct (merge_spec1 f H) as (y,(->,->)).
+Qed.
+
+Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') :
+ (forall x, f x None None = None) ->
+ forall (m: t elt)(m': t elt') x,
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+Proof.
+intros Hf m m' x.
+destruct (find x m) as [e|] eqn:Hm.
+- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec).
+ destruct (merge_spec1 f H) as (y,(Hy,->)).
+ exists y; split; trivial. now rewrite Hm.
+- destruct (find x m') as [e|] eqn:Hm'.
+ + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec).
+ destruct (merge_spec1 f H) as (y,(Hy,->)).
+ exists y; split; trivial. now rewrite Hm, Hm'.
+ + exists x. split. reflexivity. rewrite Hf.
+ apply not_in_find. intro H.
+ apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'.
+ intuition.
+Qed.
+
+Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f ->
+ (forall x, f x None None = None) ->
+ forall (m: t elt)(m': t elt') x,
+ find x (merge f m m') = f x (find x m) (find x m').
+Proof.
+ intros Hf Hf' m m' x.
+ now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)).
+Qed.
+
+Lemma bindings_o : forall m x,
+ find x m = findA (eqb x) (bindings m).
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, bindings_mapsto_iff.
+unfold eqb.
+rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto.
+Qed.
+
+Lemma bindings_b : forall m x,
+ mem x m = existsb (fun p => eqb x (fst p)) (bindings m).
+Proof.
+intros.
+apply eq_bool_alt.
+rewrite mem_spec, bindings_in_iff, existsb_exists.
+split.
+- intros (e,H).
+ rewrite InA_alt in H.
+ destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'.
+ exists (k, e); split; trivial. simpl. now apply eqb_eq.
+- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'.
+ exists e. rewrite InA_alt. exists (k,e). now repeat split.
+Qed.
+
+End BoolSpec.
+
+Section Equalities.
+Variable elt:Type.
+
+(** A few basic equalities *)
+
+Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true.
+Proof.
+ unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec.
+Qed.
+
+Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e.
+Proof.
+ split.
+ - intros H. rewrite <- (H x). apply add_spec1.
+ - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E].
+Qed.
+
+Lemma add_add_1 (m: t elt) x e :
+ add x e (add x e m) == add x e m.
+Proof.
+ intros y. rewrite !add_o. destruct E.eq_dec; auto.
+Qed.
+
+Lemma add_add_2 (m: t elt) x x' e e' :
+ ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m).
+Proof.
+ intros H y. rewrite !add_o.
+ do 2 destruct E.eq_dec; auto.
+ elim H. now transitivity y.
+Qed.
+
+Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m.
+Proof.
+ rewrite not_in_find. split.
+ - intros H. rewrite <- (H x). apply remove_spec1.
+ - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E].
+Qed.
+
+Lemma remove_remove_1 (m: t elt) x :
+ remove x (remove x m) == remove x m.
+Proof.
+ intros y. rewrite !remove_o. destruct E.eq_dec; auto.
+Qed.
+
+Lemma remove_remove_2 (m: t elt) x x' :
+ remove x (remove x' m) == remove x' (remove x m).
+Proof.
+ intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto.
+Qed.
+
+Lemma remove_add_1 (m: t elt) x e :
+ remove x (add x e m) == remove x m.
+Proof.
+ intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec.
+Qed.
+
+Lemma remove_add_2 (m: t elt) x x' e :
+ ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m).
+Proof.
+ intros H y. rewrite !remove_o, !add_o.
+ do 2 destruct E.eq_dec; auto.
+ - elim H; now transitivity y.
+ - symmetry. now apply remove_eq_o.
+ - symmetry. now apply remove_neq_o.
+Qed.
+
+Lemma add_remove_1 (m: t elt) x e :
+ add x e (remove x m) == add x e m.
+Proof.
+ intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec.
+Qed.
+
+(** Another characterisation of [Equal] *)
+
+Lemma Equal_mapsto_iff : forall m1 m2 : t elt,
+ m1 == m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2).
+Proof.
+intros m1 m2. split; [intros Heq k e|intros Hiff].
+rewrite 2 find_mapsto_iff, Heq. split; auto.
+intro k. rewrite eq_option_alt. intro e.
+rewrite <- 2 find_mapsto_iff; auto.
+Qed.
+
+(** * Relations between [Equal], [Equiv] and [Equivb]. *)
+
+(** First, [Equal] is [Equiv] with Leibniz on elements. *)
+
+Lemma Equal_Equiv : forall (m m' : t elt),
+ m == m' <-> Equiv Logic.eq m m'.
+Proof.
+intros. rewrite Equal_mapsto_iff. split; intros.
+- split.
+ + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto.
+ + intros; apply mapsto_fun with m k; auto; rewrite H; auto.
+- split; intros H'.
+ + destruct H.
+ assert (Hin : In k m') by (rewrite <- H; exists e; auto).
+ destruct Hin as (e',He').
+ rewrite (H0 k e e'); auto.
+ + destruct H.
+ assert (Hin : In k m) by (rewrite H; exists e; auto).
+ destruct Hin as (e',He').
+ rewrite <- (H0 k e' e); auto.
+Qed.
+
+(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp]
+ are related. *)
+
+Section Cmp.
+Variable eq_elt : elt->elt->Prop.
+Variable cmp : elt->elt->bool.
+
+Definition compat_cmp :=
+ forall e e', cmp e e' = true <-> eq_elt e e'.
+
+Lemma Equiv_Equivb : compat_cmp ->
+ forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'.
+Proof.
+ unfold Equivb, Equiv, Cmp; intuition.
+ red in H; rewrite H; eauto.
+ red in H; rewrite <-H; eauto.
+Qed.
+End Cmp.
+
+(** Composition of the two last results: relation between [Equal]
+ and [Equivb]. *)
+
+Lemma Equal_Equivb : forall cmp,
+ (forall e e', cmp e e' = true <-> e = e') ->
+ forall (m m':t elt), m == m' <-> Equivb cmp m m'.
+Proof.
+ intros; rewrite Equal_Equiv.
+ apply Equiv_Equivb; auto.
+Qed.
+
+Lemma Equal_Equivb_eqdec :
+ forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }),
+ let cmp := fun e e' => if eq_elt_dec e e' then true else false in
+ forall (m m':t elt), m == m' <-> Equivb cmp m m'.
+Proof.
+intros; apply Equal_Equivb.
+unfold cmp; clear cmp; intros.
+destruct eq_elt_dec; now intuition.
+Qed.
+
+End Equalities.
+
+(** * Results about [fold], [bindings], induction principles... *)
+
+Section Elt.
+ Variable elt:Type.
+
+ Definition Add x (e:elt) m m' := m' == (add x e m).
+
+ Notation eqke := (@eq_key_elt elt).
+ Notation eqk := (@eq_key elt).
+
+ Instance eqk_equiv : Equivalence eqk.
+ Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed.
+
+ Instance eqke_equiv : Equivalence eqke.
+ Proof.
+ unfold eq_key_elt; split; repeat red; intuition; simpl in *;
+ etransitivity; eauto.
+ Qed.
+
+ (** Complements about InA, NoDupA and findA *)
+
+ Lemma InA_eqke_eqk k k' e e' l :
+ E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l.
+ Proof.
+ intros Hk. rewrite 2 InA_alt.
+ intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''.
+ exists (k'',e); split; auto. red; simpl. now transitivity k.
+ Qed.
+
+ Lemma NoDupA_incl {A} (R R':relation A) :
+ (forall x y, R x y -> R' x y) ->
+ forall l, NoDupA R' l -> NoDupA R l.
+ Proof.
+ intros Incl.
+ induction 1 as [ | a l E _ IH ]; constructor; auto.
+ contradict E. revert E. rewrite 2 InA_alt. firstorder.
+ Qed.
+
+ Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l.
+ Proof.
+ apply NoDupA_incl. now destruct 1.
+ Qed.
+
+ Lemma findA_rev l k : NoDupA eqk l ->
+ findA (eqb k) l = findA (eqb k) (rev l).
+ Proof.
+ intros H. apply eq_option_alt. intros e. unfold eqb.
+ rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity.
+ change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv.
+ Qed.
+
+ (** * Bindings *)
+
+ Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil.
+ Proof.
+ unfold Empty. split; intros H.
+ - assert (H' : forall a, ~ List.In a (bindings m)).
+ { intros (k,e) H'. apply (H k e).
+ rewrite bindings_mapsto_iff, InA_alt.
+ exists (k,e); repeat split; auto with map. }
+ destruct (bindings m) as [|p l]; trivial.
+ destruct (H' p); simpl; auto.
+ - intros x e. rewrite bindings_mapsto_iff, InA_alt.
+ rewrite H. now intros (y,(E,H')).
+ Qed.
+
+ Lemma bindings_empty : bindings (@empty elt) = nil.
+ Proof.
+ rewrite <-bindings_Empty; apply empty_1.
+ Qed.
+
+ (** * Conversions between maps and association lists. *)
+
+ Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W :=
+ fun p => f (fst p) (snd p).
+
+ Definition of_list :=
+ List.fold_right (uncurry (@add _)) (@empty elt).
+
+ Definition to_list := bindings.
+
+ Lemma of_list_1 : forall l k e,
+ NoDupA eqk l ->
+ (MapsTo k e (of_list l) <-> InA eqke (k,e) l).
+ Proof.
+ induction l as [|(k',e') l IH]; simpl; intros k e Hnodup.
+ - rewrite empty_mapsto_iff, InA_nil; intuition.
+ - unfold uncurry; simpl.
+ inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
+ specialize (IH k e Hnodup'); clear Hnodup'.
+ rewrite add_mapsto_iff, InA_cons, <- IH.
+ unfold eq_key_elt at 1; simpl.
+ split; destruct 1 as [H|H]; try (intuition;fail).
+ destruct (E.eq_dec k k'); [left|right]; split; auto with map.
+ contradict Hnotin.
+ apply InA_eqke_eqk with k e; intuition.
+ Qed.
+
+ Lemma of_list_1b : forall l k,
+ NoDupA eqk l ->
+ find k (of_list l) = findA (eqb k) l.
+ Proof.
+ induction l as [|(k',e') l IH]; simpl; intros k Hnodup.
+ apply empty_o.
+ unfold uncurry; simpl.
+ inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
+ specialize (IH k Hnodup'); clear Hnodup'.
+ rewrite add_o, IH, eqb_sym. unfold eqb; now destruct E.eq_dec.
+ Qed.
+
+ Lemma of_list_2 : forall l, NoDupA eqk l ->
+ equivlistA eqke l (to_list (of_list l)).
+ Proof.
+ intros l Hnodup (k,e).
+ rewrite <- bindings_mapsto_iff, of_list_1; intuition.
+ Qed.
+
+ Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s.
+ Proof.
+ intros s k.
+ rewrite of_list_1b, bindings_o; auto.
+ apply bindings_3w.
+ Qed.
+
+ (** * Fold *)
+
+ (** Alternative specification via [fold_right] *)
+
+ Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) :
+ fold f m i = List.fold_right (uncurry f) i (rev (bindings m)).
+ Proof.
+ rewrite fold_1. symmetry. apply fold_left_rev_right.
+ Qed.
+
+ (** ** Induction principles about fold contributed by S. Lescuyer *)
+
+ (** In the following lemma, the step hypothesis is deliberately restricted
+ to the precise map m we are considering. *)
+
+ Lemma fold_rec :
+ forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A),
+ forall (i:A)(m:t elt),
+ (forall m, Empty m -> P m i) ->
+ (forall k e a m' m'', MapsTo k e m -> ~In k m' ->
+ Add k e m' m'' -> P m' a -> P m'' (f k e a)) ->
+ P m (fold f m i).
+ Proof.
+ intros A P f i m Hempty Hstep.
+ rewrite fold_spec_right.
+ set (F:=uncurry f).
+ set (l:=rev (bindings m)).
+ assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' ->
+ Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)).
+ {
+ intros k e a m' m'' H ? ? ?; eapply Hstep; eauto.
+ revert H; unfold l; rewrite InA_rev, bindings_mapsto_iff; auto with *. }
+ assert (Hdup : NoDupA eqk l).
+ { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *.
+ apply bindings_3w. }
+ assert (Hsame : forall k, find k m = findA (eqb k) l).
+ { intros k. unfold l. rewrite bindings_o, findA_rev; auto.
+ apply bindings_3w. }
+ clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l.
+ - (* empty *)
+ intros m Hsame; simpl.
+ apply Hempty. intros k e.
+ rewrite find_mapsto_iff, Hsame; simpl; discriminate.
+ - (* step *)
+ intros m Hsame; destruct a as (k,e); simpl.
+ apply Hstep' with (of_list l); auto.
+ + rewrite InA_cons; left; red; auto with map.
+ + inversion_clear Hdup. contradict H. destruct H as (e',He').
+ apply InA_eqke_eqk with k e'; auto with map.
+ rewrite <- of_list_1; auto.
+ + intro k'. rewrite Hsame, add_o, of_list_1b. simpl.
+ rewrite eqb_sym. unfold eqb. now destruct E.eq_dec.
+ inversion_clear Hdup; auto with map.
+ + apply IHl.
+ * intros; eapply Hstep'; eauto.
+ * inversion_clear Hdup; auto.
+ * intros; apply of_list_1b. inversion_clear Hdup; auto.
+ Qed.
+
+ (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
+ case, [P] must be compatible with equality of sets *)
+
+ Theorem fold_rec_bis :
+ forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A),
+ forall (i:A)(m:t elt),
+ (forall m m' a, Equal m m' -> P m a -> P m' a) ->
+ (P empty i) ->
+ (forall k e a m', MapsTo k e m -> ~In k m' ->
+ P m' a -> P (add k e m') (f k e a)) ->
+ P m (fold f m i).
+ Proof.
+ intros A P f i m Pmorphism Pempty Pstep.
+ apply fold_rec; intros.
+ apply Pmorphism with empty; auto. intro k. rewrite empty_o.
+ case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff.
+ intro H'; elim (H k e'); auto.
+ apply Pmorphism with (add k e m'); try intro; auto.
+ Qed.
+
+ Lemma fold_rec_nodep :
+ forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt),
+ P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) ->
+ P (fold f m i).
+ Proof.
+ intros; apply fold_rec_bis with (P:=fun _ => P); auto.
+ Qed.
+
+ (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
+ the step hypothesis must here be applicable anywhere.
+ At the same time, it looks more like an induction principle,
+ and hence can be easier to use. *)
+
+ Lemma fold_rec_weak :
+ forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A),
+ (forall m m' a, Equal m m' -> P m a -> P m' a) ->
+ P empty i ->
+ (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) ->
+ forall m, P m (fold f m i).
+ Proof.
+ intros; apply fold_rec_bis; auto.
+ Qed.
+
+ Lemma fold_rel :
+ forall (A B:Type)(R : A -> B -> Type)
+ (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B)
+ (m : t elt),
+ R i j ->
+ (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) ->
+ R (fold f m i) (fold g m j).
+ Proof.
+ intros A B R f g i j m Rempty Rstep.
+ rewrite 2 fold_spec_right. set (l:=rev (bindings m)).
+ assert (Rstep' : forall k e a b, InA eqke (k,e) l ->
+ R a b -> R (f k e a) (g k e b)).
+ { intros; apply Rstep; auto.
+ rewrite bindings_mapsto_iff, <- InA_rev; auto with map. }
+ clearbody l; clear Rstep m.
+ induction l; simpl; auto.
+ apply Rstep'; auto.
+ destruct a; simpl; rewrite InA_cons; left; red; auto with map.
+ Qed.
+
+ (** From the induction principle on [fold], we can deduce some general
+ induction principles on maps. *)
+
+ Lemma map_induction :
+ forall P : t elt -> Type,
+ (forall m, Empty m -> P m) ->
+ (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') ->
+ forall m, P m.
+ Proof.
+ intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto.
+ Qed.
+
+ Lemma map_induction_bis :
+ forall P : t elt -> Type,
+ (forall m m', Equal m m' -> P m -> P m') ->
+ P empty ->
+ (forall x e m, ~In x m -> P m -> P (add x e m)) ->
+ forall m, P m.
+ Proof.
+ intros.
+ apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto.
+ Qed.
+
+ (** [fold] can be used to reconstruct the same initial set. *)
+
+ Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m empty) m.
+ Proof.
+ intros.
+ apply fold_rec with (P:=fun m acc => Equal acc m); auto with map.
+ intros m' Heq k'.
+ rewrite empty_o.
+ case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff.
+ intro; elim (Heq k' e'); auto.
+ intros k e a m' m'' _ _ Hadd Heq k'.
+ red in Heq. rewrite Hadd, 2 add_o, Heq; auto.
+ Qed.
+
+ Section Fold_More.
+
+ (** ** Additional properties of fold *)
+
+ (** When a function [f] is compatible and allows transpositions, we can
+ compute [fold f] in any order. *)
+
+ Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+
+ Lemma fold_Empty (f:key->elt->A->A) :
+ forall m i, Empty m -> eqA (fold f m i) i.
+ Proof.
+ intros. apply fold_rec_nodep with (P:=fun a => eqA a i).
+ reflexivity.
+ intros. elim (H k e); auto.
+ Qed.
+
+ Lemma fold_init (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i').
+ Proof.
+ intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto.
+ intros. now apply Hf.
+ Qed.
+
+ (** Transpositions of f (a.k.a diamond property).
+ Could we swap two sequential calls to f, i.e. do we have:
+
+ f k e (f k' e' a) == f k' e' (f k e a)
+
+ First, we do no need this equation for all keys, but only
+ when k and k' aren't equal, as suggested by Pierre Castéran.
+ Think for instance of [f] being [M.add] : in general, we don't have
+ [M.add k e (M.add k e' m) == M.add k e' (M.add k e m)].
+ Fortunately, we will never encounter this situation during a real
+ [fold], since the keys received by this [fold] are unique.
+ NB: without this condition, this condition would be
+ [SetoidList.transpose2].
+
+ Secondly, instead of the equation above, we now use a statement
+ with more basic equalities, allowing to prove [fold_commutes] even
+ when [f] isn't a morphism.
+ NB: When [f] is a morphism, [Diamond f] gives back the equation above.
+*)
+
+ Definition Diamond (f:key->elt->A->A) :=
+ forall k k' e e' a b b', ~E.eq k k' ->
+ eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b).
+
+ Lemma fold_commutes (f:key->elt->A->A) :
+ Diamond f ->
+ forall i m k e, ~In k m ->
+ eqA (fold f m (f k e i)) (f k e (fold f m i)).
+ Proof.
+ intros Hf i m k e H.
+ apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto.
+ - reflexivity.
+ - intros k' e' b a Hm E.
+ apply Hf with a; try easy.
+ contradict H; rewrite <- H. now exists e'.
+ Qed.
+
+ Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map.
+
+ Lemma fold_Proper (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ Proper (Equal==>eqA==>eqA) (fold f).
+ Proof.
+ intros Hf Hf' m1 m2 Hm i j Hi.
+ rewrite 2 fold_spec_right.
+ assert (NoDupA eqk (rev (bindings m1))) by (auto with * ).
+ assert (NoDupA eqk (rev (bindings m2))) by (auto with * ).
+ apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke)
+ ; auto with *.
+ - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *. now apply Hf.
+ - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map.
+ - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto.
+ rewrite h'. eapply Hf'; now eauto.
+ - rewrite <- NoDupA_altdef; auto.
+ - intros (k,e).
+ rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm;
+ auto with *.
+ Qed.
+
+ Lemma fold_Equal (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ forall m1 m2 i,
+ Equal m1 m2 ->
+ eqA (fold f m1 i) (fold f m2 i).
+ Proof.
+ intros. now apply fold_Proper.
+ Qed.
+
+ Lemma fold_Add (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 ->
+ eqA (fold f m2 i) (f k e (fold f m1 i)).
+ Proof.
+ intros Hf Hf' m1 m2 k e i Hm1 Hm2.
+ rewrite 2 fold_spec_right.
+ set (f':=uncurry f).
+ change (f k e (fold_right f' i (rev (bindings m1))))
+ with (f' (k,e) (fold_right f' i (rev (bindings m1)))).
+ assert (NoDupA eqk (rev (bindings m1))) by (auto with * ).
+ assert (NoDupA eqk (rev (bindings m2))) by (auto with * ).
+ apply fold_right_add_restr with
+ (R:=complement eqk)(eqA:=eqke); auto with *.
+ - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf.
+ - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map.
+ - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl.
+ eapply Hf'; now eauto.
+ - rewrite <- NoDupA_altdef; auto.
+ - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder.
+ - intros (a,b).
+ rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff,
+ 2 find_mapsto_iff by (auto with * ).
+ unfold eq_key_elt; simpl.
+ rewrite Hm2, !find_spec, add_mapsto_new; intuition.
+ Qed.
+
+ Lemma fold_add (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ forall m k e i, ~In k m ->
+ eqA (fold f (add k e m) i) (f k e (fold f m i)).
+ Proof.
+ intros. now apply fold_Add.
+ Qed.
+
+ End Fold_More.
+
+ (** * Cardinal *)
+
+ Lemma cardinal_fold (m : t elt) :
+ cardinal m = fold (fun _ _ => S) m 0.
+ Proof.
+ rewrite cardinal_1, fold_1.
+ symmetry; apply fold_left_length; auto.
+ Qed.
+
+ Lemma cardinal_Empty : forall m : t elt,
+ Empty m <-> cardinal m = 0.
+ Proof.
+ intros.
+ rewrite cardinal_1, bindings_Empty.
+ destruct (bindings m); intuition; discriminate.
+ Qed.
+
+ Lemma Equal_cardinal (m m' : t elt) :
+ Equal m m' -> cardinal m = cardinal m'.
+ Proof.
+ intro. rewrite 2 cardinal_fold.
+ apply fold_Equal with (eqA:=eq); try congruence; auto with map.
+ Qed.
+
+ Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0.
+ Proof.
+ intros; rewrite <- cardinal_Empty; auto.
+ Qed.
+
+ Lemma cardinal_S m m' x e :
+ ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m).
+ Proof.
+ intros. rewrite 2 cardinal_fold.
+ change S with ((fun _ _ => S) x e).
+ apply fold_Add with (eqA:=eq); try congruence; auto with map.
+ Qed.
+
+ Lemma cardinal_inv_1 : forall m : t elt,
+ cardinal m = 0 -> Empty m.
+ Proof.
+ intros; rewrite cardinal_Empty; auto.
+ Qed.
+ Hint Resolve cardinal_inv_1 : map.
+
+ Lemma cardinal_inv_2 :
+ forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+ Proof.
+ intros; rewrite M.cardinal_spec in *.
+ generalize (bindings_mapsto_iff m).
+ destruct (bindings m); try discriminate.
+ exists p; auto.
+ rewrite H0; destruct p; simpl; auto.
+ constructor; red; auto with map.
+ Qed.
+
+ Lemma cardinal_inv_2b :
+ forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+ Proof.
+ intros.
+ generalize (@cardinal_inv_2 m); destruct cardinal.
+ elim H;auto.
+ eauto.
+ Qed.
+
+ Lemma not_empty_mapsto (m : t elt) :
+ ~Empty m -> exists k e, MapsTo k e m.
+ Proof.
+ intro.
+ destruct (@cardinal_inv_2b m) as ((k,e),H').
+ contradict H. now apply cardinal_inv_1.
+ exists k; now exists e.
+ Qed.
+
+ Lemma not_empty_in (m:t elt) :
+ ~Empty m -> exists k, In k m.
+ Proof.
+ intro. destruct (not_empty_mapsto H) as (k,Hk).
+ now exists k.
+ Qed.
+
+ (** * Additional notions over maps *)
+
+ Definition Disjoint (m m' : t elt) :=
+ forall k, ~(In k m /\ In k m').
+
+ Definition Partition (m m1 m2 : t elt) :=
+ Disjoint m1 m2 /\
+ (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2).
+
+ (** * Emulation of some functions lacking in the interface *)
+
+ Definition filter (f : key -> elt -> bool)(m : t elt) :=
+ fold (fun k e m => if f k e then add k e m else m) m empty.
+
+ Definition for_all (f : key -> elt -> bool)(m : t elt) :=
+ fold (fun k e b => if f k e then b else false) m true.
+
+ Definition exists_ (f : key -> elt -> bool)(m : t elt) :=
+ fold (fun k e b => if f k e then true else b) m false.
+
+ Definition partition (f : key -> elt -> bool)(m : t elt) :=
+ (filter f m, filter (fun k e => negb (f k e)) m).
+
+ (** [update] adds to [m1] all the bindings of [m2]. It can be seen as
+ an [union] operator which gives priority to its 2nd argument
+ in case of binding conflit. *)
+
+ Definition update (m1 m2 : t elt) := fold (@add _) m2 m1.
+
+ (** [restrict] keeps from [m1] only the bindings whose key is in [m2].
+ It can be seen as an [inter] operator, with priority to its 1st argument
+ in case of binding conflit. *)
+
+ Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1.
+
+ (** [diff] erases from [m1] all bindings whose key is in [m2]. *)
+
+ Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1.
+
+ (** Properties of these abbreviations *)
+
+ Lemma filter_iff (f : key -> elt -> bool) :
+ Proper (E.eq==>eq==>eq) f ->
+ forall m k e,
+ MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true.
+ Proof.
+ unfold filter.
+ set (f':=fun k e m => if f k e then add k e m else m).
+ intros Hf m. pattern m, (fold f' m empty). apply fold_rec.
+
+ - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition.
+ elim (Hm' k e); auto.
+
+ - intros k e acc m1 m2 Hke Hn Hadd IH k' e'.
+ change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd.
+ unfold f'; simpl.
+ rewrite add_mapsto_new by trivial.
+ case_eq (f k e); intros Hfke; simpl;
+ rewrite ?add_mapsto_iff, IH; clear IH; intuition.
+ + rewrite <- Hfke; apply Hf; auto with map.
+ + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'.
+ + assert (f k e = f k' e') by (apply Hf; auto). congruence.
+ Qed.
+
+ Lemma for_all_filter f m :
+ for_all f m = is_empty (filter (fun k e => negb (f k e)) m).
+ Proof.
+ unfold for_all, filter.
+ eapply fold_rel with (R:=fun x y => x = is_empty y).
+ - symmetry. apply is_empty_iff. apply empty_1.
+ - intros; subst. destruct (f k e); simpl; trivial.
+ symmetry. apply not_true_is_false. rewrite is_empty_spec.
+ intros H'. specialize (H' k). now rewrite add_spec1 in H'.
+ Qed.
+
+ Lemma exists_filter f m :
+ exists_ f m = negb (is_empty (filter f m)).
+ Proof.
+ unfold for_all, filter.
+ eapply fold_rel with (R:=fun x y => x = negb (is_empty y)).
+ - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1.
+ - intros; subst. destruct (f k e); simpl; trivial.
+ symmetry. rewrite negb_true_iff. apply not_true_is_false.
+ rewrite is_empty_spec.
+ intros H'. specialize (H' k). now rewrite add_spec1 in H'.
+ Qed.
+
+ Lemma for_all_iff f m :
+ Proper (E.eq==>eq==>eq) f ->
+ (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)).
+ Proof.
+ intros Hf.
+ rewrite for_all_filter.
+ rewrite <- is_empty_iff. unfold Empty.
+ split; intros H k e; specialize (H k e);
+ rewrite filter_iff in * by solve_proper; intuition.
+ - destruct (f k e); auto.
+ - now rewrite H0 in H2.
+ Qed.
+
+ Lemma exists_iff f m :
+ Proper (E.eq==>eq==>eq) f ->
+ (exists_ f m = true <->
+ (exists k e, MapsTo k e m /\ f k e = true)).
+ Proof.
+ intros Hf.
+ rewrite exists_filter. rewrite negb_true_iff.
+ rewrite <- not_true_iff_false, <- is_empty_iff.
+ split.
+ - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H.
+ - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder.
+ Qed.
+
+ Lemma Disjoint_alt : forall m m',
+ Disjoint m m' <->
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False).
+ Proof.
+ unfold Disjoint; split.
+ intros H k v v' H1 H2.
+ apply H with k; split.
+ exists v; trivial.
+ exists v'; trivial.
+ intros H k ((v,Hv),(v',Hv')).
+ eapply H; eauto.
+ Qed.
+
+ Section Partition.
+ Variable f : key -> elt -> bool.
+ Hypothesis Hf : Proper (E.eq==>eq==>eq) f.
+
+ Lemma partition_iff_1 : forall m m1 k e,
+ m1 = fst (partition f m) ->
+ (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true).
+ Proof.
+ unfold partition; simpl; intros. subst m1.
+ apply filter_iff; auto.
+ Qed.
+
+ Lemma partition_iff_2 : forall m m2 k e,
+ m2 = snd (partition f m) ->
+ (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false).
+ Proof.
+ unfold partition; simpl; intros. subst m2.
+ rewrite filter_iff.
+ split; intros (H,H'); split; auto.
+ destruct (f k e); simpl in *; auto.
+ rewrite H'; auto.
+ repeat red; intros. f_equal. apply Hf; auto.
+ Qed.
+
+ Lemma partition_Partition : forall m m1 m2,
+ partition f m = (m1,m2) -> Partition m m1 m2.
+ Proof.
+ intros. split.
+ rewrite Disjoint_alt. intros k e e'.
+ rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2)
+ by (rewrite H; auto).
+ intros (U,V) (W,Z). rewrite <- (mapsto_fun U W) in Z; congruence.
+ intros k e.
+ rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2)
+ by (rewrite H; auto).
+ destruct (f k e); intuition.
+ Qed.
+
+ End Partition.
+
+ Lemma Partition_In : forall m m1 m2 k,
+ Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}.
+ Proof.
+ intros m m1 m2 k Hm Hk.
+ destruct (In_dec m1 k) as [H|H]; [left|right]; auto.
+ destruct Hm as (Hm,Hm').
+ destruct Hk as (e,He); rewrite Hm' in He; destruct He.
+ elim H; exists e; auto.
+ exists e; auto.
+ Defined.
+
+ Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1.
+ Proof.
+ intros m1 m2 H k (H1,H2). elim (H k); auto.
+ Qed.
+
+ Lemma Partition_sym : forall m m1 m2,
+ Partition m m1 m2 -> Partition m m2 m1.
+ Proof.
+ intros m m1 m2 (H,H'); split.
+ apply Disjoint_sym; auto.
+ intros; rewrite H'; intuition.
+ Qed.
+
+ Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 ->
+ (Empty m <-> (Empty m1 /\ Empty m2)).
+ Proof.
+ intros m m1 m2 (Hdisj,Heq). split.
+ intro He.
+ split; intros k e Hke; elim (He k e); rewrite Heq; auto.
+ intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke.
+ elim (He1 k e); auto.
+ elim (He2 k e); auto.
+ Qed.
+
+ Lemma Partition_Add :
+ forall m m' x e , ~In x m -> Add x e m m' ->
+ forall m1 m2, Partition m' m1 m2 ->
+ exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/
+ Add x e m3 m2 /\ Partition m m1 m3).
+ Proof.
+ unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor).
+ assert (Heq : Equal m (remove x m')).
+ { change (Equal m' (add x e m)) in Hadd. rewrite Hadd.
+ intro k. rewrite remove_o, add_o.
+ destruct E.eq_dec as [He|Hne]; auto.
+ rewrite <- He, <- not_find_in_iff; auto. }
+ assert (H : MapsTo x e m').
+ { change (Equal m' (add x e m)) in Hadd; rewrite Hadd.
+ apply add_1; auto with map. }
+ rewrite Hor in H; destruct H.
+
+ - (* first case : x in m1 *)
+ exists (remove x m1); left. split; [|split].
+ + (* add *)
+ change (Equal m1 (add x e (remove x m1))).
+ intro k.
+ rewrite add_o, remove_o.
+ destruct E.eq_dec as [He|Hne]; auto.
+ rewrite <- He; apply find_1; auto.
+ + (* disjoint *)
+ intros k (H1,H2). elim (Hdisj k). split; auto.
+ rewrite remove_in_iff in H1; destruct H1; auto.
+ + (* mapsto *)
+ intros k' e'.
+ rewrite Heq, 2 remove_mapsto_iff, Hor.
+ intuition.
+ elim (Hdisj x); split; [exists e|exists e']; auto.
+ apply MapsTo_1 with k'; auto with map.
+
+ - (* second case : x in m2 *)
+ exists (remove x m2); right. split; [|split].
+ + (* add *)
+ change (Equal m2 (add x e (remove x m2))).
+ intro k.
+ rewrite add_o, remove_o.
+ destruct E.eq_dec as [He|Hne]; auto.
+ rewrite <- He; apply find_1; auto.
+ + (* disjoint *)
+ intros k (H1,H2). elim (Hdisj k). split; auto.
+ rewrite remove_in_iff in H2; destruct H2; auto.
+ + (* mapsto *)
+ intros k' e'.
+ rewrite Heq, 2 remove_mapsto_iff, Hor.
+ intuition.
+ elim (Hdisj x); split; [exists e'|exists e]; auto.
+ apply MapsTo_1 with k'; auto with map.
+ Qed.
+
+ Lemma Partition_fold :
+ forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A),
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond eqA f ->
+ forall m m1 m2 i,
+ Partition m m1 m2 ->
+ eqA (fold f m i) (fold f m1 (fold f m2 i)).
+ Proof.
+ intros A eqA st f Comp Tra.
+ induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction.
+
+ - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto.
+ rewrite (Partition_Empty Hp) in Hm. destruct Hm.
+ rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity.
+
+ - intros m1 m2 i Hp.
+ destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]).
+ + (* fst case: m3 is (k,e)::m1 *)
+ assert (~In k m3).
+ { contradict Hn. destruct Hn as (e',He').
+ destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. }
+ transitivity (f k e (fold f m i)).
+ apply fold_Add with (eqA:=eqA); auto.
+ symmetry.
+ transitivity (f k e (fold f m3 (fold f m2 i))).
+ apply fold_Add with (eqA:=eqA); auto.
+ apply Comp; auto with map.
+ symmetry; apply IH; auto.
+ + (* snd case: m3 is (k,e)::m2 *)
+ assert (~In k m3).
+ { contradict Hn. destruct Hn as (e',He').
+ destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. }
+ assert (~In k m1).
+ { contradict Hn. destruct Hn as (e',He').
+ destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. }
+ transitivity (f k e (fold f m i)).
+ apply fold_Add with (eqA:=eqA); auto.
+ transitivity (f k e (fold f m1 (fold f m3 i))).
+ apply Comp; auto using IH with map.
+ transitivity (fold f m1 (f k e (fold f m3 i))).
+ symmetry.
+ apply fold_commutes with (eqA:=eqA); auto.
+ apply fold_init with (eqA:=eqA); auto.
+ symmetry.
+ apply fold_Add with (eqA:=eqA); auto.
+ Qed.
+
+ Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 ->
+ cardinal m = cardinal m1 + cardinal m2.
+ Proof.
+ intros.
+ rewrite (cardinal_fold m), (cardinal_fold m1).
+ set (f:=fun (_:key)(_:elt)=>S).
+ setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)).
+ rewrite <- cardinal_fold.
+ apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto.
+ apply Partition_fold with (eqA:=eq); compute; auto with map. congruence.
+ Qed.
+
+ Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 ->
+ let f := fun k (_:elt) => mem k m1 in
+ Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)).
+ Proof.
+ intros m m1 m2 Hm f.
+ assert (Hf : Proper (E.eq==>eq==>eq) f).
+ intros k k' Hk e e' _; unfold f; rewrite Hk; auto.
+ set (m1':= fst (partition f m)).
+ set (m2':= snd (partition f m)).
+ split; rewrite Equal_mapsto_iff; intros k e.
+ rewrite (@partition_iff_1 f Hf m m1') by auto.
+ unfold f.
+ rewrite <- mem_in_iff.
+ destruct Hm as (Hm,Hm').
+ rewrite Hm'.
+ intuition.
+ exists e; auto.
+ elim (Hm k); split; auto; exists e; auto.
+ rewrite (@partition_iff_2 f Hf m m2') by auto.
+ unfold f.
+ rewrite <- not_mem_in_iff.
+ destruct Hm as (Hm,Hm').
+ rewrite Hm'.
+ intuition.
+ elim (Hm k); split; auto; exists e; auto.
+ elim H1; exists e; auto.
+ Qed.
+
+ Lemma update_mapsto_iff : forall m m' k e,
+ MapsTo k e (update m m') <->
+ (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')).
+ Proof.
+ unfold update.
+ intros m m'.
+ pattern m', (fold (@add _) m' m). apply fold_rec.
+
+ - intros m0 Hm0 k e.
+ assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto).
+ intuition.
+ elim (Hm0 k e); auto.
+
+ - intros k e m0 m1 m2 _ Hn Hadd IH k' e'.
+ change (Equal m2 (add k e m1)) in Hadd.
+ rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition.
+ Qed.
+
+ Lemma update_dec : forall m m' k e, MapsTo k e (update m m') ->
+ { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}.
+ Proof.
+ intros m m' k e H. rewrite update_mapsto_iff in H.
+ destruct (In_dec m' k) as [H'|H']; [left|right]; intuition.
+ elim H'; exists e; auto.
+ Defined.
+
+ Lemma update_in_iff : forall m m' k,
+ In k (update m m') <-> In k m \/ In k m'.
+ Proof.
+ intros m m' k. split.
+ intros (e,H); rewrite update_mapsto_iff in H.
+ destruct H; [right|left]; exists e; intuition.
+ destruct (In_dec m' k) as [H|H].
+ destruct H as (e,H). intros _; exists e.
+ rewrite update_mapsto_iff; left; auto.
+ destruct 1 as [H'|H']; [|elim H; auto].
+ destruct H' as (e,H'). exists e.
+ rewrite update_mapsto_iff; right; auto.
+ Qed.
+
+ Lemma diff_mapsto_iff : forall m m' k e,
+ MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'.
+ Proof.
+ intros m m' k e.
+ unfold diff.
+ rewrite filter_iff.
+ intuition.
+ rewrite mem_1 in *; auto; discriminate.
+ intros ? ? Hk _ _ _; rewrite Hk; auto.
+ Qed.
+
+ Lemma diff_in_iff : forall m m' k,
+ In k (diff m m') <-> In k m /\ ~In k m'.
+ Proof.
+ intros m m' k. split.
+ intros (e,H); rewrite diff_mapsto_iff in H.
+ destruct H; split; auto. exists e; auto.
+ intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto.
+ Qed.
+
+ Lemma restrict_mapsto_iff : forall m m' k e,
+ MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'.
+ Proof.
+ intros m m' k e.
+ unfold restrict.
+ rewrite filter_iff.
+ intuition.
+ intros ? ? Hk _ _ _; rewrite Hk; auto.
+ Qed.
+
+ Lemma restrict_in_iff : forall m m' k,
+ In k (restrict m m') <-> In k m /\ In k m'.
+ Proof.
+ intros m m' k. split.
+ intros (e,H); rewrite restrict_mapsto_iff in H.
+ destruct H; split; auto. exists e; auto.
+ intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto.
+ Qed.
+
+ (** specialized versions analyzing only keys (resp. bindings) *)
+
+ Definition filter_dom (f : key -> bool) := filter (fun k _ => f k).
+ Definition filter_range (f : elt -> bool) := filter (fun _ => f).
+ Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k).
+ Definition for_all_range (f : elt -> bool) := for_all (fun _ => f).
+ Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k).
+ Definition exists_range (f : elt -> bool) := exists_ (fun _ => f).
+ Definition partition_dom (f : key -> bool) := partition (fun k _ => f k).
+ Definition partition_range (f : elt -> bool) := partition (fun _ => f).
+
+ End Elt.
+
+ Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt).
+ Proof. intros m m'. apply Equal_cardinal. Qed.
+
+ Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros.
+ rewrite <- Hm1, <- Hm2; auto.
+ rewrite Hm1, Hm2; auto.
+ Qed.
+
+ Instance Partition_m {elt} :
+ Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition.
+ rewrite <- Hm2, <- Hm3.
+ split; intros (H,H'); split; auto; intros.
+ rewrite <- Hm1, <- Hm2, <- Hm3; auto.
+ rewrite Hm1, Hm2, Hm3; auto.
+ Qed.
+
+(*
+ Instance filter_m0 {elt} (f:key->elt->bool) :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ Proper (Equal==>Equal) (filter f).
+ Proof.
+ intros Hf m m' Hm. apply Equal_mapsto_iff. intros.
+ now rewrite !filter_iff, Hm.
+ Qed.
+*)
+
+ Instance filter_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt).
+ Proof.
+ intros f f' Hf m m' Hm. unfold filter.
+ rewrite 2 fold_spec_right.
+ set (l := rev (bindings m)).
+ set (l' := rev (bindings m')).
+ set (op := fun (f:key->elt->bool) =>
+ uncurry (fun k e acc => if f k e then add k e acc else acc)).
+ change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')).
+ assert (Hl : NoDupA eq_key l).
+ { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. }
+ assert (Hl' : NoDupA eq_key l').
+ { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. }
+ assert (H : PermutationA eq_key_elt l l').
+ { apply NoDupA_equivlistA_PermutationA.
+ - apply eqke_equiv.
+ - now apply NoDupA_eqk_eqke.
+ - now apply NoDupA_eqk_eqke.
+ - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1.
+ rewrite Equal_mapsto_iff in Hm. apply Hm. }
+ destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)).
+ transitivity (fold_right (op f) empty l0).
+ - apply fold_right_equivlistA_restr2
+ with (eqA:=Logic.eq)(R:=complement eq_key); auto with *.
+ + intros p p' <- acc acc' Hacc.
+ destruct p as (k,e); unfold op, uncurry; simpl.
+ destruct (f k e); now rewrite Hacc.
+ + intros (k,e) (k',e') z z'.
+ unfold op, complement, uncurry, eq_key; simpl.
+ intros Hk Hz.
+ destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity.
+ now apply add_add_2.
+ + apply NoDupA_incl with eq_key; trivial. intros; subst; now red.
+ + apply PermutationA_preserves_NoDupA with l; auto with *.
+ apply Permutation_PermutationA; auto with *.
+ apply NoDupA_incl with eq_key; trivial. intros; subst; now red.
+ + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv.
+ apply bindings_spec2w.
+ + apply PermutationA_equivlistA; auto with *.
+ apply Permutation_PermutationA; auto with *.
+ - clearbody l'. clear l Hl Hl' H P m m' Hm.
+ induction E.
+ + reflexivity.
+ + simpl. destruct x as (k,e), x' as (k',e').
+ unfold op, uncurry at 1 3; simpl.
+ destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0).
+ destruct (f k e); trivial. now f_equiv.
+ Qed.
+
+ Instance for_all_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt).
+ Proof.
+ intros f f' Hf m m' Hm. rewrite 2 for_all_filter.
+ (* Strange: we cannot rewrite Hm here... *)
+ f_equiv. f_equiv; trivial.
+ intros k k' Hk e e' He. f_equal. now apply Hf.
+ Qed.
+
+ Instance exists_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt).
+ Proof.
+ intros f f' Hf m m' Hm. rewrite 2 exists_filter.
+ f_equal. now apply is_empty_m, filter_m.
+ Qed.
+
+ Fact diamond_add {elt} : Diamond Equal (@add elt).
+ Proof.
+ intros k k' e e' a b b' Hk <- <-. now apply add_add_2.
+ Qed.
+
+ Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2.
+ unfold update.
+ apply fold_Proper; auto using diamond_add with *.
+ Qed.
+
+ Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2 y.
+ unfold restrict.
+ apply eq_option_alt. intros e.
+ rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ Qed.
+
+ Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2 y.
+ unfold diff.
+ apply eq_option_alt. intros e.
+ rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ Qed.
+
+End WProperties_fun.
+
+(** * Same Properties for self-contained weak maps and for full maps *)
+
+Module WProperties (M:WS) := WProperties_fun M.E M.
+Module Properties := WProperties.
+
+(** * Properties specific to maps with ordered keys *)
+
+Module OrdProperties (M:S).
+ Module Import ME := OrderedTypeFacts M.E.
+ Module Import O:=KeyOrderedType M.E.
+ Module Import P:=Properties M.
+ Import M.
+
+ Section Elt.
+ Variable elt:Type.
+
+ Definition Above x (m:t elt) := forall y, In y m -> E.lt y x.
+ Definition Below x (m:t elt) := forall y, In y m -> E.lt x y.
+
+ Section Bindings.
+
+ Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt),
+ sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'.
+ Proof.
+ apply SortA_equivlistA_eqlistA; eauto with *.
+ Qed.
+
+ Ltac klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *.
+ Ltac keauto := klean; intuition; eauto.
+
+ Definition gtb (p p':key*elt) :=
+ match E.compare (fst p) (fst p') with Gt => true | _ => false end.
+ Definition leb p := fun p' => negb (gtb p p').
+
+ Definition bindings_lt p m := List.filter (gtb p) (bindings m).
+ Definition bindings_ge p m := List.filter (leb p) (bindings m).
+
+ Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p.
+ Proof.
+ intros (x,e) (y,e'); unfold gtb; klean.
+ case E.compare_spec; intuition; try discriminate; ME.order.
+ Qed.
+
+ Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p.
+ Proof.
+ intros (x,e) (y,e'); unfold leb, gtb; klean.
+ case E.compare_spec; intuition; try discriminate; ME.order.
+ Qed.
+
+ Instance gtb_compat : forall p, Proper (eqke==>eq) (gtb p).
+ Proof.
+ red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H.
+ generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e''));
+ destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); klean; auto.
+ - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto.
+ - intros. rewrite H1. rewrite H, <- H2; auto.
+ Qed.
+
+ Instance leb_compat : forall p, Proper (eqke==>eq) (leb p).
+ Proof.
+ intros x a b H. unfold leb; f_equal; apply gtb_compat; auto.
+ Qed.
+
+ Hint Resolve gtb_compat leb_compat bindings_spec2 : map.
+
+ Lemma bindings_split : forall p m,
+ bindings m = bindings_lt p m ++ bindings_ge p m.
+ Proof.
+ unfold bindings_lt, bindings_ge, leb; intros.
+ apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *.
+ intros; destruct x; destruct y; destruct p.
+ rewrite gtb_1 in H; klean.
+ apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order.
+ Qed.
+
+ Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' ->
+ eqlistA eqke (bindings m')
+ (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m).
+ Proof.
+ intros; unfold bindings_lt, bindings_ge.
+ apply sort_equivlistA_eqlistA; auto with *.
+ - apply (@SortA_app _ eqke); auto with *.
+ + apply (@filter_sort _ eqke); auto with *; keauto.
+ + constructor; auto with map.
+ * apply (@filter_sort _ eqke); auto with *; keauto.
+ * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail).
+ { intros.
+ rewrite filter_InA in H1; auto with *; destruct H1.
+ rewrite leb_1 in H2.
+ destruct y; klean.
+ rewrite <- bindings_mapsto_iff in H1.
+ assert (~E.eq x t0).
+ { contradict H.
+ exists e0; apply MapsTo_1 with t0; auto.
+ ME.order. }
+ ME.order. }
+ { apply (@filter_sort _ eqke); auto with *; keauto. }
+ + intros.
+ rewrite filter_InA in H1; auto with *; destruct H1.
+ rewrite gtb_1 in H3.
+ destruct y; destruct x0; klean.
+ inversion_clear H2.
+ * red in H4; klean; destruct H4; simpl in *. ME.order.
+ * rewrite filter_InA in H4; auto with *; destruct H4.
+ rewrite leb_1 in H4. klean; ME.order.
+ - intros (k,e').
+ rewrite InA_app_iff, InA_cons, 2 filter_InA,
+ <-2 bindings_mapsto_iff, leb_1, gtb_1,
+ find_mapsto_iff, (H0 k), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with * ).
+ change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e).
+ klean.
+ split.
+ + intros [(->,->)|(Hk,Hm)].
+ * right; now left.
+ * destruct (lt_dec k x); intuition.
+ + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]].
+ * right; split; trivial; ME.order.
+ * now left.
+ * destruct (eq_dec x k) as [Hk|Hk].
+ elim H. exists e'. now rewrite Hk.
+ right; auto.
+ Qed.
+
+ Lemma bindings_Add_Above : forall m m' x e,
+ Above x m -> Add x e m m' ->
+ eqlistA eqke (bindings m') (bindings m ++ (x,e)::nil).
+ Proof.
+ intros.
+ apply sort_equivlistA_eqlistA; auto with *.
+ apply (@SortA_app _ eqke); auto with *.
+ intros.
+ inversion_clear H2.
+ destruct x0; destruct y.
+ rewrite <- bindings_mapsto_iff in H1.
+ destruct H3; klean.
+ rewrite H2.
+ apply H; firstorder.
+ inversion H3.
+ red; intros a; destruct a.
+ rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff,
+ find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with *).
+ change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e).
+ intuition.
+ destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+ exfalso.
+ assert (In t0 m) by (exists e0; auto).
+ generalize (H t0 H1).
+ ME.order.
+ Qed.
+
+ Lemma bindings_Add_Below : forall m m' x e,
+ Below x m -> Add x e m m' ->
+ eqlistA eqke (bindings m') ((x,e)::bindings m).
+ Proof.
+ intros.
+ apply sort_equivlistA_eqlistA; auto with *.
+ change (sort ltk (((x,e)::nil) ++ bindings m)).
+ apply (@SortA_app _ eqke); auto with *.
+ intros.
+ inversion_clear H1.
+ destruct y; destruct x0.
+ rewrite <- bindings_mapsto_iff in H2.
+ destruct H3; klean.
+ rewrite H1.
+ apply H; firstorder.
+ inversion H3.
+ red; intros a; destruct a.
+ rewrite InA_cons, <- 2 bindings_mapsto_iff,
+ find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with * ).
+ change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e).
+ intuition.
+ destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+ exfalso.
+ assert (In t0 m) by (exists e0; auto).
+ generalize (H t0 H1).
+ ME.order.
+ Qed.
+
+ Lemma bindings_Equal_eqlistA : forall (m m': t elt),
+ Equal m m' -> eqlistA eqke (bindings m) (bindings m').
+ Proof.
+ intros.
+ apply sort_equivlistA_eqlistA; auto with *.
+ red; intros.
+ destruct x; do 2 rewrite <- bindings_mapsto_iff.
+ do 2 rewrite find_mapsto_iff; rewrite H; split; auto.
+ Qed.
+
+ End Bindings.
+
+ Section Min_Max_Elt.
+
+ (** We emulate two [max_elt] and [min_elt] functions. *)
+
+ Fixpoint max_elt_aux (l:list (key*elt)) := match l with
+ | nil => None
+ | (x,e)::nil => Some (x,e)
+ | (x,e)::l => max_elt_aux l
+ end.
+ Definition max_elt m := max_elt_aux (bindings m).
+
+ Lemma max_elt_Above :
+ forall m x e, max_elt m = Some (x,e) -> Above x (remove x m).
+ Proof.
+ red; intros.
+ rewrite remove_in_iff in H0.
+ destruct H0.
+ rewrite bindings_in_iff in H1.
+ destruct H1.
+ unfold max_elt in *.
+ generalize (bindings_spec2 m).
+ revert x e H y x0 H0 H1.
+ induction (bindings m).
+ simpl; intros; try discriminate.
+ intros.
+ destruct a; destruct l; simpl in *.
+ injection H; clear H; intros; subst.
+ inversion_clear H1.
+ red in H; simpl in *; intuition.
+ now elim H0.
+ inversion H.
+ change (max_elt_aux (p::l) = Some (x,e)) in H.
+ generalize (IHl x e H); clear IHl; intros IHl.
+ inversion_clear H1; [ | inversion_clear H2; eauto ].
+ red in H3; simpl in H3; destruct H3.
+ destruct p as (p1,p2).
+ destruct (E.eq_dec p1 x) as [Heq|Hneq].
+ rewrite <- Heq; auto.
+ inversion_clear H2.
+ inversion_clear H5.
+ red in H2; simpl in H2; ME.order.
+ transitivity p1; auto.
+ inversion_clear H2.
+ inversion_clear H5.
+ red in H2; simpl in H2; ME.order.
+ eapply IHl; eauto with *.
+ econstructor; eauto.
+ red; eauto with *.
+ inversion H2; auto.
+ Qed.
+
+ Lemma max_elt_MapsTo :
+ forall m x e, max_elt m = Some (x,e) -> MapsTo x e m.
+ Proof.
+ intros.
+ unfold max_elt in *.
+ rewrite bindings_mapsto_iff.
+ induction (bindings m).
+ simpl; try discriminate.
+ destruct a; destruct l; simpl in *.
+ injection H; intros; subst; constructor; red; auto with *.
+ constructor 2; auto.
+ Qed.
+
+ Lemma max_elt_Empty :
+ forall m, max_elt m = None -> Empty m.
+ Proof.
+ intros.
+ unfold max_elt in *.
+ rewrite bindings_Empty.
+ induction (bindings m); auto.
+ destruct a; destruct l; simpl in *; try discriminate.
+ assert (H':=IHl H); discriminate.
+ Qed.
+
+ Definition min_elt m : option (key*elt) := match bindings m with
+ | nil => None
+ | (x,e)::_ => Some (x,e)
+ end.
+
+ Lemma min_elt_Below :
+ forall m x e, min_elt m = Some (x,e) -> Below x (remove x m).
+ Proof.
+ unfold min_elt, Below; intros.
+ rewrite remove_in_iff in H0; destruct H0.
+ rewrite bindings_in_iff in H1.
+ destruct H1.
+ generalize (bindings_spec2 m).
+ destruct (bindings m).
+ try discriminate.
+ destruct p; injection H; intros; subst.
+ inversion_clear H1.
+ red in H2; destruct H2; simpl in *; ME.order.
+ inversion_clear H4.
+ rewrite (@InfA_alt _ eqke) in H3; eauto with *.
+ apply (H3 (y,x0)); auto.
+ Qed.
+
+ Lemma min_elt_MapsTo :
+ forall m x e, min_elt m = Some (x,e) -> MapsTo x e m.
+ Proof.
+ intros.
+ unfold min_elt in *.
+ rewrite bindings_mapsto_iff.
+ destruct (bindings m).
+ simpl; try discriminate.
+ destruct p; simpl in *.
+ injection H; intros; subst; constructor; red; auto with *.
+ Qed.
+
+ Lemma min_elt_Empty :
+ forall m, min_elt m = None -> Empty m.
+ Proof.
+ intros.
+ unfold min_elt in *.
+ rewrite bindings_Empty.
+ destruct (bindings m); auto.
+ destruct p; simpl in *; discriminate.
+ Qed.
+
+ End Min_Max_Elt.
+
+ Section Induction_Principles.
+
+ Lemma map_induction_max :
+ forall P : t elt -> Type,
+ (forall m, Empty m -> P m) ->
+ (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') ->
+ forall m, P m.
+ Proof.
+ intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+ apply X; apply cardinal_inv_1; auto.
+
+ case_eq (max_elt m); intros.
+ destruct p.
+ assert (Add k e (remove k m) m).
+ { apply max_elt_MapsTo, find_spec, add_id in H.
+ unfold Add. symmetry. now rewrite add_remove_1. }
+ apply X0 with (remove k m) k e; auto with map.
+ apply IHn.
+ assert (S n = S (cardinal (remove k m))).
+ { rewrite Heqn.
+ eapply cardinal_S; eauto with map. }
+ inversion H1; auto.
+ eapply max_elt_Above; eauto.
+
+ apply X; apply max_elt_Empty; auto.
+ Qed.
+
+ Lemma map_induction_min :
+ forall P : t elt -> Type,
+ (forall m, Empty m -> P m) ->
+ (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') ->
+ forall m, P m.
+ Proof.
+ intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+ apply X; apply cardinal_inv_1; auto.
+
+ case_eq (min_elt m); intros.
+ destruct p.
+ assert (Add k e (remove k m) m).
+ { apply min_elt_MapsTo, find_spec, add_id in H.
+ unfold Add. symmetry. now rewrite add_remove_1. }
+ apply X0 with (remove k m) k e; auto.
+ apply IHn.
+ assert (S n = S (cardinal (remove k m))).
+ { rewrite Heqn.
+ eapply cardinal_S; eauto with map. }
+ inversion H1; auto.
+ eapply min_elt_Below; eauto.
+
+ apply X; apply min_elt_Empty; auto.
+ Qed.
+
+ End Induction_Principles.
+
+ Section Fold_properties.
+
+ (** The following lemma has already been proved on Weak Maps,
+ but with one additionnal hypothesis (some [transpose] fact). *)
+
+ Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+ (f:key->elt->A->A)(i:A),
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Equal m1 m2 ->
+ eqA (fold f m1 i) (fold f m2 i).
+ Proof.
+ intros m1 m2 A eqA st f i Hf Heq.
+ rewrite 2 fold_spec_right.
+ apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+ intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto.
+ apply eqlistA_rev. apply bindings_Equal_eqlistA. auto.
+ Qed.
+
+ Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+ (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
+ Above x m1 -> Add x e m1 m2 ->
+ eqA (fold f m2 i) (f x e (fold f m1 i)).
+ Proof.
+ intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
+ transitivity (fold_right f' i (rev (bindings m1 ++ (x,e)::nil))).
+ apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+ intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto.
+ apply eqlistA_rev.
+ apply bindings_Add_Above; auto.
+ rewrite distr_rev; simpl.
+ reflexivity.
+ Qed.
+
+ Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+ (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
+ Below x m1 -> Add x e m1 m2 ->
+ eqA (fold f m2 i) (fold f m1 (f x e i)).
+ Proof.
+ intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
+ transitivity (fold_right f' i (rev (((x,e)::nil)++bindings m1))).
+ apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+ intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto.
+ apply eqlistA_rev.
+ simpl; apply bindings_Add_Below; auto.
+ rewrite distr_rev; simpl.
+ rewrite fold_right_app.
+ reflexivity.
+ Qed.
+
+ End Fold_properties.
+
+ End Elt.
+
+End OrdProperties.
diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v
new file mode 100644
index 00000000..05c5e5d8
--- /dev/null
+++ b/theories/MMaps/MMapInterface.v
@@ -0,0 +1,292 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* elt->bool) e1 e2 := cmp e1 e2 = true.
+
+(** ** Weak signature for maps
+
+ No requirements for an ordering on keys nor elements, only decidability
+ of equality on keys. First, a functorial signature: *)
+
+Module Type WSfun (E : DecidableType).
+
+ Definition key := E.t.
+ Hint Transparent key.
+
+ Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p').
+
+ Definition eq_key_elt {elt} (p p':key*elt) :=
+ E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+ Parameter t : Type -> Type.
+ (** the abstract type of maps *)
+
+ Section Ops.
+
+ Parameter empty : forall {elt}, t elt.
+ (** The empty map. *)
+
+ Variable elt:Type.
+
+ Parameter is_empty : t elt -> bool.
+ (** Test whether a map is empty or not. *)
+
+ Parameter add : key -> elt -> t elt -> t elt.
+ (** [add x y m] returns a map containing the same bindings as [m],
+ plus a binding of [x] to [y]. If [x] was already bound in [m],
+ its previous binding disappears. *)
+
+ Parameter find : key -> t elt -> option elt.
+ (** [find x m] returns the current binding of [x] in [m],
+ or [None] if no such binding exists. *)
+
+ Parameter remove : key -> t elt -> t elt.
+ (** [remove x m] returns a map containing the same bindings as [m],
+ except for [x] which is unbound in the returned map. *)
+
+ Parameter mem : key -> t elt -> bool.
+ (** [mem x m] returns [true] if [m] contains a binding for [x],
+ and [false] otherwise. *)
+
+ Parameter bindings : t elt -> list (key*elt).
+ (** [bindings m] returns an assoc list corresponding to the bindings
+ of [m], in any order. *)
+
+ Parameter cardinal : t elt -> nat.
+ (** [cardinal m] returns the number of bindings in [m]. *)
+
+ Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
+ (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+ where [k1] ... [kN] are the keys of all bindings in [m]
+ (in any order), and [d1] ... [dN] are the associated data. *)
+
+ Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
+ (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal,
+ that is, contain equal keys and associate them with equal data.
+ [cmp] is the equality predicate used to compare the data associated
+ with the keys. *)
+
+ Variable elt' elt'' : Type.
+
+ Parameter map : (elt -> elt') -> t elt -> t elt'.
+ (** [map f m] returns a map with same domain as [m], where the associated
+ value a of all bindings of [m] has been replaced by the result of the
+ application of [f] to [a]. Since Coq is purely functional, the order
+ in which the bindings are passed to [f] is irrelevant. *)
+
+ Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
+ (** Same as [map], but the function receives as arguments both the
+ key and the associated value for each binding of the map. *)
+
+ Parameter merge : (key -> option elt -> option elt' -> option elt'') ->
+ t elt -> t elt' -> t elt''.
+ (** [merge f m m'] creates a new map whose bindings belong to the ones
+ of either [m] or [m']. The presence and value for a key [k] is
+ determined by [f k e e'] where [e] and [e'] are the (optional)
+ bindings of [k] in [m] and [m']. *)
+
+ End Ops.
+ Section Specs.
+
+ Variable elt:Type.
+
+ Parameter MapsTo : key -> elt -> t elt -> Prop.
+
+ Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
+
+ Global Declare Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+
+ Variable m m' : t elt.
+ Variable x y : key.
+ Variable e : elt.
+
+ Parameter find_spec : find x m = Some e <-> MapsTo x e m.
+ Parameter mem_spec : mem x m = true <-> In x m.
+ Parameter empty_spec : find x (@empty elt) = None.
+ Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None.
+ Parameter add_spec1 : find x (add x e m) = Some e.
+ Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m.
+ Parameter remove_spec1 : find x (remove x m) = None.
+ Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m.
+
+ (** Specification of [bindings] *)
+ Parameter bindings_spec1 :
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ (** When compared with ordered maps, here comes the only
+ property that is really weaker: *)
+ Parameter bindings_spec2w : NoDupA eq_key (bindings m).
+
+ (** Specification of [cardinal] *)
+ Parameter cardinal_spec : cardinal m = length (bindings m).
+
+ (** Specification of [fold] *)
+ Parameter fold_spec :
+ forall {A} (i : A) (f : key -> elt -> A -> A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+
+ (** Equality of maps *)
+
+ (** Caveat: there are at least three distinct equality predicates on maps.
+ - The simpliest (and maybe most natural) way is to consider keys up to
+ their equivalence [E.eq], but elements up to Leibniz equality, in
+ the spirit of [eq_key_elt] above. This leads to predicate [Equal].
+ - Unfortunately, this [Equal] predicate can't be used to describe
+ the [equal] function, since this function (for compatibility with
+ ocaml) expects a boolean comparison [cmp] that may identify more
+ elements than Leibniz. So logical specification of [equal] is done
+ via another predicate [Equivb]
+ - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
+ it can be generalized in a [Equiv] expecting a more general
+ (possibly non-decidable) equality predicate on elements *)
+
+ Definition Equal (m m':t elt) := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).
+
+ (** Specification of [equal] *)
+ Parameter equal_spec : forall cmp : elt -> elt -> bool,
+ equal cmp m m' = true <-> Equivb cmp m m'.
+
+ End Specs.
+ Section SpecMaps.
+
+ Variables elt elt' elt'' : Type.
+
+ Parameter map_spec : forall (f:elt->elt') m x,
+ find x (map f m) = option_map f (find x m).
+
+ Parameter mapi_spec : forall (f:key->elt->elt') m x,
+ exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+
+ Parameter merge_spec1 :
+ forall (f:key->option elt->option elt'->option elt'') m m' x,
+ In x m \/ In x m' ->
+ exists y:key, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+
+ Parameter merge_spec2 :
+ forall (f:key -> option elt->option elt'->option elt'') m m' x,
+ In x (merge f m m') -> In x m \/ In x m'.
+
+ End SpecMaps.
+End WSfun.
+
+(** ** Static signature for Weak Maps
+
+ Similar to [WSfun] but expressed in a self-contained way. *)
+
+Module Type WS.
+ Declare Module E : DecidableType.
+ Include WSfun E.
+End WS.
+
+
+
+(** ** Maps on ordered keys, functorial signature *)
+
+Module Type Sfun (E : OrderedType).
+ Include WSfun E.
+
+ Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p').
+
+ (** Additional specification of [bindings] *)
+
+ Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m).
+
+ (** Remark: since [fold] is specified via [bindings], this stronger
+ specification of [bindings] has an indirect impact on [fold],
+ which can now be proved to receive bindings in increasing order. *)
+
+End Sfun.
+
+
+(** ** Maps on ordered keys, self-contained signature *)
+
+Module Type S.
+ Declare Module E : OrderedType.
+ Include Sfun E.
+End S.
+
+
+
+(** ** Maps with ordering both on keys and datas *)
+
+Module Type Sord.
+
+ Declare Module Data : OrderedType.
+ Declare Module MapS : S.
+ Import MapS.
+
+ Definition t := MapS.t Data.t.
+
+ Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder.
+
+ Definition cmp e e' :=
+ match Data.compare e e' with Eq => true | _ => false end.
+
+ Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'.
+
+ Parameter compare : t -> t -> comparison.
+
+ Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2).
+
+End Sord.
+
+
+(* TODO: provides filter + partition *)
+
+(* TODO: provide split
+ Parameter split : key -> t elt -> t elt * option elt * t elt.
+
+ Parameter split_spec k m :
+ split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...)
+
+ min_binding, max_binding, choose ?
+*)
diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v
new file mode 100644
index 00000000..c521178c
--- /dev/null
+++ b/theories/MMaps/MMapList.v
@@ -0,0 +1,1144 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(*
+ assert (X.lt k' k);
+ [let e := fresh "e" in destruct H3 as (e,H3);
+ change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ =>
+ assert (X.lt k' k);
+ [change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ =>
+ assert (X.lt k' k);
+ [change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ end.
+
+(** * [find] *)
+
+Fixpoint find (k:key) (m: t elt) : option elt :=
+ match m with
+ | nil => None
+ | (k',x)::m' =>
+ match X.compare k k' with
+ | Lt => None
+ | Eq => Some x
+ | Gt => find k m'
+ end
+ end.
+
+Lemma find_spec m (Hm:Sort m) x e :
+ find x m = Some e <-> MapsTo x e m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - split. discriminate. inversion 1.
+ - inversion_clear Hm.
+ unfold MapsTo in *. rewrite InA_cons, eqke_def.
+ case X.compare_spec; intros.
+ + split. injection 1 as ->; auto.
+ intros [(_,<-)|IN]; trivial. SortLt. MX.order.
+ + split. discriminate.
+ intros [(E,<-)|IN]; trivial; try SortLt; MX.order.
+ + rewrite IH; trivial. split; auto.
+ intros [(E,<-)|IN]; trivial. MX.order.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (m : t elt) : bool :=
+ match m with
+ | nil => false
+ | (k',_) :: l =>
+ match X.compare k k' with
+ | Lt => false
+ | Eq => true
+ | Gt => mem k l
+ end
+ end.
+
+Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - split. discriminate. inversion 1. inversion_clear H0.
+ - inversion_clear Hm.
+ rewrite In_cons; simpl.
+ case X.compare_spec; intros.
+ + intuition.
+ + split. discriminate. intros [E|(e,IN)]. MX.order.
+ SortLt. MX.order.
+ + rewrite IH; trivial. split; auto. intros [E|IN]; trivial.
+ MX.order.
+Qed.
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Lemma empty_spec x : find x empty = None.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma empty_sorted : Sort empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_spec m :
+ is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate.
+ intros H. specialize (H k). now rewrite compare_refl in H.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) : t elt :=
+ match s with
+ | nil => (k,x) :: nil
+ | (k',y) :: l =>
+ match X.compare k k' with
+ | Lt => (k,x)::s
+ | Eq => (k,x)::l
+ | Gt => (k',y) :: add k x l
+ end
+ end.
+
+Lemma add_spec1 m x e : find x (add x e m) = Some e.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - now rewrite compare_refl.
+ - case X.compare_spec; simpl; rewrite ?compare_refl; trivial.
+ rewrite <- compare_gt_iff. now intros ->.
+Qed.
+
+Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - case X.compare_spec; trivial; MX.order.
+ - case X.compare_spec; simpl; intros; trivial.
+ + rewrite <-H. case X.compare_spec; trivial; MX.order.
+ + do 2 (case X.compare_spec; trivial; try MX.order).
+ + now rewrite IH.
+Qed.
+
+Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
+ Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0,H1.
+ simpl; case X.compare; intuition.
+Qed.
+Hint Resolve add_Inf.
+
+Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto.
+ constructor; auto.
+ apply Inf_eq with (x',e'); auto.
+Qed.
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) : t elt :=
+ match s with
+ | nil => nil
+ | (k',x) :: l =>
+ match X.compare k k' with
+ | Lt => s
+ | Eq => l
+ | Gt => (k',x) :: remove k l
+ end
+ end.
+
+Lemma remove_spec1 m (Hm:Sort m) x : find x (remove x m) = None.
+Proof.
+ induction m as [|(k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ case X.compare_spec; simpl.
+ - intros E. rewrite <- E in H0.
+ apply Sort_Inf_NotIn in H0; trivial. unfold In in H0.
+ setoid_rewrite <- find_spec in H0; trivial.
+ destruct (find x m); trivial.
+ elim H0; now exists e.
+ - rewrite <- compare_lt_iff. now intros ->.
+ - rewrite <- compare_gt_iff. intros ->; auto.
+Qed.
+
+Lemma remove_spec2 m (Hm:Sort m) x y :
+ ~X.eq x y -> find y (remove x m) = find y m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ case X.compare_spec; simpl; intros E E'; try rewrite IH; auto.
+ case X.compare_spec; simpl; trivial; try MX.order.
+ intros. rewrite <- E in H0,H1. clear E E'.
+ destruct (find y m) eqn:F; trivial.
+ apply find_spec in F; trivial.
+ SortLt. MX.order.
+Qed.
+
+Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt),
+ Inf (x',e') m -> Inf (x',e') (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0.
+ simpl; case X.compare; intuition.
+ inversion_clear Hm.
+ apply Inf_lt with (x'',e''); auto.
+Qed.
+Hint Resolve remove_Inf.
+
+Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case X.compare_spec; intuition; inversion_clear Hm; auto.
+Qed.
+
+(** * [bindings] *)
+
+Definition bindings (m: t elt) := m.
+
+Lemma bindings_spec1 m x e :
+ InA eqke (x,e) (bindings m) <-> MapsTo x e m.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m).
+Proof.
+ auto.
+Qed.
+
+Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m).
+Proof.
+ now apply Sort_NoDupA.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A :=
+ match m with
+ | nil => acc
+ | (k,e)::m' => fold f m' (f k e acc)
+ end.
+
+Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+Proof.
+ induction m as [|(k,e) m IH]; simpl; auto.
+Qed.
+
+(** * [equal] *)
+
+Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool :=
+ match m, m' with
+ | nil, nil => true
+ | (x,e)::l, (x',e')::l' =>
+ match X.compare x x' with
+ | Eq => cmp e e' && equal cmp l l'
+ | _ => false
+ end
+ | _, _ => false
+ end.
+
+Definition Equivb (cmp:elt->elt->bool) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
+ Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
+ induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl.
+ - trivial.
+ - intros _ cmp (H,_).
+ exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left.
+ - intros _ cmp (H,_).
+ exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left.
+ - intros Hm' cmp E.
+ inversion_clear Hm; inversion_clear Hm'.
+ case X.compare_spec; intros E'.
+ + apply andb_true_intro; split.
+ * eapply E; eauto. apply InA_cons; now left.
+ * apply IH; clear IH; trivial.
+ destruct E as (E1,E2). split.
+ { intros x. clear E2.
+ split; intros; SortLt.
+ specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
+ destruct E1 as ([E1|E1],_); eauto. MX.order.
+ specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
+ destruct E1 as (_,[E1|E1]); eauto. MX.order. }
+ { intros x xe xe' Hx HX'. eapply E2; eauto. }
+ + assert (IN : In k ((k',e')::m')).
+ { apply E. apply In_cons; now left. }
+ apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
+ SortLt. MX.order.
+ + assert (IN : In k' ((k,e)::m)).
+ { apply E. apply In_cons; now left. }
+ apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
+ SortLt. MX.order.
+Qed.
+
+Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp :
+ equal cmp m m' = true -> Equivb cmp m m'.
+Proof.
+ revert m' Hm'.
+ induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl;
+ try discriminate.
+ - split. reflexivity. inversion 1.
+ - intros Hm'. case X.compare_spec; try discriminate.
+ rewrite andb_true_iff. intros E (C,EQ).
+ inversion_clear Hm; inversion_clear Hm'.
+ apply IH in EQ; trivial.
+ destruct EQ as (E1,E2).
+ split.
+ + intros x. rewrite 2 In_cons; simpl. rewrite <- E1.
+ intuition; now left; MX.order.
+ + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def.
+ intuition; subst.
+ * trivial.
+ * SortLt. MX.order.
+ * SortLt. MX.order.
+ * eapply E2; eauto.
+Qed.
+
+Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp :
+ equal cmp m m' = true <-> Equivb cmp m m'.
+Proof.
+ split. now apply equal_2. now apply equal_1.
+Qed.
+
+(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *)
+
+Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
+ eqk x y -> cmp (snd x) (snd y) = true ->
+ (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
+Proof.
+ intros.
+ inversion H; subst.
+ inversion H0; subst.
+ destruct x; destruct y; compute in H1, H2.
+ split; intros.
+ apply equal_2; auto.
+ simpl.
+ case X.compare_spec; intros; try MX.order.
+ rewrite H2; simpl.
+ apply equal_1; auto.
+ apply equal_2; auto.
+ generalize (equal_1 H H0 H3).
+ simpl.
+ case X.compare_spec; try discriminate.
+ rewrite andb_true_iff. intuition.
+Qed.
+
+Variable elt':Type.
+
+(** * [map] and [mapi] *)
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
+ match m with
+ | nil => nil
+ | (k,e)::m' => (k,f e) :: map f m'
+ end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
+ match m with
+ | nil => nil
+ | (k,e)::m' => (k,f k e) :: mapi f m'
+ end.
+
+End Elt.
+Arguments find {elt} k m.
+Section Elt2.
+Variable elt elt' : Type.
+
+(** Specification of [map] *)
+
+Lemma map_spec (f:elt->elt') m x :
+ find x (map f m) = option_map f (find x m).
+Proof.
+ induction m as [|(k,e) m IH]; simpl; trivial.
+ now case X.compare_spec.
+Qed.
+
+Lemma map_Inf (f:elt->elt') m x e e' :
+ Inf (x,e) m -> Inf (x,e') (map f m).
+Proof.
+ induction m as [|(x0,e0) m IH]; simpl; auto.
+ inversion_clear 1; auto.
+Qed.
+Hint Resolve map_Inf.
+
+Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) :
+ Sort (map f m).
+Proof.
+ induction m as [|(x,e) m IH]; simpl; auto.
+ inversion_clear Hm. constructor; eauto.
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_spec (f:key->elt->elt') m x :
+ exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m as [|(k,e) m IH]; simpl.
+ - now exists x.
+ - elim X.compare_spec; intros; simpl.
+ + now exists k.
+ + now exists x.
+ + apply IH.
+Qed.
+
+Lemma mapi_Inf (f:key->elt->elt') m x e :
+ Inf (x,e) m -> Inf (x,f x e) (mapi f m).
+Proof.
+ induction m as [|(x0,e0) m IH]; simpl; auto.
+ inversion_clear 1; auto.
+Qed.
+Hint Resolve mapi_Inf.
+
+Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) :
+ Sort (mapi f m).
+Proof.
+ induction m as [|(x,e) m IH]; simpl; auto.
+ inversion_clear Hm; auto.
+Qed.
+
+End Elt2.
+Section Elt3.
+
+(** * [merge] *)
+
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) :=
+ match o with
+ | Some e => (k,e)::l
+ | None => l
+ end.
+
+Fixpoint merge_l (m : t elt) : t elt'' :=
+ match m with
+ | nil => nil
+ | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l)
+ end.
+
+Fixpoint merge_r (m' : t elt') : t elt'' :=
+ match m' with
+ | nil => nil
+ | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l')
+ end.
+
+Fixpoint merge (m : t elt) : t elt' -> t elt'' :=
+ match m with
+ | nil => merge_r
+ | (k,e) :: l =>
+ fix merge_aux (m' : t elt') : t elt'' :=
+ match m' with
+ | nil => merge_l m
+ | (k',e') :: l' =>
+ match X.compare k k' with
+ | Lt => option_cons k (f k (Some e) None) (merge l m')
+ | Eq => option_cons k (f k (Some e) (Some e')) (merge l l')
+ | Gt => option_cons k' (f k' None (Some e')) (merge_aux l')
+ end
+ end
+ end.
+
+Notation oee' := (option elt * option elt')%type.
+
+Fixpoint combine (m : t elt) : t elt' -> t oee' :=
+ match m with
+ | nil => map (fun e' => (None,Some e'))
+ | (k,e) :: l =>
+ fix combine_aux (m':t elt') : list (key * oee') :=
+ match m' with
+ | nil => map (fun e => (Some e,None)) m
+ | (k',e') :: l' =>
+ match X.compare k k' with
+ | Lt => (k,(Some e, None))::combine l m'
+ | Eq => (k,(Some e, Some e'))::combine l l'
+ | Gt => (k',(None,Some e'))::combine_aux l'
+ end
+ end
+ end.
+
+Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) :=
+ List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition merge' m m' :=
+ let m0 : t oee' := combine m m' in
+ let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in
+ fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma merge_equiv : forall m m', merge' m m' = merge m m'.
+Proof.
+ unfold merge'.
+ induction m as [|(k,e) m IHm]; intros.
+ - (* merge_r *)
+ simpl.
+ induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto.
+ - induction m' as [|(k',e') m' IHm']; simpl.
+ + f_equal.
+ (* merge_l *)
+ clear k e IHm.
+ induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto.
+ + elim X.compare_spec; intros; simpl; f_equal.
+ * apply IHm.
+ * apply IHm.
+ * apply IHm'.
+Qed.
+
+Lemma combine_Inf :
+ forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
+ Inf (x,e) m ->
+ Inf (x,e') m' ->
+ Inf (x,e'') (combine m m').
+Proof.
+ induction m.
+ - intros. simpl. eapply map_Inf; eauto.
+ - induction m'; intros.
+ + destruct a.
+ replace (combine ((t0, e0) :: m) nil) with
+ (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
+ eapply map_Inf; eauto.
+ + simpl.
+ destruct a as (k,e0); destruct a0 as (k',e0').
+ elim X.compare_spec.
+ * inversion_clear H; auto.
+ * inversion_clear H; auto.
+ * inversion_clear H0; auto.
+Qed.
+Hint Resolve combine_Inf.
+
+Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') :
+ Sort (combine m m').
+Proof.
+ revert m' Hm'.
+ induction m.
+ - intros; clear Hm. simpl. apply map_sorted; auto.
+ - induction m'; intros.
+ + clear Hm'.
+ destruct a.
+ replace (combine ((t0, e) :: m) nil) with
+ (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
+ apply map_sorted; auto.
+ + simpl.
+ destruct a as (k,e); destruct a0 as (k',e').
+ inversion_clear Hm; inversion_clear Hm'.
+ case X.compare_spec; [intros Heq| intros Hlt| intros Hlt];
+ constructor; auto.
+ * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto).
+ exact (combine_Inf _ H0 H3).
+ * assert (Inf (k, e') ((k',e')::m')) by auto.
+ exact (combine_Inf _ H0 H3).
+ * assert (Inf (k', e) ((k,e)::m)) by auto.
+ exact (combine_Inf _ H3 H2).
+Qed.
+
+Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') :
+ Sort (merge m m').
+Proof.
+ intros.
+ rewrite <- merge_equiv.
+ unfold merge'.
+ assert (Hmm':=combine_sorted Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun k p => f k (fst p) (snd p)).
+ assert (H1:=mapi_sorted f' Hmm').
+ set (l1:=mapi f' l0) in *; clearbody l1.
+ clear f' f Hmm' l0 Hm Hm' m m'.
+ (* Sort fold_right_pair *)
+ induction l1.
+ - simpl; auto.
+ - inversion_clear H1.
+ destruct a; destruct o; auto.
+ simpl.
+ constructor; auto.
+ clear IHl1.
+ (* Inf fold_right_pair *)
+ induction l1.
+ + simpl; auto.
+ + destruct a; destruct o; simpl; auto.
+ * inversion_clear H0; auto.
+ * inversion_clear H0. inversion_clear H.
+ compute in H1.
+ apply IHl1; auto.
+ apply Inf_lt with (t1, None); auto.
+Qed.
+
+Definition at_least_one (o:option elt)(o':option elt') :=
+ match o, o' with
+ | None, None => None
+ | _, _ => Some (o,o')
+ end.
+
+Lemma combine_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) :
+ find x (combine m m') = at_least_one (find x m) (find x m').
+Proof.
+ revert m' Hm'.
+ induction m.
+ intros.
+ simpl.
+ induction m'.
+ intros; simpl; auto.
+ simpl; destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm'; auto.
+ induction m'.
+ (* m' = nil *)
+ intros; destruct a; simpl.
+ destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto.
+ inversion_clear Hm; clear H0 Hlt Hm' IHm t0.
+ induction m; simpl; auto.
+ inversion_clear H.
+ destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ (* m' <> nil *)
+ intros.
+ destruct a as (k,e); destruct a0 as (k',e'); simpl.
+ inversion Hm; inversion Hm'; subst.
+ destruct (X.compare_spec k k'); simpl;
+ destruct (X.compare_spec x k);
+ MX.order || destruct (X.compare_spec x k');
+ simpl; try MX.order; auto.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') =
+ at_least_one (find x m) (find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+Qed.
+
+Definition at_least_one_then_f k (o:option elt)(o':option elt') :=
+ match o, o' with
+ | None, None => None
+ | _, _ => f k o o'
+ end.
+
+Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) :
+ exists y, X.eq y x /\
+ find x (merge m m') = at_least_one_then_f y (find x m) (find x m').
+Proof.
+ intros.
+ rewrite <- merge_equiv.
+ unfold merge'.
+ assert (H:=combine_spec Hm Hm' x).
+ assert (H2:=combine_sorted Hm Hm').
+ set (f':= fun k p => f k (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o.
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'. revert H.
+ match goal with |- ?G =>
+ assert (G/\(find x m0 = None ->
+ find x (fold_right_pair option_cons (mapi f' m0) nil) = None));
+ [|intuition] end.
+ induction m0; simpl in *; intuition.
+ - exists x; split; [easy|].
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ - destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *.
+ + (* x = k *)
+ exists k; split; [easy|].
+ assert (at_least_one_then_f k o o' = f k oo oo').
+ { destruct o; destruct o'; simpl in *; inversion_clear H; auto. }
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ * destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
+ now compute.
+ symmetry in H5.
+ destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)).
+ exists p; apply find_spec; auto.
+ + (* x < k *)
+ destruct (f' k (oo,oo')); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ now exists x.
+ * apply IHm0; trivial.
+ rewrite <- H.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+ red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_spec; auto.
+ + (* k < x *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ intros. apply IHm0; auto.
+ * apply IHm0; auto.
+
+ - (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate.
+ + (* x < k *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ elim X.compare_spec; trivial; try MX.order. intros.
+ apply IHm0; auto.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+ now compute.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_spec; auto.
+ + (* k < x *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ elim X.compare_spec; trivial; try MX.order. intros.
+ apply IHm0; auto.
+ apply IHm0; auto.
+Qed.
+
+(** Specification of [merge] *)
+
+Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) :
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (merge m m') = f y (find x m) (find x m').
+Proof.
+ intros.
+ destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')).
+ exists y; split; [easy|]. rewrite H'.
+ destruct H as [(e,H)|(e,H)];
+ apply find_spec in H; trivial; rewrite H; simpl; auto.
+ now destruct (find x m).
+Qed.
+
+Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) :
+ In x (merge m m') -> In x m \/ In x m'.
+Proof.
+ intros.
+ destruct H as (e,H).
+ apply find_spec in H; auto using merge_sorted.
+ destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')).
+ rewrite H in H'.
+ destruct (find x m) eqn:F.
+ - apply find_spec in F; eauto.
+ - destruct (find x m') eqn:F'.
+ + apply find_spec in F'; eauto.
+ + simpl in H'. discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+Module Make (X: OrderedType) <: S with Module E := X.
+Module Raw := Raw X.
+Module E := X.
+
+Definition key := E.t.
+Definition eq_key {elt} := @Raw.PX.eqk elt.
+Definition eq_key_elt {elt} := @Raw.PX.eqke elt.
+Definition lt_key {elt} := @Raw.PX.ltk elt.
+
+Record t_ (elt:Type) := Mk
+ {this :> Raw.t elt;
+ sorted : sort Raw.PX.ltk this}.
+Definition t := t_.
+
+Definition empty {elt} := Mk (Raw.empty_sorted elt).
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (Raw.mapi_sorted f m.(sorted)).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := length m.(this).
+ Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A :=
+ Raw.fold f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx.
+ Qed.
+
+ Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m.
+ Proof. exact (Raw.find_spec m.(sorted)). Qed.
+
+ Lemma mem_spec m : forall x, mem x m = true <-> In x m.
+ Proof. exact (Raw.mem_spec m.(sorted)). Qed.
+
+ Lemma empty_spec : forall x, find x empty = None.
+ Proof. exact (Raw.empty_spec _). Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None).
+ Proof. exact (Raw.is_empty_spec m.(this)). Qed.
+
+ Lemma add_spec1 m : forall x e, find x (add x e m) = Some e.
+ Proof. exact (Raw.add_spec1 m.(this)). Qed.
+ Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m.
+ Proof. exact (Raw.add_spec2 m.(this)). Qed.
+
+ Lemma remove_spec1 m : forall x, find x (remove x m) = None.
+ Proof. exact (Raw.remove_spec1 m.(sorted)). Qed.
+ Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. exact (Raw.remove_spec2 m.(sorted)). Qed.
+
+ Lemma bindings_spec1 m : forall x e,
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. exact (Raw.bindings_spec1 m.(this)). Qed.
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed.
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. reflexivity. Qed.
+
+ Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof. exact (Raw.fold_spec m.(this)). Qed.
+
+ Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed.
+
+End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m :
+ forall x, find x (map f m) = option_map f (find x m).
+ Proof. exact (Raw.map_spec f m.(this)). Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m :
+ forall x, exists y,
+ E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. exact (Raw.mapi_spec f m.(this)). Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+ Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). Qed.
+
+End Make.
+
+Module Make_ord (X: OrderedType)(D : OrderedType) <:
+Sord with Module Data := D
+ with Module MapS.E := X.
+
+Module Data := D.
+Module MapS := Make(X).
+Import MapS.
+
+Module MD := OrderedTypeFacts(D).
+Import MD.
+
+Definition t := MapS.t D.t.
+
+Definition cmp e e' :=
+ match D.compare e e' with Eq => true | _ => false end.
+
+Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop :=
+ match m, m' with
+ | nil, nil => True
+ | (x,e)::l, (x',e')::l' =>
+ match X.compare x x' with
+ | Eq => D.eq e e' /\ eq_list l l'
+ | _ => False
+ end
+ | _, _ => False
+ end.
+
+Definition eq m m' := eq_list m.(this) m'.(this).
+
+Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop :=
+ match m, m' with
+ | nil, nil => False
+ | nil, _ => True
+ | _, nil => False
+ | (x,e)::l, (x',e')::l' =>
+ match X.compare x x' with
+ | Lt => True
+ | Gt => False
+ | Eq => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
+ end
+ end.
+
+Definition lt m m' := lt_list m.(this) m'.(this).
+
+Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
+Proof.
+ intros (l,Hl); induction l.
+ intros (l',Hl'); unfold eq; simpl.
+ destruct l'; unfold equal; simpl; intuition.
+ intros (l',Hl'); unfold eq.
+ destruct l'.
+ destruct a; unfold equal; simpl; intuition.
+ destruct a as (x,e).
+ destruct p as (x',e').
+ unfold equal; simpl.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition.
+ unfold cmp at 1.
+ elim D.compare_spec; try MD.order; simpl.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Mk H3)).
+ unfold equal, eq in H5; simpl in H5; auto.
+ destruct (andb_prop _ _ H); clear H.
+ generalize H0; unfold cmp.
+ elim D.compare_spec; try MD.order; simpl; try discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Mk H3)).
+ unfold equal, eq in H6; simpl in H6; auto.
+Qed.
+
+Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'.
+Proof.
+ now rewrite eq_equal, equal_spec.
+Qed.
+
+Lemma eq_refl : forall m : t, eq m m.
+Proof.
+ intros (m,Hm); induction m; unfold eq; simpl; auto.
+ destruct a.
+ destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto.
+ - split. reflexivity. inversion_clear Hm. apply (IHm H).
+ - MapS.Raw.MX.order.
+ - MapS.Raw.MX.order.
+Qed.
+
+Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+Proof.
+ intros (m,Hm); induction m;
+ intros (m', Hm'); destruct m'; unfold eq; simpl;
+ try destruct a as (x,e); try destruct p as (x',e'); auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ inversion_clear Hm; inversion_clear Hm'.
+ apply (IHm H0 (Mk H4)); auto.
+Qed.
+
+Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold eq; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ now transitivity e'.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H1 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Instance eq_equiv : Equivalence eq.
+Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. Qed.
+
+Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold lt; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; transitivity e'; auto.
+ left; MD.order.
+ left; MD.order.
+ right.
+ split.
+ transitivity e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H2 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Lemma lt_irrefl : forall m, ~ lt m m.
+Proof.
+ intros (m,Hm); induction m; unfold lt; simpl; auto.
+ destruct a.
+ destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto.
+ - intuition. MD.order. inversion_clear Hm. now apply (IHm H0).
+ - MapS.Raw.MX.order.
+Qed.
+
+Instance lt_strorder : StrictOrder lt.
+Proof. split; [exact lt_irrefl|exact lt_trans]. Qed.
+
+Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m1',Hm1'); destruct m1';
+ intros (m2,Hm2); destruct m2; unfold eq, lt;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; simpl; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; MD.order.
+ right.
+ split.
+ MD.order.
+ inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2.
+ apply (IHm1 H0 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2,Hm2); destruct m2;
+ intros (m2',Hm2'); destruct m2'; unfold eq, lt;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; simpl; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; MD.order.
+ right.
+ split.
+ MD.order.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'.
+ apply (IHm1 H0 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof.
+ intros m1 m1' H1 m2 m2' H2. split; intros.
+ now apply (lt_compat2 H2), (lt_compat1 H1).
+ symmetry in H1, H2.
+ now apply (lt_compat2 H2), (lt_compat1 H1).
+Qed.
+
+Ltac cmp_solve :=
+ unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto.
+
+Fixpoint compare_list m1 m2 := match m1, m2 with
+| nil, nil => Eq
+| nil, _ => Lt
+| _, nil => Gt
+| (k1,e1)::m1, (k2,e2)::m2 =>
+ match X.compare k1 k2 with
+ | Lt => Lt
+ | Gt => Gt
+ | Eq => match D.compare e1 e2 with
+ | Lt => Lt
+ | Gt => Gt
+ | Eq => compare_list m1 m2
+ end
+ end
+end.
+
+Definition compare m1 m2 := compare_list m1.(this) m2.(this).
+
+Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2).
+Proof.
+ unfold CompSpec.
+ intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl.
+ revert m2 Hm2.
+ induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2];
+ try constructor; simpl; intros; auto.
+ elim X.compare_spec; simpl; try constructor; auto; intros.
+ elim D.compare_spec; simpl; try constructor; auto; intros.
+ inversion_clear Hm1; inversion_clear Hm2.
+ destruct (IH1 H1 _ H3); simpl; try constructor; auto.
+ elim X.compare_spec; try Raw.MX.order. right. now split.
+ elim X.compare_spec; try Raw.MX.order. now left.
+ elim X.compare_spec; try Raw.MX.order; auto.
+Qed.
+
+End Make_ord.
diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v
new file mode 100644
index 00000000..d3aab238
--- /dev/null
+++ b/theories/MMaps/MMapPositive.v
@@ -0,0 +1,698 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* x
+ | y~1 => rev_append y x~1
+ | y~0 => rev_append y x~0
+ end.
+Local Infix "@" := rev_append (at level 60).
+Definition rev x := x@1.
+
+(** The module of maps over positive keys *)
+
+Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
+
+ Module E:=PositiveOrderedTypeBits.
+ Module ME:=KeyOrderedType E.
+
+ Definition key := positive : Type.
+
+ Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p').
+
+ Definition eq_key_elt {A} (p p':key*A) :=
+ E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+ Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p').
+
+ Instance eqk_equiv {A} : Equivalence (@eq_key A) := _.
+ Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _.
+ Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _.
+
+ Inductive tree (A : Type) :=
+ | Leaf : tree A
+ | Node : tree A -> option A -> tree A -> tree A.
+
+ Arguments Leaf {A}.
+
+ Scheme tree_ind := Induction for tree Sort Prop.
+
+ Definition t := tree.
+
+ Definition empty {A} : t A := Leaf.
+
+ Section A.
+ Variable A:Type.
+
+ Fixpoint is_empty (m : t A) : bool :=
+ match m with
+ | Leaf => true
+ | Node l None r => (is_empty l) &&& (is_empty r)
+ | _ => false
+ end.
+
+ Fixpoint find (i : key) (m : t A) : option A :=
+ match m with
+ | Leaf => None
+ | Node l o r =>
+ match i with
+ | xH => o
+ | xO ii => find ii l
+ | xI ii => find ii r
+ end
+ end.
+
+ Fixpoint mem (i : key) (m : t A) : bool :=
+ match m with
+ | Leaf => false
+ | Node l o r =>
+ match i with
+ | xH => match o with None => false | _ => true end
+ | xO ii => mem ii l
+ | xI ii => mem ii r
+ end
+ end.
+
+ Fixpoint add (i : key) (v : A) (m : t A) : t A :=
+ match m with
+ | Leaf =>
+ match i with
+ | xH => Node Leaf (Some v) Leaf
+ | xO ii => Node (add ii v Leaf) None Leaf
+ | xI ii => Node Leaf None (add ii v Leaf)
+ end
+ | Node l o r =>
+ match i with
+ | xH => Node l (Some v) r
+ | xO ii => Node (add ii v l) o r
+ | xI ii => Node l o (add ii v r)
+ end
+ end.
+
+ (** helper function to avoid creating empty trees that are not leaves *)
+
+ Definition node (l : t A) (o: option A) (r : t A) : t A :=
+ match o,l,r with
+ | None,Leaf,Leaf => Leaf
+ | _,_,_ => Node l o r
+ end.
+
+ Fixpoint remove (i : key) (m : t A) : t A :=
+ match m with
+ | Leaf => Leaf
+ | Node l o r =>
+ match i with
+ | xH => node l None r
+ | xO ii => node (remove ii l) o r
+ | xI ii => node l o (remove ii r)
+ end
+ end.
+
+ (** [bindings] *)
+
+ Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) :=
+ match m with
+ | Leaf => a
+ | Node l None r => xbindings l i~0 (xbindings r i~1 a)
+ | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a)
+ end.
+
+ Definition bindings (m : t A) := xbindings m 1 nil.
+
+ (** [cardinal] *)
+
+ Fixpoint cardinal (m : t A) : nat :=
+ match m with
+ | Leaf => 0%nat
+ | Node l None r => (cardinal l + cardinal r)%nat
+ | Node l (Some _) r => S (cardinal l + cardinal r)
+ end.
+
+ (** Specification proofs *)
+
+ Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.
+ Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.
+
+ Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo.
+ Proof.
+ intros k k' Hk e e' He m m' Hm. red in Hk. now subst.
+ Qed.
+
+ Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m.
+ Proof. reflexivity. Qed.
+
+ Lemma mem_find :
+ forall m x, mem x m = match find x m with None => false | _ => true end.
+ Proof.
+ induction m; destruct x; simpl; auto.
+ Qed.
+
+ Lemma mem_spec : forall m x, mem x m = true <-> In x m.
+ Proof.
+ unfold In, MapsTo; intros m x; rewrite mem_find.
+ split.
+ - destruct (find x m).
+ exists a; auto.
+ intros; discriminate.
+ - destruct 1 as (e0,H0); rewrite H0; auto.
+ Qed.
+
+ Lemma gleaf : forall (i : key), find i Leaf = None.
+ Proof. destruct i; simpl; auto. Qed.
+
+ Theorem empty_spec:
+ forall (i: key), find i empty = None.
+ Proof. exact gleaf. Qed.
+
+ Lemma is_empty_spec m :
+ is_empty m = true <-> forall k, find k m = None.
+ Proof.
+ induction m; simpl.
+ - intuition. apply empty_spec.
+ - destruct o. split; try discriminate.
+ intros H. now specialize (H xH).
+ rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2.
+ clear IHm1 IHm2.
+ split.
+ + intros (H1,H2) k. destruct k; simpl; auto.
+ + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)).
+ Qed.
+
+ Theorem add_spec1:
+ forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x.
+ Proof.
+ intros m i; revert m.
+ induction i; destruct m; simpl; auto.
+ Qed.
+
+ Theorem add_spec2:
+ forall (m: t A) (i j: key) (x: A),
+ i <> j -> find j (add i x m) = find j m.
+ Proof.
+ intros m i j; revert m i.
+ induction j; destruct i, m; simpl; intros;
+ rewrite ?IHj, ?gleaf; auto; try congruence.
+ Qed.
+
+ Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
+ Proof. destruct i; simpl; auto. Qed.
+
+ Lemma gnode l o r i : find i (node l o r) = find i (Node l o r).
+ Proof.
+ destruct o,l,r; simpl; trivial.
+ destruct i; simpl; now rewrite ?gleaf.
+ Qed.
+
+ Opaque node.
+
+ Theorem remove_spec1:
+ forall (m: t A)(i: key), find i (remove i m) = None.
+ Proof.
+ induction m; simpl.
+ - intros; rewrite rleaf. apply gleaf.
+ - destruct i; simpl remove; rewrite gnode; simpl; auto.
+ Qed.
+
+ Theorem remove_spec2:
+ forall (m: t A)(i j: key),
+ i <> j -> find j (remove i m) = find j m.
+ Proof.
+ induction m; simpl; intros.
+ - now rewrite rleaf.
+ - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial;
+ try apply IHm1; try apply IHm2; congruence.
+ Qed.
+
+ Local Notation InL := (InA eq_key_elt).
+
+ Lemma xbindings_spec: forall m j acc k e,
+ InL (k,e) (xbindings m j acc) <->
+ InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e.
+ Proof.
+ induction m as [|l IHl o r IHr]; simpl.
+ - intros. split; intro H.
+ + now left.
+ + destruct H as [H|[x [_ H]]]. assumption.
+ now rewrite gleaf in H.
+ - intros j acc k e. case o as [e'|];
+ rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split.
+ + intros [[H|[H|H]]|H]; auto.
+ * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-).
+ right. now exists 1.
+ * destruct H as (x,(->,H)). right. now exists x~1.
+ * destruct H as (x,(->,H)). right. now exists x~0.
+ + intros [H|H]; auto.
+ destruct H as (x,(->,H)).
+ destruct x; simpl in *.
+ * left. right. right. now exists x.
+ * right. now exists x.
+ * left. left. injection H as ->. reflexivity.
+ + intros [[H|H]|H]; auto.
+ * destruct H as (x,(->,H)). right. now exists x~1.
+ * destruct H as (x,(->,H)). right. now exists x~0.
+ + intros [H|H]; auto.
+ destruct H as (x,(->,H)).
+ destruct x; simpl in *.
+ * left. right. now exists x.
+ * right. now exists x.
+ * discriminate.
+ Qed.
+
+ Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
+ Proof. induction j; intros; simpl; auto. Qed.
+
+ Lemma xbindings_sort m j acc :
+ sort lt_key acc ->
+ (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) ->
+ sort lt_key (xbindings m j acc).
+ Proof.
+ revert j acc.
+ induction m as [|l IHl o r IHr]; simpl; trivial.
+ intros j acc Hacc Hsacc. destruct o as [e|].
+ - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|].
+ + intros. now apply Hsacc.
+ + case_eq (xbindings r j~1 acc); [constructor|].
+ intros (z,e') q H. constructor.
+ assert (H': InL (z,e') (xbindings r j~1 acc)).
+ { rewrite H. now constructor. }
+ clear H q. rewrite xbindings_spec in H'.
+ destruct H' as [H'|H'].
+ * apply (Hsacc 1 (z,e')); trivial. now exists e.
+ * destruct H' as (x,(->,H)).
+ red. simpl. now apply lt_rev_append.
+ + intros x (y,e') Hx Hy. inversion_clear Hy.
+ rewrite H. simpl. now apply lt_rev_append.
+ rewrite xbindings_spec in H.
+ destruct H as [H|H].
+ * now apply Hsacc.
+ * destruct H as (z,(->,H)). simpl.
+ now apply lt_rev_append.
+ - apply IHl; [apply IHr; [apply Hacc|]|].
+ + intros. now apply Hsacc.
+ + intros x (y,e') Hx H. rewrite xbindings_spec in H.
+ destruct H as [H|H].
+ * now apply Hsacc.
+ * destruct H as (z,(->,H)). simpl.
+ now apply lt_rev_append.
+ Qed.
+
+ Lemma bindings_spec1 m k e :
+ InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m.
+ Proof.
+ unfold bindings, MapsTo. rewrite xbindings_spec.
+ split; [ intros [H|(y & H & H')] | intros IN ].
+ - inversion H.
+ - simpl in *. now subst.
+ - right. now exists k.
+ Qed.
+
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof.
+ unfold bindings.
+ apply xbindings_sort. constructor. inversion 2.
+ Qed.
+
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof.
+ apply ME.Sort_NoDupA.
+ apply bindings_spec2.
+ Qed.
+
+ Lemma xbindings_length m j acc :
+ length (xbindings m j acc) = (cardinal m + length acc)%nat.
+ Proof.
+ revert j acc.
+ induction m; simpl; trivial; intros.
+ destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2;
+ now rewrite ?Nat.add_succ_r, Nat.add_assoc.
+ Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof.
+ unfold bindings. rewrite xbindings_length. simpl.
+ symmetry. apply Nat.add_0_r.
+ Qed.
+
+ (** [map] and [mapi] *)
+
+ Variable B : Type.
+
+ Section Mapi.
+
+ Variable f : key -> option A -> option B.
+
+ Fixpoint xmapi (m : t A) (i : key) : t B :=
+ match m with
+ | Leaf => Leaf
+ | Node l o r => Node (xmapi l (i~0))
+ (f (rev i) o)
+ (xmapi r (i~1))
+ end.
+
+ End Mapi.
+
+ Definition mapi (f : key -> A -> B) m :=
+ xmapi (fun k => option_map (f k)) m 1.
+
+ Definition map (f : A -> B) m := mapi (fun _ => f) m.
+
+ End A.
+
+ Lemma xgmapi:
+ forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A),
+ (forall k, f k None = None) ->
+ find i (xmapi f m j) = f (j@i) (find i m).
+ Proof.
+ induction i; intros; destruct m; simpl; rewrite ?IHi; auto.
+ Qed.
+
+ Theorem mapi_spec0 :
+ forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A),
+ find i (mapi f m) = option_map (f i) (find i m).
+ Proof.
+ intros. unfold mapi. rewrite xgmapi; simpl; auto.
+ Qed.
+
+ Lemma mapi_spec :
+ forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key),
+ exists j, E.eq j i /\
+ find i (mapi f m) = option_map (f j) (find i m).
+ Proof.
+ intros.
+ exists i. split. reflexivity. apply mapi_spec0.
+ Qed.
+
+ Lemma map_spec :
+ forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key),
+ find x (map f m) = option_map f (find x m).
+ Proof.
+ intros; unfold map. apply mapi_spec0.
+ Qed.
+
+ Section merge.
+ Variable A B C : Type.
+ Variable f : key -> option A -> option B -> option C.
+
+ Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C :=
+ match m1 with
+ | Leaf => xmapi (fun k => f k None) m2 i
+ | Node l1 o1 r1 =>
+ match m2 with
+ | Leaf => xmapi (fun k o => f k o None) m1 i
+ | Node l2 o2 r2 =>
+ Node (xmerge l1 l2 (i~0))
+ (f (rev i) o1 o2)
+ (xmerge r1 r2 (i~1))
+ end
+ end.
+
+ Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B),
+ (forall i, f i None None = None) ->
+ find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2).
+ Proof.
+ induction i; intros; destruct m1; destruct m2; simpl; auto;
+ rewrite ?xgmapi, ?IHi; simpl; auto.
+ Qed.
+
+ End merge.
+
+ Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 :=
+ xmerge
+ (fun k o1 o2 => match o1,o2 with
+ | None,None => None
+ | _, _ => f k o1 o2
+ end)
+ m1 m2 xH.
+
+ Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) :
+ forall m m' x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+ Proof.
+ intros. exists x. split. reflexivity.
+ unfold merge.
+ rewrite xgmerge; simpl; auto.
+ rewrite <- 2 mem_spec, 2 mem_find in H.
+ destruct (find x m); simpl; auto.
+ destruct (find x m'); simpl; auto. intuition discriminate.
+ Qed.
+
+ Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) :
+ forall m m' x, In x (merge f m m') -> In x m \/ In x m'.
+ Proof.
+ intros.
+ rewrite <-mem_spec, mem_find in H.
+ unfold merge in H.
+ rewrite xgmerge in H; simpl; auto.
+ rewrite <- 2 mem_spec, 2 mem_find.
+ destruct (find x m); simpl in *; auto.
+ destruct (find x m'); simpl in *; auto.
+ Qed.
+
+ Section Fold.
+
+ Variables A B : Type.
+ Variable f : key -> A -> B -> B.
+
+ (** the additional argument, [i], records the current path, in
+ reverse order (this should be more efficient: we reverse this argument
+ only at present nodes only, rather than at each node of the tree).
+ we also use this convention in all functions below
+ *)
+
+ Fixpoint xfold (m : t A) (v : B) (i : key) :=
+ match m with
+ | Leaf => v
+ | Node l (Some x) r =>
+ xfold r (f (rev i) x (xfold l v i~0)) i~1
+ | Node l None r =>
+ xfold r (xfold l v i~0) i~1
+ end.
+ Definition fold m i := xfold m i 1.
+
+ End Fold.
+
+ Lemma fold_spec :
+ forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof.
+ unfold fold, bindings. intros A m B i f. revert m i.
+ set (f' := fun a p => f (fst p) (snd p) a).
+ assert (H: forall m i j acc,
+ fold_left f' acc (xfold f m i j) =
+ fold_left f' (xbindings m j acc) i).
+ { induction m as [|l IHl o r IHr]; intros; trivial.
+ destruct o; simpl; now rewrite IHr, <- IHl. }
+ intros. exact (H m i 1 nil).
+ Qed.
+
+ Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
+ match m1, m2 with
+ | Leaf, _ => is_empty m2
+ | _, Leaf => is_empty m1
+ | Node l1 o1 r1, Node l2 o2 r2 =>
+ (match o1, o2 with
+ | None, None => true
+ | Some v1, Some v2 => cmp v1 v2
+ | _, _ => false
+ end)
+ &&& equal cmp l1 l2 &&& equal cmp r1 r2
+ end.
+
+ Definition Equal (A:Type)(m m':t A) :=
+ forall y, find y m = find y m'.
+ Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).
+
+ Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+ Equivb cmp m m' -> equal cmp m m' = true.
+ Proof.
+ induction m.
+ - (* m = Leaf *)
+ destruct 1 as (E,_); simpl.
+ apply is_empty_spec; intros k.
+ destruct (find k m') eqn:F; trivial.
+ assert (H : In k m') by now exists a.
+ rewrite <- E in H.
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ - (* m = Node *)
+ destruct m'.
+ + (* m' = Leaf *)
+ destruct 1 as (E,_); simpl.
+ destruct o.
+ * assert (H : In xH (@Leaf A)).
+ { rewrite <- E. now exists a. }
+ destruct H as (e,H). now red in H.
+ * apply andb_true_intro; split; apply is_empty_spec; intros k.
+ destruct (find k m1) eqn:F; trivial.
+ assert (H : In (xO k) (@Leaf A)).
+ { rewrite <- E. exists a; auto. }
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ destruct (find k m2) eqn:F; trivial.
+ assert (H : In (xI k) (@Leaf A)).
+ { rewrite <- E. exists a; auto. }
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ + (* m' = Node *)
+ destruct 1.
+ assert (Equivb cmp m1 m'1).
+ { split.
+ intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
+ intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. }
+ assert (Equivb cmp m2 m'2).
+ { split.
+ intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
+ intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. }
+ simpl.
+ destruct o; destruct o0; simpl.
+ repeat (apply andb_true_intro; split); auto.
+ apply (H0 xH); red; auto.
+ generalize (H xH); unfold In, MapsTo; simpl; intuition.
+ destruct H4; try discriminate; eauto.
+ generalize (H xH); unfold In, MapsTo; simpl; intuition.
+ destruct H5; try discriminate; eauto.
+ apply andb_true_intro; split; auto.
+ Qed.
+
+ Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+ equal cmp m m' = true -> Equivb cmp m m'.
+ Proof.
+ induction m.
+ (* m = Leaf *)
+ simpl.
+ split; intros.
+ split.
+ destruct 1; red in H0; destruct k; discriminate.
+ rewrite is_empty_spec in H.
+ intros (e,H'). red in H'. now rewrite H in H'.
+ red in H0; destruct k; discriminate.
+ (* m = Node *)
+ destruct m'.
+ (* m' = Leaf *)
+ simpl.
+ destruct o; intros; try discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ split; intros.
+ split; unfold In, MapsTo; destruct 1.
+ destruct k; simpl in *; try discriminate.
+ rewrite is_empty_spec in H1.
+ now rewrite H1 in H.
+ rewrite is_empty_spec in H0.
+ now rewrite H0 in H.
+ destruct k; simpl in *; discriminate.
+ unfold In, MapsTo; destruct k; simpl in *; discriminate.
+ (* m' = Node *)
+ destruct o; destruct o0; simpl; intros; try discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ destruct (andb_prop _ _ H0); clear H0.
+ destruct (IHm1 _ _ H2); clear H2 IHm1.
+ destruct (IHm2 _ _ H1); clear H1 IHm2.
+ split; intros.
+ destruct k; unfold In, MapsTo in *; simpl; auto.
+ split; eauto.
+ destruct k; unfold In, MapsTo in *; simpl in *.
+ eapply H4; eauto.
+ eapply H3; eauto.
+ congruence.
+ destruct (andb_prop _ _ H); clear H.
+ destruct (IHm1 _ _ H0); clear H0 IHm1.
+ destruct (IHm2 _ _ H1); clear H1 IHm2.
+ split; intros.
+ destruct k; unfold In, MapsTo in *; simpl; auto.
+ split; eauto.
+ destruct k; unfold In, MapsTo in *; simpl in *.
+ eapply H3; eauto.
+ eapply H2; eauto.
+ try discriminate.
+ Qed.
+
+ Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+ equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof.
+ split. apply equal_2. apply equal_1.
+ Qed.
+
+End PositiveMap.
+
+(** Here come some additionnal facts about this implementation.
+ Most are facts that cannot be derivable from the general interface. *)
+
+Module PositiveMapAdditionalFacts.
+ Import PositiveMap.
+
+ (* Derivable from the Map interface *)
+ Theorem gsspec {A} i j x (m: t A) :
+ find i (add j x m) = if E.eq_dec i j then Some x else find i m.
+ Proof.
+ destruct (E.eq_dec i j) as [->|];
+ [ apply add_spec1 | apply add_spec2; auto ].
+ Qed.
+
+ (* Not derivable from the Map interface *)
+ Theorem gsident {A} i (m:t A) v :
+ find i m = Some v -> add i v m = m.
+ Proof.
+ revert m.
+ induction i; destruct m; simpl in *; try congruence.
+ - intro H; now rewrite (IHi m2 H).
+ - intro H; now rewrite (IHi m1 H).
+ Qed.
+
+ Lemma xmapi_ext {A B}(f g: key -> option A -> option B) :
+ (forall k (o : option A), f k o = g k o) ->
+ forall m i, xmapi f m i = xmapi g m i.
+ Proof.
+ induction m; intros; simpl; auto. now f_equal.
+ Qed.
+
+ Theorem xmerge_commut{A B C}
+ (f: key -> option A -> option B -> option C)
+ (g: key -> option B -> option A -> option C) :
+ (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
+ forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i.
+ Proof.
+ intros E.
+ induction m1; destruct m2; intros i; simpl; trivial; f_equal;
+ try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext;
+ intros; apply E.
+ Qed.
+
+ Theorem merge_commut{A B C}
+ (f: key -> option A -> option B -> option C)
+ (g: key -> option B -> option A -> option C) :
+ (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
+ forall m1 m2, merge f m1 m2 = merge g m2 m1.
+ Proof.
+ intros E m1 m2.
+ unfold merge. apply xmerge_commut.
+ intros k [x1|] [x2|]; trivial.
+ Qed.
+
+End PositiveMapAdditionalFacts.
diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v
new file mode 100644
index 00000000..656c61e1
--- /dev/null
+++ b/theories/MMaps/MMapWeakList.v
@@ -0,0 +1,687 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* a = a'.
+Proof. split; congruence. Qed.
+
+Module Raw (X:DecidableType).
+
+Module Import PX := KeyDecidableType X.
+
+Definition key := X.t.
+Definition t (elt:Type) := list (X.t * elt).
+
+Ltac dec := match goal with
+ | |- context [ X.eq_dec ?x ?x ] =>
+ let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E]
+ | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E]
+ | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ]
+ | |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [E|E]
+end.
+
+Section Elt.
+
+Variable elt : Type.
+Notation NoDupA := (@NoDupA _ eqk).
+
+(** * [find] *)
+
+Fixpoint find (k:key) (s: t elt) : option elt :=
+ match s with
+ | nil => None
+ | (k',x)::s' => if X.eq_dec k k' then Some x else find k s'
+ end.
+
+Lemma find_spec : forall m (Hm:NoDupA m) x e,
+ find x m = Some e <-> MapsTo x e m.
+Proof.
+ unfold PX.MapsTo.
+ induction m as [ | (k,e) m IH]; simpl.
+ - split; inversion 1.
+ - intros Hm k' e'. rewrite InA_cons.
+ change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e).
+ inversion_clear Hm. dec.
+ + rewrite Some_iff; intuition.
+ elim H. apply InA_eqk with (k',e'); auto.
+ + rewrite IH; intuition.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (s : t elt) : bool :=
+ match s with
+ | nil => false
+ | (k',_) :: l => if X.eq_dec k k' then true else mem k l
+ end.
+
+Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m.
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; intros Hm x.
+ - split. discriminate. inversion_clear 1. inversion H0.
+ - inversion_clear Hm. rewrite PX.In_cons; simpl.
+ rewrite <- IH by trivial.
+ dec; intuition.
+Qed.
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Lemma empty_spec x : find x empty = None.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma empty_NoDup : NoDupA empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m; simpl; intuition; try discriminate.
+ specialize (H a).
+ revert H. now dec.
+Qed.
+
+(* Not part of the exported specifications, used later for [merge]. *)
+
+Lemma find_eq : forall m (Hm:NoDupA m) x x',
+ X.eq x x' -> find x m = find x' m.
+Proof.
+ induction m; simpl; auto; destruct a; intros.
+ inversion_clear Hm.
+ rewrite (IHm H1 x x'); auto.
+ dec; dec; trivial.
+ elim E0. now transitivity x.
+ elim E. now transitivity x'.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) : t elt :=
+ match s with
+ | nil => (k,x) :: nil
+ | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l
+ end.
+
+Lemma add_spec1 m x e : find x (add x e m) = Some e.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl.
+ - now dec.
+ - dec; simpl; now dec.
+Qed.
+
+Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m.
+Proof.
+ intros N.
+ assert (N' : ~X.eq y x) by now contradict N.
+ induction m as [ | (k,e') m IH]; simpl.
+ - dec; trivial.
+ - repeat (dec; simpl); trivial. elim N. now transitivity k.
+Qed.
+
+Lemma add_InA : forall m x y e e',
+ ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; intros.
+ - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1.
+ - revert H0; dec; rewrite !InA_cons.
+ + rewrite E. intuition.
+ + intuition. right; eapply IH; eauto.
+Qed.
+
+Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m).
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; intros Hm x e.
+ - constructor; auto. now inversion 1.
+ - inversion_clear Hm. dec; constructor; auto.
+ + contradict H. apply InA_eqk with (x,e); auto.
+ + contradict H; apply add_InA with x e; auto.
+Qed.
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) : t elt :=
+ match s with
+ | nil => nil
+ | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
+ end.
+
+Lemma remove_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ repeat (dec; simpl); auto.
+ destruct (find x m) eqn:F; trivial.
+ apply find_spec in F; trivial.
+ elim H. apply InA_eqk with (x,e); auto.
+Qed.
+
+Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y ->
+ find y (remove x m) = find y m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial; intros E.
+ inversion_clear Hm.
+ repeat (dec; simpl); auto.
+ elim E. now transitivity k.
+Qed.
+
+Lemma remove_InA : forall m (Hm:NoDupA m) x y e,
+ InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial; intros.
+ inversion_clear Hm.
+ revert H; dec; rewrite !InA_cons; intuition.
+ right; eapply H; eauto.
+Qed.
+
+Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ inversion_clear Hm.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); auto.
+ constructor; auto.
+ contradict H; apply remove_InA with x; auto.
+Qed.
+
+(** * [bindings] *)
+
+Definition bindings (m: t elt) := m.
+
+Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m).
+Proof.
+ trivial.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A :=
+ match m with
+ | nil => acc
+ | (k,e)::m' => fold f m' (f k e acc)
+ end.
+
+Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; auto.
+Qed.
+
+(** * [equal] *)
+
+Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) :=
+ match find k m' with
+ | None => false
+ | Some e' => cmp e e'
+ end.
+
+Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+ fold (fun k e b => andb (check cmp k e m') b) m true.
+
+Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+ andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m).
+
+Definition Submap (cmp:elt->elt->bool) m m' :=
+ (forall k, In k m -> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Definition Equivb (cmp:elt->elt->bool) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+ Submap cmp m m' -> submap cmp m m' = true.
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ destruct a; simpl; intros.
+ destruct H.
+ inversion_clear Hm.
+ assert (H3 : In t0 m').
+ { apply H; exists e; auto with *. }
+ destruct H3 as (e', H3).
+ assert (H4 : find t0 m' = Some e') by now apply find_spec.
+ unfold check at 2. rewrite H4.
+ rewrite (H0 t0); simpl; auto with *.
+ eapply IHm; auto.
+ split; intuition.
+ apply H.
+ destruct H6 as (e'',H6); exists e''; auto.
+ apply H0 with k; auto.
+Qed.
+
+Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+ submap cmp m m' = true -> Submap cmp m m'.
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ intuition.
+ destruct H0; inversion H0.
+ inversion H0.
+
+ destruct a; simpl; intros.
+ inversion_clear Hm.
+ rewrite andb_b_true in H.
+ assert (check cmp t0 e m' = true).
+ clear H1 H0 Hm' IHm.
+ set (b:=check cmp t0 e m') in *.
+ generalize H; clear H; generalize b; clear b.
+ induction m; simpl; auto; intros.
+ destruct a; simpl in *.
+ destruct (andb_prop _ _ (IHm _ H)); auto.
+ rewrite H2 in H.
+ destruct (IHm H1 m' Hm' cmp H); auto.
+ unfold check in H2.
+ case_eq (find t0 m'); [intros e' H5 | intros H5];
+ rewrite H5 in H2; try discriminate.
+ split; intros.
+ destruct H6 as (e0,H6); inversion_clear H6.
+ compute in H7; destruct H7; subst.
+ exists e'.
+ apply PX.MapsTo_eq with t0; auto with *.
+ apply find_spec; auto.
+ apply H3.
+ exists e0; auto.
+ inversion_clear H6.
+ compute in H8; destruct H8; subst.
+ assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. }
+ apply find_spec in H8; trivial. congruence.
+ apply H4 with k; auto.
+Qed.
+
+(** Specification of [equal] *)
+
+Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+ equal cmp m m' = true <-> Equivb cmp m m'.
+Proof.
+ unfold Equivb, equal.
+ split.
+ - intros.
+ destruct (andb_prop _ _ H); clear H.
+ generalize (submap_2 Hm Hm' H0).
+ generalize (submap_2 Hm' Hm H1).
+ firstorder.
+ - intuition.
+ apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
+Qed.
+End Elt.
+Section Elt2.
+Variable elt elt' : Type.
+
+(** * [map] and [mapi] *)
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
+ match m with
+ | nil => nil
+ | (k,e)::m' => (k,f e) :: map f m'
+ end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
+ match m with
+ | nil => nil
+ | (k,e)::m' => (k,f k e) :: mapi f m'
+ end.
+
+(** Specification of [map] *)
+
+Lemma map_spec (f:elt->elt')(m:t elt)(x:key) :
+ find x (map f m) = option_map f (find x m).
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; trivial.
+ dec; simpl; trivial.
+Qed.
+
+Lemma map_NoDup m (Hm : NoDupA (@eqk elt) m)(f:elt->elt') :
+ NoDupA (@eqk elt') (map f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ contradict H.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion H.
+ destruct a; inversion H; auto.
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) :
+ exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; trivial.
+ - now exists x.
+ - dec; simpl.
+ + now exists k.
+ + destruct IH as (y,(Hy,H)). now exists y.
+Qed.
+
+Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'),
+ NoDupA (@eqk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+ constructor; auto.
+ contradict H.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion_clear H.
+ destruct a; inversion_clear H; auto.
+Qed.
+
+End Elt2.
+
+Lemma mapfst_InA {elt}(m:t elt) x :
+ InA X.eq x (List.map fst m) <-> In x m.
+Proof.
+ induction m as [| (k,e) m IH]; simpl; auto.
+ - split; inversion 1. inversion H0.
+ - rewrite InA_cons, In_cons. simpl. now rewrite IH.
+Qed.
+
+Lemma mapfst_NoDup {elt}(m:t elt) :
+ NoDupA X.eq (List.map fst m) <-> NoDupA eqk m.
+Proof.
+ induction m as [| (k,e) m IH]; simpl.
+ - split; constructor.
+ - split; inversion_clear 1; constructor; try apply IH; trivial.
+ + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto.
+ + rewrite mapfst_InA. contradict H0. now apply In_alt'.
+Qed.
+
+Lemma filter_NoDup f (m:list key) :
+ NoDupA X.eq m -> NoDupA X.eq (List.filter f m).
+Proof.
+ induction 1; simpl.
+ - constructor.
+ - destruct (f x); trivial. constructor; trivial.
+ contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)).
+ exists y; split; trivial. now rewrite filter_In in H.
+Qed.
+
+Lemma NoDupA_unique_repr (l:list key) x y :
+ NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y.
+Proof.
+ intros H E Hx Hy.
+ induction H; simpl in *.
+ - inversion Hx.
+ - intuition; subst; trivial.
+ elim H. apply InA_alt. now exists y.
+ elim H. apply InA_alt. now exists x.
+Qed.
+
+Section Elt3.
+
+Variable elt elt' elt'' : Type.
+
+Definition restrict (m:t elt)(k:key) :=
+ match find k m with
+ | None => true
+ | Some _ => false
+ end.
+
+Definition domains (m:t elt)(m':t elt') :=
+ List.map fst m ++ List.filter (restrict m) (List.map fst m').
+
+Lemma domains_InA m m' (Hm : NoDupA eqk m) x :
+ InA X.eq x (domains m m') <-> In x m \/ In x m'.
+Proof.
+ unfold domains.
+ assert (Proper (X.eq==>eq) (restrict m)).
+ { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). }
+ rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition.
+ unfold restrict.
+ destruct (find x m) eqn:F.
+ - left. apply find_spec in F; trivial. now exists e.
+ - now right.
+Qed.
+
+Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' ->
+ NoDupA X.eq (domains m m').
+Proof.
+ intros Hm Hm'. unfold domains.
+ apply NoDupA_app; auto with *.
+ - now apply mapfst_NoDup.
+ - now apply filter_NoDup, mapfst_NoDup.
+ - intros x.
+ rewrite mapfst_InA. intros (e,H).
+ apply find_spec in H; trivial.
+ rewrite InA_alt. intros (y,(Hy,H')).
+ rewrite (find_eq Hm Hy) in H.
+ rewrite filter_In in H'. destruct H' as (_,H').
+ unfold restrict in H'. now rewrite H in H'.
+Qed.
+
+Fixpoint fold_keys (f:key->option elt'') l :=
+ match l with
+ | nil => nil
+ | k::l =>
+ match f k with
+ | Some e => (k,e)::fold_keys f l
+ | None => fold_keys f l
+ end
+ end.
+
+Lemma fold_keys_In f l x e :
+ List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e.
+Proof.
+ induction l as [|k l IH]; simpl.
+ - intuition.
+ - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition;
+ try left; congruence.
+Qed.
+
+Lemma fold_keys_NoDup f l :
+ NoDupA X.eq l -> NoDupA eqk (fold_keys f l).
+Proof.
+ induction 1; simpl.
+ - constructor.
+ - destruct (f x); trivial.
+ constructor; trivial. contradict H.
+ apply InA_alt in H. destruct H as ((k,e'),(E,H)).
+ rewrite fold_keys_In in H.
+ apply InA_alt. exists k. now split.
+Qed.
+
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition merge m m' : t elt'' :=
+ fold_keys (fun k => f k (find k m) (find k m')) (domains m m').
+
+Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') :
+ NoDupA (@eqk elt'') (merge m m').
+Proof.
+ now apply fold_keys_NoDup, domains_NoDup.
+Qed.
+
+Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x :
+ In x m \/ In x m' ->
+ exists y:key, X.eq y x /\
+ find x (merge m m') = f y (find x m) (find x m').
+Proof.
+ assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup.
+ rewrite <- domains_InA; trivial.
+ rewrite InA_alt. intros (y,(Hy,H)).
+ exists y; split; [easy|].
+ rewrite (find_eq Hm Hy), (find_eq Hm' Hy).
+ destruct (f y (find y m) (find y m')) eqn:F.
+ - apply find_spec; trivial.
+ red. apply InA_alt. exists (y,e). split. now split.
+ unfold merge. apply fold_keys_In. now split.
+ - destruct (find x (merge m m')) eqn:F'; trivial.
+ rewrite <- F; clear F. symmetry.
+ apply find_spec in F'; trivial.
+ red in F'. rewrite InA_alt in F'.
+ destruct F' as ((y',e'),(E,F')).
+ unfold merge in F'; rewrite fold_keys_In in F'.
+ destruct F' as (H',F').
+ compute in E; destruct E as (Hy',<-).
+ replace y with y'; trivial.
+ apply (@NoDupA_unique_repr (domains m m')); auto.
+ now apply domains_NoDup.
+ now transitivity x.
+Qed.
+
+Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x :
+ In x (merge m m') -> In x m \/ In x m'.
+Proof.
+ rewrite <- domains_InA; trivial.
+ intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)).
+ unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_).
+ apply InA_alt. exists k. split; trivial. now destruct E.
+Qed.
+
+End Elt3.
+End Raw.
+
+
+Module Make (X: DecidableType) <: WS with Module E:=X.
+ Module Raw := Raw X.
+
+ Module E := X.
+ Definition key := E.t.
+ Definition eq_key {elt} := @Raw.PX.eqk elt.
+ Definition eq_key_elt {elt} := @Raw.PX.eqke elt.
+
+ Record t_ (elt:Type) := Mk
+ {this :> Raw.t elt;
+ nodup : NoDupA Raw.PX.eqk this}.
+ Definition t := t_.
+
+ Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt).
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e).
+ Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x).
+ Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (Raw.mapi_NoDup m.(nodup) f).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := length m.(this).
+ Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp m m' : Prop := Raw.Equivb cmp m.(this) m'.(this).
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx.
+ Qed.
+
+ Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m.
+ Proof. exact (Raw.find_spec m.(nodup)). Qed.
+
+ Lemma mem_spec m : forall x, mem x m = true <-> In x m.
+ Proof. exact (Raw.mem_spec m.(nodup)). Qed.
+
+ Lemma empty_spec : forall x, find x empty = None.
+ Proof. exact (Raw.empty_spec _). Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None).
+ Proof. exact (Raw.is_empty_spec m.(this)). Qed.
+
+ Lemma add_spec1 m : forall x e, find x (add x e m) = Some e.
+ Proof. exact (Raw.add_spec1 m.(this)). Qed.
+ Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m.
+ Proof. exact (Raw.add_spec2 m.(this)). Qed.
+
+ Lemma remove_spec1 m : forall x, find x (remove x m) = None.
+ Proof. exact (Raw.remove_spec1 m.(nodup)). Qed.
+ Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. exact (Raw.remove_spec2 m.(nodup)). Qed.
+
+ Lemma bindings_spec1 m : forall x e,
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. exact (Raw.bindings_spec1 m.(this)). Qed.
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. reflexivity. Qed.
+
+ Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof. exact (Raw.fold_spec m.(this)). Qed.
+
+ Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed.
+
+End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m :
+ forall x, find x (map f m) = option_map f (find x m).
+ Proof. exact (Raw.map_spec f m.(this)). Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m :
+ forall x, exists y,
+ E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. exact (Raw.mapi_spec f m.(this)). Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+ Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed.
+
+End Make.
diff --git a/theories/MMaps/MMaps.v b/theories/MMaps/MMaps.v
new file mode 100644
index 00000000..054d0722
--- /dev/null
+++ b/theories/MMaps/MMaps.v
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* assert_false l x r
| Node _ ll lx lr =>
- if ge_lt_dec (height ll) (height lr) then
+ if (height lr) <=? (height ll) then
create ll lx (create lr x r)
else
match lr with
@@ -97,11 +97,11 @@ Definition bal l x r :=
end
end
else
- if gt_le_dec hr (hl+2) then
+ if (hl+2) hr then
match r with
| Leaf => assert_false l x r
| Node _ rl rx rr =>
- if ge_lt_dec (height rr) (height rl) then
+ if (height rl) <=? (height rr) then
create (create l x rl) rx rr
else
match rl with
@@ -138,8 +138,8 @@ Fixpoint join l : elt -> t -> t :=
fix join_aux (r:t) : t := match r with
| Leaf => add x l
| Node rh rl rx rr =>
- if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
- else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
+ if (rh+2) lh then bal ll lx (join lr x r)
+ else if (lh+2) rh then bal (join_aux rl) rx rr
else create l x r
end
end.
@@ -419,12 +419,12 @@ Local Open Scope Int_scope.
Ltac join_tac :=
intro l; induction l as [| lh ll _ lx lr Hlr];
[ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
- [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE];
+ [ | destruct ((rh+2) lh) eqn:LT;
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto]
end
- | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
+ | destruct ((lh+2) rh) eqn:LT';
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v
index 25a8c162..8dd240f4 100644
--- a/theories/MSets/MSetPositive.v
+++ b/theories/MSets/MSetPositive.v
@@ -16,79 +16,13 @@
Sandrine Blazy (used for building certified compilers).
*)
-Require Import Bool BinPos Orders MSetInterface.
+Require Import Bool BinPos Orders OrdersEx MSetInterface.
Set Implicit Arguments.
Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.
-(** Even if [positive] can be seen as an ordered type with respect to the
- usual order (see above), we can also use a lexicographic order over bits
- (lower bits are considered first). This is more natural when using
- [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)
-
-Module PositiveOrderedTypeBits <: UsualOrderedType.
- Definition t:=positive.
- Include HasUsualEq <+ UsualIsEq.
- Definition eqb := Pos.eqb.
- Definition eqb_eq := Pos.eqb_eq.
- Include HasEqBool2Dec.
-
- Fixpoint bits_lt (p q:positive) : Prop :=
- match p, q with
- | xH, xI _ => True
- | xH, _ => False
- | xO p, xO q => bits_lt p q
- | xO _, _ => True
- | xI p, xI q => bits_lt p q
- | xI _, _ => False
- end.
-
- Definition lt:=bits_lt.
-
- Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
- Proof.
- induction x; simpl; auto.
- Qed.
-
- Lemma bits_lt_trans :
- forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
- Proof.
- induction x; destruct y,z; simpl; eauto; intuition.
- Qed.
-
- Instance lt_compat : Proper (eq==>eq==>iff) lt.
- Proof.
- intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
- Qed.
-
- Instance lt_strorder : StrictOrder lt.
- Proof.
- split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
- Qed.
-
- Fixpoint compare x y :=
- match x, y with
- | x~1, y~1 => compare x y
- | x~1, _ => Gt
- | x~0, y~0 => compare x y
- | x~0, _ => Lt
- | 1, y~1 => Lt
- | 1, 1 => Eq
- | 1, y~0 => Gt
- end.
-
- Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
- Proof.
- unfold eq, lt.
- induction x; destruct y; try constructor; simpl; auto.
- destruct (IHx y); subst; auto.
- destruct (IHx y); subst; auto.
- Qed.
-
-End PositiveOrderedTypeBits.
-
Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
Module E:=PositiveOrderedTypeBits.
@@ -303,12 +237,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Node l true r => S (cardinal l + cardinal r)
end.
- Definition omap (f: elt -> elt) x :=
- match x with
- | None => None
- | Some i => Some (f i)
- end.
-
(** would it be more efficient to use a path like in the above functions ? *)
Fixpoint choose (m: t) : option elt :=
@@ -316,7 +244,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r => if o then Some 1 else
match choose l with
- | None => omap xI (choose r)
+ | None => option_map xI (choose r)
| Some i => Some i~0
end
end.
@@ -326,7 +254,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r =>
match min_elt l with
- | None => if o then Some 1 else omap xI (min_elt r)
+ | None => if o then Some 1 else option_map xI (min_elt r)
| Some i => Some i~0
end
end.
@@ -336,7 +264,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r =>
match max_elt r with
- | None => if o then Some 1 else omap xO (max_elt l)
+ | None => if o then Some 1 else option_map xO (max_elt l)
| Some i => Some i~1
end
end.
@@ -967,7 +895,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
Proof.
intro. apply SortA_NoDupA with E.lt; auto with *.
- apply E.eq_equiv.
apply elements_spec2.
Qed.
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index a9aa30df..ae6fe7dd 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -426,8 +426,9 @@ Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.
(** A variant where generalized variables should be given by the user. *)
Ltac do_depelim' rev tac H :=
- (try intros until H) ; block_goal ; rev H ;
- (try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim.
+ (try intros until H) ; block_goal ;
+ (try revert_until H ; block_goal) ;
+ generalize_eqs H ; rev H ; tac H ; simpl_dep_elim.
(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
By default, we don't try to generalize the hyp by its variable indices. *)
@@ -463,3 +464,9 @@ Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) :
Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H.
+
+Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) :=
+ do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l) H.
+
+Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) "using" constr(c) :=
+ do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l using c) H.
diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v
index e39128cb..65fe8780 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** Various syntaxic shortands that are useful with [Program]. *)
+(** Various syntactic shorthands that are useful with [Program]. *)
Require Export Coq.Program.Tactics.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index e848e4df..011328ec 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -572,6 +572,7 @@ Lemma Alembert_C6 :
(forall n:nat, An n <> 0) ->
Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
Rabs x < / k -> { l:R | Pser An x l }.
+Proof.
intros.
cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }.
intro X.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index f5b34de9..6d30319c 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -10,7 +10,7 @@ Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
-Require Import Omega.
+Require Import OmegaTactic.
Local Open Scope R_scope.
Definition A1 (x:R) (N:nat) : R :=
@@ -50,6 +50,7 @@ Theorem cos_plus_form :
forall (x y:R) (n:nat),
(0 < n)%nat ->
A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
+Proof.
intros.
unfold A1, B1.
rewrite
@@ -251,12 +252,14 @@ apply lt_O_Sn.
Qed.
Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
+Proof.
intros.
assert (H := pow_Rsqr x i).
unfold Rsqr in H; exact H.
Qed.
Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
+Proof.
intro.
unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p).
unfold cos_in, cos_n, infinite_sum, R_dist in p.
@@ -276,6 +279,7 @@ apply pow_sqr.
Qed.
Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
+Proof.
intros.
unfold cos.
destruct (exist_cos (Rsqr (x + y))) as (x0,p).
@@ -298,6 +302,7 @@ apply pow_sqr.
Qed.
Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
+Proof.
intro.
case (Req_dec x 0); intro.
rewrite H.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index 30a26f77..94b881cc 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -24,6 +24,7 @@ Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
Lemma Boule_convex : forall c d x y z,
Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z.
+Proof.
intros c d x y z bx b_y intz.
unfold Boule in bx, b_y; apply Rabs_def2 in bx;
apply Rabs_def2 in b_y; apply Rabs_def1;
@@ -33,6 +34,7 @@ Qed.
Definition boule_of_interval x y (h : x < y) :
{c :R & {r : posreal | c - r = x /\ c + r = y}}.
+Proof.
exists ((x + y)/2).
assert (radius : 0 < (y - x)/2).
unfold Rdiv; apply Rmult_lt_0_compat.
@@ -71,6 +73,7 @@ Qed.
Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
Boule c1 r1 x -> Boule c2 r2 x ->
{r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
+Proof.
intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
assert (Rmax (c1 - r1)(c2 - r2) < x).
apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
@@ -366,6 +369,7 @@ Qed.
(* Uniform convergence implies pointwise simple convergence *)
Lemma CVU_cv : forall f g c d, CVU f g c d ->
forall x, Boule c d x -> Un_cv (fun n => f n x) (g x).
+Proof.
intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn].
exists N; intros n nN; rewrite R_dist_sym; apply Pn; assumption.
Qed.
@@ -374,6 +378,7 @@ Qed.
Lemma CVU_ext_lim :
forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) ->
CVU f g2 c d.
+Proof.
intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn].
exists N; intros; rewrite <- q; auto.
Qed.
@@ -388,6 +393,7 @@ Lemma CVU_derivable :
(forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) ->
(forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) ->
forall x, Boule c d x -> derivable_pt_lim g x (g' x).
+Proof.
intros f f' g g' c d cvu cvp dff' x bx.
set (rho_ :=
fun n y =>
diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v
index 68718db0..cc45139d 100644
--- a/theories/Reals/Ratan.v
+++ b/theories/Reals/Ratan.v
@@ -450,6 +450,7 @@ fourier.
Qed.
Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}.
+Proof.
destruct (total_order_T (Rabs y) 1) as [Hs|Hgt].
assert (yle1 : Rabs y <= 1) by (destruct Hs; fourier).
clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ].
@@ -567,10 +568,12 @@ Lemma pos_opp_lt : forall x, 0 < x -> -x < x.
Proof. intros; fourier. Qed.
Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y.
+Proof.
intros; rewrite tan_neg; assumption.
Qed.
Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}.
+Proof.
destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]].
set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub)))
(proj1 (Rabs_def2 _ _ Ptan_ub)))).
@@ -649,6 +652,7 @@ exact df_neq.
Qed.
Lemma atan_increasing : forall x y, x < y -> atan x < atan y.
+Proof.
intros x y d.
assert (t1 := atan_bound x).
assert (t2 := atan_bound y).
@@ -663,6 +667,7 @@ solve[rewrite yx; apply Rle_refl].
Qed.
Lemma atan_0 : atan 0 = 0.
+Proof.
apply tan_is_inj; try (apply atan_bound).
assert (t := PI_RGT_0); rewrite Ropp_div; split; fourier.
rewrite atan_right_inv, tan_0.
@@ -670,6 +675,7 @@ reflexivity.
Qed.
Lemma atan_1 : atan 1 = PI/4.
+Proof.
assert (ut := PI_RGT_0).
assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; fourier).
assert (t := atan_bound 1).
@@ -865,6 +871,7 @@ Qed.
Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) :
{l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+Proof.
exact (alternated_series (Ratan_seq x)
(Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)).
Defined.
@@ -888,6 +895,7 @@ Qed.
Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) :
{l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+Proof.
destruct (Rle_lt_dec 0 x).
assert (pr : 0 <= x <= 1) by tauto.
exact (ps_atan_exists_01 x pr).
@@ -902,6 +910,7 @@ solve[intros; exists 0%nat; intros; rewrite R_dist_eq; auto].
Qed.
Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}.
+Proof.
destruct (Rle_lt_dec x 1).
destruct (Rle_lt_dec (-1) x).
left;split; auto.
@@ -1563,6 +1572,7 @@ Qed.
Theorem Alt_PI_eq : Alt_PI = PI.
+Proof.
apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4);
[ | apply Rgt_not_eq; fourier].
assert (0 < PI/6) by (apply PI6_RGT_0).
diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v
index 11d94c11..8e2b2d08 100644
--- a/theories/Structures/EqualitiesFacts.v
+++ b/theories/Structures/EqualitiesFacts.v
@@ -8,132 +8,172 @@
Require Import Equalities Bool SetoidList RelationPairs.
-(** * Keys and datas used in FMap *)
+Set Implicit Arguments.
-Module KeyDecidableType(Import D:DecidableType).
+(** * Keys and datas used in MMap *)
- Section Elt.
- Variable elt : Type.
- Notation key:=t.
+Module KeyDecidableType(D:DecidableType).
- Local Open Scope signature_scope.
+ Local Open Scope signature_scope.
+ Local Notation key := D.t.
- Definition eqk : relation (key*elt) := eq @@1.
- Definition eqke : relation (key*elt) := eq * Logic.eq.
- Hint Unfold eqk eqke.
+ Definition eqk {elt} : relation (key*elt) := D.eq @@1.
+ Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq.
- (* eqke is stricter than eqk *)
+ Hint Unfold eqk eqke.
- Global Instance eqke_eqk : subrelation eqke eqk.
- Proof. firstorder. Qed.
+ (** eqk, eqke are equalities *)
- (* eqk, eqke are equalities, ltk is a strict order *)
+ Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _.
- Global Instance eqk_equiv : Equivalence eqk := _.
+ Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _.
- Global Instance eqke_equiv : Equivalence eqke := _.
+ (** eqke is stricter than eqk *)
- (* Additionnal facts *)
+ Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt).
+ Proof. firstorder. Qed.
- Lemma InA_eqke_eqk :
- forall x m, InA eqke x m -> InA eqk x m.
- Proof.
- unfold eqke, RelProd; induction 1; firstorder.
- Qed.
- Hint Resolve InA_eqke_eqk.
+ (** Alternative definitions of eqke and eqk *)
- Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
- Proof.
- intros. rewrite <- H; auto.
- Qed.
+ Lemma eqke_def {elt} k k' (e e':elt) :
+ eqke (k,e) (k',e') = (D.eq k k' /\ e = e').
+ Proof. reflexivity. Defined.
- Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
- Definition In k m := exists e:elt, MapsTo k e m.
+ Lemma eqke_def' {elt} (p q:key*elt) :
+ eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q).
+ Proof. reflexivity. Defined.
- Hint Unfold MapsTo In.
+ Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'.
+ Proof. now destruct 1. Qed.
- (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+ Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'.
+ Proof. now destruct 1. Qed.
- Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
- Proof.
- firstorder.
- exists x; auto.
- induction H.
- destruct y; compute in H.
- exists e; left; auto.
- destruct IHInA as [e H0].
- exists e; auto.
- Qed.
-
- Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
- Proof.
+ Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'.
+ Proof. reflexivity. Defined.
+
+ Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q).
+ Proof. reflexivity. Qed.
+
+ Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'.
+ Proof. trivial. Qed.
+
+ Hint Resolve eqke_1 eqke_2 eqk_1.
+
+ (* Additionnal facts *)
+
+ Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) :
+ InA eqke p m -> InA eqk p m.
+ Proof.
+ induction 1; firstorder.
+ Qed.
+ Hint Resolve InA_eqke_eqk.
+
+ Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) :
+ InA eqk p m -> exists q, eqk p q /\ InA eqke q m.
+ Proof.
+ induction 1; firstorder.
+ Qed.
+
+ Lemma InA_eqk {elt} p q (m:list (key*elt)) :
+ eqk p q -> InA eqk p m -> InA eqk q m.
+ Proof.
+ now intros <-.
+ Qed.
+
+ Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e).
+ Definition In {elt} k m := exists e:elt, MapsTo k e m.
+
+ Hint Unfold MapsTo In.
+
+ (* Alternative formulations for [In k l] *)
+
+ Lemma In_alt {elt} k (l:list (key*elt)) :
+ In k l <-> exists e, InA eqk (k,e) l.
+ Proof.
+ unfold In, MapsTo.
+ split; intros (e,H).
+ - exists e; auto.
+ - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)).
+ compute in E. exists e'. now rewrite E.
+ Qed.
+
+ Lemma In_alt' {elt} (l:list (key*elt)) k e :
+ In k l <-> InA eqk (k,e) l.
+ Proof.
+ rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute.
+ Qed.
+
+ Lemma In_alt2 {elt} k (l:list (key*elt)) :
+ In k l <-> Exists (fun p => D.eq k (fst p)) l.
+ Proof.
unfold In, MapsTo.
setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
firstorder.
exists (snd x), x; auto.
- Qed.
-
- Lemma In_nil : forall k, In k nil <-> False.
- Proof.
- intros; rewrite In_alt2; apply Exists_nil.
- Qed.
-
- Lemma In_cons : forall k p l,
- In k (p::l) <-> eq k (fst p) \/ In k l.
- Proof.
- intros; rewrite !In_alt2, Exists_cons; intuition.
- Qed.
-
- Global Instance MapsTo_compat :
- Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
- Proof.
+ Qed.
+
+ Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False.
+ Proof.
+ rewrite In_alt2; apply Exists_nil.
+ Qed.
+
+ Lemma In_cons {elt} k p (l:list (key*elt)) :
+ In k (p::l) <-> D.eq k (fst p) \/ In k l.
+ Proof.
+ rewrite !In_alt2, Exists_cons; intuition.
+ Qed.
+
+ Instance MapsTo_compat {elt} :
+ Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt).
+ Proof.
intros x x' Hx e e' He l l' Hl. unfold MapsTo.
rewrite Hx, He, Hl; intuition.
- Qed.
+ Qed.
- Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
- Proof.
+ Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt).
+ Proof.
intros x x' Hx l l' Hl. rewrite !In_alt.
setoid_rewrite Hl. setoid_rewrite Hx. intuition.
- Qed.
-
- Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
- Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
+ Qed.
- Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
- Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
+ Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e :
+ D.eq x y -> MapsTo x e l -> MapsTo y e l.
+ Proof. now intros <-. Qed.
- Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
- Proof.
- intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
- right; exists x; auto.
- Qed.
+ Lemma In_eq {elt} (l:list (key*elt)) x y :
+ D.eq x y -> In x l -> In y l.
+ Proof. now intros <-. Qed.
- Lemma In_inv_2 : forall k k' e e' l,
- InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
- Proof.
- intros; invlist InA; intuition.
- Qed.
+ Lemma In_inv {elt} k k' e (l:list (key*elt)) :
+ In k ((k',e) :: l) -> D.eq k k' \/ In k l.
+ Proof.
+ intros (e',H). red in H. rewrite InA_cons, eqke_def in H.
+ intuition. right. now exists e'.
+ Qed.
- Lemma In_inv_3 : forall x x' l,
- InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
- Proof.
- intros; invlist InA; compute in * |- ; intuition.
- Qed.
+ Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) :
+ InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l.
+ Proof.
+ rewrite InA_cons, eqk_def. intuition.
+ Qed.
- End Elt.
+ Lemma In_inv_3 {elt} x x' (l:list (key*elt)) :
+ InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+ Proof.
+ rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1.
+ eauto with *.
+ Qed.
- Hint Unfold eqk eqke.
Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve InA_eqke_eqk.
- Hint Unfold MapsTo In.
Hint Resolve In_inv_2 In_inv_3.
End KeyDecidableType.
-(** * PairDecidableType
-
+(** * PairDecidableType
+
From two decidable types, we can build a new DecidableType
over their cartesian product. *)
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
index acc7c767..b484257b 100644
--- a/theories/Structures/OrdersEx.v
+++ b/theories/Structures/OrdersEx.v
@@ -84,3 +84,70 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
End PairOrderedType.
+(** Even if [positive] can be seen as an ordered type with respect to the
+ usual order (see above), we can also use a lexicographic order over bits
+ (lower bits are considered first). This is more natural when using
+ [positive] as indexes for sets or maps (see MSetPositive and MMapPositive. *)
+
+Local Open Scope positive.
+
+Module PositiveOrderedTypeBits <: UsualOrderedType.
+ Definition t:=positive.
+ Include HasUsualEq <+ UsualIsEq.
+ Definition eqb := Pos.eqb.
+ Definition eqb_eq := Pos.eqb_eq.
+ Include HasEqBool2Dec.
+
+ Fixpoint bits_lt (p q:positive) : Prop :=
+ match p, q with
+ | xH, xI _ => True
+ | xH, _ => False
+ | xO p, xO q => bits_lt p q
+ | xO _, _ => True
+ | xI p, xI q => bits_lt p q
+ | xI _, _ => False
+ end.
+
+ Definition lt:=bits_lt.
+
+ Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+ Proof.
+ induction x; simpl; auto.
+ Qed.
+
+ Lemma bits_lt_trans :
+ forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+ Proof.
+ induction x; destruct y,z; simpl; eauto; intuition.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+ intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
+ Qed.
+
+ Fixpoint compare x y :=
+ match x, y with
+ | x~1, y~1 => compare x y
+ | x~1, _ => Gt
+ | x~0, y~0 => compare x y
+ | x~0, _ => Lt
+ | 1, y~1 => Lt
+ | 1, 1 => Eq
+ | 1, y~0 => Gt
+ end.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+ unfold eq, lt.
+ induction x; destruct y; try constructor; simpl; auto.
+ destruct (IHx y); subst; auto.
+ destruct (IHx y); subst; auto.
+ Qed.
+
+End PositiveOrderedTypeBits.
diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v
index 059992f5..4d49ac84 100644
--- a/theories/Structures/OrdersLists.v
+++ b/theories/Structures/OrdersLists.v
@@ -6,51 +6,47 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-Require Export RelationPairs SetoidList Orders.
+Require Export RelationPairs SetoidList Orders EqualitiesFacts.
Set Implicit Arguments.
Unset Strict Implicit.
(** * Specialization of results about lists modulo. *)
-Module OrderedTypeLists (Import O:OrderedType).
+Module OrderedTypeLists (O:OrderedType).
-Section ForNotations.
-
-Notation In:=(InA eq).
-Notation Inf:=(lelistA lt).
-Notation Sort:=(sort lt).
-Notation NoDup:=(NoDupA eq).
+Local Notation In:=(InA O.eq).
+Local Notation Inf:=(lelistA O.lt).
+Local Notation Sort:=(sort O.lt).
+Local Notation NoDup:=(NoDupA O.eq).
Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
Proof. intros. rewrite <- H; auto. Qed.
Lemma ListIn_In : forall l x, List.In x l -> In x l.
-Proof. exact (In_InA eq_equiv). Qed.
+Proof. exact (In_InA O.eq_equiv). Qed.
-Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_ltA lt_strorder). Qed.
+Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA O.lt_strorder). Qed.
-Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_eqA eq_equiv lt_compat). Qed.
+Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed.
-Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
-Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
+Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x.
+Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed.
-Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
-Proof. exact (@In_InfA t lt). Qed.
+Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l.
+Proof. exact (@In_InfA O.t O.lt). Qed.
-Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
-Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed.
+Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l.
+Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed.
Lemma Inf_alt :
- forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
-Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed.
+ forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)).
+Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed.
Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
-Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed.
-
-End ForNotations.
+Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed.
Hint Resolve ListIn_In Sort_NoDup Inf_lt.
Hint Immediate In_eq Inf_lt.
@@ -58,140 +54,66 @@ Hint Immediate In_eq Inf_lt.
End OrderedTypeLists.
+(** * Results about keys and data as manipulated in MMaps. *)
+Module KeyOrderedType(O:OrderedType).
+ Include KeyDecidableType(O). (* provides eqk, eqke *)
+ Local Notation key:=O.t.
+ Local Open Scope signature_scope.
-(** * Results about keys and data as manipulated in FMaps. *)
-
-
-Module KeyOrderedType(Import O:OrderedType).
- Module Import MO:=OrderedTypeLists(O).
-
- Section Elt.
- Variable elt : Type.
- Notation key:=t.
-
- Local Open Scope signature_scope.
-
- Definition eqk : relation (key*elt) := eq @@1.
- Definition eqke : relation (key*elt) := eq * Logic.eq.
- Definition ltk : relation (key*elt) := lt @@1.
-
- Hint Unfold eqk eqke ltk.
+ Definition ltk {elt} : relation (key*elt) := O.lt @@1.
- (* eqke is stricter than eqk *)
+ Hint Unfold ltk.
- Global Instance eqke_eqk : subrelation eqke eqk.
- Proof. firstorder. Qed.
+ (* ltk is a strict order *)
- (* eqk, eqke are equalities, ltk is a strict order *)
+ Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _.
- Global Instance eqk_equiv : Equivalence eqk := _.
+ Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt).
+ Proof. unfold eqk, ltk; auto with *. Qed.
- Global Instance eqke_equiv : Equivalence eqke := _.
+ Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt).
+ Proof. eapply subrelation_proper; eauto with *. Qed.
- Global Instance ltk_strorder : StrictOrder ltk := _.
+ (* Additionnal facts *)
- Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
- Proof. unfold eqk, ltk; auto with *. Qed.
+ Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt).
+ Proof. apply pair_compat. Qed.
- (* Additionnal facts *)
-
- Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt).
- Proof. apply pair_compat. Qed.
+ Section Elt.
+ Variable elt : Type.
+ Implicit Type p q : key*elt.
+ Implicit Type l m : list (key*elt).
- Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+ Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q.
Proof.
- intros e e' LT EQ; rewrite EQ in LT.
+ intros LT EQ; rewrite EQ in LT.
elim (StrictOrder_Irreflexive _ LT).
Qed.
- Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+ Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q.
Proof.
- intros e e' LT EQ; rewrite EQ in LT.
+ intros LT EQ; rewrite EQ in LT.
elim (StrictOrder_Irreflexive _ LT).
Qed.
- Lemma InA_eqke_eqk :
- forall x m, InA eqke x m -> InA eqk x m.
- Proof.
- unfold eqke, RelProd; induction 1; firstorder.
- Qed.
- Hint Resolve InA_eqke_eqk.
-
- Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
- Definition In k m := exists e:elt, MapsTo k e m.
Notation Sort := (sort ltk).
Notation Inf := (lelistA ltk).
- Hint Unfold MapsTo In.
-
- (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
-
- Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
- Proof.
- firstorder.
- exists x; auto.
- induction H.
- destruct y; compute in H.
- exists e; left; auto.
- destruct IHInA as [e H0].
- exists e; auto.
- Qed.
+ Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l.
+ Proof. now intros <-. Qed.
- Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
- Proof.
- unfold In, MapsTo.
- setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
- firstorder.
- exists (snd x), x; auto.
- Qed.
-
- Lemma In_nil : forall k, In k nil <-> False.
- Proof.
- intros; rewrite In_alt2; apply Exists_nil.
- Qed.
-
- Lemma In_cons : forall k p l,
- In k (p::l) <-> eq k (fst p) \/ In k l.
- Proof.
- intros; rewrite !In_alt2, Exists_cons; intuition.
- Qed.
-
- Global Instance MapsTo_compat :
- Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
- Proof.
- intros x x' Hx e e' He l l' Hl. unfold MapsTo.
- rewrite Hx, He, Hl; intuition.
- Qed.
-
- Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
- Proof.
- intros x x' Hx l l' Hl. rewrite !In_alt.
- setoid_rewrite Hl. setoid_rewrite Hx. intuition.
- Qed.
-
- Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
- Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
-
- Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
- Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
-
- Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
- Proof. intros l x x' H. rewrite H; auto. Qed.
-
- Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+ Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l.
Proof. apply InfA_ltA; auto with *. Qed.
Hint Immediate Inf_eq.
Hint Resolve Inf_lt.
- Lemma Sort_Inf_In :
- forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
+ Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p.
Proof. apply SortA_InfA_InA; auto with *. Qed.
- Lemma Sort_Inf_NotIn :
- forall l k e, Sort l -> Inf (k,e) l -> ~In k l.
+ Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l.
Proof.
intros; red; intros.
destruct H1 as [e' H2].
@@ -200,57 +122,34 @@ Module KeyOrderedType(Import O:OrderedType).
repeat red; reflexivity.
Qed.
- Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
+ Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l.
Proof. apply SortA_NoDupA; auto with *. Qed.
- Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+ Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q.
Proof.
intros; invlist sort; eapply Sort_Inf_In; eauto.
Qed.
- Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
- ltk e e' \/ eqk e e'.
+ Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) ->
+ ltk p q \/ eqk p q.
Proof.
intros; invlist InA; auto with relations.
left; apply Sort_In_cons_1 with l; auto with relations.
Qed.
- Lemma Sort_In_cons_3 :
- forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
+ Lemma Sort_In_cons_3 x l k e :
+ Sort ((k,e)::l) -> In x l -> ~O.eq x k.
Proof.
intros; invlist sort; red; intros.
eapply Sort_Inf_NotIn; eauto using In_eq.
Qed.
- Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
- Proof.
- intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
- right; exists x; auto.
- Qed.
-
- Lemma In_inv_2 : forall k k' e e' l,
- InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
- Proof.
- intros; invlist InA; intuition.
- Qed.
-
- Lemma In_inv_3 : forall x x' l,
- InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
- Proof.
- intros; invlist InA; compute in * |- ; intuition.
- Qed.
-
End Elt.
- Hint Unfold eqk eqke ltk.
- Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve ltk_not_eqk ltk_not_eqke.
- Hint Resolve InA_eqke_eqk.
- Hint Unfold MapsTo In.
Hint Immediate Inf_eq.
Hint Resolve Inf_lt.
Hint Resolve Sort_Inf_NotIn.
- Hint Resolve In_inv_2 In_inv_3.
End KeyOrderedType.
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index 99ecd150..d210792f 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(** * An light axiomatization of integers (used in FSetAVL). *)
+(** * An light axiomatization of integers (used in MSetAVL). *)
(** We define a signature for an integer datatype based on [Z].
The goal is to allow a switch after extraction to ocaml's
@@ -14,11 +14,11 @@
(typically : when mesuring the height of an AVL tree).
*)
-Require Import ZArith.
+Require Import BinInt.
Delimit Scope Int_scope with I.
Local Open Scope Int_scope.
-(** * a specification of integers *)
+(** * A specification of integers *)
Module Type Int.
@@ -31,19 +31,19 @@ Module Type Int.
Parameter _1 : t.
Parameter _2 : t.
Parameter _3 : t.
- Parameter plus : t -> t -> t.
+ Parameter add : t -> t -> t.
Parameter opp : t -> t.
- Parameter minus : t -> t -> t.
- Parameter mult : t -> t -> t.
+ Parameter sub : t -> t -> t.
+ Parameter mul : t -> t -> t.
Parameter max : t -> t -> t.
Notation "0" := _0 : Int_scope.
Notation "1" := _1 : Int_scope.
Notation "2" := _2 : Int_scope.
Notation "3" := _3 : Int_scope.
- Infix "+" := plus : Int_scope.
- Infix "-" := minus : Int_scope.
- Infix "*" := mult : Int_scope.
+ Infix "+" := add : Int_scope.
+ Infix "-" := sub : Int_scope.
+ Infix "*" := mul : Int_scope.
Notation "- x" := (opp x) : Int_scope.
(** For logical relations, we can rely on their counterparts in Z,
@@ -61,7 +61,17 @@ Module Type Int.
Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.
- (** Some decidability fonctions (informative). *)
+ (** Informative comparisons. *)
+
+ Axiom eqb : t -> t -> bool.
+ Axiom ltb : t -> t -> bool.
+ Axiom leb : t -> t -> bool.
+
+ Infix "=?" := eqb.
+ Infix "" := ltb.
+ Infix "<=?" := leb.
+
+ (** For compatibility, some decidability fonctions (informative). *)
Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}.
Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}.
@@ -83,11 +93,14 @@ Module Type Int.
Axiom i2z_1 : i2z _1 = 1%Z.
Axiom i2z_2 : i2z _2 = 2%Z.
Axiom i2z_3 : i2z _3 = 3%Z.
- Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
+ Axiom i2z_add : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z.
- Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
- Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
+ Axiom i2z_sub : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
+ Axiom i2z_mul : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p).
+ Axiom i2z_eqb : forall n p, eqb n p = Z.eqb (i2z n) (i2z p).
+ Axiom i2z_ltb : forall n p, ltb n p = Z.ltb (i2z n) (i2z p).
+ Axiom i2z_leb : forall n p, leb n p = Z.leb (i2z n) (i2z p).
End Int.
@@ -97,11 +110,42 @@ End Int.
Module MoreInt (Import I:Int).
Local Notation int := I.t.
+ Lemma eqb_eq n p : (n =? p) = true <-> n == p.
+ Proof.
+ now rewrite i2z_eqb, Z.eqb_eq.
+ Qed.
+
+ Lemma eqb_neq n p : (n =? p) = false <-> ~(n == p).
+ Proof.
+ rewrite <- eqb_eq. destruct (n =? p); intuition.
+ Qed.
+
+ Lemma ltb_lt n p : (n p) = true <-> n < p.
+ Proof.
+ now rewrite i2z_ltb, Z.ltb_lt.
+ Qed.
+
+ Lemma ltb_nlt n p : (n p) = false <-> ~(n < p).
+ Proof.
+ rewrite <- ltb_lt. destruct (n p); intuition.
+ Qed.
+
+ Lemma leb_le n p : (n <=? p) = true <-> n <= p.
+ Proof.
+ now rewrite i2z_leb, Z.leb_le.
+ Qed.
+
+ Lemma leb_nle n p : (n <=? p) = false <-> ~(n <= p).
+ Proof.
+ rewrite <- leb_le. destruct (n <=? p); intuition.
+ Qed.
+
(** A magic (but costly) tactic that goes from [int] back to the [Z]
friendly world ... *)
Hint Rewrite ->
- i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
+ i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max
+ i2z_eqb i2z_ltb i2z_leb : i2z.
Ltac i2z := match goal with
| H : ?a = ?b |- _ =>
@@ -149,18 +193,18 @@ Module MoreInt (Import I:Int).
| EI1 : ExprI
| EI2 : ExprI
| EI3 : ExprI
- | EIplus : ExprI -> ExprI -> ExprI
+ | EIadd : ExprI -> ExprI -> ExprI
| EIopp : ExprI -> ExprI
- | EIminus : ExprI -> ExprI -> ExprI
- | EImult : ExprI -> ExprI -> ExprI
+ | EIsub : ExprI -> ExprI -> ExprI
+ | EImul : ExprI -> ExprI -> ExprI
| EImax : ExprI -> ExprI -> ExprI
| EIraw : int -> ExprI.
Inductive ExprZ : Set :=
- | EZplus : ExprZ -> ExprZ -> ExprZ
+ | EZadd : ExprZ -> ExprZ -> ExprZ
| EZopp : ExprZ -> ExprZ
- | EZminus : ExprZ -> ExprZ -> ExprZ
- | EZmult : ExprZ -> ExprZ -> ExprZ
+ | EZsub : ExprZ -> ExprZ -> ExprZ
+ | EZmul : ExprZ -> ExprZ -> ExprZ
| EZmax : ExprZ -> ExprZ -> ExprZ
| EZofI : ExprI -> ExprZ
| EZraw : Z -> ExprZ.
@@ -186,9 +230,9 @@ Module MoreInt (Import I:Int).
| 1 => constr:EI1
| 2 => constr:EI2
| 3 => constr:EI3
- | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey)
- | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey)
- | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey)
+ | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey)
+ | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey)
+ | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey)
| max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
| - ?x => let ex := i2ei x in constr:(EIopp ex)
| ?x => constr:(EIraw x)
@@ -198,9 +242,9 @@ Module MoreInt (Import I:Int).
with z2ez trm :=
match constr:trm with
- | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
- | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
- | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
+ | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey)
+ | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey)
+ | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey)
| (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
| (- ?x)%Z => let ex := z2ez x in constr:(EZopp ex)
| i2z ?x => let ex := i2ei x in constr:(EZofI ex)
@@ -232,9 +276,9 @@ Module MoreInt (Import I:Int).
| EI1 => 1
| EI2 => 2
| EI3 => 3
- | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
- | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
- | EImult e1 e2 => (ei2i e1)*(ei2i e2)
+ | EIadd e1 e2 => (ei2i e1)+(ei2i e2)
+ | EIsub e1 e2 => (ei2i e1)-(ei2i e2)
+ | EImul e1 e2 => (ei2i e1)*(ei2i e2)
| EImax e1 e2 => max (ei2i e1) (ei2i e2)
| EIopp e => -(ei2i e)
| EIraw i => i
@@ -244,9 +288,9 @@ Module MoreInt (Import I:Int).
Fixpoint ez2z (e:ExprZ) : Z :=
match e with
- | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
- | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
- | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
+ | EZadd e1 e2 => ((ez2z e1)+(ez2z e2))%Z
+ | EZsub e1 e2 => ((ez2z e1)-(ez2z e2))%Z
+ | EZmul e1 e2 => ((ez2z e1)*(ez2z e2))%Z
| EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2)
| EZopp e => (-(ez2z e))%Z
| EZofI e => i2z (ei2i e)
@@ -278,9 +322,9 @@ Module MoreInt (Import I:Int).
| EI1 => EZraw (1%Z)
| EI2 => EZraw (2%Z)
| EI3 => EZraw (3%Z)
- | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
- | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
- | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
+ | EIadd e1 e2 => EZadd (norm_ei e1) (norm_ei e2)
+ | EIsub e1 e2 => EZsub (norm_ei e1) (norm_ei e2)
+ | EImul e1 e2 => EZmul (norm_ei e1) (norm_ei e2)
| EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
| EIopp e => EZopp (norm_ei e)
| EIraw i => EZofI (EIraw i)
@@ -290,9 +334,9 @@ Module MoreInt (Import I:Int).
Fixpoint norm_ez (e:ExprZ) : ExprZ :=
match e with
- | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
- | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
- | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
+ | EZadd e1 e2 => EZadd (norm_ez e1) (norm_ez e2)
+ | EZsub e1 e2 => EZsub (norm_ez e1) (norm_ez e2)
+ | EZmul e1 e2 => EZmul (norm_ez e1) (norm_ez e2)
| EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
| EZopp e => EZopp (norm_ez e)
| EZofI e => norm_ei e
@@ -316,24 +360,22 @@ Module MoreInt (Import I:Int).
| EPraw p => EPraw p
end.
- Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
+ Lemma norm_ei_correct (e:ExprI) : ez2z (norm_ei e) = i2z (ei2i e).
Proof.
- induction e; simpl; intros; i2z; auto; try congruence.
+ induction e; simpl; i2z; auto; try congruence.
Qed.
- Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
+ Lemma norm_ez_correct (e:ExprZ) : ez2z (norm_ez e) = ez2z e.
Proof.
- induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
+ induction e; simpl; i2z; auto; try congruence; apply norm_ei_correct.
Qed.
- Lemma norm_ep_correct :
- forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
+ Lemma norm_ep_correct (e:ExprP) : ep2p (norm_ep e) <-> ep2p e.
Proof.
- induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
+ induction e; simpl; rewrite ?norm_ez_correct; intuition.
Qed.
- Lemma norm_ep_correct2 :
- forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
+ Lemma norm_ep_correct2 (e:ExprP) : ep2p (norm_ep e) -> ep2p e.
Proof.
intros; destruct (norm_ep_correct e); auto.
Qed.
@@ -363,23 +405,50 @@ Module Z_as_Int <: Int.
Definition _1 := 1.
Definition _2 := 2.
Definition _3 := 3.
- Definition plus := Z.add.
+ Definition add := Z.add.
Definition opp := Z.opp.
- Definition minus := Z.sub.
- Definition mult := Z.mul.
+ Definition sub := Z.sub.
+ Definition mul := Z.mul.
Definition max := Z.max.
- Definition gt_le_dec := Z_gt_le_dec.
- Definition ge_lt_dec := Z_ge_lt_dec.
+ Definition eqb := Z.eqb.
+ Definition ltb := Z.ltb.
+ Definition leb := Z.leb.
+
Definition eq_dec := Z.eq_dec.
+ Definition gt_le_dec i j : {i > j} + { i <= j }.
+ Proof.
+ generalize (Z.ltb_spec j i).
+ destruct (j i); [left|right]; inversion H; trivial.
+ now apply Z.lt_gt.
+ Defined.
+ Definition ge_lt_dec i j : {i >= j} + { i < j }.
+ Proof.
+ generalize (Z.ltb_spec i j).
+ destruct (i j); [right|left]; inversion H; trivial.
+ now apply Z.le_ge.
+ Defined.
+
Definition i2z : t -> Z := fun n => n.
- Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
- Lemma i2z_0 : i2z _0 = 0. Proof. auto. Qed.
- Lemma i2z_1 : i2z _1 = 1. Proof. auto. Qed.
- Lemma i2z_2 : i2z _2 = 2. Proof. auto. Qed.
- Lemma i2z_3 : i2z _3 = 3. Proof. auto. Qed.
- Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p. Proof. auto. Qed.
- Lemma i2z_opp n : i2z (- n) = - i2z n. Proof. auto. Qed.
- Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p. Proof. auto. Qed.
- Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p. Proof. auto. Qed.
- Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). Proof. auto. Qed.
+ Lemma i2z_eq n p : i2z n = i2z p -> n = p. Proof. trivial. Qed.
+ Lemma i2z_0 : i2z _0 = 0. Proof. reflexivity. Qed.
+ Lemma i2z_1 : i2z _1 = 1. Proof. reflexivity. Qed.
+ Lemma i2z_2 : i2z _2 = 2. Proof. reflexivity. Qed.
+ Lemma i2z_3 : i2z _3 = 3. Proof. reflexivity. Qed.
+ Lemma i2z_add n p : i2z (n + p) = i2z n + i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_opp n : i2z (- n) = - i2z n.
+ Proof. reflexivity. Qed.
+ Lemma i2z_sub n p : i2z (n - p) = i2z n - i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_mul n p : i2z (n * p) = i2z n * i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_eqb n p : eqb n p = Z.eqb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_leb n p : leb n p = Z.leb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_ltb n p : ltb n p = Z.ltb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+
End Z_as_Int.
diff --git a/theories/theories.itarget b/theories/theories.itarget
index 3a87d8cf..4519070e 100644
--- a/theories/theories.itarget
+++ b/theories/theories.itarget
@@ -3,6 +3,7 @@ Bool/vo.otarget
Classes/vo.otarget
FSets/vo.otarget
MSets/vo.otarget
+MMaps/vo.otarget
Structures/vo.otarget
Init/vo.otarget
Lists/vo.otarget
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index d660f420..0931fd55 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -46,9 +46,10 @@ let section s =
let usage () =
output_string stderr "Usage summary:
-coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ...
- [file.ml{lib,pack}] ... [-extra[-phony] result dependencies command]
- ... [-I dir] ... [-R physicalpath logicalpath] ... [VARIABLE = value]
+coq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}]
+ ... [any] ... [-extra[-phony] result dependencies command]
+ ... [-I dir] ... [-R physicalpath logicalpath]
+ ... [-Q physicalpath logicalpath] ... [VARIABLE = value]
... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file]
[-h] [--help]
@@ -56,8 +57,8 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ...
[file.ml[i4]?]: Objective Caml file to be compiled
[file.ml{lib,pack}]: ocamlbuild file that describes a Objective Caml
library/module
-[subdirectory] : subdirectory that should be \"made\" and has a
- Makefile itself to do so.
+[any] : subdirectory that should be \"made\" and has a Makefile itself
+ to do so. Very fragile and discouraged.
[-extra result dependencies command]: add target \"result\" with command
\"command\" and dependencies \"dependencies\". If \"result\" is not
generic (do not contains a %), \"result\" is built by _make all_ and
@@ -157,7 +158,7 @@ let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) =
|l ->
try
let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in
- let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option" in
+ let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" in
(None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l])
with Not_found ->
(
@@ -297,7 +298,7 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in
print "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL) && ";
printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind
in
- print "uninstall_me.sh:\n";
+ printf "uninstall_me.sh: %s\n" !makefile_name;
print "\techo '#!/bin/sh' > $@ \n";
if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs;
uninstall_by_root where_what_oth;
@@ -320,7 +321,7 @@ let make_makefile sds =
end
let clean sds sps =
- print "clean:\n";
+ print "clean::\n";
if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin
print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n";
print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n";
@@ -329,6 +330,7 @@ let clean sds sps =
if !some_vfile then
begin
print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n";
+ print "\tfind . -name .coq-native -type d -empty -delete\n";
print "\trm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n"
end;
print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n";
@@ -342,7 +344,11 @@ let clean sds sps =
(fun x -> print "\t+cd "; print x; print " && $(MAKE) clean\n")
sds;
print "\n";
- print "archclean:\n";
+ let () =
+ if !some_vfile then
+ let () = print "cleanall:: clean\n" in
+ print "\trm -f $(patsubst %.v,.%.aux,$(VFILES))\n\n" in
+ print "archclean::\n";
print "\trm -f *.cmx *.o\n";
List.iter
(fun x -> print "\t+cd "; print x; print " && $(MAKE) archclean\n")
@@ -365,7 +371,7 @@ let implicit () =
print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n";
print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n";
- print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+ print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
let ml_rules () =
print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n";
@@ -457,7 +463,7 @@ let variables is_install opt (args,defs) =
print "ifeq ($(CAMLP4),camlp5)
CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo unix.cma threads.cma
else
-CAMLP4EXTEND=
+CAMLP4EXTEND=threads.cma
endif\n";
print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)threads/ $(COQSRCLIBS) compat5.cmo \\
$(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n";
@@ -530,9 +536,13 @@ let include_dirs (inc_ml,inc_i,inc_r) =
List.iter (fun x -> print "\\\n "; print x) str_r; print "\n\n";
end
+let double_colon = ["clean"; "cleanall"; "archclean"]
+
let custom sps =
let pr_path (file,dependencies,is_phony,com) =
- print file; print ": "; print dependencies; print "\n";
+ print file;
+ print (if List.mem file double_colon then ":: " else ": ");
+ print dependencies; print "\n";
if com <> "" then (print "\t"; print com; print "\n");
print "\n"
in
@@ -543,7 +553,12 @@ let subdirs sds =
let pr_subdir s =
print s; print ":\n\t+cd \""; print s; print "\" && $(MAKE) all\n\n"
in
- if sds <> [] then section "Subdirectories.";
+ if sds <> [] then
+ let () =
+ Format.eprintf "@[Warning: Targets for subdirectories are very fragile.@ " in
+ let () =
+ Format.eprintf "For example,@ nothing is done to handle dependencies@ with them.@]@." in
+ section "Subdirectories.";
List.iter pr_subdir sds
let forpacks l =
@@ -695,22 +710,25 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
end
let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc =
- let other_targets = CList.map_filter
- (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None)
- sps @ sds in
+ let other_targets =
+ CList.map_filter
+ (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None)
+ sps @ sds in
main_targets vfiles mlfiles other_targets inc;
- print ".PHONY: ";
- print_list " "
- ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" ::
- "uninstall_me.sh" :: "uninstall" :: "userinstall" :: "depend" ::
- "html" :: "validate" ::
- (sds@(CList.map_filter
- (fun (n,_,is_phony,_) ->
- if is_phony then Some n else None) sps)));
- print "\n\n";
- custom sps;
- subdirs sds;
- forpacks mlpackfiles
+ print ".PHONY: ";
+ print_list
+ " "
+ ("all" :: "archclean" :: "beautify" :: "byte" :: "clean" :: "cleanall"
+ :: "gallina" :: "gallinahtml" :: "html" :: "install" :: "install-doc"
+ :: "install-natdynlink" :: "install-toploop" :: "opt" :: "printenv"
+ :: "quick" :: "uninstall" :: "userinstall" :: "validate" :: "vio2vo"
+ :: (sds@(CList.map_filter
+ (fun (n,_,is_phony,_) ->
+ if is_phony then Some n else None) sps)));
+ print "\n\n";
+ custom sps;
+ subdirs sds;
+ forpacks mlpackfiles
let banner () =
print (Printf.sprintf
@@ -750,7 +768,7 @@ let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l
let warn_install_at_root_directory
(vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) =
- let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r@inc_i in
+ let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") (inc_r@inc_i) in
let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in
let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in
if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files
@@ -764,10 +782,10 @@ let check_overlapping_include (_,inc_i,inc_r) =
| [] -> ()
| (pdir,_,abspdir)::l ->
if not (is_prefix pwd abspdir) then
- Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir;
+ Printf.eprintf "Warning: in option -R/-Q, %s is not a subdirectory of the current directory\n" pdir;
List.iter (fun (pdir',_,abspdir') ->
if is_prefix abspdir abspdir' || is_prefix abspdir' abspdir then
- Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l;
+ Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l;
in aux (inc_i@inc_r)
let do_makefile args =
diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml
index 383a68df..a2cc8384 100644
--- a/tools/coq_tex.ml
+++ b/tools/coq_tex.ml
@@ -79,7 +79,7 @@ let expos = Str.regexp "^"
let tex_escaped s =
let dollar = "\\$" and backslash = "\\\\" and expon = "\\^" in
- let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>']") in
+ let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>'`]") in
let adapt_delim = function
| "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c
| "\\" -> "{\\char'134}"
@@ -89,6 +89,7 @@ let tex_escaped s =
| "<" -> "{<}"
| ">" -> "{>}"
| "'" -> "{\\textquotesingle}"
+ | "`" -> "\\`{}"
| _ -> assert false
in
let adapt = function
diff --git a/tools/coqc.ml b/tools/coqc.ml
index f636ffd8..7e822dbe 100644
--- a/tools/coqc.ml
+++ b/tools/coqc.ml
@@ -111,7 +111,7 @@ let parse_args () =
|"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs"
|"-impredicative-set"|"-vm"|"-no-native-compiler"
|"-verbose-compat-notations"|"-no-compat-notations"
- |"-indices-matter"|"-quick"|"-color"
+ |"-indices-matter"|"-quick"|"-color"|"-type-in-type"
|"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch"
as o) :: rem ->
parse (cfiles,o::args) rem
@@ -121,7 +121,7 @@ let parse_args () =
| ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"
|"-load-vernac-source"|"-l"|"-load-vernac-object"
|"-load-ml-source"|"-require"|"-load-ml-object"
- |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"
+ |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"
|"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs"
as o) :: rem ->
begin
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
index edf7ee8e..cb704146 100644
--- a/tools/coqdoc/cpretty.mll
+++ b/tools/coqdoc/cpretty.mll
@@ -405,7 +405,7 @@ let set_kw =
let gallina_kw_to_hide =
"Implicit" space+ "Arguments"
- | "Ltac"
+ | ("Local" space+)? "Ltac"
| "Require"
| "Import"
| "Export"
@@ -456,13 +456,7 @@ rule coq_bol = parse
{ begin_show (); coq_bol lexbuf }
| space* end_show
{ end_show (); coq_bol lexbuf }
- | space* ("Local"|"Global")
- {
- in_proof := None;
- let s = lexeme lexbuf in
- output_indented_keyword s lexbuf;
- coq_bol lexbuf }
- | space* gallina_kw_to_hide
+ | space* (("Local"|"Global") space+)? gallina_kw_to_hide
{ let s = lexeme lexbuf in
if !Cdglobals.light && section_or_end s then
let eol = skip_to_dot lexbuf in
@@ -596,7 +590,7 @@ and coq = parse
end }
| eof
{ () }
- | gallina_kw_to_hide
+ | (("Local"|"Global") space+)? gallina_kw_to_hide
{ let s = lexeme lexbuf in
if !Cdglobals.light && section_or_end s then
begin
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index ae6e6388..06030c45 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -595,7 +595,6 @@ module Html = struct
| '<' -> Buffer.add_string buff "<"
| '>' -> Buffer.add_string buff ">"
| '&' -> Buffer.add_string buff "&"
- | '\'' -> Buffer.add_string buff "´"
| '\"' -> Buffer.add_string buff """
| c -> Buffer.add_char buff c
done;
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
index 5dbd5379..80787298 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/toplevel/auto_ind_decl.mli
@@ -6,7 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Term
open Names
open Ind_tables
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 22ea09c5..b29ba1ef 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -6,7 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Util
open Pp
open Errors
open Indtypes
@@ -53,12 +52,15 @@ let _ = Errors.register_handler explain_exn_default
(** Pre-explain a vernac interpretation error *)
-let wrap_vernac_error (exn, info) strm =
- let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
- let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
- (e, info)
+let wrap_vernac_error with_header (exn, info) strm =
+ if with_header then
+ let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
+ let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
+ (e, info)
+ else
+ (EvaluatedError (strm, None), info)
-let process_vernac_interp_error exn = match fst exn with
+let process_vernac_interp_error with_header exn = match fst exn with
| Univ.UniverseInconsistency i ->
let msg =
if !Constrextern.print_universes then
@@ -66,40 +68,40 @@ let process_vernac_interp_error exn = match fst exn with
Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
else
mt() in
- wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".")
+ wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".")
| TypeError(ctx,te) ->
- wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te)
+ wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te)
| PretypeError(ctx,sigma,te) ->
- wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te)
+ wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te)
| Typeclasses_errors.TypeClassError(env, te) ->
- wrap_vernac_error exn (Himsg.explain_typeclass_error env te)
+ wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te)
| InductiveError e ->
- wrap_vernac_error exn (Himsg.explain_inductive_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_inductive_error e)
| Modops.ModuleTypingError e ->
- wrap_vernac_error exn (Himsg.explain_module_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_module_error e)
| Modintern.ModuleInternalizationError e ->
- wrap_vernac_error exn (Himsg.explain_module_internalization_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e)
| RecursionSchemeError e ->
- wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e)
| Cases.PatternMatchingError (env,sigma,e) ->
- wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e)
+ wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e)
| Tacred.ReductionTacticError e ->
- wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e)
| Logic.RefinerError e ->
- wrap_vernac_error exn (Himsg.explain_refiner_error e)
+ wrap_vernac_error with_header exn (Himsg.explain_refiner_error e)
| Nametab.GlobalizationError q ->
- wrap_vernac_error exn
+ wrap_vernac_error with_header exn
(str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
spc () ++ str "was not found" ++
spc () ++ str "in the current" ++ spc () ++ str "environment.")
| Refiner.FailError (i,s) ->
let s = Lazy.force s in
- wrap_vernac_error exn
+ wrap_vernac_error with_header exn
(str "Tactic failure" ++
(if Pp.is_empty s then s else str ": " ++ s) ++
if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").")
| AlreadyDeclared msg ->
- wrap_vernac_error exn (msg ++ str ".")
+ wrap_vernac_error with_header exn (msg ++ str ".")
| _ ->
exn
@@ -108,9 +110,9 @@ let rec strip_wrapping_exceptions = function
strip_wrapping_exceptions e
| exc -> exc
-let process_vernac_interp_error (exc, info) =
+let process_vernac_interp_error ?(with_header=true) (exc, info) =
let exc = strip_wrapping_exceptions exc in
- let e = process_vernac_interp_error (exc, info) in
+ let e = process_vernac_interp_error with_header (exc, info) in
let ltac_trace = Exninfo.get info Proof_type.ltac_trace_info in
let loc = Option.default Loc.ghost (Loc.get_loc info) in
match ltac_trace with
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index 1768af11..100b3772 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -12,7 +12,7 @@ val print_loc : Loc.t -> Pp.std_ppcmds
(** Pre-explain a vernac interpretation error *)
-val process_vernac_interp_error : Util.iexn -> Util.iexn
+val process_vernac_interp_error : ?with_header:bool -> Util.iexn -> Util.iexn
(** General explain function. Should not be used directly now,
see instead function [Errors.print] and variants *)
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index f44ac367..33891ad9 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -103,8 +103,13 @@ let instance_hook k pri global imps ?hook cst =
let declare_instance_constant k pri global imps ?hook id poly uctx term termtype =
let kind = IsDefinition Instance in
+ let uctx =
+ let levels = Univ.LSet.union (Universes.universes_of_constr termtype)
+ (Universes.universes_of_constr term) in
+ Universes.restrict_universe_context uctx levels
+ in
let entry =
- Declare.definition_entry ~types:termtype ~poly ~univs:uctx term
+ Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term
in
let cdecl = (DefinitionEntry entry, kind) in
let kn = Declare.declare_constant id cdecl in
@@ -165,7 +170,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
in
let env' = push_rel_context ctx env in
evars := Evarutil.nf_evar_map !evars;
- evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars;
+ evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars;
let subst = List.map (Evarutil.nf_evar !evars) subst in
if abstract then
begin
@@ -208,7 +213,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
let get_id =
function
| Ident id' -> id'
- | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+ | Qualid (loc,id') -> (loc, snd (repr_qualid id'))
in
let props, rest =
List.fold_left
@@ -232,7 +237,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
k.cl_projs;
c :: props, rest'
with Not_found ->
- (CHole (Loc.ghost, Some Evar_kinds.GoalEvar, Misctypes.IntroAnonymous, None) :: props), rest
+ (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest
else props, rest)
([], props) k.cl_props
in
@@ -277,7 +282,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro
in
let term = Option.map nf term in
if not (Evd.has_undefined evm) && not (Option.is_empty term) then
- let ctx = Evd.universe_context evm in
+ let ctx = Evd.universe_context_set evm in
declare_instance_constant k pri global imps ?hook id
poly ctx (Option.get term) termtype
else if !refine_instance || Option.is_empty term then begin
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index 0a351d3c..2b7e9e4f 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -8,7 +8,6 @@
open Names
open Context
-open Evd
open Environ
open Constrexpr
open Typeclasses
@@ -33,7 +32,7 @@ val declare_instance_constant :
?hook:(Globnames.global_reference -> unit) ->
Id.t -> (** name *)
bool -> (* polymorphic *)
- Univ.universe_context -> (* Universes *)
+ Univ.universe_context_set -> (* Universes *)
Constr.t -> (** body *)
Term.types -> (** type *)
Names.Id.t
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 9cb3bb86..754ad852 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -233,9 +233,9 @@ let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = ma
in
(gr,inst,Lib.is_modtype_strict ())
-let interp_assumption evdref env bl c =
+let interp_assumption evdref env impls bl c =
let c = prod_constr_expr c bl in
- let ty, impls = interp_type_evars_impls env evdref c in
+ let ty, impls = interp_type_evars_impls env evdref ~impls c in
let evd, nf = nf_evars_and_universes !evdref in
let ctx = Evd.universe_context_set evd in
((nf ty, ctx), impls)
@@ -259,12 +259,15 @@ let do_assumptions (_, poly, _ as kind) nl l =
l []
else l
in
- let _,l = List.fold_map (fun env (is_coe,(idl,c)) ->
- let (t,ctx),imps = interp_assumption evdref env [] c in
+ let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) ->
+ let (t,ctx),imps = interp_assumption evdref env ienv [] c in
let env =
push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in
- (env,((is_coe,idl),t,(ctx,imps))))
- env l
+ let ienv = List.fold_right (fun (_,id) ienv ->
+ let impls = compute_internalization_data env Variable t imps in
+ Id.Map.add id impls ienv) idl ienv in
+ ((env,ienv),((is_coe,idl),t,(ctx,imps))))
+ (env,empty_internalization_env) l
in
let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in
let l = List.map (on_pi2 (nf_evar evd)) l in
@@ -746,8 +749,8 @@ let interp_fix_body env_rec evdref impls (_,ctx) fix ccl =
let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-let declare_fix (_,poly,_ as kind) ctx f ((def,_),eff) t imps =
- let ce = definition_entry ~types:t ~poly ~univs:ctx ~eff def in
+let declare_fix ?(opaque = false) (_,poly,_ as kind) ctx f ((def,_),eff) t imps =
+ let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in
declare_definition f kind ce imps (Lemmas.mk_hook (fun _ r -> r))
let _ = Obligations.declare_fix_ref := declare_fix
diff --git a/toplevel/command.mli b/toplevel/command.mli
index 894333ad..3a38e52c 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -11,7 +11,6 @@ open Term
open Entries
open Libnames
open Globnames
-open Tacexpr
open Vernacexpr
open Constrexpr
open Decl_kinds
@@ -167,5 +166,5 @@ val do_cofixpoint :
val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit
-val declare_fix : definition_kind -> Univ.universe_context -> Id.t ->
+val declare_fix : ?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t ->
Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 03074ced..f1d8a492 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -57,28 +57,20 @@ let load_rcfile() =
else
Flags.if_verbose msg_info (str"Skipping rcfile loading.")
-(* Puts dir in the path of ML and in the LoadPath *)
-let coq_add_path unix_path s =
- Mltop.add_path ~unix_path ~coq_root:(Names.DirPath.make [Nameops.coq_root;Names.Id.of_string s]) ~implicit:true;
- Mltop.add_ml_dir unix_path
-
(* Recursively puts dir in the LoadPath if -nois was not passed *)
let add_stdlib_path ~unix_path ~coq_root ~with_ml =
- if !Flags.load_init then
- Mltop.add_rec_path ~unix_path ~coq_root ~implicit:true
- else
- Mltop.add_path ~unix_path ~coq_root ~implicit:false;
+ Mltop.add_rec_path ~unix_path ~coq_root ~implicit:(!Flags.load_init);
if with_ml then
Mltop.add_rec_ml_dir unix_path
let add_userlib_path ~unix_path =
- Mltop.add_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false;
+ Mltop.add_rec_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false;
Mltop.add_rec_ml_dir unix_path
(* Options -I, -I-as, and -R of the command line *)
let includes = ref []
-let push_include s alias recursive implicit =
- includes := (s,alias,recursive,implicit) :: !includes
+let push_include s alias implicit =
+ includes := (s, alias, implicit) :: !includes
let ml_includes = ref []
let push_ml_include s = ml_includes := s :: !ml_includes
@@ -91,10 +83,11 @@ let init_load_path () =
let coq_root = Names.DirPath.make [Nameops.coq_root] in
(* NOTE: These directories are searched from last to first *)
(* first, developer specific directory to open *)
- if Coq_config.local then coq_add_path (coqlib/"dev") "dev";
+ if Coq_config.local then
+ Mltop.add_ml_dir (coqlib/"dev");
(* main loops *)
if Coq_config.local || !Flags.boot then begin
- let () = Mltop.add_ml_dir (coqlib/"stm") in
+ Mltop.add_ml_dir (coqlib/"stm");
Mltop.add_ml_dir (coqlib/"ide")
end;
Mltop.add_ml_dir (coqlib/"toploop");
@@ -109,13 +102,13 @@ let init_load_path () =
List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs;
(* then directories in COQPATH *)
List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath;
- (* then current directory *)
- Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix ~implicit:false;
- (* additional loadpath, given with options -I-as, -Q, and -R *)
+ (* then current directory (not recursively!) *)
+ Mltop.add_ml_dir ".";
+ Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false;
+ (* additional loadpath, given with options -Q and -R *)
List.iter
- (fun (unix_path, coq_root, reci, implicit) ->
- (if reci then Mltop.add_rec_path else Mltop.add_path)
- ~unix_path ~coq_root ~implicit)
+ (fun (unix_path, coq_root, implicit) ->
+ Mltop.add_rec_path ~unix_path ~coq_root ~implicit)
(List.rev !includes);
(* additional ml directories, given with option -I *)
List.iter Mltop.add_ml_dir (List.rev !ml_includes)
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index 5f7133c3..c019cc1c 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -15,8 +15,8 @@ val set_rcfile : string -> unit
val no_load_rc : unit -> unit
val load_rcfile : unit -> unit
-val push_include : string -> Names.DirPath.t -> bool -> bool -> unit
-(** [push_include phys_path log_path recursive implicit] *)
+val push_include : string -> Names.DirPath.t -> bool -> unit
+(** [push_include phys_path log_path implicit] *)
val push_ml_include : string -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 142f3386..e9e86953 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -135,9 +135,9 @@ let set_outputstate s =
outputstate:=s
let outputstate () = if not (String.is_empty !outputstate) then extern_state !outputstate
-let set_include d p recursive implicit =
+let set_include d p implicit =
let p = dirpath_of_string p in
- push_include d p recursive implicit
+ push_include d p implicit
let load_vernacular_list = ref ([] : (string * bool) list)
let add_load_vernacular verb s =
@@ -378,7 +378,7 @@ let schedule_vio_compilation () =
let get_native_name s =
(* We ignore even critical errors because this mode has to be super silent *)
try
- String.concat Filename.dir_sep [Filename.dirname s;
+ String.concat "/" [Filename.dirname s;
Nativelib.output_dir; Library.native_name_from_filename s]
with _ -> ""
@@ -402,21 +402,21 @@ let parse_args arglist =
(* Complex options with many args *)
|"-I"|"-include" ->
begin match rem with
- | d :: "-as" :: p :: rem -> set_include d p false true; args := rem
- | d :: "-as" :: [] -> error_missing_arg "-as"
| d :: rem -> push_ml_include d; args := rem
| [] -> error_missing_arg opt
end
|"-Q" ->
begin match rem with
- | d :: p :: rem -> set_include d p true false; args := rem
+ | d :: p :: rem -> set_include d p false; args := rem
| _ -> error_missing_arg opt
end
|"-R" ->
begin match rem with
- | d :: "-as" :: [] -> error_missing_arg "-as"
- | d :: "-as" :: p :: rem
- | d :: p :: rem -> set_include d p true true; args := rem
+ | d :: "-as" :: [] -> error_missing_arg opt
+ | d :: "-as" :: p :: rem ->
+ warning "option -R * -as * deprecated, remove the -as";
+ set_include d p true; args := rem
+ | d :: p :: rem -> set_include d p true; args := rem
| _ -> error_missing_arg opt
end
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index 9341f2f7..5429e660 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -879,7 +879,9 @@ let explain_label_already_declared l =
str ("The label "^Label.to_string l^" is already declared.")
let explain_application_to_not_path _ =
- str "Application of modules is restricted to paths."
+ strbrk "A module cannot be applied to another module application or " ++
+ strbrk "with-expression; you must give a name to the intermediate result " ++
+ strbrk "module first."
let explain_not_a_functor () =
str "Application of a non-functor."
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
index e6b23828..fbc45b4a 100644
--- a/toplevel/indschemes.ml
+++ b/toplevel/indschemes.ml
@@ -85,7 +85,7 @@ let _ =
{ optsync = true;
optdepr = false;
optname = "automatic declaration of boolean equality";
- optkey = ["Equality";"Schemes"];
+ optkey = ["Boolean";"Equality";"Schemes"];
optread = (fun () -> !eq_flag) ;
optwrite = (fun b -> eq_flag := b) }
let _ = (* compatibility *)
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 161cf824..639ec1e6 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -61,23 +61,42 @@ let rec make_tags = function
| GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l
| [] -> []
+let make_fresh_key =
+ let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in
+ fun () ->
+ let cur = incr id; !id in
+ let lbl = Id.of_string ("_" ^ string_of_int cur) in
+ let kn = Lib.make_kn lbl in
+ let (mp, dir, _) = KerName.repr kn in
+ (** We embed the full path of the kernel name in the label so that the
+ identifier should be unique. This ensures that including two modules
+ together won't confuse the corresponding labels. *)
+ let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i"
+ (ModPath.to_string mp) (DirPath.to_string dir) cur)
+ in
+ KerName.make mp dir (Label.of_id lbl)
+
type tactic_grammar_obj = {
+ tacobj_key : KerName.t;
tacobj_local : locality_flag;
tacobj_tacgram : tactic_grammar;
tacobj_tacpp : Pptactic.pp_tactic;
tacobj_body : Tacexpr.glob_tactic_expr
}
-let cache_tactic_notation ((_, key), tobj) =
+let cache_tactic_notation (_, tobj) =
+ let key = tobj.tacobj_key in
Tacenv.register_alias key tobj.tacobj_body;
Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram;
Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp
-let open_tactic_notation i ((_, key), tobj) =
+let open_tactic_notation i (_, tobj) =
+ let key = tobj.tacobj_key in
if Int.equal i 1 && not tobj.tacobj_local then
Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram
-let load_tactic_notation i ((_, key), tobj) =
+let load_tactic_notation i (_, tobj) =
+ let key = tobj.tacobj_key in
(** Only add the printing and interpretation rules. *)
Tacenv.register_alias key tobj.tacobj_body;
Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp;
@@ -85,7 +104,10 @@ let load_tactic_notation i ((_, key), tobj) =
Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram
let subst_tactic_notation (subst, tobj) =
- { tobj with tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; }
+ { tobj with
+ tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key;
+ tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body;
+ }
let classify_tactic_notation tacobj = Substitute tacobj
@@ -115,6 +137,7 @@ let add_tactic_notation (local,n,prods,e) =
tacgram_prods = prods;
} in
let tacobj = {
+ tacobj_key = make_fresh_key ();
tacobj_local = local;
tacobj_tacgram = parule;
tacobj_tacpp = pprule;
@@ -1103,7 +1126,7 @@ let open_notation i (_, nobj) =
let scope = nobj.notobj_scope in
let (ntn, df) = nobj.notobj_notation in
let pat = nobj.notobj_interp in
- if Int.equal i 1 then begin
+ if Int.equal i 1 && not (Notation.exists_notation_in_scope scope ntn pat) then begin
(* Declare the interpretation *)
Notation.declare_notation_interpretation ntn scope pat df;
(* Declare the uninterpretation *)
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
index 9dc1dd5b..0b6fc48c 100644
--- a/toplevel/mltop.ml
+++ b/toplevel/mltop.ml
@@ -161,17 +161,6 @@ let add_rec_ml_dir unix_path =
(* Adding files to Coq and ML loadpath *)
-let add_path ~unix_path:dir ~coq_root:coq_dirpath ~implicit =
- if exists_dir dir then
- begin
- add_ml_dir dir;
- Loadpath.add_load_path dir
- (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath)
- coq_dirpath
- end
- else
- msg_warning (str ("Cannot open " ^ dir))
-
let convert_string d =
try Names.Id.of_string d
with UserError _ ->
@@ -191,11 +180,9 @@ let add_rec_path ~unix_path ~coq_root ~implicit =
let dirs = List.map_filter convert_dirs dirs in
let () = add_ml_dir unix_path in
let add (path, dir) =
- Loadpath.add_load_path path Loadpath.ImplicitPath dir in
- let () = if implicit then List.iter add dirs in
- Loadpath.add_load_path unix_path
- (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath)
- coq_root
+ Loadpath.add_load_path path ~implicit dir in
+ let () = List.iter add dirs in
+ Loadpath.add_load_path unix_path ~implicit coq_root
else
msg_warning (str ("Cannot open " ^ unix_path))
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index 2a91afd8..4f3f4ddd 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -47,7 +47,6 @@ val add_ml_dir : string -> unit
val add_rec_ml_dir : string -> unit
(** Adds a path to the Coq and ML paths *)
-val add_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
val add_rec_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
(** List of modules linked to the toplevel *)
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
index aa068586..523134b5 100644
--- a/toplevel/obligations.ml
+++ b/toplevel/obligations.ml
@@ -21,7 +21,7 @@ open Pp
open Errors
open Util
-let declare_fix_ref = ref (fun _ _ _ _ _ _ -> assert false)
+let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false)
let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false)
let trace s =
@@ -319,6 +319,7 @@ type program_info = {
prg_kind : definition_kind;
prg_reduce : constr -> constr;
prg_hook : unit Lemmas.declaration_hook;
+ prg_opaque : bool;
}
let assumption_message = Declare.assumption_message
@@ -512,8 +513,9 @@ let declare_definition prg =
let body, typ = subst_body true prg in
let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
(Evd.evar_universe_context_subst prg.prg_ctx) in
+ let opaque = prg.prg_opaque in
let ce =
- definition_entry ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
+ definition_entry ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind)
~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body)
in
progmap_remove prg;
@@ -564,6 +566,7 @@ let declare_mutual_definition l =
let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
let (local,poly,kind) = first.prg_kind in
let fixnames = first.prg_deps in
+ let opaque = first.prg_opaque in
let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in
let indexes, fixdecls =
match fixkind with
@@ -584,7 +587,7 @@ let declare_mutual_definition l =
in
(* Declare the recursive definitions *)
let ctx = Evd.evar_context_universe_context first.prg_ctx in
- let kns = List.map4 (!declare_fix_ref (local, poly, kind) ctx)
+ let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx)
fixnames fixdecls fixtypes fiximps in
(* Declare notations *)
List.iter Metasyntax.add_notation_interpretation first.prg_notations;
@@ -640,7 +643,7 @@ let declare_obligation prg obl body ty uctx =
else
Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) }
-let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook =
+let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls kind reduce hook =
let obls', b =
match b with
| None ->
@@ -655,7 +658,7 @@ let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook
Array.mapi
(fun i (n, t, l, o, d, tac) ->
{ obl_name = n ; obl_body = None;
- obl_location = l; obl_type = reduce t; obl_status = o;
+ obl_location = l; obl_type = t; obl_status = o;
obl_deps = d; obl_tac = tac })
obls, b
in
@@ -664,7 +667,8 @@ let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook
prg_obligations = (obls', Array.length obls');
prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
prg_implicits = impls; prg_kind = kind; prg_reduce = reduce;
- prg_hook = hook; }
+ prg_hook = hook;
+ prg_opaque = opaque; }
let get_prog name =
let prg_infos = !from_prg in
@@ -976,9 +980,9 @@ let show_term n =
++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body)
let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
- ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) obls =
+ ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) obls =
let info = str (Id.to_string n) ++ str " has type-checked" in
- let prg = init_prog_info n term t ctx [] None [] obls implicits kind reduce hook in
+ let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in
let obls,_ = prg.prg_obligations in
if Int.equal (Array.length obls) 0 then (
Flags.if_verbose msg_info (info ++ str ".");
@@ -994,11 +998,11 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition)
| _ -> res)
let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
- ?(hook=Lemmas.mk_hook (fun _ _ -> ())) notations fixkind =
+ ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) notations fixkind =
let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
List.iter
(fun (n, b, t, imps, obls) ->
- let prg = init_prog_info n (Some b) t ctx deps (Some fixkind)
+ let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind)
notations obls imps kind reduce hook
in progmap_add n prg) l;
let _defined =
diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli
index 582b4935..40f124ca 100644
--- a/toplevel/obligations.mli
+++ b/toplevel/obligations.mli
@@ -14,10 +14,9 @@ open Pp
open Globnames
open Vernacexpr
open Decl_kinds
-open Tacexpr
(** Forward declaration. *)
-val declare_fix_ref : (definition_kind -> Univ.universe_context -> Id.t ->
+val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t ->
Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref
val declare_definition_ref :
@@ -69,7 +68,7 @@ val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types ->
?kind:Decl_kinds.definition_kind ->
?tactic:unit Proofview.tactic ->
?reduce:(Term.constr -> Term.constr) ->
- ?hook:unit Lemmas.declaration_hook -> obligation_info -> progress
+ ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress
type notations =
(Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
@@ -85,7 +84,7 @@ val add_mutual_definitions :
?tactic:unit Proofview.tactic ->
?kind:Decl_kinds.definition_kind ->
?reduce:(Term.constr -> Term.constr) ->
- ?hook:unit Lemmas.declaration_hook ->
+ ?hook:unit Lemmas.declaration_hook -> ?opaque:bool ->
notations ->
fixpoint_kind -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
index 55f53351..737b7fb5 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -472,10 +472,15 @@ let add_inductive_class ind =
let k =
let ctx = oneind.mind_arity_ctxt in
let inst = Univ.UContext.instance mind.mind_universes in
+ let map = function
+ | (_, Some _, _) -> None
+ | (_, None, t) -> Some (lazy t)
+ in
+ let args = List.map_filter map ctx in
let ty = Inductive.type_of_inductive_knowing_parameters
(push_rel_context ctx (Global.env ()))
((mind,oneind),inst)
- (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx))
+ (Array.of_list args)
in
{ cl_impl = IndRef ind;
cl_context = List.map (const None) ctx, ctx;
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index d22524e5..bf0f305a 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -13,7 +13,6 @@ Record
Vernacinterp
Mltop
Vernacentries
-Whelp
Vernac
Usage
Coqloop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index d4d44569..f053839c 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -23,9 +23,7 @@ let print_usage_channel co command =
output_string co
" -I dir look for ML files in dir\
\n -include dir (idem)\
-\n -I dir -as coqdir implicitly map physical dir to logical coqdir\
-\n -R dir -as coqdir recursively map physical dir to logical coqdir\
-\n -R dir coqdir (idem)\
+\n -R dir coqdir recursively map physical dir to logical coqdir\
\n -Q dir coqdir map physical dir to logical coqdir\
\n -top coqdir set the toplevel name to be coqdir instead of Top\
\n -notop set the toplevel name to be the empty logical path\
@@ -47,6 +45,11 @@ let print_usage_channel co command =
\n -require f load Coq object file f.vo and import it (Require f.)\
\n -compile f compile Coq file f.v (implies -batch)\
\n -compile-verbose f verbosely compile Coq file f.v (implies -batch)\
+\n -quick quickly compile .v files to .vio files (skip proofs)\
+\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\
+\n into fi.vo\
+\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\
+\n proofs in each fi.vio\
\n\
\n -where print Coq's standard library location and exit\
\n -config print Coq's configuration information and exit\
@@ -66,6 +69,7 @@ let print_usage_channel co command =
\n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\
\n -impredicative-set set sort Set impredicative\
\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\
+\n -type-in-type disable universe consistency checking\
\n -time display the time taken by each command\
\n -no-native-compiler disable the native_compute reduction machinery\
\n -h, -help print this list of options\
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index fb12edfb..cfa9bddc 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -387,12 +387,13 @@ let err_unmapped_library loc qid =
pr_dirpath dir ++ str".")
let err_notfound_library loc qid =
- msg_error
- (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str"."))
+ user_err_loc
+ (loc,"locate_library",
+ strbrk "Unable to locate library " ++ pr_qualid qid ++ str".")
let print_located_library r =
let (loc,qid) = qualid_of_reference r in
- try msg_found_library (Library.locate_qualified_library false qid)
+ try msg_found_library (Library.locate_qualified_library ~warn:false qid)
with
| Library.LibUnmappedDir -> err_unmapped_library loc qid
| Library.LibNotFound -> err_notfound_library loc qid
@@ -496,7 +497,7 @@ let vernac_exact_proof c =
(* spiwack: for simplicity I do not enforce that "Proof proof_term" is
called only at the begining of a proof. *)
let status = by (Tactics.New.exact_proof c) in
- save_proof (Vernacexpr.Proved(true,None));
+ save_proof (Vernacexpr.(Proved(Opaque None,None)));
if not status then Pp.feedback Feedback.AddedAxiom
let vernac_assumption locality poly (local, kind) l nl =
@@ -598,11 +599,8 @@ let vernac_constraint l = do_constraint l
(* Modules *)
let vernac_import export refl =
- let import ref =
- Library.import_module export (qualid_of_reference ref)
- in
- List.iter import refl;
- Lib.add_frozen_state ()
+ Library.import_module export (List.map qualid_of_reference refl);
+ Lib.add_frozen_state ()
let vernac_declare_module export (loc, id) binders_ast mty_ast =
(* We check the state of the system (in section, in module type)
@@ -752,9 +750,25 @@ let vernac_end_segment (_,id as lid) =
(* Libraries *)
-let vernac_require import qidl =
+let vernac_require from import qidl =
let qidl = List.map qualid_of_reference qidl in
- let modrefl = List.map Library.try_locate_qualified_library qidl in
+ let root = match from with
+ | None -> None
+ | Some from ->
+ let (_, qid) = Libnames.qualid_of_reference from in
+ let (hd, tl) = Libnames.repr_qualid qid in
+ Some (Libnames.add_dirpath_suffix hd tl)
+ in
+ let locate (loc, qid) =
+ try
+ let warn = Flags.is_verbose () in
+ let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in
+ (dir, f)
+ with
+ | Library.LibUnmappedDir -> err_unmapped_library loc qid
+ | Library.LibNotFound -> err_notfound_library loc qid
+ in
+ let modrefl = List.map locate qidl in
if Dumpglob.dump () then
List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl);
Library.require_library_from_dirpath modrefl import
@@ -878,11 +892,10 @@ let vernac_set_used_variables e =
let expand filename =
Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) filename
-let vernac_add_loadpath isrec pdir ldiropt =
+let vernac_add_loadpath implicit pdir ldiropt =
let pdir = expand pdir in
let alias = Option.default Nameops.default_root_prefix ldiropt in
- (if isrec then Mltop.add_rec_path else Mltop.add_path)
- ~unix_path:pdir ~coq_root:alias ~implicit:true
+ Mltop.add_rec_path ~unix_path:pdir ~coq_root:alias ~implicit
let vernac_remove_loadpath path =
Loadpath.remove_load_path (expand path)
@@ -963,20 +976,27 @@ let register_ltac local isrec tacl =
(name, body)
in
let rfun = List.map map tacl in
- let ltacrecvars =
+ let recvars =
let fold accu (op, _) = match op with
| UpdateTac _ -> accu
- | NewTac id -> Id.Map.add id (Lib.make_kn id) accu
+ | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu
in
- if isrec then List.fold_left fold Id.Map.empty rfun
- else Id.Map.empty
+ if isrec then List.fold_left fold [] rfun
+ else []
in
- let ist = { (Tacintern.make_empty_glob_sign ()) with Genintern.ltacrecvars; } in
+ let ist = Tacintern.make_empty_glob_sign () in
let map (name, body) =
let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in
(name, body)
in
- let defs = List.map map rfun in
+ let defs () =
+ (** Register locally the tactic to handle recursivity. This function affects
+ the whole environment, so that we transactify it afterwards. *)
+ let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in
+ let () = List.iter iter_rec recvars in
+ List.map map rfun
+ in
+ let defs = Future.transactify defs () in
let iter (def, tac) = match def with
| NewTac id ->
Tacenv.register_ltac false local id tac;
@@ -1124,6 +1144,7 @@ let vernac_declare_arguments locality r l nargs flags =
vernac_declare_implicits locality r implicits;
if nargs >= 0 && nargs < List.fold_left max 0 rargs then
error "The \"/\" option must be placed after the last \"!\".";
+ let no_flags = List.is_empty flags in
let rec narrow = function
| #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl
| [] -> [] | _ :: tl -> narrow tl in
@@ -1141,7 +1162,7 @@ let vernac_declare_arguments locality r l nargs flags =
some_implicits_specified ||
some_scopes_specified ||
some_simpl_flags_specified) &&
- List.length flags = 0 then
+ no_flags then
msg_warning (strbrk "This command is just asserting the number and names of arguments of " ++ pr_global sr ++ strbrk". If this is what you want add ': assert' to silence the warning. If you want to clear implicit arguments add ': clear implicits'. If you want to clear notation scopes add ': clear scopes'")
@@ -1503,7 +1524,7 @@ let vernac_check_may_eval redexp glopt rc =
Evarconv.check_problems_are_solved env sigma';
let sigma',nf = Evarutil.nf_evars_and_universes sigma' in
let uctx = Evd.universe_context sigma' in
- let env = Environ.push_context uctx env in
+ let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in
let c = nf c in
let j =
if Evarutil.has_undefined_evars sigma' c then
@@ -1516,12 +1537,8 @@ let vernac_check_may_eval redexp glopt rc =
let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in
let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in
msg_notice (print_judgment env sigma' j ++
- (if l != Evar.Set.empty then
- let l = Evar.Set.fold (fun ev -> Evar.Map.add ev (Evarutil.nf_evar_info sigma' (Evd.find sigma' ev))) l Evar.Map.empty in
- (fnl () ++ str "where" ++ fnl () ++ pr_evars sigma' l)
- else
- mt ()) ++
- Printer.pr_universe_ctx uctx)
+ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++
+ Printer.pr_universe_ctx uctx)
| Some r ->
Tacintern.dump_glob_red_expr r;
let (sigma',r_interp) = interp_redexp env sigma' r in
@@ -1883,7 +1900,7 @@ let interp ?proof locality poly c =
| VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set
- | VernacRequire (export, qidl) -> vernac_require export qidl
+ | VernacRequire (from, export, qidl) -> vernac_require from export qidl
| VernacImport (export,qidl) -> vernac_import export qidl
| VernacCanonical qid -> vernac_canonical qid
| VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t
@@ -1951,14 +1968,16 @@ let interp ?proof locality poly c =
| VernacComments l -> if_verbose msg_info (str "Comments ok\n")
| VernacNop -> ()
+ (* The STM should handle that, but LOAD bypasses the STM... *)
+ | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm")
+ | VernacAbortAll -> msg_warning (str "VernacAbortAll not handled by Stm")
+ | VernacRestart -> msg_warning (str "VernacRestart not handled by Stm")
+ | VernacUndo _ -> msg_warning (str "VernacUndo not handled by Stm")
+ | VernacUndoTo _ -> msg_warning (str "VernacUndoTo not handled by Stm")
+ | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm")
+
(* Proof management *)
| VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false
- | VernacAbort id -> anomaly (str "VernacAbort not handled by Stm")
- | VernacAbortAll -> anomaly (str "VernacAbortAll not handled by Stm")
- | VernacRestart -> anomaly (str "VernacRestart not handled by Stm")
- | VernacUndo _ -> anomaly (str "VernacUndo not handled by Stm")
- | VernacUndoTo _ -> anomaly (str "VernacUndoTo not handled by Stm")
- | VernacBacktrack _ -> anomaly (str "VernacBacktrack not handled by Stm")
| VernacFocus n -> vernac_focus n
| VernacUnfocus -> vernac_unfocus ()
| VernacUnfocused -> vernac_unfocused ()
@@ -2061,7 +2080,7 @@ let locate_if_not_already loc (e, info) =
| Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info)
exception HasNotFailed
-exception HasFailed of string
+exception HasFailed of std_ppcmds
let with_fail b f =
if not b then f ()
@@ -2076,8 +2095,8 @@ let with_fail b f =
| HasNotFailed as e -> raise e
| e ->
let e = Errors.push e in
- raise (HasFailed (Pp.string_of_ppcmds
- (Errors.iprint (Cerrors.process_vernac_interp_error e)))))
+ raise (HasFailed (Errors.iprint
+ (Cerrors.process_vernac_interp_error ~with_header:false e))))
()
with e when Errors.noncritical e ->
let (e, _) = Errors.push e in
@@ -2086,8 +2105,7 @@ let with_fail b f =
errorlabstrm "Fail" (str "The command has not failed!")
| HasFailed msg ->
if is_verbose () || !Flags.ide_slave then msg_info
- (str "The command has indeed failed with message:" ++
- fnl () ++ str "=> " ++ hov 0 (str msg))
+ (str "The command has indeed failed with message:" ++ fnl () ++ msg)
| _ -> assert false
end
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index 17f971fd..d3e48f75 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -10,14 +10,17 @@ open Util
open Pp
open Errors
+type deprecation = bool
+type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
+
(* Table of vernac entries *)
let vernac_tab =
(Hashtbl.create 51 :
- (Vernacexpr.extend_name, (Genarg.raw_generic_argument list -> unit -> unit)) Hashtbl.t)
+ (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t)
-let vinterp_add s f =
+let vinterp_add depr s f =
try
- Hashtbl.add vernac_tab s f
+ Hashtbl.add vernac_tab s (depr, f)
with Failure _ ->
errorlabstrm "vinterp_add"
(str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.")
@@ -28,7 +31,7 @@ let overwriting_vinterp_add s f =
let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s
with Not_found -> ()
end;
- Hashtbl.add vernac_tab s f
+ Hashtbl.add vernac_tab s (false, f)
let vinterp_map s =
try
@@ -44,7 +47,16 @@ let vinterp_init () = Hashtbl.clear vernac_tab
let call ?locality (opn,converted_args) =
let loc = ref "Looking up command" in
try
- let callback = vinterp_map opn in
+ let depr, callback = vinterp_map opn in
+ let () = if depr then
+ let rules = Egramml.get_extend_vernac_rule opn in
+ let pr_gram = function
+ | Egramml.GramTerminal s -> str s
+ | Egramml.GramNonTerminal _ -> str "_"
+ in
+ let pr = pr_sequence pr_gram rules in
+ msg_warning (str "Deprecated vernacular command: " ++ pr)
+ in
loc:= "Checking arguments";
let hunk = callback converted_args in
loc:= "Executing command";
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index 38fce5d1..02820654 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -8,9 +8,13 @@
(** Interpretation of extended vernac phrases. *)
-val vinterp_add : Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit
+type deprecation = bool
+type vernac_command = Genarg.raw_generic_argument list -> unit -> unit
+
+val vinterp_add : deprecation -> Vernacexpr.extend_name ->
+ vernac_command -> unit
val overwriting_vinterp_add :
- Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit
+ Vernacexpr.extend_name -> vernac_command -> unit
val vinterp_init : unit -> unit
val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
deleted file mode 100644
index daedc30f..00000000
--- a/toplevel/whelp.ml4
+++ /dev/null
@@ -1,224 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* !whelp_server_name);
- optwrite = (fun s -> whelp_server_name := s) }
-
-let _ =
- declare_string_option
- { optsync = false;
- optdepr = false;
- optname = "Whelp getter";
- optkey = ["Whelp";"Getter"];
- optread = (fun () -> !getter_server_name);
- optwrite = (fun s -> getter_server_name := s) }
-
-
-let make_whelp_request req c =
- !whelp_server_name ^ "/apply?xmluri=" ^ !getter_server_name ^ "/getempty¶m.profile=firewall&profile=firewall¶m.keys=d_c%2CC1%2CHC2%2CL¶m.embedkeys=d_c%2CTC1%2CHC2%2CL¶m.thkeys=T1%2CT2%2CL%2CE¶m.prooftreekeys=HAT%2CG%2CHAO%2CL¶m.media-type=text%2Fhtml¶m.thmedia-type=&prooftreemedia-type=¶m.doctype-public=¶m.encoding=¶m.thencoding=¶m.prooftreeencoding=&advanced=no&keys=S%2CT1%2CT2%2CL%2CRT%2CE¶m.expression=" ^ c ^ "¶m.action=" ^ req
-
-let b = Buffer.create 16
-
-let url_char c =
- if 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' ||
- '0' <= c && c <= '9' || c ='.'
- then Buffer.add_char b c
- else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c))
-
-let url_string s = String.iter url_char s
-
-let rec url_list_with_sep sep f = function
- | [] -> ()
- | [a] -> f a
- | a::l -> f a; url_string sep; url_list_with_sep sep f l
-
-let url_id id = url_string (Id.to_string id)
-
-let uri_of_dirpath dir =
- url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir)
-
-let error_whelp_unknown_reference ref =
- let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in
- errorlabstrm ""
- (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++
- strbrk ", are not supported in Whelp.")
-
-let uri_of_repr_kn ref (mp,dir,l) =
- match mp with
- | MPfile sl ->
- uri_of_dirpath (Label.to_id l :: DirPath.repr dir @ DirPath.repr sl)
- | _ ->
- error_whelp_unknown_reference ref
-
-let url_paren f l = url_char '('; f l; url_char ')'
-let url_bracket f l = url_char '['; f l; url_char ']'
-
-let whelp_of_glob_sort = function
- | GProp -> "Prop"
- | GSet -> "Set"
- | GType _ -> "Type"
-
-let uri_int n = Buffer.add_string b (string_of_int n)
-
-let uri_of_ind_pointer l =
- url_string ".ind#xpointer"; url_paren (url_list_with_sep "/" uri_int) l
-
-let uri_of_global ref =
- match ref with
- | VarRef id -> error ("Unknown Whelp reference: "^(Id.to_string id)^".")
- | ConstRef cst ->
- uri_of_repr_kn ref (repr_con cst); url_string ".con"
- | IndRef (kn,i) ->
- uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1]
- | ConstructRef ((kn,i),j) ->
- uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j]
-
-let whelm_special = Id.of_string "WHELM_ANON_VAR"
-
-let url_of_name = function
- | Name id -> url_id id
- | Anonymous -> url_id whelm_special (* No anon id in Whelp *)
-
-let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c
-
-let uri_params f = function
- | [] -> ()
- | l -> url_string "\\subst";
- url_bracket (url_list_with_sep ";" (uri_of_binding f)) l
-
-let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp)
-
-let section_parameters = function
- | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_)),_) ->
- get_discharged_hyp_names (path_of_global (IndRef(induri,0)))
- | GRef (_,(ConstRef cst as ref),_) ->
- get_discharged_hyp_names (path_of_global ref)
- | _ -> []
-
-let merge vl al =
- let rec aux acc = function
- | ([],l) | (_,([] as l)) -> List.rev acc, l
- | (v::vl,a::al) -> aux ((v,a)::acc) (vl,al)
- in aux [] (vl,al)
-
-let rec uri_of_constr c =
- match c with
- | GVar (_,id) -> url_id id
- | GRef (_,ref,_) -> uri_of_global ref
- | GHole _ | GEvar _ -> url_string "?"
- | GSort (_,s) -> url_string (whelp_of_glob_sort s)
- | GApp (_,f,args) ->
- let inst,rest = merge (section_parameters f) args in
- uri_of_constr f; url_char ' '; uri_params uri_of_constr inst;
- url_list_with_sep " " uri_of_constr rest
- | GLambda (_,na,k,ty,c) ->
- url_string "\\lambda "; url_of_name na; url_string ":";
- uri_of_constr ty; url_string "."; uri_of_constr c
- | GProd (_,Anonymous,k,ty,c) ->
- uri_of_constr ty; url_string "\\to "; uri_of_constr c
- | GProd (_,Name id,k,ty,c) ->
- url_string "\\forall "; url_id id; url_string ":";
- uri_of_constr ty; url_string "."; uri_of_constr c
- | GLetIn (_,na,b,c) ->
- url_string "let "; url_of_name na; url_string "\\def ";
- uri_of_constr b; url_string " in "; uri_of_constr c
- | GCast (_,c, (CastConv t|CastVM t|CastNative t)) ->
- uri_of_constr c; url_string ":"; uri_of_constr t
- | GRec _ | GIf _ | GLetTuple _ | GCases _ ->
- error "Whelp does not support pattern-matching and (co-)fixpoint."
- | GCast (_,_, CastCoerce) ->
- anomaly (Pp.str "Written w/o parenthesis")
- | GPatVar _ ->
- anomaly (Pp.str "Found constructors not supported in constr")
-
-let make_string f x = Buffer.reset b; f x; Buffer.contents b
-
-let send_whelp req s =
- let url = make_whelp_request req s in
- let command = Util.subst_command_placeholder browser_cmd_fmt url in
- let _ = CUnix.run_command ~hook:print_string command in ()
-
-let whelp_constr env sigma req c =
- let c = detype false [whelm_special] env sigma c in
- send_whelp req (make_string uri_of_constr c)
-
-let whelp_constr_expr req c =
- let (sigma,env)= Lemmas.get_current_context () in
- let _,c = interp_open_constr env sigma c in
- whelp_constr env sigma req c
-
-let whelp_locate s =
- send_whelp "locate" s
-
-let whelp_elim ind =
- send_whelp "elim" (make_string uri_of_global (IndRef ind))
-
-let on_goal f =
- let gls = Proof.V82.subgoals (get_pftreestate ()) in
- let gls = { gls with Evd.it = List.hd gls.Evd.it } in
- f (pf_env gls) (project gls) (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
-
-type whelp_request =
- | Locate of string
- | Elim of inductive
- | Constr of string * constr
-
-let whelp = function
- | Locate s -> whelp_locate s
- | Elim ind -> whelp_elim ind
- | Constr (s,c) -> whelp_constr (Global.env()) (Evd.empty) s c
-
-VERNAC ARGUMENT EXTEND whelp_constr_request
-| [ "Match" ] -> [ "match" ]
-| [ "Instance" ] -> [ "instance" ]
-END
-
-VERNAC COMMAND EXTEND Whelp CLASSIFIED AS QUERY
-| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ]
-| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ]
-| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ]
-| [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c]
-END
-
-VERNAC COMMAND EXTEND WhelpHint CLASSIFIED AS QUERY
-| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ]
-| [ "Whelp" "Hint" ] => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] ->
- [ on_goal (fun env sigma -> whelp_constr env sigma "hint") ]
-END
diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli
deleted file mode 100644
index 62272c50..00000000
--- a/toplevel/whelp.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* unit
--
cgit v1.2.3