(* Change from Comp to finitely supported distribution, carried by a list of pairs *)

Add LoadPath "~/fcf/src".
Add LoadPath "./Dist".
Require Import FCF.EqDec.
Require Import CpdtTactics.
Require Import List.
Require Import FCF.Rat.
Require Import FCF.Fold.

Require Import Coq.Lists.ListSet.
Require Import SetLems.
Require Import PIOA.
Require Import Dist.
Require Import Program.
Require Import Bool.

Section PIOARel.

  Definition refinement {L : Set} (P1 P2 : @PIOA L) := forall acts, exists acts',
        (f <- (run P1 acts); ret (traceOf P1 f)) ~~ (f <- (run P2 acts'); ret (traceOf P2 f)).

  Lemma refinement_refl : forall {L  : Set} (P : @PIOA L), refinement P P.
    unfold refinement.
    intros.
    exists acts.
    unfold distEquiv; crush.
  Qed.

  Lemma refinement_trans : forall {L : Set} (P Q R : @PIOA L), refinement P Q -> refinement Q R -> refinement P R.
    intros.
    unfold refinement in *.
    intro.
    destruct (H acts).
    destruct (H0 x).
    exists x0.
    rewrite H1.
    crush.
  Qed.

  Add Parametric Relation {L : Set} : (@PIOA L) refinement
  reflexivity proved by refinement_refl
  transitivity proved by refinement_trans
                           as refine_rel.

(* Without convex combination. *)
Section SyncSim.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (c : act_lab P1 -> act_lab P2).

  Record SyncSimR (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) :=
    {
      sync_obs : (forall e1 e2, R e1 e2 -> (f <- e1; ret (traceOf P1 f)) ~~ (f <- e2; ret (traceOf P2 f)));
      sync_startcond: (R (ret (FragStart _ (start P1))) (ret (FragStart _ (start  P2))));
      sync_stepcond:
        (forall gamma a, R (run P1 gamma) (run P2 (map c gamma)) -> R (appAction P1 a (run P1 gamma))
                                                      (appAction P2 (c a) (run P2 (map c gamma))))}.

  Lemma SyncSimObs : forall R (xs : list (act_lab P1)) a, SyncSimR R ->
                                   R (run P1 xs) (run P2 (map c xs)) ->
                                   R (run P1 (a :: xs)) (run P2 ((c a) :: (map c xs))).
    intros.
    rewrite run_cons.
    rewrite run_cons.
    apply (sync_stepcond _ H).
    auto.
  Qed.

  Lemma SyncSymInd : forall R (xs : list (act_lab P1)), SyncSimR R -> R (run P1 xs) (run P2 (map c xs)).
    intros.
    induction xs.
    simpl.
    unfold run.
    unfold appList.
    apply (sync_startcond _ H).
    simpl.
    apply SyncSimObs.
    apply H.
    auto.
  Qed.

  Lemma SyncSimSound : forall R, SyncSimR R -> refinement P1 P2.
    intros.
    unfold refinement.
    intros; exists (map c acts).
    apply (sync_obs _ H).
    apply SyncSymInd.
    auto.
  Qed.

End SyncSim.

  Section CompSymm.
    Context {L : Set}.
    Context (P1 P2 : @PIOA L).

    Lemma symm_comp_ins : forall l, comp_ins P1 P2 l = comp_ins P2 P1 l.
    unfold comp_ins.
    crush.
    rewrite orb_comm.
    rewrite (orb_comm (pO P2 l) (pO P1 l)).
    crush.
    Qed.

    Lemma symm_comp_outs : forall l, comp_outs P1 P2 l = comp_outs P2 P1 l.
      unfold comp_outs; crush.
      rewrite orb_comm.
      rewrite (orb_comm (pI P2 l) (pI P1 l)).
      crush.
    Qed.

    Lemma symm_comp_hiddens : forall l, comp_hiddens P1 P2 l = comp_hiddens P2 P1 l.
    unfold comp_hiddens; crush.
    rewrite (orb_comm (pH P1 l)).
    destruct (pH P2 l); crush.
    destruct (pH P1 l); crush.
    rewrite orb_comm.
    rewrite andb_comm.
    rewrite (andb_comm (pI P1 l)).
    crush.
    Qed.

    Definition symm_lab_corr (l : act_lab (P1 |+| P2)) : act_lab (P2 |+| P1).
      unfold act_lab in *; simpl in *; unfold action in *; simpl in *.
      destruct l; econstructor; instantiate (1 := x).
      rewrite <- symm_comp_ins.
      rewrite <- symm_comp_outs.
      rewrite <- symm_comp_hiddens.
      apply e.
    Defined.

    Fixpoint symm_fragCorr (xs : Frag (P2 |+| P1)) : Frag (P1  |+| P2) :=
      match xs with
      | FragStart _ (p2,p1) => FragStart (compPIOA P1 P2) (p1,p2)
      | FragStep _ l (p2,p1) f =>
        FragStep (compPIOA P1 P2) l (p1,p2) (symm_fragCorr f)
      end.

    Lemma symm_refine : refinement (P1 |+| P2) (P2 |+| P1).
    apply (SyncSimSound _ _ symm_lab_corr (fun x y => x ~~ (y0 <- y; ret symm_fragCorr y0))).
    assert (forall x, traceOf (P1 |+| P2) (symm_fragCorr x) = traceOf (P2 |+| P1) x).
    induction x; simpl; destruct p; crush.
    unfold ext_action; simpl.
    rewrite <- symm_comp_ins.
    rewrite <- symm_comp_outs.
    crush.
    crush.

    econstructor.
    intros.
    rewrite (distBind_cong_l _ _ _ H0).
    rewrite bindAssoc.
    apply distBind_cong_r; intros.
    rewrite bind_ret.
    rewrite H.
    unfold distEquiv; crush.
    simpl.
    rewrite bind_ret.
    simpl.
    unfold comp_start; simpl.
    unfold distEquiv; crush.

    intros.
    unfold appAction.
    rewrite (distBind_cong_l _ _ _ H0).
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    rewrite bind_ret.
    simpl.
    unfold comp_trans; simpl.
    destruct a; simpl.
    assert (forall x, lastState (P2 |+| P1) x = (fun p => (snd p, fst p)) (lastState (P1 |+| P2) (symm_fragCorr x))).
    induction x1; destruct p; crush.
    rewrite H2; simpl.
    destruct (lastState (P1 |+| P2) (symm_fragCorr x)); simpl.

    destruct (trans P1 p x0); destruct (trans P2 p0 x0).
    assert ((x0 <- d; y <- d0; ret (x0, y)) ~~ (y <- d0; x0 <- d; ret (x0, y))).
    apply bind_symm; intros; unfold distEquiv; crush.
    rewrite (distBind_cong_l _ _ _ H3).
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.
    Qed.

End CompSymm.

Section CompAssoc.
  Context {L : Set}.
  Context (P1 P2 P3 : @PIOA L).

    Lemma assocRefR : refinement (P1 |+| (P2 |+| P3)) ((P1 |+| P2) |+| P3).
      admit.
    Admitted.

    Lemma assocRefL : refinement ((P1 |+| P2) |+| P3) (P1 |+| (P2 |+| P3)).
      admit.
    Admitted.

End CompAssoc.

(* Without convex combination. *)
Section SimPIOA.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (c : list (act_lab P1) -> (act_lab P1) -> list (act_lab P2)).

  Fixpoint runC (acts : list (act_lab P1)) : list (act_lab P2) :=
    match acts with
    | nil => nil
    | a :: acts' =>
      (c acts' a) ++ (runC acts')
    end.

  Record SimR (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) :=
    {
      obs : (forall e1 e2, R e1 e2 -> (f <- e1; ret (traceOf P1 f)) ~~ (f <- e2; ret (traceOf P2 f)));
      startcond: (R (ret (FragStart _ (start P1))) (ret (FragStart _ (start  P2))));
      stepcond:
    (forall gamma a, R (run P1 gamma) (run P2 (runC gamma)) -> R (appAction P1 a (run P1 gamma)) (appList P2 (run P2 (runC gamma)) (c gamma a)))}.

  Lemma simInd : forall R (xs : list (act_lab P1)) a, SimR R ->
                                   R (run P1 xs) (run P2 (runC xs)) ->
                                   R (run P1 (a :: xs)) (run P2 ((c xs a) ++ (runC xs))).
    intros.
    rewrite run_cons.
    rewrite run_app.
    apply (stepcond _ H).
    auto.
  Qed.

  Lemma simInv : forall R xs, SimR R -> R (run P1 xs) (run P2 (runC xs)).
    intros.
    induction xs.
    simpl.
    unfold run.
    unfold appList.
    apply (startcond _ H).
    simpl.
    apply simInd.
    apply H.
    auto.
  Qed.

  Lemma simSound : forall R, SimR R -> refinement P1 P2.
    intros.
    unfold refinement.
    intros; exists (runC acts).
    apply (obs _ H).
    apply simInv.
    auto.
  Qed.

End SimPIOA.

Section ImplPIOA.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).

  Definition implement := forall (P : PIOA),
      refinement (compPIOA P1 P) (compPIOA P2 P).

End ImplPIOA.

Section CompImpl.
  Context {L : Set}.
  Context (P1 P2 P3 : @PIOA L).

  Lemma implrefl :
    implement P1 P1.
    intros; unfold implement; intros.
    reflexivity.
  Qed.

  Lemma impltrans :
    implement P1 P2 -> implement P2 P3 -> implement P1 P3.
    intros; unfold implement in *; intros.
    rewrite (H P).
    apply H0.
  Qed.

  Lemma implementcomp :
    implement P1 P2 -> implement (compPIOA P1 P3) (compPIOA P2 P3).
    intros.
    unfold implement in *.
    intros.
    rewrite (assocRefL P1 P3 P).
    rewrite (H (compPIOA P3 P)).
    rewrite assocRefR.
    reflexivity.
  Qed.

End CompImpl.

Definition option_lift {A B} (P : A -> B -> Prop) (x : option A) (y : option B) :=
  (x = None /\ y = None) \/
  (exists c1 c2,
      x = Some c1 /\ y = Some c2 /\ P c1 c2).

Section SimplImplement.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (lab_eq1 : pI P1 = pI P2).
  Context (lab_eq2 : pO P1 = pO P2).
  Context (lab_eq3 : pH P1 = pH P2).
  Context (st_corr : pQ P1 -> pQ P2).
  Context (start_corr : st_corr (start P1) = start P2).
  Context (trans_corr :
             forall s l,
               option_lift (fun d1 d2 => (x <- d1; ret (st_corr x)) ~~ d2) (trans P1 s l) (trans P2 (st_corr s) l)
               ).

  Definition simpl_lab_corr : forall P, act_lab (P1 |+| P) -> act_lab (P2 |+| P).
    intros.
    destruct H.
    econstructor.
    unfold action in *; simpl in *; unfold comp_ins, comp_hiddens, comp_outs in *.
  repeat rewrite lab_eq1 in e.
  repeat rewrite lab_eq2 in e.
  repeat rewrite lab_eq3 in e.
  apply e.
  Defined.

  Fixpoint simpl_actlist_corr (P : PIOA) (al : list (act_lab (P1 |+| P))) :=
    map (simpl_lab_corr P) al.

  Definition simpl_frag_corr (P : PIOA) (f : Frag (P1 |+| P)) : Frag (P2 |+| P).
    induction f.
    apply FragStart.
    simpl in p.
    simpl.
    split.
    apply (st_corr (fst p)).
    apply (snd p).

    apply FragStep.
    apply l.
    simpl in *.
    apply (st_corr (fst p), snd p).
    apply IHf.
  Defined.

  Lemma simpl_frag_corr_correct (P : PIOA) (f : Frag (P1 |+| P)) :
    traceOf _ (simpl_frag_corr _ f) = traceOf _ f.
  induction f.
  simpl; unfold distEquiv; crush.
  simpl.
  rewrite IHf.
  unfold ext_action; simpl; unfold comp_ins, comp_outs.
  rewrite lab_eq1.
  rewrite lab_eq2.
  auto.
  Qed.

  Definition simpl_simR : forall P, Dist (Frag (P1 |+| P)) -> Dist (Frag (P2 |+| P)) -> Prop :=
    fun _ e1 e2 =>
      (x <- e1; ret (simpl_frag_corr _ x)) ~~ e2.

  Lemma simpl_sim : forall P, SyncSimR (P1 |+| P) (P2 |+| P) (simpl_lab_corr P) (simpl_simR P).
  intros; constructor.
  intros.
  unfold simpl_simR in H.
  symmetry in H.
  rewrite (distBind_cong_l _ _ _ H).
  rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret; simpl.
  rewrite simpl_frag_corr_correct.
  unfold distEquiv; crush.
  unfold simpl_simR; simpl.
  rewrite bind_ret.
  simpl.
  unfold comp_start; simpl.
  rewrite start_corr.
  unfold distEquiv; crush.
  intros.
  unfold simpl_simR in *.
  unfold appAction.
  symmetry; symmetry in H.
  rewrite (distBind_cong_l _ _ _ H).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret.
  simpl.
  unfold comp_trans; simpl.
  assert (forall x, lastState (P2 |+| P) (simpl_frag_corr P x) =
          ((st_corr (fst (lastState _ x)), snd (lastState _ x)))).
  induction x0; crush.
  rewrite H1; simpl.
  destruct (lastState (P1 |+| P) x); simpl.
  destruct a; simpl.
  unfold option_lift in trans_corr.
  destruct (trans_corr p x0).
  destruct H2.
  rewrite H2, H3.
  destruct (trans P p0 x0).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros; repeat rewrite bind_ret; simpl.
  unfold distEquiv; crush.
  rewrite bind_ret; unfold distEquiv; crush.
  destruct H2.
  destruct H2.
  destruct H2.
  destruct H3.
  rewrite H2, H3.
  destruct (trans P p0 x0).
  repeat rewrite bindAssoc.
  symmetry in H4.
  rewrite (distBind_cong_l _ _ _ H4).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret; repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  repeat rewrite bind_ret.
  simpl.
  unfold distEquiv; crush.
  rewrite bindAssoc.
  symmetry in H4.
  rewrite (distBind_cong_l _ _ _ H4).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  repeat rewrite bind_ret; simpl.
  unfold distEquiv; crush.
Qed.

  Lemma simpl_implement : implement P1 P2.
    unfold implement.
    intros.
    eapply SyncSimSound.
    apply simpl_sim.
  Qed.

End SimplImplement.

  Add Parametric Relation {L : Set} : (@PIOA L) implement
  reflexivity proved by implrefl
  transitivity proved by impltrans
                           as implement_rel.

Section SimplImplLabExt.
  Context (L L' : Set).
  Context (Lsur : L' -> option L).
  Context (Linj : L -> L').
  Context (Linv : forall x, Some x = Lsur (Linj x)).
 Context (Linv2 : (forall l l', Some l = Lsur l' -> Linj l = l')).
  Context (P1 P2 : @PIOA L).

  Definition act_lab_corr_lab_ext (f : act_lab P1 -> act_lab P2) : act_lab (lab_ext L L' P1 Lsur) -> act_lab (lab_ext L L' P2 Lsur).
    intros.
    destruct H.
    unfold action in e; simpl in e.
    destruct (Lsur x).
    cut (act_lab P2 -> act_lab (lab_ext L L' P2 Lsur)).
    intro.
    apply H; apply f.
    econstructor.
    apply e.

    intro.
    destruct H.
    econstructor.
    instantiate (1 := Linj x0).
    unfold action; simpl.
    rewrite <- Linv.
    apply e0.
    crush.
 Defined.

 Definition lab_ext_frag_corr : forall P, Frag (lab_ext L L' P Lsur) -> Frag P.
 intros.
 induction H.
 apply FragStart.
 apply p.
 destruct (Lsur l).
 apply FragStep.
 apply l0.
 apply p.
 apply IHFrag.
 apply IHFrag.
 Defined.

 Lemma lab_ext_traceOf_corr : forall P f,
     map Linj (traceOf P (lab_ext_frag_corr _ f)) = (traceOf (lab_ext L L' P Lsur) f).
 intros.
 induction f.
 simpl.
 crush.
 simpl.
 unfold ext_action.
 simpl.

 rewrite <- IHf.
 remember (Lsur l) as y; destruct y.
 simpl.
 unfold ext_action; simpl.
 destruct (pI P l0 || pO P l0).
 rewrite map_cons.
 simpl.
 rewrite (Linv2 _ _ Heqy).
 auto.

 auto.
 simpl.
 auto.
 Qed.

 Definition sync_R_lab_ext (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) : Dist (Frag (lab_ext L L' P1 Lsur)) -> Dist (Frag (lab_ext  L L' P2 Lsur)) -> Prop :=
   fun d1 d2 =>
     R (x <- d1; ret (lab_ext_frag_corr _ x)) (y <- d2; ret (lab_ext_frag_corr _ y)).

 End SimplImplLabExt.

End PIOARel.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Import VariableModule2.

Set Implicit Arguments.
Set Printing Universes.

Module TypingInfoFun(t : TauTypingInfo) <: TypingInfoProofsSig.
  Include t.

Lemma beq_t_refl:
 forall (t : T),
   beq_t t t = true.
Proof.
  intros.
  induction t; crush.
Qed.
Hint Resolve beq_t_refl.

End TypingInfoFun.

(*
Lemma beq_tau_sym : forall x y, beq_tau x y = beq_tau y x.
Proof.
  induction x; induction y; try solve [crush].
Qed.
Hint Immediate beq_tau_sym.

Lemma beq_tau_trans :
  forall x y z,
    beq_tau x y = true -> beq_tau y z = true -> beq_tau x z = true.
Proof.
  induction x; induction y; induction z; intros; try solve [inversion H]; try solve [inversion H0].
  inversion H. inversion H0.
  crush.
  apply beq_tvar_trans with (x:= t) (y:= t0) (z:= t1) in H2; try assumption.
  reflexivity.
  unfold beq_tau.
  fold beq_tau.
  unfold beq_tau in H.
  fold beq_tau in H.
  unfold beq_tau in H0.
  fold beq_tau in H0.
  apply andb_true_iff in H.
  apply andb_true_iff in H0.
  inversion H.
  inversion H0.
  apply andb_true_iff.
  apply IHx1 with (z:= z1)in H1; try assumption.
  apply IHx2 with (z:= z2)in H2; try assumption.
  split; try assumption.
Qed.
Hint Resolve beq_tau_trans.

Lemma beq_tau_eq:
  forall t0 t1, beq_tau t0 t1 = true -> t0 = t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H].
  inversion H.
  apply beq_tvar_eq in H1.
  rewrite H1.
  reflexivity.
  reflexivity.
  clear IHt1_1.
  clear IHt1_2.
  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.
Qed.

Lemma beq_tau_neq:
  forall t0 t1, beq_tau t0 t1 = false -> t0 <> t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try solve [discriminate].
  apply beq_tvar_neq in H.
  crush.
  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.
Qed.
*)


(** Definitions to build explorable predicates. **)

From Coq Require Import List.
From Lib Require Import decide pick.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Definition of explorability **)

(** Explorable means that we can list all the elements satisfying the constraint,
  modulo an equivalent relation. **)
Definition explorable_modulo A (P : A -> Prop) (M : A -> A -> Prop) :=
  { l : list A | forall x, P x <-> exists y, In y l /\ M x y }.

Definition explorable2_modulo A1 A2 (P : A1 -> A2 -> Prop) :=
  explorable_modulo (fun x => let '(x1, x2) := x in P x1 x2).

Definition explorable3_modulo A1 A2 A3 (P : A1 -> A2 -> A3 -> Prop) :=
  explorable_modulo (fun x => let '(x1, x2, x3) := x in P x1 x2 x3).

Definition explorable4_modulo A1 A2 A3 A4 (P : A1 -> A2 -> A3 -> A4 -> Prop) :=
  explorable_modulo (fun x => let '(x1, x2, x3, x4) := x in P x1 x2 x3 x4).

Definition explorable5_modulo A1 A2 A3 A4 A5 (P : A1 -> A2 -> A3 -> A4 -> A5 -> Prop) :=
  explorable_modulo (fun x => let '(x1, x2, x3, x4, x5) := x in P x1 x2 x3 x4 x5).

(** Explorable means that we can list all the elements satisfying the constraint. **)
Definition explorable A (P : A -> Prop) :=
  { l : list A | forall x, P x <-> In x l }.

Definition explorable2 A1 A2 (P : A1 -> A2 -> Prop) :=
  explorable (fun x => let '(x1, x2) := x in P x1 x2).

Definition explorable3 A1 A2 A3 (P : A1 -> A2 -> A3 -> Prop) :=
  explorable (fun x => let '(x1, x2, x3) := x in P x1 x2 x3).

Definition explorable4 A1 A2 A3 A4 (P : A1 -> A2 -> A3 -> A4 -> Prop) :=
  explorable (fun x => let '(x1, x2, x3, x4) := x in P x1 x2 x3 x4).

Definition explorable5 A1 A2 A3 A4 A5 (P : A1 -> A2 -> A3 -> A4 -> A5 -> Prop) :=
  explorable (fun x => let '(x1, x2, x3, x4, x5) := x in P x1 x2 x3 x4 x5).

Definition explorable_Type T :=
  explorable (fun _ : T => True).

Create HintDb explorability.

(** * Lemmas about explorability **)

Lemma explorable_modulo_eq_explorable : forall A (P : A -> Prop),
  explorable_modulo P eq ->
  explorable P.
Proof.
  intros A P [l F]. exists l. split.
  - intro p. apply F in p. destruct p as [? [? ?]]. now subst.
  - intro I. apply F. now exists x.
Defined.

Hint Resolve explorable_modulo_eq_explorable : pickability.

Lemma explorable_explorable_modulo_eq : forall A (P : A -> Prop),
  explorable P ->
  explorable_modulo P eq.
Proof.
  intros A P [l F]. exists l. split.
  - intro I. apply F in I. now exists x.
  - intros [? [? ?]]. apply F. now subst.
Defined.

Hint Resolve explorable_explorable_modulo_eq : pickability.

Lemma explorable2_modulo_eq_explorable2 : forall A1 A2 (P : A1 -> A2 -> Prop),
  explorable2_modulo P eq ->
  explorable2 P.
Proof.
  intros A1 A2 P. now apply explorable_modulo_eq_explorable.
Defined.

Lemma explorable2_explorable2_modulo_eq : forall A1 A2 (P : A1 -> A2 -> Prop),
  explorable2 P ->
  explorable2_modulo P eq.
Proof.
  intros A1 A2 P. now apply explorable_explorable_modulo_eq.
Defined.

Lemma explorable3_modulo_eq_explorable3 : forall A1 A2 A3 (P : A1 -> A2 -> A3 -> Prop),
  explorable3_modulo P eq ->
  explorable3 P.
Proof.
  intros A1 A2 A3 P. now apply explorable_modulo_eq_explorable.
Defined.

Lemma explorable3_explorable3_modulo_eq : forall A1 A2 A3 (P : A1 -> A2 -> A3 -> Prop),
  explorable3 P ->
  explorable3_modulo P eq.
Proof.
  intros A1 A2 A3 P. now apply explorable_explorable_modulo_eq.
Defined.

Lemma explorable4_modulo_eq_explorable4 : forall A1 A2 A3 A4 (P : A1 -> A2 -> A3 -> A4 -> Prop),
  explorable4_modulo P eq ->
  explorable4 P.
Proof.
  intros A1 A2 A3 A4 P. now apply explorable_modulo_eq_explorable.
Defined.

Lemma explorable4_explorable4_modulo_eq : forall A1 A2 A3 A4 (P : A1 -> A2 -> A3 -> A4 -> Prop),
  explorable4 P ->
  explorable4_modulo P eq.
Proof.
  intros A1 A2 A3 A4 P. now apply explorable_explorable_modulo_eq.
Defined.

Lemma explorable5_modulo_eq_explorable5 : forall A1 A2 A3 A4 A5 (P : A1 -> A2 -> A3 -> A4 -> A5 -> Prop),
  explorable5_modulo P eq ->
  explorable5 P.
Proof.
  intros A1 A2 A3 A4 A5 P. now apply explorable_modulo_eq_explorable.
Defined.

Lemma explorable5_explorable5_modulo_eq : forall A1 A2 A3 A4 A5 (P : A1 -> A2 -> A3 -> A4 -> A5 -> Prop),
  explorable5 P ->
  explorable5_modulo P eq.
Proof.
  intros A1 A2 A3 A4 A5 P. now apply explorable_explorable_modulo_eq.
Defined.

Lemma explorable_modulo_pickable : forall A (P : A -> Prop) (M : A -> A -> Prop),
  (forall a, M a a) ->
  (forall a b, P a -> M a b -> P b) ->
  explorable_modulo P M ->
  pickable P.
Proof.
  intros A P M Refl Trans [[|x l] F].
  - right. intros [x p]. apply F in p. now inversion p.
  - left. exists x. apply F. exists x. split; auto. now left.
Defined.

Hint Resolve explorable_modulo_pickable : pickability.

Lemma explorable_pickable : forall A (P : A -> Prop),
  explorable P ->
  pickable P.
Proof.
  intros A P E. apply explorable_modulo_pickable with eq; auto.
  - now intros; subst.
  - now apply explorable_explorable_modulo_eq.
Defined.

Hint Resolve explorable_pickable : pickability.

Lemma explorable2_pickable2 : forall A1 A2 (P : A1 -> A2 -> Prop),
  explorable2 P ->
  pickable2 P.
Proof.
  intros A1 A2 P [[|[x1 x2] l] F].
  - right. intros [x1 [x2 p]]. apply F with (x1, x2) in p. now inversion p.
  - left. exists (x1, x2). apply F with (x := (x1, x2)). now left.
Defined.

Hint Resolve explorable2_pickable2 : pickability.

Lemma explorable3_pickable3 : forall A1 A2 A3 (P : A1 -> A2 -> A3 -> Prop),
  explorable3 P ->
  pickable3 P.
Proof.
  intros A1 A2 A3 P [[|[[x1 x2] x3] l] F].
  - right. intros [x1 [x2 [x3 p]]]. apply F with (x1, x2, x3) in p. now inversion p.
  - left. exists (x1, x2, x3). apply F with (x := (x1, x2, x3)). now left.
Defined.

Hint Resolve explorable3_pickable3 : pickability.

Lemma explorable4_pickable4 : forall A1 A2 A3 A4 (P : A1 -> A2 -> A3 -> A4 -> Prop),
  explorable4 P ->
  pickable4 P.
Proof.
  intros A1 A2 A3 A4 P [[|[[[x1 x2] x3] x4] l] F].
  - right. intros [x1 [x2 [x3 [x4 p]]]]. apply F with (x1, x2, x3, x4) in p. now inversion p.
  - left. exists (x1, x2, x3, x4). apply F with (x := (x1, x2, x3, x4)). now left.
Defined.

Hint Resolve explorable4_pickable4 : pickability.

Lemma explorable5_pickable5 : forall A1 A2 A3 A4 A5 (P : A1 -> A2 -> A3 -> A4 -> A5 -> Prop),
  explorable5 P ->
  pickable5 P.
Proof.
  intros A1 A2 A3 A4 A5 P [[|[[[[x1 x2] x3] x4] x5] l] F].
  - right. intros [x1 [x2 [x3 [x4 [x5 p]]]]]. apply F with (x1, x2, x3, x4, x5) in p. now inversion p.
  - left. exists (x1, x2, x3, x4, x5). apply F with (x := (x1, x2, x3, x4, x5)). now left.
Defined.

Hint Resolve explorable5_pickable5 : pickability.

(** * Tactics **)

Ltac prove_explorable := now eauto with explorability pickability decidability.

(** Solves a goal of the form [explorable_Type T] given an exhaustive list of elements. **)
Ltac prove_explorable_Type l :=
  let x := fresh "x" in
  exists l; intros x; split; [ destruct x; repeat first [ now left | right ] | now auto ].

(** * Adding external lemmas to the database **)

(** ** Basic data types **)

Lemma explorable_unit : explorable_Type unit.
Proof.
  prove_explorable_Type (tt :: nil).
Defined.

Hint Resolve explorable_unit : explorability.

Lemma explorable_bool : explorable_Type bool.
Proof.
  prove_explorable_Type (true :: false :: nil).
Defined.

Hint Resolve explorable_bool : explorability.

Lemma explorable_comparison : explorable_Type comparison.
Proof.
  prove_explorable_Type (Eq :: Lt :: Gt :: nil).
Defined.

Hint Resolve explorable_comparison : explorability.

(** ** List **)

Lemma explorable_In : forall T (l : list T),
  explorable (fun x => List.In x l).
Proof.
  intros T l. now exists l.
Defined.

Hint Resolve explorable_In : explorability.