Commit 5446fba3 authored by Robbert Krebbers's avatar Robbert Krebbers

Initial commit

parents
Global Generalizable All Variables.
Global Set Automatic Coercions Import.
Require Export Morphisms RelationClasses List Bool Utf8 Program Setoid NArith.
Arguments existT {_ _} _ _.
Arguments existT2 {_ _ _} _ _ _.
Definition proj1_T2 {A} {P Q : A Type} (x : sigT2 P Q) : A :=
match x with existT2 a _ _ => a end.
Definition proj2_T2 {A} {P Q : A Type} (x : sigT2 P Q) : P (proj1_T2 x) :=
match x with existT2 _ p _ => p end.
Definition proj3_T2 {A} {P Q : A Type} (x : sigT2 P Q) : Q (proj1_T2 x) :=
match x with existT2 _ _ q => q end.
(* Common notations *)
Delimit Scope C_scope with C.
Global Open Scope C_scope.
Notation "(=)" := eq (only parsing) : C_scope.
Notation "( x =)" := (eq x) (only parsing) : C_scope.
Notation "(= x )" := (λ y, eq y x) (only parsing) : C_scope.
Notation "(≠)" := (λ x y, x y) (only parsing) : C_scope.
Notation "( x ≠)" := (λ y, x y) (only parsing) : C_scope.
Notation "(≠ x )" := (λ y, y x) (only parsing) : C_scope.
Hint Extern 0 (?x = ?x) => reflexivity.
Notation "(→)" := (λ x y, x y) : C_scope.
Notation "( T →)" := (λ y, T y) : C_scope.
Notation "(→ T )" := (λ y, y T) : C_scope.
Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : C_scope.
Infix "∘" := compose : C_scope.
Notation "(∘)" := compose (only parsing) : C_scope.
Notation "( f ∘)" := (compose f) (only parsing) : C_scope.
Notation "(∘ f )" := (λ g, compose g f) (only parsing) : C_scope.
Notation "x ↾ p" := (exist _ x p) (at level 20) : C_scope.
Notation "` x" := (proj1_sig x) : C_scope.
(* Provable propositions *)
Class PropHolds (P : Prop) := prop_holds: P.
(* Decidable propositions *)
Class Decision (P : Prop) := decide : {P} + {¬P}.
Arguments decide _ {_}.
(* Common relations & operations *)
Class Equiv A := equiv: relation A.
Infix "≡" := equiv (at level 70, no associativity) : C_scope.
Notation "(≡)" := equiv (only parsing) : C_scope.
Notation "( x ≡)" := (equiv x) (only parsing) : C_scope.
Notation "(≡ x )" := (λ y, y x) (only parsing) : C_scope.
Notation "(≢)" := (λ x y, ¬x y) (only parsing) : C_scope.
Notation "x ≢ y":= (¬x y) (at level 70, no associativity) : C_scope.
Notation "( x ≢)" := (λ y, x y) (only parsing) : C_scope.
Notation "(≢ x )" := (λ y, y x) (only parsing) : C_scope.
Instance equiv_default_relation `{Equiv A} : DefaultRelation () | 3.
Hint Extern 0 (?x ?x) => reflexivity.
Class Empty A := empty: A.
Notation "∅" := empty : C_scope.
Class Union A := union: A A A.
Infix "∪" := union (at level 50, left associativity) : C_scope.
Notation "(∪)" := union (only parsing) : C_scope.
Notation "( x ∪)" := (union x) (only parsing) : C_scope.
Notation "(∪ x )" := (λ y, union y x) (only parsing) : C_scope.
Class Intersection A := intersection: A A A.
Infix "∩" := intersection (at level 40) : C_scope.
Notation "(∩)" := intersection (only parsing) : C_scope.
Notation "( x ∩)" := (intersection x) (only parsing) : C_scope.
Notation "(∩ x )" := (λ y, intersection y x) (only parsing) : C_scope.
Class Difference A := difference: A A A.
Infix "∖" := difference (at level 40) : C_scope.
Notation "(∖)" := difference (only parsing) : C_scope.
Notation "( x ∖)" := (difference x) (only parsing) : C_scope.
Notation "(∖ x )" := (λ y, difference y x) (only parsing) : C_scope.
Class SubsetEq A := subseteq: A A Prop.
Infix "⊆" := subseteq (at level 70) : C_scope.
Notation "(⊆)" := subseteq (only parsing) : C_scope.
Notation "( X ⊆ )" := (subseteq X) (only parsing) : C_scope.
Notation "( ⊆ X )" := (λ Y, subseteq Y X) (only parsing) : C_scope.
Notation "X ⊈ Y" := (¬X Y) (at level 70) : C_scope.
Notation "(⊈)" := (λ X Y, X Y) (only parsing) : C_scope.
Notation "( X ⊈ )" := (λ Y, X Y) (only parsing) : C_scope.
Notation "( ⊈ X )" := (λ Y, Y X) (only parsing) : C_scope.
Hint Extern 0 (?x ?x) => reflexivity.
Class Singleton A B := singleton: A B.
Notation "{{ x }}" := (singleton x) : C_scope.
Notation "{{ x ; y ; .. ; z }}" := (union .. (union (singleton x) (singleton y)) .. (singleton z)) : C_scope.
Class ElemOf A B := elem_of: A B Prop.
Infix "∈" := elem_of (at level 70) : C_scope.
Notation "(∈)" := elem_of (only parsing) : C_scope.
Notation "( x ∈)" := (elem_of x) (only parsing) : C_scope.
Notation "(∈ X )" := (λ x, elem_of x X) (only parsing) : C_scope.
Notation "x ∉ X" := (¬x X) (at level 80) : C_scope.
Notation "(∉)" := (λ x X, x X) (only parsing) : C_scope.
Notation "( x ∉)" := (λ X, x X) (only parsing) : C_scope.
Notation "(∉ X )" := (λ x, x X) (only parsing) : C_scope.
Class UnionWith M := union_with: {A}, (A A A) M A M A M A.
Class IntersectWith M := intersect_with: {A}, (A A A) M A M A M A.
(* Common properties *)
Class Injective {A B} R S (f : A B) := injective: x y : A, S (f x) (f y) R x y.
Class Idempotent {A} R (f : A A A) := idempotent: x, R (f x x) x.
Class Commutative {A B} R (f : B B A) := commutative: x y, R (f x y) (f y x).
Class LeftId {A} R (i : A) (f : A A A) := left_id: x, R (f i x) x.
Class RightId {A} R (i : A) (f : A A A) := right_id: x, R (f x i) x.
Class Associative {A} R (f : A A A) := associative: x y z, R (f x (f y z)) (f (f x y) z).
Arguments injective {_ _ _ _} _ {_} _ _ _.
Arguments idempotent {_ _} _ {_} _.
Arguments commutative {_ _ _} _ {_} _ _.
Arguments left_id {_ _} _ _ {_} _.
Arguments right_id {_ _} _ _ {_} _.
Arguments associative {_ _} _ {_} _ _ _.
(* Monadic operations *)
Section monad_ops.
Context (M : Type Type).
Class MRet := mret: {A}, A M A.
Class MBind := mbind: {A B}, (A M B) M A M B.
Class MJoin := mjoin: {A}, M (M A) M A.
Class FMap := fmap: {A B}, (A B) M A M B.
End monad_ops.
Arguments mret {M MRet A} _.
Arguments mbind {M MBind A B} _ _.
Arguments mjoin {M MJoin A} _.
Arguments fmap {M FMap A B} _ _.
Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : C_scope.
Notation "x ← y ; z" := (y = (λ x : _, z)) (at level 65, next at level 35, right associativity) : C_scope.
Infix "<$>" := fmap (at level 65, right associativity, only parsing) : C_scope.
(* Ordered structures *)
Class BoundedPreOrder A `{Empty A} `{SubsetEq A} := {
bounded_preorder :>> PreOrder ();
subseteq_empty x : x
}.
(* Note: no equality to avoid the need for setoids. We define equality in a generic way. *)
Class BoundedJoinSemiLattice A `{Empty A} `{SubsetEq A} `{Union A} := {
jsl_preorder :>> BoundedPreOrder A;
subseteq_union_l x y : x x y;
subseteq_union_r x y : y x y;
union_least x y z : x z y z x y z
}.
Class MeetSemiLattice A `{Empty A} `{SubsetEq A} `{Intersection A} := {
msl_preorder :>> BoundedPreOrder A;
subseteq_intersection_l x y : x y x;
subseteq_intersection_r x y : x y y;
intersection_greatest x y z : z x z y z x y
}.
(* Containers *)
Class Size C := size: C nat.
Class Map A C := map: (A A) (C C).
Class Collection A C `{ElemOf A C} `{Empty C} `{Union C}
`{Intersection C} `{Difference C} `{Singleton A C} `{Map A C} := {
elem_of_empty (x : A) : x ;
elem_of_singleton (x y : A) : x {{ y }} x = y;
elem_of_union X Y (x : A) : x X Y x X x Y;
elem_of_intersection X Y (x : A) : x X Y x X x Y;
elem_of_difference X Y (x : A) : x X Y x X x Y;
elem_of_map f X (x : A) : x map f X y, x = f y y X
}.
Class Elements A C := elements: C list A.
Class FinCollection A C `{Empty C} `{Union C} `{Intersection C} `{Difference C}
`{Singleton A C} `{ElemOf A C} `{Map A C} `{Elements A C} := {
fin_collection :>> Collection A C;
elements_spec X x : x X In x (elements X);
elements_nodup X : NoDup (elements X)
}.
Class Fresh A C := fresh: C A.
Class FreshSpec A C `{!Fresh A C} `{!ElemOf A C} := {
fresh_proper X Y : ( x, x X x Y) fresh X = fresh Y;
is_fresh (X : C) : fresh X X
}.
(* Maps *)
Class Lookup K M := lookup: {A}, K M A option A.
Notation "m !! i" := (lookup i m) (at level 20) : C_scope.
Notation "(!!)" := lookup (only parsing) : C_scope.
Notation "( m !!)" := (λ i, lookup i m) (only parsing) : C_scope.
Notation "(!! i )" := (lookup i) (only parsing) : C_scope.
Class PartialAlter K M := partial_alter: {A}, (option A option A) K M A M A.
Class Alter K M := alter: {A}, (A A) K M A M A.
Class Dom K M := dom: C `{Empty C} `{Union C} `{Singleton K C}, M C.
Class Merge M := merge: {A}, (option A option A option A) M A M A M A.
Class Insert K M := insert: {A}, K A M A M A.
Notation "<[ k := a ]>" := (insert k a) (at level 5, right associativity) : C_scope.
Class Delete K M := delete: K M M.
(* Misc *)
Instance pointwise_reflexive {A} `{R : relation B} :
Reflexive R Reflexive (pointwise_relation A R) | 9.
Proof. firstorder. Qed.
Instance pointwise_symmetric {A} `{R : relation B} :
Symmetric R Symmetric (pointwise_relation A R) | 9.
Proof. firstorder. Qed.
Instance pointwise_transitive {A} `{R : relation B} :
Transitive R Transitive (pointwise_relation A R) | 9.
Proof. firstorder. Qed.
Definition fst_map {A A' B} (f : A A') (p : A * B) : A' * B := (f (fst p), snd p).
Definition snd_map {A B B'} (f : B B') (p : A * B) : A * B' := (fst p, f (snd p)).
Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) : relation (A * B) := λ x y,
R1 (fst x) (fst y) R2 (snd x) (snd y).
Section prod_relation.
Context `{R1 : relation A} `{R2 : relation B}.
Global Instance: Reflexive R1 Reflexive R2 Reflexive (prod_relation R1 R2).
Proof. firstorder eauto. Qed.
Global Instance: Symmetric R1 Symmetric R2 Symmetric (prod_relation R1 R2).
Proof. firstorder eauto. Qed.
Global Instance: Transitive R1 Transitive R2 Transitive (prod_relation R1 R2).
Proof. firstorder eauto. Qed.
Global Instance: Equivalence R1 Equivalence R2 Equivalence (prod_relation R1 R2).
Proof. split; apply _. Qed.
Global Instance: Proper (R1 ==> R2 ==> prod_relation R1 R2) pair.
Proof. firstorder eauto. Qed.
Global Instance: Proper (prod_relation R1 R2 ==> R1) fst.
Proof. firstorder eauto. Qed.
Global Instance: Proper (prod_relation R1 R2 ==> R2) snd.
Proof. firstorder eauto. Qed.
End prod_relation.
Definition lift_relation {A B} (R : relation A) (f : B A) : relation B := λ x y, R (f x) (f y).
Definition lift_relation_equivalence {A B} (R : relation A) (f : B A) :
Equivalence R Equivalence (lift_relation R f).
Proof. unfold lift_relation. firstorder. Qed.
Hint Extern 0 (Equivalence (lift_relation _ _)) => eapply @lift_relation_equivalence : typeclass_instances.
Instance: A B (x : B), Commutative (=) (λ _ _ : A, x).
Proof. easy. Qed.
Instance: A (x : A), Associative (=) (λ _ _ : A, x).
Proof. easy. Qed.
Instance: A, Associative (=) (λ x _ : A, x).
Proof. easy. Qed.
Instance: A, Associative (=) (λ _ x : A, x).
Proof. easy. Qed.
Instance: A, Idempotent (=) (λ x _ : A, x).
Proof. easy. Qed.
Instance: A, Idempotent (=) (λ _ x : A, x).
Proof. easy. Qed.
Instance left_id_propholds {A} (R : relation A) i f : LeftId R i f x, PropHolds (R (f i x) x).
Proof. easy. Qed.
Instance right_id_propholds {A} (R : relation A) i f : RightId R i f x, PropHolds (R (f x i) x).
Proof. easy. Qed.
Instance idem_propholds {A} (R : relation A) f : Idempotent R f x, PropHolds (R (f x x) x).
Proof. easy. Qed.
Ltac simplify_eqs := repeat
match goal with
| |- _ => progress subst
| |- _ = _ => reflexivity
| H : _ _ |- _ => now destruct H
| H : _ = _ False |- _ => now destruct H
| H : _ = _ |- _ => discriminate H
| H : _ = _ |- ?G => change (id G); injection H; clear H; intros; unfold id at 1
| H : ?f _ = ?f _ |- _ => apply (injective f) in H
| H : ?f _ ?x = ?f _ ?x |- _ => apply (injective (λ y, f y x)) in H
end.
Hint Extern 0 (PropHolds _) => assumption : typeclass_instances.
Instance: Proper (iff ==> iff) PropHolds.
Proof. now repeat intro. Qed.
Ltac solve_propholds :=
match goal with
| [ |- PropHolds (?P) ] => apply _
| [ |- ?P ] => change (PropHolds P); apply _
end.
Tactic Notation "remember" constr(t) "as" "(" ident(x) "," ident(E) ")" :=
remember t as x;
match goal with
| E' : x = _ |- _ => rename E' into E
end.
Require Export base orders.
Section collection.
Context `{Collection A B}.
Lemma elem_of_empty_iff x : x False.
Proof. split. apply elem_of_empty. easy. Qed.
Lemma elem_of_union_l x X Y : x X x X Y.
Proof. intros. apply elem_of_union. auto. Qed.
Lemma elem_of_union_r x X Y : x Y x X Y.
Proof. intros. apply elem_of_union. auto. Qed.
Global Instance collection_subseteq: SubsetEq B := λ X Y, x, x X x Y.
Global Instance: BoundedJoinSemiLattice B.
Proof. firstorder. Qed.
Global Instance: MeetSemiLattice B.
Proof. firstorder. Qed.
Lemma elem_of_subseteq X Y : X Y x, x X x Y.
Proof. easy. Qed.
Lemma elem_of_equiv X Y : X Y x, x X x Y.
Proof. firstorder. Qed.
Lemma elem_of_equiv_alt X Y : X Y ( x, x X x Y) ( x, x Y x X).
Proof. firstorder. Qed.
Global Instance: Proper ((=) ==> () ==> iff) ().
Proof. intros ???. subst. firstorder. Qed.
Lemma empty_ne_singleton x : {{ x }}.
Proof. intros [_ E]. destruct (elem_of_empty x). apply E. now apply elem_of_singleton. Qed.
End collection.
Section cmap.
Context `{Collection A C}.
Lemma elem_of_map_1 (f : A A) (X : C) (x : A) : x X f x map f X.
Proof. intros. apply (elem_of_map _). eauto. Qed.
Lemma elem_of_map_1_alt (f : A A) (X : C) (x : A) y : x X y = f x y map f X.
Proof. intros. apply (elem_of_map _). eauto. Qed.
Lemma elem_of_map_2 (f : A A) (X : C) (x : A) : x map f X y, x = f y y X.
Proof. intros. now apply (elem_of_map _). Qed.
End cmap.
Definition fresh_sig `{FreshSpec A C} (X : C) : { x : A | x X } := exist ( X) (fresh X) (is_fresh X).
Lemma elem_of_fresh_iff `{FreshSpec A C} (X : C) : fresh X X False.
Proof. split. apply is_fresh. easy. Qed.
Ltac split_elem_ofs := repeat
match goal with
| H : context [ _ _ ] |- _ => setoid_rewrite elem_of_subseteq in H
| H : context [ _ _ ] |- _ => setoid_rewrite elem_of_equiv_alt in H
| H : context [ _ ] |- _ => setoid_rewrite elem_of_empty_iff in H
| H : context [ _ {{ _ }} ] |- _ => setoid_rewrite elem_of_singleton in H
| H : context [ _ _ _ ] |- _ => setoid_rewrite elem_of_union in H
| H : context [ _ _ _ ] |- _ => setoid_rewrite elem_of_intersection in H
| H : context [ _ _ _ ] |- _ => setoid_rewrite elem_of_difference in H
| H : context [ _ map _ _ ] |- _ => setoid_rewrite elem_of_map in H
| |- context [ _ _ ] => setoid_rewrite elem_of_subseteq
| |- context [ _ _ ] => setoid_rewrite elem_of_equiv_alt
| |- context [ _ ] => setoid_rewrite elem_of_empty_iff
| |- context [ _ {{ _ }} ] => setoid_rewrite elem_of_singleton
| |- context [ _ _ _ ] => setoid_rewrite elem_of_union
| |- context [ _ _ _ ] => setoid_rewrite elem_of_intersection
| |- context [ _ _ _ ] => setoid_rewrite elem_of_difference
| |- context [ _ map _ _ ] => setoid_rewrite elem_of_map
end.
Ltac destruct_elem_ofs := repeat
match goal with
| H : context [ @elem_of (_ * _) _ _ ?x _ ] |- _ => is_var x; destruct x
| H : context [ @elem_of (_ + _) _ _ ?x _] |- _ => is_var x; destruct x
end.
Tactic Notation "simplify_elem_of" tactic(t) :=
intros; (* due to bug #2790 *)
simpl in *;
split_elem_ofs;
destruct_elem_ofs;
intuition (simplify_eqs; t).
Tactic Notation "simplify_elem_of" := simplify_elem_of auto.
Ltac naive_firstorder t :=
match goal with
(* intros *)
| |- _, _ => intro; naive_firstorder t
(* destructs without information loss *)
| H : False |- _ => destruct H
| H : ?X, Hneg : ¬?X|- _ => now destruct Hneg
| H : _ _ |- _ => destruct H; naive_firstorder t
| H : _, _ |- _ => destruct H; naive_firstorder t
(* simplification *)
| |- _ => progress (simplify_eqs; simpl in *); naive_firstorder t
(* constructs *)
| |- _ _ => split; naive_firstorder t
(* solve *)
| |- _ => solve [t]
(* dirty destructs *)
| H : context [ _, _ ] |- _ => edestruct H; clear H; naive_firstorder t || clear H; naive_firstorder t
| H : context [ _ _ ] |- _ => edestruct H; clear H; naive_firstorder t || clear H; naive_firstorder t
| H : context [ _ _ ] |- _ => edestruct H; clear H; naive_firstorder t || clear H; naive_firstorder t
(* dirty constructs *)
| |- x, _ => eexists; naive_firstorder t
| |- _ _ => left; naive_firstorder t || right; naive_firstorder t
| H : _ False |- _ => destruct H; naive_firstorder t
end.
Tactic Notation "naive_firstorder" tactic(t) :=
unfold iff, not in *;
naive_firstorder t.
Tactic Notation "esimplify_elem_of" tactic(t) :=
(simplify_elem_of t);
try naive_firstorder t.
Tactic Notation "esimplify_elem_of" := esimplify_elem_of (eauto 5).
Section no_dup.
Context `{Collection A B} (R : relation A) `{!Equivalence R}.
Definition elem_of_upto (x : A) (X : B) := y, y X R x y.
Definition no_dup (X : B) := x y, x X y X R x y x = y.
Global Instance: Proper (() ==> iff) (elem_of_upto x).
Proof. firstorder. Qed.
Global Instance: Proper (R ==> () ==> iff) elem_of_upto.
Proof.
intros ?? E1 ?? E2. split; intros [z [??]]; exists z.
rewrite <-E1, <-E2; intuition.
rewrite E1, E2; intuition.
Qed.
Global Instance: Proper (() ==> iff) no_dup.
Proof. firstorder. Qed.
Lemma elem_of_upto_elem_of x X : x X elem_of_upto x X.
Proof. unfold elem_of_upto. esimplify_elem_of. Qed.
Lemma elem_of_upto_empty x : ¬elem_of_upto x .
Proof. unfold elem_of_upto. esimplify_elem_of. Qed.
Lemma elem_of_upto_singleton x y : elem_of_upto x {{ y }} R x y.
Proof. unfold elem_of_upto. esimplify_elem_of. Qed.
Lemma elem_of_upto_union X Y x : elem_of_upto x (X Y) elem_of_upto x X elem_of_upto x Y.
Proof. unfold elem_of_upto. esimplify_elem_of. Qed.
Lemma not_elem_of_upto x X : ¬elem_of_upto x X y, y X ¬R x y.
Proof. unfold elem_of_upto. esimplify_elem_of. Qed.
Lemma no_dup_empty: no_dup .
Proof. unfold no_dup. simplify_elem_of. Qed.
Lemma no_dup_add x X : ¬elem_of_upto x X no_dup X no_dup ({{ x }} X).
Proof. unfold no_dup, elem_of_upto. esimplify_elem_of. Qed.
Lemma no_dup_inv_add x X : x X no_dup ({{ x }} X) ¬elem_of_upto x X.
Proof. intros Hin Hnodup [y [??]]. rewrite (Hnodup x y) in Hin; simplify_elem_of. Qed.
Lemma no_dup_inv_union_l X Y : no_dup (X Y) no_dup X.
Proof. unfold no_dup. simplify_elem_of. Qed.
Lemma no_dup_inv_union_r X Y : no_dup (X Y) no_dup Y.
Proof. unfold no_dup. simplify_elem_of. Qed.
End no_dup.
Section quantifiers.
Context `{Collection A B} (P : A Prop).
Definition cforall X := x, x X P x.
Definition cexists X := x, x X P x.
Lemma cforall_empty : cforall .
Proof. unfold cforall. simplify_elem_of. Qed.
Lemma cforall_singleton x : cforall {{ x }} P x.
Proof. unfold cforall. simplify_elem_of. Qed.
Lemma cforall_union X Y : cforall X cforall Y cforall (X Y).
Proof. unfold cforall. simplify_elem_of. Qed.
Lemma cforall_union_inv_1 X Y : cforall (X Y) cforall X.
Proof. unfold cforall. simplify_elem_of. Qed.
Lemma cforall_union_inv_2 X Y : cforall (X Y) cforall Y.
Proof. unfold cforall. simplify_elem_of. Qed.
Lemma cexists_empty : ¬cexists .
Proof. unfold cexists. esimplify_elem_of. Qed.
Lemma cexists_singleton x : cexists {{ x }} P x.
Proof. unfold cexists. esimplify_elem_of. Qed.
Lemma cexists_union_1 X Y : cexists X cexists (X Y).
Proof. unfold cexists. esimplify_elem_of. Qed.
Lemma cexists_union_2 X Y : cexists Y cexists (X Y).
Proof. unfold cexists. esimplify_elem_of. Qed.
Lemma cexists_union_inv X Y : cexists (X Y) cexists X cexists Y.
Proof. unfold cexists. esimplify_elem_of. Qed.
End quantifiers.
Lemma cforall_weak `{Collection A B} (P Q : A Prop) (Hweak : x, P x Q x) X :
cforall P X cforall Q X.
Proof. firstorder. Qed.
Lemma cexists_weak `{Collection A B} (P Q : A Prop) (Hweak : x, P x Q x) X :
cexists P X cexists Q X.
Proof. firstorder. Qed.
Require Export base.
Definition decide_rel {A B} (R : A B Prop)
{dec : x y, Decision (R x y)} (x : A) (y : B) : Decision (R x y) := dec x y.
Ltac case_decide :=
match goal with
| H : context [@decide ?P ?dec] |- _ => case (@decide P dec) in *
| H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ => case (@decide_rel _ _ R x y dec) in *
| |- context [@decide ?P ?dec] => case (@decide P dec) in *
| |- context [@decide_rel _ _ ?R ?x ?y ?dec] => case (@decide_rel _ _ R x y dec) in *
end.
Ltac solve_trivial_decision :=
match goal with
| [ |- Decision (?P) ] => apply _
| [ |- sumbool ?P (¬?P) ] => change (Decision P); apply _
end.
Ltac solve_decision :=
first [solve_trivial_decision | unfold Decision; decide equality; solve_trivial_decision].
Program Instance True_dec: Decision True := left _.
Program Instance False_dec: Decision False := right _.
Program Instance prod_eq_dec `(A_dec : x y : A, Decision (x = y))
`(B_dec : x y : B, Decision (x = y)) : x y : A * B, Decision (x = y) := λ x y,
match A_dec (fst x) (fst y) with
| left _ => match B_dec (snd x) (snd y) with left _ => left _ | right _ => right _ end
| right _ => right _
end.
Solve Obligations using (program_simpl; f_equal; firstorder).
Program Instance and_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P Q) :=
match P_dec with
| left _ => match Q_dec with left _ => left _ | right _ => right _ end
| right _ => right _