Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntaxb_ott
               rulesb_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Notation "Γ ⊢ E A" := (Btyping Γ E A) (at level 45).
Notation "[ z ~> u ]' t" := (subst_term u z t) (at level 0).
Notation "t ^^' u"       := (open_term_wrt_term t u) (at level 67).

Notation "t ->* r" := (bsteps t r) (at level 68).

Lemma star_one:
forall a b, bstep a (t_term b) -> bsteps a (t_term b).
Proof.
eauto using bsteps.
Qed.

Lemma star_trans:
forall a b, bsteps a (t_term b) -> forall c, bsteps b (t_term c) -> bsteps a (t_term c).
Proof.
  introv H.
  inductions H; eauto using bsteps.
Qed.

Hint Resolve star_one star_trans : core.

Lemma valueb_lc : forall v,
    valueb v -> lc_term v.
Proof.
  intros v H.
  induction* H.
Qed.

Lemma multi_red_app : forall v t t',
    valueb v -> t ->* (t_term t') -> (trm_app v t) ->* (t_term (trm_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(wellformedb (appCtxRb v)). eauto.
  forwards*: do_stepb H1 H.
Qed.

Lemma multi_blame_app : forall v t,
    valueb v -> t ->* (t_blame) -> (trm_app v t) ->* (t_blame).
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply bstep_nb.
  assert(wellformedb (appCtxRb v)). eauto.
  forwards*: do_stepb H0 H.
  simpl. forwards*: IHRed.
  apply bstep_b.
  assert(wellformedb (appCtxRb v)). eauto.
  forwards*: blame_stepb H0 H.
Qed.

Lemma multi_red_app2 : forall t1 t2 t1',
    lc_term t2 -> t1 ->* (t_term t1') -> (trm_app t1 t2) ->* (t_term (trm_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(wellformedb (appCtxLb t2)). eauto.
  forwards*: do_stepb H0 H.
Qed.

Lemma multi_blame_app2 : forall t1 t2 ,
    lc_term t2 -> t1 ->* t_blame -> (trm_app t1 t2) ->* t_blame.
Proof.
  introv Val Red.
  inductions Red; eauto.
  eapply bstep_nb.
  assert(wellformedb (appCtxLb t2)). eauto.
  forwards*: do_stepb H0 H.
  simpl. forwards*: IHRed.
  apply bstep_b.
  assert(wellformedb (appCtxLb t2)). eauto.
  forwards*: blame_stepb H0 H.
Qed.

Lemma multi_red_cast : forall t t' A B,
    t ->* (t_term t') -> (trm_cast t A B) ->* (t_term (trm_cast t' A B)).
Proof.
  introv Red.
  inductions Red; eauto.
  assert(wellformedb (castCtxb A B)). eauto.
  forwards*: do_stepb H0 H.
Qed.

Lemma multi_blame_cast : forall t A B,
    t ->* t_blame -> (trm_cast t A B) ->* t_blame.
Proof.
  introv Red.
  inductions Red; eauto.
  eapply bstep_nb.
  assert(wellformedb (castCtxb A B)). eauto.
  forwards*: do_stepb H0 H.
  simpl. forwards*: IHRed.
  apply bstep_b.
  assert(wellformedb (castCtxb A B)). eauto.
  forwards*: blame_stepb H0 H.
Qed.


From Hammer Require Import Hammer.

Require Import Coq.Classes.EquivDec.

Theorem EquivDec_refl_left {T : Type} {c : EqDec T (@eq T)} :
forall (n : T), equiv_dec n n = left (refl_equal _).
Proof. hammer_hook "EquivDec" "EquivDec.EquivDec_refl_left".
intros. destruct (equiv_dec n n); try congruence.
Require Eqdep_dec.
rewrite (Eqdep_dec.UIP_dec (A := T) (@equiv_dec _ _ _ c) e (refl_equal _)).
reflexivity.
Qed.

Export Coq.Classes.EquivDec.


From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Import lang adequacy proofmode notation.
(* Import lang *again*. This used to break notation. *)
From iris.heap_lang Require Import lang.
Set Default Proof Using "Type".

Section tests.
  Context `{heapG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.

  Definition simpl_test :
    ⌜(10 = 4 + 6)%nat⌝ -∗
    WP let: "x" := ref #1 in "x" <- !"x";; !"x" {{ v, ⌜v = #1⌝ }}.
  Proof.
    iIntros "?". wp_alloc l. repeat (wp_pure _) || wp_load || wp_store.
    match goal with
    | |- context [ (10 = 4 + 6)%nat ] => done
    end.
  Qed.

  Definition val_scope_test_1 := SOMEV (#(), #()).

  Definition heap_e : expr :=
    let: "x" := ref #1 in "x" <- !"x" + #1 ;; !"x".

  Lemma heap_e_spec E : WP heap_e @ E {{ v, ⌜v = #2⌝ }}%I.
  Proof.
    iIntros "". rewrite /heap_e. Show.
    wp_alloc l as "?". wp_let. wp_load. Show.
    wp_op. wp_store. by wp_load.
  Qed.

  Definition heap_e2 : expr :=
    let: "x" := ref #1 in
    let: "y" := ref #1 in
    "x" <- !"x" + #1 ;; !"x".

  Lemma heap_e2_spec E : WP heap_e2 @ E [{ v, ⌜v = #2⌝ }]%I.
  Proof.
    iIntros "". rewrite /heap_e2.
    wp_alloc l as "Hl". Show. wp_let. wp_alloc l'. wp_let.
    wp_load. wp_op. wp_store. wp_load. done.
  Qed.

  Definition heap_e3 : expr :=
    let: "x" := #true in
    let: "f" := λ: "z", "z" + #1 in
    if: "x" then "f" #0 else "f" #1.

  Lemma heap_e3_spec E : WP heap_e3 @ E [{ v, ⌜v = #1⌝ }]%I.
  Proof.
    iIntros "". rewrite /heap_e3.
    by repeat (wp_pure _).
  Qed.

  Definition heap_e4 : expr :=
    let: "x" := (let: "y" := ref (ref #1) in ref "y") in
    ! ! !"x".

  Lemma heap_e4_spec : WP heap_e4 [{ v, ⌜ v = #1 ⌝ }]%I.
  Proof.
    rewrite /heap_e4. wp_alloc l. wp_alloc l'. wp_let.
    wp_alloc l''. wp_let. by repeat wp_load.
  Qed.

  Definition heap_e5 : expr :=
    let: "x" := ref (ref #1) in FAA (!"x") (#10 + #1) + ! !"x".

  Lemma heap_e5_spec E : WP heap_e5 @ E [{ v, ⌜v = #13⌝ }]%I.
  Proof.
    rewrite /heap_e5. wp_alloc l. wp_alloc l'. wp_let.
    wp_load. wp_op. wp_faa. do 2 wp_load. wp_op. done.
  Qed.

  Definition heap_e6 : val := λ: "v", "v" = "v".

  Lemma heap_e6_spec (v : val) : (WP heap_e6 v {{ w, ⌜ w = #true ⌝ }})%I.
  Proof. wp_lam. wp_op. by case_bool_decide. Qed.

  Definition FindPred : val :=
    rec: "pred" "x" "y" :=
      let: "yp" := "y" + #1 in
      if: "yp" < "x" then "pred" "x" "yp" else "y".
  Definition Pred : val :=
    λ: "x",
      if: "x" ≤ #0 then -FindPred (-"x" + #2) #0 else FindPred "x" #0.

  Lemma FindPred_spec n1 n2 E Φ :
    n1 < n2 →
    Φ #(n2 - 1) -∗ WP FindPred #n2 #n1 @ E [{ Φ }].
  Proof.
    iIntros (Hn) "HΦ".
    iInduction (Z.gt_wf n2 n1) as [n1' _] "IH" forall (Hn).
    wp_rec. wp_let. wp_op. wp_let.
    wp_op; case_bool_decide; wp_if.
    - iApply ("IH" with "[%] [%] HΦ"); omega.
    - by assert (n1' = n2 - 1) as -> by omega.
  Qed.

  Lemma Pred_spec n E Φ : Φ #(n - 1) -∗ WP Pred #n @ E [{ Φ }].
  Proof.
    iIntros "HΦ". wp_lam.
    wp_op. case_bool_decide; wp_if.
    - wp_op. wp_op.
      wp_apply FindPred_spec; first omega.
      wp_op. by replace (n - 1) with (- (-n + 2 - 1)) by omega.
    - wp_apply FindPred_spec; eauto with omega.
  Qed.

  Lemma Pred_user E :
    WP let: "x" := Pred #42 in Pred "x" @ E [{ v, ⌜v = #40⌝ }]%I.
  Proof. iIntros "". wp_apply Pred_spec. wp_let. by wp_apply Pred_spec. Qed.

  Lemma wp_apply_evar e P :
    P -∗ (∀ Q Φ, Q -∗ WP e {{ Φ }}) -∗ WP e {{ _, True }}.
  Proof. iIntros "HP HW". wp_apply "HW". iExact "HP". Qed.

  Lemma wp_cas l v :
    val_is_unboxed v →
    l ↦ v -∗ WP CAS #l v v {{ _, True }}.
  Proof.
    iIntros (?) "?". wp_cas as ? | ?. done. done.
  Qed.

  Lemma wp_alloc_split :
    WP Alloc #0 {{ _, True }}%I.
  Proof. wp_alloc l as "[Hl1 Hl2]". Show. done. Qed.

  Lemma wp_alloc_drop :
    WP Alloc #0 {{ _, True }}%I.
  Proof. wp_alloc l as "_". Show. done. Qed.

End tests.

Section printing_tests.
  Context `{heapG Σ}.

  (* These terms aren't even closed, but that's not what this is about.  The
  length of the variable names etc. has been carefully chosen to trigger
  particular behavior of the Coq pretty printer. *)

  Lemma wp_print_long_expr (fun1 fun2 fun3 : expr) :
    True -∗ WP let: "val1" := fun1 #() in
       let: "val2" := fun2 "val1" in
       let: "val3" := fun3 "val2" in
       if: "val1" = "val2" then "val" else "val3"  {{ _, True }}.
  Proof.
    iIntros "_". Show.
  Abort.

  Lemma wp_print_long_expr (fun1 fun2 fun3 : expr) Φ :
    True -∗ WP let: "val1" := fun1 #() in
       let: "val2" := fun2 "val1" in
       let: "v" := fun3 "v" in
       if: "v" = "v" then "v" else "v"  {{ Φ }}.
  Proof.
    iIntros "_". Show.
  Abort.

  Lemma wp_print_long_expr (fun1 fun2 fun3 : expr) Φ E :
    True -∗ WP let: "val1" := fun1 #() in
       let: "val2" := fun2 "val1" in
       let: "v" := fun3 "v" in
       if: "v" = "v" then "v" else "v" @ E {{ Φ }}.
  Proof.
    iIntros "_". Show.
  Abort.

  Lemma texan_triple_long_expr (fun1 fun2 fun3 : expr) :
    {{{ True }}}
       let: "val1" := fun1 #() in
       let: "val2" := fun2 "val1" in
       let: "val3" := fun3 "val2" in
       if: "val1" = "val2" then "val" else "val3"
    {{{ (x y : val) (z : Z), RET (x, y, #z); True }}}.
  Proof. Show. Abort.

End printing_tests.

Section error_tests.
  Context `{heapG Σ}.

  Check "not_cas".
  Lemma not_cas :
    (WP #() {{ _, True }})%I.
  Proof.
    Fail wp_cas_suc.
  Abort.
End error_tests.

Lemma heap_e_adequate σ : adequate NotStuck heap_e σ (= #2).
Proof. eapply (heap_adequacy heapΣ)=> ?. by apply heap_e_spec. Qed.


(*|
==============================
Syntactic equality over ctrees
==============================
As always with coinductive structures in Coq, [eq] is too strong
to be usable. We hence define through this file [equ], a coinductive
syntactic equality over the structure. [equ] enforces the trees to
have the exact same shape, constructor by constructor.

This relation is analogous to what is dubbed as _strong bisimulation_
for [itree], but we are trying to avoid this terminology here since
we reserve the notion of bisimulation for the equivalence relations
that take internal non-determinism into account.

.. coq:: none
|*)
From Coq Require Import RelationClasses Program.

From Coinduction Require Import
	coinduction rel tactics.

From CTree Require Import
     CTree
     Eq.Shallow.

Import CTree.

(*|
.. coq::
|*)

Section equ.

  Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

(*|
We also need to do some gymnastics to work around the
two-layered definition of [ctree]. We first define a
relation transformer [equF] as an indexed inductive type
on [ctree'], which is then composed with [observe] to obtain
a relation transformer on [ctree] ([equ_]).

In short, this is necessitated by the fact that dependent
pattern-matching is not allowed on [ctree].
|*)

  Variant equb (eq : ctree E R1 -> ctree E R2 -> Prop) :
    ctree' E R1 -> ctree' E R2 -> Prop :=
  | Eq_Ret x y (REL : RR x y) : equb eq (RetF x) (RetF y)
  | Eq_Vis {X} (e : E X) k1 k2
      (REL : forall x, eq (k1 x) (k2 x)) :
      equb eq (VisF e k1) (VisF e k2)
  | Eq_Br b {n} (k1 : Fin.t n -> _) (k2 : Fin.t n -> _)
              (REL : forall i, eq (k1 i) (k2 i)) :
      equb eq (BrF b n k1) (BrF b n k2)
  .
  Hint Constructors equb: core.

  Definition equb_ eq : ctree E R1 -> ctree E R2 -> Prop :=
	fun t1 t2 => equb eq (observe t1) (observe t2).

  Program Definition fequ: mon (ctree E R1 -> ctree E R2 -> Prop) := {|body := equb_|}.
  Next Obligation.
    unfold pointwise_relation, Basics.impl, equb_.
    intros ?? INC ?? EQ. inversion_clear EQ; auto.
  Qed.

End equ.

(*|
The relation itself, defined as the greatest fixed-point of [fequ].
Through this development, we use the [coinduction] package developed
by Damien Pous to define and reason about coinductive relations.
The approach is based on the so-called "companion", described in
the paper "Coinduction All the Way Up" (Pous, LICS'16).

The greastest fixed-point is defined by the construction [gfp].
It gives access to the following tactics:
- [coinduction S CIH] initiates a coinductive proof;
- [step in H] unfold in [H] the [gfp], exposing here for instance
[equF], allowing for an inversion to be performed;
- [step] unfolds in the goal the [gfp], exposing [equF], so that
one can play the game once. Note that formally speaking, this
corresponds to reasoning "up-to fequ".
- additionnaly, the companion provides extensive support for
up-to reasoning: any function [f] proved to be below the companion,
denoted [t], is accessible during a proof by coinduction.

|*)

Definition equ {E R1 R2} R := (gfp (@fequ E R1 R2 R)).
#[global] Hint Unfold equ: core.
#[global] Hint Constructors equb: core.
Arguments equb_ _ _ _ _/.

Ltac fold_equ :=
  repeat
    match goal with
    | h: context[@fequ ?E ?R1 ?R2 ?RR] |- _ => fold (@equ E R1 R2 RR) in h
    | |- context[@fequ ?E ?R1 ?R2 ?RR] => fold (@equ E R1 R2 RR)
    end.

Ltac __coinduction_equ R H :=
  unfold equ; apply_coinduction; fold_equ; intros R H.

Tactic Notation "__step_equ" :=
  match goal with
  | |- context [@equ ?E ?R1 ?R2 ?RR _ _] =>
      unfold equ;
      step;
      fold (@equ E R1 R2 RR);
      simpl body
  | |- _ => step
  end.

#[local] Tactic Notation "step" := __step_equ.

#[local] Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) :=
  __coinduction_equ R H.

Ltac __step_in_equ H :=
  match type of H with
  | context [@equ ?E ?R1 ?R2 ?RR _ _] =>
      unfold equ in H;
      step in H;
      fold (@equ E R1 R2 RR) in H;
      simpl body in H
  end.

#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H.

Module EquNotations.

  Infix "≅" := (equ eq) (at level 70).

(*|
The associated companions:
|*)
  Notation et Q  := (t (fequ Q)).
  Notation eT Q  := (T (fequ Q)).
  Notation ebt Q := (bt (fequ Q)).
  Notation ebT Q := (bT (fequ Q)).
  Notation "t [≅ Q ] u" := (et Q _ t u) (at level 79).
  Notation "t {≅ Q } u" := (ebt Q _ t u) (at level 79).
  Notation "t {{≅ Q }} u" := (equb Q (equ Q) t u) (at level 79).
  Notation "t [≅] u" := (et eq _ t u) (at level 79).
  Notation "t {≅} u" := (ebt eq _ t u) (at level 79).
  Notation "t {{≅}} u" := (equb eq (equ eq) t u) (at level 79).

End EquNotations.

Import EquNotations.

Section equ_theory.

  Variable (E : Type -> Type) (R : Type) (RR : R -> R -> Prop).
  Notation eT  := (coinduction.T (fequ (E := E) RR)).
  Notation et  := (coinduction.t (fequ (E := E) RR)).
  Notation ebt := (coinduction.bt (fequ (E := E) RR)).
(*|
This is just a hack to avoid a universe inconsistency when
 using both the relational algebra and coinduction libraries
 (we fix the type at which we'll use [eq]).
|*)
  Definition seq: relation (ctree E R) := eq.

(*|
[eq] is a post-fixpoint, thus [const eq] is below [t]
These kind of lemmas are proofs of validity of up-to reasoning
principles: [t_equ RR] is the companion of the monotone function
[fequ RR]. By proving that the function (on relations over ctrees)
[const seq] (i.e. [fun R => eq]) is below the companion, it is proved
to be a valid enhancement, and hence can be used at any point during
a coinductive proof.
Here concretely, bisimulation candidates don't ever need
to be closed by reflexivity in effect: the companion is always reflexive.
|*)
	Lemma refl_t {RRR: Reflexive RR}: const seq <= et.
	Proof.
		apply leq_t. intro. cbn.
		change (@eq (ctree E R)  <= equb_ RR eq).
		intros p ? <-. cbn. desobs p; auto.
	Qed.

(*|
[converse] is compatible: up-to symmetry is valid
|*)
	Lemma converse_t {RRS: Symmetric RR}: converse <= et.
  Proof.
    apply leq_t. intros S x y H; cbn. destruct H; auto.
  Qed.

(*|
[squaring] is compatible: up-to transitivity is valid
|*)
  Lemma square_t {RRR: Reflexive RR} {RRT: Transitive RR}: square <= et.
	Proof.
		apply leq_t.
		intros S x z [y xy yz]; cbn.
		inversion xy; inversion yz; try (exfalso; congruence).
		- constructor. replace y0 with x1 in * by congruence. eauto.
		- rewrite <-H in H2.
      destruct (Vis_eq1 H2).
      destruct (Vis_eq2 H2) as [-> ->].
      constructor. intro x0. now exists (k2 x0).
    - rewrite <- H in H2.
      destruct (Br_eq1 H2); subst.
      destruct (Br_eq2 H2).
      constructor. intros i. now (exists (k0 i)).
  Qed.

(*|
Having [const eq], [converse] and [square] below the companion entails respectively
that the companion, at all point, is reflexive, symmetric, transitive.
The companion library directly provide these results for bisimilarity, [t R], [b (t R)]
and [T f R].
|*)
  #[global] Instance Equivalence_et `{Equivalence _ RR} S: Equivalence (et S).
  Proof. apply Equivalence_t. apply refl_t. apply square_t. apply converse_t. Qed.
  #[global] Instance Equivalence_T `{Equivalence _ RR} f S: Equivalence (eT f S).
  Proof. apply Equivalence_T. apply refl_t. apply square_t. apply converse_t. Qed.
  #[global] Instance Equivalence_bt `{Equivalence _ RR} S: Equivalence (ebt S).
  Proof. apply Equivalence_bt. apply refl_t. apply square_t. apply converse_t. Qed.

(*|
This instance is a bit annoyingly adhoc, but useful for unfolding laws notably:
essentially we can conclude by reflexivity without stepping completely through
[equb], but only after exposing it by unfolding and case-analysing on the structure
of the tree.
|*)
  #[global] Instance Reflexive_equb (equ : ctree E R -> ctree E R -> Prop) :
    Reflexive RR -> Reflexive equ -> Reflexive (equb RR equ).
  Proof.
    red. destruct x; auto.
  Qed.

End equ_theory.

#[global] Instance Equivalence_equ {E R}: Equivalence (@equ E R R eq).
Proof. apply Equivalence_et. typeclasses eauto. Qed.

#[global] Hint Constructors equb : core.
Arguments equb_ {E R1 R2} RR eq t1 t2/.

#[global] Instance equb_eq_equ {E X} {Q : rel X X} :
  Proper (equ eq ==> equ eq ==> flip impl) (@equ E X X Q).
Proof.
  unfold Proper, respectful, flip, impl.
  coinduction ? IH.
  intros t t' EQt u u' EQu EQ.
  step in EQt.
  step in EQu.
  step in EQ.
  inv EQt; rewrite <- H in EQ.
  - inv EQ.
    rewrite <- H3 in EQu.
    inv EQu.
    cbn*; rewrite <- H0, <- H2; auto.
  - dependent destruction EQ.
    cbn*.
    rewrite <- x in EQu.
    dependent destruction EQu.
    rewrite <- H0, <- x.
    eauto.
  - dependent destruction EQ.
    cbn*.
    rewrite <- x in EQu.
    dependent destruction EQu.
    rewrite <- H0, <- x.
    eauto.
Qed.

#[global] Instance equb_eq_equ' {E X Y} {R : rel X Y} :
  Proper (equ eq ==> equ eq ==> flip impl) (@equ E X Y R).
Proof.
  unfold Proper, respectful, flip, impl; cbn.
  unfold equ; coinduction ? IH.
  intros t t' EQt u u' EQu EQ.
  step in EQt.
  step in EQu.
  step in EQ.
  cbn*; inv EQt; rewrite <- H in EQ.
  - inv EQ.
    rewrite <- H3 in EQu.
    inv EQu; auto.
  - dependent destruction EQ.
    cbn.
    rewrite <- x in EQu.
    dependent destruction EQu.
    rewrite <- x.
    eauto.
  - dependent destruction EQ.
    cbn.
    rewrite <- x in EQu.
    dependent destruction EQu.
    rewrite <- x.
    eauto.
Qed.

(*|
Dependent inversion of [equ] and [equb] equations
-------------------------------------------------
We assume [JMeq_eq] to invert easily bisimilarity of dependently typed constructors
|*)
Lemma equ_vis_invT {E X Y S} (e1 : E X) (e2 : E Y) (k1 : X -> ctree E S) k2 :
  Vis e1 k1 ≅ Vis e2 k2 ->
  X = Y.
Proof.
  intros EQ.
	step in EQ. dependent induction EQ; auto.
Qed.

Lemma equ_vis_invE {E X S} (e1 e2 : E X) (k1 k2 : X -> ctree E S) :
  Vis e1 k1 ≅ Vis e2 k2 ->
  e1 = e2 /\ forall x, k1 x ≅ k2 x.
Proof.
  intros EQ; step in EQ.
	inv EQ.
	dependent destruction H2.
	dependent destruction H4.
	auto.
Qed.

Lemma equ_br_invT {E S b b' n m} (k1 : _ -> ctree E S) k2 :
  Br b n k1 ≅ Br b' m k2 ->
  n = m /\ b = b'.
Proof.
  intros EQ; step in EQ.
	dependent destruction EQ; auto.
Qed.

Lemma equ_br_invE {E S b n} (k1 : _ -> ctree E S) k2 :
  Br b n k1 ≅ Br b n k2 ->
  forall x, k1 x ≅ k2 x.
Proof.
  intros EQ; step in EQ.
	inv EQ.
	dependent destruction H; auto.
Qed.

Lemma equb_vis_invT {E X Y S} (e1 : E X) (e2 : E Y) (k1 : X -> ctree E S) k2 :
  equb eq (equ eq) (VisF e1 k1) (VisF e2 k2) ->
  X = Y.
Proof.
  intros EQ.
	dependent induction EQ; auto.
Qed.

Lemma equb_vis_invE {E X S} (e1 e2 : E X) (k1 k2 : X -> ctree E S) :
  equb eq (equ eq) (VisF e1 k1) (VisF e2 k2) ->
  e1 = e2 /\ forall x, equ eq (k1 x) (k2 x).
Proof.
  intros EQ.
	inv EQ.
	dependent destruction H; dependent destruction H4; auto.
Qed.

Lemma equb_br_invT {E S b b' n m} (k1 : _ -> ctree E S) k2 :
  equb eq (equ eq) (BrF b n k1) (BrF b' m k2) ->
  n = m /\ b = b'.
Proof.
  intros EQ.
	dependent induction EQ; auto.
Qed.

Lemma equb_br_invE {E S b n} (k1 : _ -> ctree E S) k2 :
  equb eq (equ eq) (BrF b n k1) (BrF b n k2) ->
  forall x, equ eq (k1 x) (k2 x).
Proof.
  intros EQ.
	inv EQ.
	dependent destruction H; auto.
Qed.

(*|
Proper Instances
----------------
equ eq       ==> going (equ eq)  observe
∀(equ eq)    ==> going (equ eq)  BrF
∀(equ eq)    ==> going (equ eq)  VisF
observing eq --> equ eq
going(equ)   ==> eq ==> fimpl    equb eq (t_equ eq r)
eq ==> going(equ)   ==> fimpl    equb eq (t_equ eq r)
equ ==> equ ==> flip impl)       bt_equ eq r
|*)

#[global] Instance equ_observe {E R} :
  Proper (equ eq ==> going (equ eq)) (@observe E R).
Proof.
  constructor. step in H.
  now step.
Qed.

#[global] Instance equ_BrF {E R} b n :
  Proper (pointwise_relation _ (equ eq) ==> going (equ eq)) (@BrF E R _ b n).
Proof.
  constructor. red in H. step. econstructor; eauto.
Qed.

#[global] Instance equ_VisF {E R X} (e : E X) :
  Proper (pointwise_relation _ (equ eq) ==> going (equ eq)) (@VisF E R _ _ e).
Proof.
  constructor. red in H. step. econstructor; eauto.
Qed.

#[global] Instance observing_sub_equ E R :
  subrelation (@observing E R R eq) (equ eq).
Proof.
  repeat intro.
  step. rewrite (observing_observe H). apply Reflexive_equb; eauto.
Qed.

#[global] Instance equ_eq_equ {E R r} :
  Proper (going (equ eq) ==> eq ==> flip impl)
	     (@equb E R R eq (et eq r)).
Proof.
  unfold Proper, respectful, flip, impl. intros. subst.
  inv H. step in H0. inv H0; inv H1; auto.
  - invert.
    subst. constructor. intros. rewrite REL. auto.
  - invert.
    subst. constructor. intros. rewrite REL. auto.
Qed.

#[global] Instance eq_equ_equ {E R r} :
  Proper (eq ==> going (equ eq) ==> flip impl)
	     (@equb E R R eq (et eq r)).
Proof.
  unfold Proper, respectful, flip, impl. intros. subst.
  inv H0. step in H. inv H; inv H1; auto.
  - invert.
    subst. constructor. intros. rewrite REL. auto.
  - invert.
    subst. constructor. intros. rewrite REL. auto.
Qed.

#[global] Instance equ_clos_eT_goal {E R} RR f :
  Proper (@equ E R R eq ==> equ eq ==> flip impl) (eT eq f RR).
Proof.
  cbn; intros ? ? eq1 ? ? eq2 H.
  rewrite eq1, eq2.
  auto.
Qed.

#[global] Instance equ_clos_eT_ctx {E R} RR f :
  Proper (@equ E R R eq ==> equ eq ==> impl) (eT eq f RR).
Proof.
  cbn; intros ? ? eq1 ? ? eq2 H.
  rewrite <- eq1, <- eq2.
  auto.
Qed.

Ltac _apply f :=
  match goal with
    |- context [@body ?x ?l ?y] => apply (f _ l)
  end.

#[global] Instance gfp_bt_equ {E R r} :
	 Proper (gfp (@fequ E R R eq) ==> equ eq ==> flip impl)
	  (ebt eq r).
Proof.
	unfold Proper, respectful, flip, impl.
	intros.
	etransitivity; [|etransitivity]; [|apply H1 |].
  _apply @gfp_bt; assumption.
	_apply @gfp_bt; symmetry; assumption.
Qed.

#[global] Instance Equivalence_bt_equb_gen {E X R S} `{Equivalence _ R}:
  Proper ((gfp (@fequ E X _ eq)) ==> (gfp (@fequ E X _ eq)) ==> flip impl) (ebt R S).
Proof.
	unfold Proper, respectful, flip, impl.
	intros.
	etransitivity; [|etransitivity]; [| eassumption |].
	_apply @gfp_bt; rewrite H0; reflexivity.
	_apply @gfp_bt; rewrite H1; reflexivity.
Qed.

(*|
Up-to bind principle
~~~~~~~~~~~~~~~~~~~~
Consider two computations explicitely built as sequences
[t >>= k] and [u >>= l]. When trying to prove that they are
bisimilar via a coinductive proof, one is faced with a goal
of the shape:
[t_equ RR r (t >>= k) (u >>= l)]
One can of course case analysis on the structure of [t] and [u]
to make progress in the proof.
But if we know from another source that [t ≅ u], we would like
to be able to simply "match" these prefixes, and continue the
coinductive proof over the continuations.
Such a reasoning is dubbed "up-to bind" reasoning, which we
prove sound in the following.

More formally, this corresponds as always to establishing that
the appropriate function is a valid enhancement. The function
in question here is:
f R = {(bind t k, bind u l) | equ SS t u /\ forall x y, SS x y -> R (k x) (l x)}

|*)
Section bind.

(*|
Heterogeneous [pair], should be moved to coinduction library
|*)
  Definition pointwise {X X' Y Y'} (SS : rel X X')
    : rel Y Y' -> rel (X -> Y) (X' -> Y') :=
    fun R k k' => forall x x', SS x x' -> R (k x) (k' x').

  Definition pairH {A B : Type} (x : A) (y : B) : A -> B -> Prop :=
    fun x' y' => x = x' /\ y = y'.

  Lemma leq_pairH : forall {A B : Type} (x : A) (y : B) (R : rel A B),
      R x y <-> pairH x y <= R.
  Proof.
    firstorder congruence.
  Qed.

  Section Bind_ctx.

    Context {E: Type -> Type} {X X' Y Y': Type}.

(*|
Most general contextualisation function associated to [bind].
Can be read more digestly as, where R is a relation on ctrees
(the prefixes of the binds) and S on the continuations:
bind_ctx R S = {(bind t k, bind t' k') | R t t' /\ S k k'}

Note that at this point, this is more general that what we are
interested in: we will specialize [R] and [S] for our purpose,
first here w.r.t. to [equ], later w.r.t. to other relations over
[ctree]s.

Remark: the Coinduction library provides generic binary contexts
[binary_ctx], but whose both arguments are at the same types.
We could provide an heterogeneous version of [binary_ctx] and have
[bind_ctx] be an instance of it to avoid having to rethink in terms
of [sup_all] locally.
|*)

    Definition bind_ctx
               (R: rel (ctree E X) (ctree E X'))
               (S: rel (X -> ctree E Y) (X' -> ctree E Y')):
      rel (ctree E Y) (ctree E Y') :=
      sup_all (fun x => sup (R x)
                         (fun x' => sup_all
                                   (fun k => sup (S k)
                                              (fun k' => pairH (bind x k) (bind x' k'))))).

(*|
Two lemmas to interact with [bind_ctx] before making it opaque:
- [leq_bind_ctx] specifies relations above the context
- [in_bind_ctx] specifies how to populate it
|*)
    Lemma leq_bind_ctx:
      forall R S S', bind_ctx R S <= S' <->
                  (forall x x', R x x' -> forall k k', S k k' -> S' (bind x k) (bind x' k')).
    Proof.
      intros.
      unfold bind_ctx.
      setoid_rewrite sup_all_spec.
      setoid_rewrite sup_spec.
      setoid_rewrite sup_all_spec.
      setoid_rewrite sup_spec.
      setoid_rewrite <-leq_pairH.
      firstorder.
    Qed.

    Lemma in_bind_ctx (R S :rel _ _) x x' y y':
      R x x' -> S y y' -> bind_ctx R S (bind x y) (bind x' y').
    Proof. intros. now apply ->leq_bind_ctx. Qed.
    #[global] Opaque bind_ctx.

  End Bind_ctx.

(*|
Specialization of [bind_ctx] to the [equ]-based closure we are
looking for, and the proof of validity of the principle. As
always with the companion, we prove that it is valid by proving
that it si below the companion.
|*)
  Section Equ_Bind_ctx.

    Context {E: Type -> Type} {X1 X2 Y1 Y2: Type}.

(*|
Specialization of [bind_ctx] to a function acting with [equ] on the bound value,
and with the argument (pointwise) on the continuation.
|*)
    Program Definition bind_ctx_equ SS: mon (rel (ctree E Y1) (ctree E Y2)) :=
      {|body := fun R => @bind_ctx E X1 X2 Y1 Y2 (equ SS) (pointwise SS R) |}.
    Next Obligation.
      intros ??? H. apply leq_bind_ctx. intros ?? H' ?? H''.
      apply in_bind_ctx. apply H'. intros t t' HS. apply H0, H'', HS.
    Qed.

(*|
The resulting enhancing function gives a valid up-to technique
|*)
    Lemma bind_ctx_equ_t (SS : rel X1 X2) (RR : rel Y1 Y2): bind_ctx_equ SS <= et RR.
    Proof.
      apply Coinduction. intros R. apply (leq_bind_ctx _).
      intros x x' xx' k k' kk'.
      step in xx'.
      cbn; unfold observe; cbn.
      destruct xx'.
      - cbn in *.
        generalize (kk' _ _ REL).
        apply (fequ RR).
        apply id_T.
      - constructor; intros ?. apply (fTf_Tf (fequ _)).
        apply in_bind_ctx. apply REL.
        red; intros. apply (b_T (fequ _)), kk'; auto.
      - constructor. intro a. apply (fTf_Tf (fequ _)).
        apply in_bind_ctx. apply REL.
        red; intros. apply (b_T (fequ _)), kk'; auto.
    Qed.

  End Equ_Bind_ctx.

End bind.

(*|
Expliciting the reasoning rule provided by the up-to principle.
|*)

Lemma et_clo_bind (E: Type -> Type) (X1 X2 Y1 Y2 : Type) :
	forall (t1 : ctree E X1) (t2 : ctree E X2) (k1 : X1 -> ctree E Y1) (k2 : X2 -> ctree E Y2)
    (S : rel X1 X2) (R : rel Y1 Y2) RR,
		equ S t1 t2 ->
    (forall x1 x2, S x1 x2 -> et R RR (k1 x1) (k2 x2)) ->
    et R RR (bind t1 k1) (bind t2 k2)
.
Proof.
  intros.
  apply (ft_t (bind_ctx_equ_t S R)).
  now apply in_bind_ctx.
Qed.

Lemma et_clo_bind_eq (E: Type -> Type) (X Y1 Y2 : Type) :
	forall (t : ctree E X) (k1 : X -> ctree E Y1) (k2 : X -> ctree E Y2)
    (R : rel Y1 Y2) RR,
    (forall x, et R RR (k1 x) (k2 x)) ->
    et R RR (bind t k1) (bind t k2)
.
Proof.
  intros * EQ.
  apply (ft_t (bind_ctx_equ_t (X2 := X) eq R)).
  apply in_bind_ctx.
  reflexivity.
  intros ? ? <-.
  apply EQ.
Qed.

(*|
And in particular, we get the proper instance justifying rewriting [equ]
to the left of a [bind].
|*)
#[global] Instance bind_equ_cong_gen :
 forall (E : Type -> Type) (X Y : Type) (R : rel Y Y) RR,
   Proper (equ (@eq X) ==> pointwise_relation X (et R RR) ==> et R RR) (@bind E X Y).
Proof.
  repeat red. intros.
  eapply et_clo_bind; eauto.
  intros ? ? <-; auto.
Qed.

(*|
Specializing these congruence lemmas at the [sbisim] level for equational proofs
|*)
Lemma equ_clo_bind (E: Type -> Type) (X1 X2 Y1 Y2 : Type) :
	forall (t1 : ctree E X1) (t2 : ctree E X2) (k1 : X1 -> ctree E Y1) (k2 : X2 -> ctree E Y2)
    (S : rel X1 X2) (R : rel Y1 Y2),
		equ S t1 t2 ->
    (forall x1 x2, S x1 x2 -> equ R (k1 x1) (k2 x2)) ->
    equ R (bind t1 k1) (bind t2 k2)
.
Proof.
  intros.
  apply (ft_t (bind_ctx_equ_t S R)).
  now apply in_bind_ctx.
Qed.

Lemma equ_clo_bind_eq (E: Type -> Type) (X Y1 Y2 : Type) :
	forall (t : ctree E X) (k1 : X -> ctree E Y1) (k2 : X -> ctree E Y2)
    (R : rel Y1 Y2),
    (forall x, equ R (k1 x) (k2 x)) ->
    equ R (bind t k1) (bind t k2)
.
Proof.
  intros * EQ.
  apply (ft_t (bind_ctx_equ_t (X2 := X) eq R)).
  apply in_bind_ctx.
  reflexivity.
  intros ? ? <-.
  apply EQ.
Qed.

Ltac __upto_bind_equ' SS :=
  match goal with
    (* Out of a coinductive proof --- terminology abuse, this is simply using the congruence of the relation, not a upto *)
    |- @equ ?E ?R1 ?R2 ?RR (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
      apply (@equ_clo_bind E T1 T2 R1 R2 _ _ _ _ SS RR)

    (* Upto when unguarded *)
  | |- body (t (@fequ ?E ?R1 ?R2 ?RR)) ?R (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
        apply (ft_t (@bind_ctx_equ_t E T1 T2 R1 R2 SS RR)), in_bind_ctx

    (* Upto when guarded *)
  | |- body (bt (@fequ ?E ?R1 ?R2 ?RR)) ?R (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
      apply (fbt_bt (@bind_ctx_equ_t E T1 T2 R1 R2 SS RR)), in_bind_ctx
  end.
Tactic Notation "__upto_bind_equ" uconstr(eq) := __upto_bind_equ' eq.

Ltac __eupto_bind_equ :=
  match goal with
    (* Out of a coinductive proof --- terminology abuse, this is simply using the congruence of the relation, not a upto *)
    |- @equ ?E ?R1 ?R2 ?RR (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
      eapply (@equ_clo_bind E T1 T2 R1 R2 _ _ _ _ _ RR)

    (* Upto when unguarded *)
  | |- body (t (@fequ ?E ?R1 ?R2 ?RR)) ?R (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
        eapply (ft_t (@bind_ctx_equ_t E T1 T2 R1 R2 _ RR)), in_bind_ctx

    (* Upto when guarded *)
  | |- body (bt (@fequ ?E ?R1 ?R2 ?RR)) ?R (CTree.bind (T := ?T1) _ _) (CTree.bind (T := ?T2) _ _) =>
      eapply (fbt_bt (@bind_ctx_equ_t E T1 T2 R1 R2 _ RR)), in_bind_ctx
  end.

Ltac __upto_bind_eq_equ :=
  __upto_bind_equ eq; [reflexivity | intros ? ? <-].

(*|
Up-to [equ eq] bisimulations
----------------------------
The transitivity of the [et R] gives us "equ bisimulation up-to equ". Looking forward,
in order to establish "up-to equ" principles for other bisimulations, we define here the
associated enhancing function.
|*)

(*|
Definition of the enhancing function
|*)
Variant equ_clos_body {E X1 X2} (R : rel (ctree E X1) (ctree E X2)) : (rel (ctree E X1) (ctree E X2)) :=
  | Equ_clos : forall t t' u' u
                 (Equt : t ≅ t')
                 (HR : R t' u')
                 (Equu : u' ≅ u),
      equ_clos_body R t u.

Program Definition equ_clos {E X1 X2} : mon (rel (ctree E X1) (ctree E X2)) :=
  {| body := @equ_clos_body E X1 X2 |}.
Next Obligation.
  intros * ?? LE t u EQ; inv EQ.
  econstructor; eauto.
  apply LE; auto.
Qed.

(*|
Sufficient condition to prove compatibility only over the simulation
|*)
Lemma equ_clos_sym {E X} : compat converse (@equ_clos E X X).
Proof.
  intros R t u EQ; inv EQ.
  apply Equ_clos with u' t'; intuition.
Qed.

(*|
Elementary equational theory
----------------------------
At this point, equipped with our coinductive structural equality,
we can already express some very tight equations. Mainly
- unfolding lemmas for our operations ([bind] and [iter] notably);
- the three monadic laws
|*)
Import CTree.
Import CTreeNotations.
Open Scope ctree.

(*|
Even eta-laws for coinductive data-structures are not valid w.r.t. to [eq]
in Coq. We however do recover them w.r.t. [equ].
|*)
Lemma ctree_eta_ {E R} (t : ctree E R) : t ≅ go (_observe t).
Proof. now step. Qed.

Lemma ctree_eta {E R} (t : ctree E R) : t ≅ go (observe t).
Proof.
  now step.
Qed.

Lemma unfold_spinD {E R} : @spinD E R ≅ Guard spinD.
Proof.
  exact (ctree_eta spinD).
Qed.

Notation bind_ t k :=
  match observe t with
  | RetF r => k%function r
  | VisF e ke => Vis e (fun x => bind (ke x) k)
  | BrF b n ke => Br b n (fun x => bind (ke x) k)
  end.

Lemma unfold_bind {E R S} (t : ctree E R) (k : R -> ctree E S)
  : bind t k ≅ bind_ t k.
Proof.
	now step.
Qed.

Notation iter_ step i :=
  (lr <- step%function i;;
   match lr with
   | inl l => Guard (iter step l)
   | inr r => Ret r
   end)%ctree.

Lemma unfold_iter {E R I} (step : I -> ctree E (I + R)) i:
	iter step i ≅ iter_ step i.
Proof.
	now step.
Qed.

(*|
Monadic laws
------------
The three usual monadic laws can be estalished w.r.t. [equ eq].
|*)
Lemma bind_ret_l {E X Y} : forall (x : X) (k : X -> ctree E Y),
    Ret x >>= k ≅ k x.
Proof.
  intros.
  now rewrite unfold_bind.
Qed.

Lemma bind_ret_r {E X} : forall (t : ctree E X),
    x <- t;; Ret x ≅ t.
Proof.
  coinduction S CIH.
  intros t.
  rewrite unfold_bind.
  cbn*; desobs t; constructor; auto.
Qed.

Lemma bind_bind {E X Y Z} : forall (t : ctree E X) (k : X -> ctree E Y) (l : Y -> ctree E Z),
    (t >>= k) >>= l ≅ t >>= (fun x => k x >>= l).
Proof.
  coinduction S CIH; intros.
  rewrite (ctree_eta t). cbn*.
  desobs t; cbn.
  - reflexivity.
  - constructor; intros. apply CIH.
  - constructor; intros. apply CIH.
Qed.

(*|
Structural rules
|*)
Lemma bind_vis {E X Y Z} (e : E X) (k : X -> ctree E Y) (g : Y -> ctree E Z):
  Vis e k >>= g ≅ Vis e (fun x => k x >>= g).
Proof.
  now rewrite unfold_bind.
Qed.

Lemma bind_trigger {E X Y} (e : E X) (k : X -> ctree E Y) :
  trigger e >>= k ≅ Vis e (fun x => k x).
Proof.
  unfold trigger; rewrite bind_vis; setoid_rewrite bind_ret_l.
  reflexivity.
Qed.

Lemma bind_br {E X Y} b n (k : _ -> ctree E X) (g : X -> ctree E Y):
  Br b n k >>= g ≅ Br b n (fun x => k x >>= g).
Proof.
  now rewrite unfold_bind.
Qed.

Lemma bind_Step {E X Y} (t : ctree E X) (g : X -> ctree E Y):
  Step t >>= g ≅ Step (t >>= g).
Proof.
  now cbn; rewrite bind_br.
Qed.

Lemma bind_Guard {E X Y} (t : ctree E X) (g : X -> ctree E Y):
  Guard t >>= g ≅ Guard (t >>= g).
Proof.
  now cbn; rewrite bind_br.
Qed.

Lemma vis_equ_bind {E X Y Z} :
  forall (t : ctree E X) (e : E Z) k (k' : X -> ctree E Y),
  x <- t;; k' x ≅ Vis e k ->
  (exists r, t ≅ Ret r) \/
  exists k0, t ≅ Vis e k0 /\ forall x, k x ≅ x <- k0 x;; k' x.
Proof.
  intros.
  destruct (observe t) eqn:?.
  - left. exists r. rewrite ctree_eta, Heqc. reflexivity.
  - rewrite (ctree_eta t), Heqc, bind_vis in H.
    apply equ_vis_invT in H as ?. subst.
    pose proof (equ_vis_invE _ _ _ _ H). destruct H0. subst.
    right. exists k0. split.
    + rewrite (ctree_eta t), Heqc. reflexivity.
    + cbn in H1. symmetry in H1. apply H1.
  - rewrite (ctree_eta t), Heqc, bind_br in H. step in H. inv H.
Qed.

Lemma br_equ_bind {E X Y} :
  forall (t : ctree E X) b n k (k' : X -> ctree E Y),
  x <- t;; k' x ≅ Br b (S n) k ->
  (exists r, t ≅ Ret r) \/
  exists k0, t ≅ Br b (S n) k0 /\ forall x, k x ≅ x <- k0 x;; k' x.
Proof.
  intros.
  destruct (observe t) eqn:?.
  - left. exists r. rewrite ctree_eta, Heqc. reflexivity.
  - rewrite (ctree_eta t), Heqc, bind_vis in H. step in H. inv H.
  - rewrite (ctree_eta t), Heqc, bind_br in H.
    apply equ_br_invT in H as ?. destruct H0 as [-> ->].
    pose proof (equ_br_invE _ _ H).
    right. exists k0. split.
    + rewrite (ctree_eta t), Heqc. reflexivity.
    + cbn in H0. symmetry in H0. apply H0.
Qed.

Lemma ret_equ_bind {E X Y} :
  forall (t : ctree E Y) (k : Y -> ctree E X) r,
  x <- t;; k x ≅ Ret r ->
  exists r1, t ≅ Ret r1 /\ k r1 ≅ Ret r.
Proof.
  intros. setoid_rewrite (ctree_eta t) in H. setoid_rewrite (ctree_eta t).
  destruct (observe t) eqn:?.
  - rewrite bind_ret_l in H. eauto.
  - rewrite bind_vis in H. step in H. inv H.
  - rewrite bind_br in H. step in H. inv H.
Qed.

(*|
Map
|*)
Lemma map_map {E R S T}: forall (f : R -> S) (g : S -> T) (t : ctree E R),
    map g (map f t) ≅ map (fun x => g (f x)) t.
Proof.
  unfold map. intros. rewrite bind_bind. setoid_rewrite bind_ret_l. reflexivity.
Qed.

Lemma bind_map {E R S T}: forall (f : R -> S) (k: S -> ctree E T) (t : ctree E R),
    bind (map f t) k ≅ bind t (fun x => k (f x)).
Proof.
  unfold map. intros. rewrite bind_bind. setoid_rewrite bind_ret_l. reflexivity.
Qed.

Lemma map_bind {E X Y Z} (t: ctree E X) (k: X -> ctree E Y) (f: Y -> Z) :
  (map f (bind t k)) ≅ bind t (fun x => map f (k x)).
Proof.
  intros. unfold map. apply bind_bind.
Qed.

Lemma map_ret {E A B} (f : A -> B) (a : A) :
    @map E _ _ f (Ret a) ≅ Ret (f a).
Proof.
  intros. unfold map.
  rewrite bind_ret_l; reflexivity.
Qed.

(*|
Convenience: all child-less invisible brs can be proved [equ], no need to work w.r.t. a bisim
|*)
Lemma br0_always_stuck : forall {E R} vis k,
    Br vis 0 k ≅ @CTree.stuck E R vis.
Proof.
  intros.
  step.
  constructor; intros abs; inv abs.
Qed.

Lemma brD0_always_stuck : forall {E R} k,
    BrD 0 k ≅ (CTree.stuckD : ctree E R).
Proof.
  intros.
  step.
  constructor; intros abs; inv abs.
Qed.

Lemma brS0_always_stuck : forall {E R} k,
    BrS 0 k ≅ (CTree.stuckS : ctree E R).
Proof.
  intros.
  step.
  constructor; intros abs; inv abs.
Qed.

Lemma br_equ: forall (E: Type -> Type) R b n (k k': fin n -> ctree E R),
    (forall t, k t ≅ k' t) ->
    Br b n k ≅ Br b n k'.
Proof.
  intros E R b n k k' EQ.
  step; econstructor; auto.
Qed.

(*|
Very crude simulation of [subst] for [≅] equations
|*)
Ltac subs :=
  match goal with
    [ h : ?x ≅ _, h' : context[?x] |- _ ] =>
      rewrite h in h'; clear h
  end.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Cumulative Inductive btree {A : Type} : Type :=
  | bnil : A -> btree
  | bcons : btree -> btree -> btree.

Derive NoConfusion NoConfusionHom for btree.
Derive Subterm for btree.
Next Obligation.
apply Subterm.WellFounded_trans_clos.
intro x; revert x.
fix wf_btree 1.
intro x.
apply Acc_intro.
intro y; intro yx.
destruct x; inversion yx; apply wf_btree.
Defined.

Lemma not_btree_direct_subterm_bnil {A} (x : @btree A) (ys : A) :
  notT (btree_direct_subterm A x (bnil ys)).
intro H.
inversion H.
Qed.

Lemma not_btree_subterm_bnil {A} (x : @btree A) : forall (ys : A),
  notT (btree_subterm A x (bnil ys)).
intros ys H.
revert H.
revert x.
fix not_btree_subterm_bnil 2.
intros x H.
inversion H.
- exact (not_btree_direct_subterm_bnil _ _ H0).
- exact (not_btree_subterm_bnil _ H1).
Qed.

Lemma not_btree_direct_subterm_bcons {A} (x ys zs : @btree A)
  (pfy : x ≠ ys)
  (pfz : x ≠ zs)
  : notT (btree_direct_subterm A x (bcons ys zs)).
intro H.
inversion H.
- apply pfz in H3; assumption.
- apply pfy in H2; assumption.
Qed.

Existing Instance NoConfusionPackage_btree.
Existing Instance NoConfusionHomPackage_btree.
Existing Instance well_founded_btree_subterm.

Equations bnil_eq {A} {x y : A} : x = y -> bnil x = bnil y :=
bnil_eq eq_refl := eq_refl.

Equations bcons_eq {A} {x y z w : @btree A} (xz : x = z) (yw : y = w) : bcons x y = bcons z w :=
bcons_eq eq_refl eq_refl := eq_refl.

Equations distribute_eq_bnil {A} {x y : A} (xs : bnil x = bnil y) : x = y :=
distribute_eq_bnil eq_refl := eq_refl.

Equations distribute_eq_bcons {A} {x y z w : @btree A} (xs : bcons x y = bcons z w) : x = z /\ y = w :=
distribute_eq_bcons eq_refl := conj eq_refl eq_refl.

Equations lift_eq_bnil {A} {x y : A} :
  (x = y ∨ x ≠ y) ->
  ((bnil x = bnil y) ∨ (bnil x ≠ bnil y)) :=
lift_eq_bnil (Specif.left eq_refl) := Specif.left eq_refl;
lift_eq_bnil (Specif.right pfXY) := Specif.right (fun pfXYs => pfXY (distribute_eq_bnil pfXYs)).

Equations lift_eq_bcons {A} {x y z w : @btree A} :
  (x = y ∨ x ≠ y) ->
  (z = w ∨ z ≠ w) ->
  ((bcons x z = bcons y w) ∨ (bcons x z ≠ bcons y w)) :=
lift_eq_bcons (Specif.left eq_refl) (Specif.left eq_refl) := Specif.left eq_refl ;
lift_eq_bcons (Specif.left eq_refl) (Specif.right pfZW) :=
  Specif.right (fun eqXZW => pfZW (proj2 (distribute_eq_bcons eqXZW))) ;
lift_eq_bcons (Specif.right pfXY) (Specif.left eq_refl) :=
  Specif.right (fun eqXZY => pfXY (proj1 (distribute_eq_bcons eqXZY))) ;
lift_eq_bcons (Specif.right pfXY) (Specif.right _) :=
  Specif.right (fun pfXZYW => pfXY (proj1 (distribute_eq_bcons pfXZYW))).

Equations dec_eq_btree {A} `{EqDecA : EqDec A} : EqDec (@btree A) :=
dec_eq_btree (bnil xs) (bnil ys) := lift_eq_bnil (EqDecA xs ys) ;
dec_eq_btree (bnil _) (bcons xs ys) := Specif.right _ ;
dec_eq_btree (bcons xs ys) (bnil _) := Specif.right _ ;
dec_eq_btree (bcons xs ys) (bcons zs ws) := lift_eq_bcons (dec_eq_btree xs zs) (dec_eq_btree ys ws).

Existing Instance dec_eq_btree.

Equations dec_btree_direct_subterm {A} `{EqDecA : EqDec A} (x y : @btree A) :
  btree_direct_subterm A x y \/
  ~btree_direct_subterm A x y :=
dec_btree_direct_subterm x (bnil ys) := or_intror (not_btree_direct_subterm_bnil x ys);
dec_btree_direct_subterm x (bcons ys zs) with (dec_eq_btree x ys) => {
  dec_btree_direct_subterm x (bcons ?(x) zs) (Specif.left eq_refl) :=
    or_introl (btree_direct_subterm_1_2 _ _ _);
  dec_btree_direct_subterm x (bcons ys zs) (Specif.right _) with (dec_eq_btree x zs) => {
  dec_btree_direct_subterm x (bcons ys ?(x)) (Specif.right _) (Specif.left eq_refl) :=
    or_introl (btree_direct_subterm_1_1 _ _ _);
  dec_btree_direct_subterm x (bcons ys zs) (Specif.right pfy) (Specif.right pfz) :=
    or_intror (not_btree_direct_subterm_bcons x ys zs pfy pfz)
  }
}.

Class DecSubterm {A : Type} (R : A -> A -> Prop) := {
  dec_subterm (x y : A) : R x y \/ ~R x y
}.

Program Instance dec_subterm_btree_direct_subterm {A} `{EqDecA : EqDec A} : DecSubterm (btree_direct_subterm A) := {}.
Next Obligation.
exact (dec_btree_direct_subterm _ _).
Qed.

Lemma split_clos_trans_l {A} (R : Relation_Definitions.relation A) (x y : A) :
  Relation_Operators.clos_trans A R x y <-> exists z, R x z /\ (y = z \/ Relation_Operators.clos_trans A R z y).

split.
{
  intro xy.
  apply Operators_Properties.clos_trans_t1n in xy.
  inversion xy.
  {
    refine (@ex_intro _ _ y0 _).
    refine (conj _ _).
    {
      rewrite <- H0 in H.
      assumption.
    }
    {
      refine (or_introl _).
      symmetry.
      assumption.
    }
  }
  {
    refine (@ex_intro _ _ y0 _).
    refine (conj _ _).
    {
      assumption.
    }
    {
      refine (or_intror _).
      apply Operators_Properties.clos_t1n_trans in H0.
      assumption.
    }
  }
}
{
  intro xy.
  inversion xy.
  inversion H.
  inversion H1.
  {
    rewrite <- H2 in H0.
    refine (Relation_Operators.t_step _ _ _ _ _).
    assumption.
  }
  {
    refine (Relation_Operators.t_trans _ _ _ _ _ (Relation_Operators.t_step _ _ _ _ H0) _).
    assumption.
  }
}
Qed.

(* Almost the same proof as split_clos_trans_l *)
Lemma split_clos_trans_r {A} (R : Relation_Definitions.relation A) (x y : A) :
  Relation_Operators.clos_trans A R x y <-> exists z, R z y /\ (x = z \/ Relation_Operators.clos_trans A R x z).
split.
{
  intro xy.
  apply Operators_Properties.clos_trans_tn1 in xy.
  inversion xy.
  {
    refine (@ex_intro _ _ x _).
    refine (conj _ _).
    {
      assumption.
    }
    {
      refine (or_introl _).
      reflexivity.
    }
  }
  {
    refine (@ex_intro _ _ y0 _).
    refine (conj _ _).
    {
      assumption.
    }
    {
      refine (or_intror _).
      apply Operators_Properties.clos_tn1_trans in H0.
      assumption.
    }
  }
}
{
  intro xy.
  inversion xy.
  inversion H.
  inversion H1.
  {
    rewrite <- H2 in H0.
    refine (Relation_Operators.t_step _ _ _ _ _).
    assumption.
  }
  {
    refine (Relation_Operators.t_trans _ _ _ _ _ _ (Relation_Operators.t_step _ _ _ _ H0)).
    assumption.
  }
}
Qed.

Lemma btree_direct_subterm_bcons {A} (x y z : @btree A) :
  btree_direct_subterm A x (bcons y z) <->
  ((x = y) \/ (x = z)).
split.
{
  intro H.
  inversion H.
  - exact (or_intror eq_refl).
  - exact (or_introl eq_refl).
}
{
  intro H.
  destruct H as [H | H]; rewrite H.
  - exact (btree_direct_subterm_1_2 _ _ _).
  - exact (btree_direct_subterm_1_1 _ _ _).
}
Qed.

Lemma distribute_or_and (x y z : Prop) :
  (x \/ y) /\ z <-> x /\ z \/ y /\ z.
tauto.
Qed.

Lemma distribute_ex_and_eq {A} (f g : A -> Prop) (x : A) :
  (exists y : A, y = x /\ f y \/ g y) <->
  f x \/ (exists y : A, g y).
split; intro H.
{
  destruct H.
  destruct H.
  {
    refine (or_introl _).
    destruct H.
    rewrite H in H0.
    assumption.
  }
  {
    refine (or_intror _).
    exact (ex_intro _ _ H).
  }
}
{
  destruct H.
  {
    refine (ex_intro _ x _).
    tauto.
  }
  {
    destruct H as (y & H).
    refine (ex_intro _ y _).
    tauto.
  }
}
Qed.

Lemma or_False_id_r (x : Prop) :
  x <-> x \/ False.
tauto.
Qed.

Lemma ex_False (A : Type) :
  (exists _ : A, False) <-> False.
intuition.
destruct H.
assumption.
Qed.

Lemma btree_subterm_bcons {A} (x y z : @btree A) :
  btree_subterm A x (bcons y z) <->
  x = y \/
  x = z \/
  btree_subterm A x y \/
  btree_subterm A x z.
refine (iff_Transitive _ _ _ (split_clos_trans_r _ x (bcons y z)) _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun x' => and_iff_compat_r _ (btree_direct_subterm_bcons x' _ _))) _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => distribute_or_and _ _ _)) _).
refine (iff_Transitive _ _ _ (distribute_ex_and_eq _ _ _) _).
rewrite or_assoc.
refine (or_iff_compat_l _ _).
rewrite <- (or_assoc (x = z) (btree_subterm A x y) (btree_subterm A x z)).
rewrite (or_comm (x = z) (btree_subterm A x y)).
rewrite (or_assoc (btree_subterm A x y) (x = z) (btree_subterm A x z)).
refine (or_iff_compat_l _ _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => and_comm _ _)) _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => distribute_or_and _ _ _)) _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => or_iff_compat_r _ (and_comm _ _))) _).
refine (iff_Transitive _ _ _ (distribute_ex_and_eq _ _ _) _).
refine (or_iff_compat_l _ _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => and_comm _ _)) _).
refine (iff_Transitive _ _ _ (Morphisms_Prop.ex_iff_morphism _ _ (fun _ => or_False_id_r _)) _).
refine (iff_Transitive _ _ _ (distribute_ex_and_eq _ _ _) _).
rewrite (ex_False _).
rewrite <- (or_False_id_r _).
reflexivity.
Qed.

Fixpoint dec_btree_subterm {A} `{EqDecA : EqDec A} (x y : @btree A) :
  btree_subterm A x y \/
  ~btree_subterm A x y.
destruct y.
{
  exact (or_intror (not_btree_subterm_bnil _ _)).
}
{
  rewrite btree_subterm_bcons.
  destruct (dec_eq_btree x y1).
  {
    refine (or_introl _).
    refine (or_introl _).
    assumption.
  }
  {
    destruct (dec_eq_btree x y2).
    {
      refine (or_introl _).
      refine (or_intror _).
      refine (or_introl _).
      assumption.
    }
    {
      destruct (dec_btree_subterm _ _ x y1).
      {
        refine (or_introl _).
        refine (or_intror _).
        refine (or_intror _).
        refine (or_introl _).
        assumption.
      }
      {
        destruct (dec_btree_subterm _ _ x y2).
        {
          refine (or_introl _).
          refine (or_intror _).
          refine (or_intror _).
          refine (or_intror _).
          assumption.
        }
        {
          refine (or_intror _).
          clear dec_btree_subterm.
          tauto.
        }
      }
    }
  }
}
Qed.

Program Instance dec_subterm_btree_subterm {A} `{EqDecA : EqDec A} : DecSubterm (btree_subterm A) := {}.
Next Obligation.
exact (dec_btree_subterm _ _).
Qed.

Ltac is_btree_subterm :=
  solve [
  repeat (assumption || match goal with
  | |- btree_subterm ?A ?x ?y =>
         exact (Relation_Operators.t_step _ _ _ _ (btree_direct_subterm_1_1 _ _ _))
      || exact (Relation_Operators.t_step _ _ _ _ (btree_direct_subterm_1_2 _ _ _))
      || refine (Relation_Operators.t_trans _ _ _ _ _ _ (Relation_Operators.t_step _ _ _ _ (btree_direct_subterm_1_1 _ _ _)))
      || refine (Relation_Operators.t_trans _ _ _ _ _ _ (Relation_Operators.t_step _ _ _ _ (btree_direct_subterm_1_2 _ _ _)))
  end)
  ] ||
  match goal with
  | |- ?H => gfail 0 "is_btree_subterm failed" H
  end.

Definition is_btree_subterm_ex1 : btree_subterm () (bnil tt) (bcons (bnil tt) (bcons (bnil tt) (bnil tt))) :=
  ltac:(is_btree_subterm).

Definition is_btree_subterm_ex2 : btree_subterm () (bnil tt) (bcons (bnil tt) (bnil tt)) :=
  ltac:(is_btree_subterm).

Fail Definition is_btree_subterm_ex3 : btree_subterm () (bcons (bnil tt) (bnil tt)) (bnil tt) :=
  ltac:(is_btree_subterm).


(** Proof Reflection in Coq ; subj_red.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export red.
Require Export ND_subst_lems.

Set Implicit Arguments.

Section subject_reduction.

Variable l1 l2 : list nat.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let C := list F.
Let T := trm l1.

(*
Proof by case analysis on (imm_red d e) and inverting the so obtained
instances (ND G d p) twice by using inversion lemmas.

The difference with old_subj_red.v is that here the Inversion tactic is
avoided; the large proof terms it constructs are now folded and opaque
in the proof, by the use of the inversion lemma's (see inv_lems.v).
This file contains more lines of tactics though.

To give an idea, compare the size of their compiled counterparts.
subj_red.vo     	 58354
old_subj_red.vo		428700

Compilation times:
coqc -opt subj_red.v  	   12.70s user 0.22s system 96% cpu 13.393  total
coqc -opt old_subj_red.v  163.34s user 1.74s system 97% cpu 2:50.07 total
*)

Lemma SR_imm_red :
 forall (G : C) (d e : P) (p : F), imm_red d e -> ND G d p -> ND G e p.
Proof.
intros G d e p H.
case H; clear H d e.

(*pr_imp*)
intros d e q H.
(* next 12 lines iso.: Inversion_clear H. Inversion_clear H0. *)
elim (imp_elim_inv H). clear H.
intros r H.
elim H. clear H.
intros H1 H2.
elim (imp_intro_inv H1). clear H1.
intros s H3.
elim H3. clear H3.
intros H4 H5.
injection H4. clear H4.
intros H6 H7.
rewrite H6.
rewrite H7 in H2.
apply (substO_hyp_prf_ok H2 H5).

(*pr_cnj1*)
intros d1 d2 H.
elim (cnj_elim1_inv H). clear H.
intros q H0.
elim (cnj_intro_inv H0). clear H0.
intros p1 H1.
elim H1. clear H1.
intros p2 H2.
elim H2. clear H2.
intros H3 H4.
elim H4. clear H4.
intros H5 H6.
injection H3. clear H3.
intros H7 H8.
rewrite H8.
exact H5.

(*pr_cnj2*)
intros d1 d2 H.
elim (cnj_elim2_inv H). clear H.
intros q H0.
elim (cnj_intro_inv H0). clear H0.
intros p1 H1.
elim H1. clear H1.
intros p2 H2.
elim H2. clear H2.
intros H3 H4.
elim H4. clear H4.
intros H5 H6.
injection H3.
intros H7 H8.
rewrite H7.
exact H6.

(*pr_dsj1*)
intros d e1 e2 q H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
elim (dsj_intro1_inv H); clear H.
intros s H2; elim H2; clear H2; intros H2 H3.
injection H2; intros H4 H5.
rewrite H5 in H0.
apply (substO_hyp_prf_ok H3 H0).

(*pr_dsj2*)
intros d e1 e2 q H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
elim (dsj_intro2_inv H); clear H.
intros s H2; elim H2; clear H2; intros H2 H3.
injection H2; intros H4 H5.
rewrite H4 in H1.
apply (substO_hyp_prf_ok H3 H1).

(*pr_uvq*)
intros d t H.
elim (uvq_elim_inv H). clear H.
intros q H0.
elim H0. clear H0.
intros H1 H2.
rewrite H1. clear H1.
elim (uvq_intro_inv H2).
intros r H3.
elim H3. clear H3.
intros H4 H5.
injection H4. clear H4.
intro H6.
rewrite H6.
apply (substO_var_prf_ok G t H5).

(*pr_exq*)
intros d e t q H.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H0.
elim (exq_intro_inv H); clear H; intros H1 H2.
injection H1; clear H1; intro H1.
assert (H3 : ND (subst_frm 0 q t :: G) (subst_var_prf 0 e t) p).
rewrite <- (simpl_subst_frm p 0 t).
rewrite H1 in H0.
exact (subst_var_prf_ok 0 G (q :: nil) t H0).
exact (subst_hyp_prf_ok nil H2 H3).

(*pcd_bot*)
intros d e f q H.
elim (bot_inv H); clear H; intros H H0; rewrite H; clear H.
elim (dsj_elim_inv H0); clear H0.
intros r H; elim H; clear H; intros H H0; elim H0; clear H0; intros H0 H1;
 elim H1; clear H1; intros H1 H2.
exact (ND_dsj_elim H0 (ND_bot_elim q H1) (ND_bot_elim q H2)).

(*pcd_imp*)
intros d e f g H.
elim (imp_elim_inv H); clear H.
intros s H; elim H; clear H; intros H H0.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H1;
 elim H1; clear H1; intros H1 H2.
exact
 (ND_dsj_elim H (ND_imp_elim H1 (ND_weakening G nil r1 H0))
    (ND_imp_elim H2 (ND_weakening G nil r2 H0))).

(*pcd_cnj1*)
intros d e f H.
elim (cnj_elim1_inv H); clear H; intros s H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
exact (ND_dsj_elim H (ND_cnj_elim1 H0) (ND_cnj_elim1 H1)).

(*pcd_cnj2*)
intros d e f H.
elim (cnj_elim2_inv H); clear H; intros s H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
exact (ND_dsj_elim H (ND_cnj_elim2 H0) (ND_cnj_elim2 H1)).

(*pcd_dsj*)
intros d e f g h H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
elim (dsj_elim_inv H); clear H.
intros r3 H; elim H; clear H; intros r4 H; elim H; clear H; intros H H2;
 elim H2; clear H2; intros H2 H3.
exact
 (ND_dsj_elim H
    (ND_dsj_elim H2 (ND_weakening G (r1 :: nil) r3 H0)
       (ND_weakening G (r2 :: nil) r3 H1))
    (ND_dsj_elim H3 (ND_weakening G (r1 :: nil) r4 H0)
       (ND_weakening G (r2 :: nil) r4 H1))).

(*pcd_uvq*)
intros d e f t H.
elim (uvq_elim_inv H); clear H.
intros q H; elim H; clear H; intros H H0.
rewrite H; clear H.
elim (dsj_elim_inv H0); clear H0.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.

exact (ND_dsj_elim H (ND_uvq_elim t H0) (ND_uvq_elim t H1)).

(*pcd_exq*)
intros d e f g H.
elim (exq_elim_inv H); clear H.
intros s H; elim H; clear H; intros H H0.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H1;
 elim H1; clear H1; intros H1 H2.
apply ND_dsj_elim with (1:=H).
apply ND_exq_elim with (1:=H1).
exact (ND_weakening (lift_cxt 0 G) (s :: nil) (lift_frm 0 r1) H0).
apply ND_exq_elim with (1:=H2).
exact (ND_weakening (lift_cxt 0 G) (s :: nil) (lift_frm 0 r2) H0).

(*pce_bot*)
intros d e q H.
elim (bot_inv H); clear H.
intros H H0; rewrite H; clear H.
elim (exq_elim_inv H0); clear H0.
 intros r H; elim H; clear H; intros H H0.
apply ND_exq_elim with (1:=H).
exact (ND_bot_elim (lift_frm 0 q) H0).

(*pce_imp*)
intros d e f H.
elim (imp_elim_inv H); clear H.
intros s H; elim H; clear H; intros H H0.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H1.
assert
 (H2 :
  ND (r :: lift_cxt 0 G) (lift_hyp_prf 0 (lift_var_prf 0 f)) (lift_frm 0 s)).
apply
 (ND_weakening (d:=lift_var_prf 0 f) (lift_cxt 0 G) nil
    (p:=lift_frm 0 s) r).
exact (ND_lift_var H0 0).
apply ND_exq_elim with (1:=H) (2:=(ND_imp_elim H1 H2)).

(*pce_cnj1*)
intros d e H.
elim (cnj_elim1_inv H); clear H.
intros q H.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H0.
apply ND_exq_elim with (1:=H) (2:=ND_cnj_elim1 H0).

(*pce_cnj2*)
intros d e H.
elim (cnj_elim2_inv H); clear H.
intros q H.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H0.
apply ND_exq_elim with (1:=H) (2:=ND_cnj_elim2 H0).

(*pce_dsj*)
intros d e f g H.
elim (dsj_elim_inv H); clear H.
intros r1 H; elim H; clear H; intros r2 H; elim H; clear H; intros H H0;
 elim H0; clear H0; intros H0 H1.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H2.
apply ND_exq_elim with (1:=H).
simpl in H2.
apply ND_dsj_elim with (1:=H2).
exact (ND_weakening (lift_cxt 0 G) (lift_frm 0 r1 :: nil) r (ND_lift_var H0 0)).
exact (ND_weakening (lift_cxt 0 G) (lift_frm 0 r2 :: nil) r (ND_lift_var H1 0)).

(*pce_uvq*)
intros d e t H.
elim (uvq_elim_inv H); clear H.
intros p' H; elim H; clear H; intros H H0.
rewrite H; clear H.
elim (exq_elim_inv H0); clear H0.
intros r H; elim H; clear H; intros H H0.
cut
 (ND (r :: lift_cxt 0 G) (uvq_elim (lift_trm 0 t) e)
    (lift_frm 0 (subst_frm 0 p' t))).
intro H1.
apply ND_exq_elim with (1:=H) (2:=H1).
rewrite distr_lift_substO_frm.
apply ND_uvq_elim.
exact H0.

(*pce_exq*)
intros d e f H.
elim (exq_elim_inv H); clear H.
intros s H; elim H; clear H; intros H H0.
elim (exq_elim_inv H); clear H.
intros r H; elim H; clear H; intros H H1.
cut
 (ND (r :: lift_cxt 0 G) (exq_elim e (lift_hyp_prf 1 (lift_var_prf 1 f)))
    (lift_frm 0 p)).
intro H2.
apply ND_exq_elim with (1:=H) (2:=H2).
cut
 (ND (lift_frm 1 s :: lift_cxt 0 (r :: lift_cxt 0 G))
    (lift_hyp_prf 1 (lift_var_prf 1 f)) (lift_frm 0 (lift_frm 0 p))).
intro H2.
simpl in H1.
apply ND_exq_elim with (1:=H1) (2:=H2).
unfold lift_cxt in |- *.
apply
 (ND_weakening (d:=lift_var_prf 1 f) (lift_cxt 0 (lift_cxt 0 G))
    (lift_frm 1 s :: nil) (p:=lift_frm 0 (lift_frm 0 p))
    (lift_frm 0 r)).
simpl in |- *.
rewrite permute_lift_cxt.
rewrite permute_lift_frm.
exact (ND_lift_var H0 1).
exact (le_n 0).
exact (le_n 0).

Qed.

(*****************************************************************************)

Lemma SR :
 forall d d' : P, red d d' -> forall (G : C) (p : F), ND G d p -> ND G d' p.
Proof.
intros d d' H.
elim H; clear H d d'.

(*red_imm_red*)
intros d d' H G p H0.
exact (SR_imm_red H H0).

(*red_bot_elim*)
intros d d' p H IH G q H0.
elim (bot_inv H0). clear H0.
intros H0 H1.
rewrite H0.
exact (ND_bot_elim p (IH G (bot _ _) H1)).

(*red_imp_intro*)
intros d d' p H IH G q H0.
elim (imp_intro_inv H0). clear H0.
intros r H0.
elim H0.
intros H1 H2.
rewrite H1.
exact (ND_imp_intro (IH (p :: G) r H2)).

(*red_imp_elim_1*)
intros d d' e H IH G p H0.
elim (imp_elim_inv H0). clear H0.
intros q H0.
elim H0. intros H1 H2.
exact (ND_imp_elim (IH G (imp q p) H1) H2).

(*red_imp_elim_2*)
intros d d' e H IH G p H0.
elim (imp_elim_inv H0). clear H0.
intros q H0.
elim H0. intros H1 H2.
exact (ND_imp_elim H1 (IH G q H2)).

(*red_cnj_intro_1*)
intros d d' e H IH G p H0.
elim (cnj_intro_inv H0). clear H0.
intros p1 H0.
elim H0. intros p2 H1.
elim H1. clear H0 H1.
intros H1 H2.
rewrite H1.
elim H2. clear H1 H2.
intros H1 H2.
exact (ND_cnj_intro (IH G p1 H1) H2).

(*red_cnj_intro_2*)
intros d d' e H IH G p H0.
elim (cnj_intro_inv H0). clear H0.
intros p1 H0.
elim H0. intros p2 H1.
elim H1. clear H0 H1.
intros H1 H2.
rewrite H1.
elim H2. clear H1 H2.
intros H1 H2.
exact (ND_cnj_intro H1 (IH G p2 H2)).

(*red_cnj_elim1*)
intros d d' H IH G p H0.
elim (cnj_elim1_inv H0). clear H0.
intros q H0.
exact (ND_cnj_elim1 (IH G (cnj p q) H0)).

(*red_cnj_elim2*)
intros d d' H IH G p H0.
elim (cnj_elim2_inv H0). clear H0.
intros q H0.
exact (ND_cnj_elim2 (IH G (cnj q p) H0)).

(*red_dsj_intro1*)
intros d d' p H IH G q H0.
elim (dsj_intro1_inv H0). clear H0.
intros r H0.
elim H0. intros H1 H2.
rewrite H1.
exact (ND_dsj_intro1 p (IH G r H2)).

(*red_dsj_intro2*)
intros d d' p H IH G q H0.
elim (dsj_intro2_inv H0). clear H0.
intros r H0.
elim H0. intros H1 H2.
rewrite H1.
exact (ND_dsj_intro2 p (IH G r H2)).

(*red_dsj_elim_1*)
intros d d' e f H IH G q H0.
elim (dsj_elim_inv H0); clear H0.
intros r1 H0; elim H0; clear H0; intros r2 H0; elim H0; clear H0;
 intros H0 H1; elim H1; clear H1; intros H1 H2.
exact (ND_dsj_elim (IH G (dsj r1 r2) H0) H1 H2).

(*red_dsj_elim_2*)
intros d d' e f H IH G q H0.
elim (dsj_elim_inv H0); clear H0.
intros r1 H0; elim H0; clear H0; intros r2 H0; elim H0; clear H0;
 intros H0 H1; elim H1; clear H1; intros H1 H2.
exact (ND_dsj_elim H0 (IH (r1 :: G) q H1) H2).

(*red_dsj_elim_3*)
intros d d' e f H IH G q H0.
elim (dsj_elim_inv H0); clear H0.
intros r1 H0; elim H0; clear H0; intros r2 H0; elim H0; clear H0;
 intros H0 H1; elim H1; clear H1; intros H1 H2.
exact (ND_dsj_elim H0 H1 (IH (r2 :: G) q H2)).

(*red_uvq_intro*)
intros d d' H IH G p H0.
elim (uvq_intro_inv H0).
intros p' H1.
elim H1.
clear H0 H1.
intros H0 H1.
rewrite H0.
exact (ND_uvq_intro G (IH (lift_cxt 0 G) p' H1)).

(*red_uvq_elim*)
intros d d' t H IH G p H0.
elim (uvq_elim_inv H0). intros p' H1.
elim H1. intro H2.
rewrite H2. clear H0 H1 H2.
intro H0.
exact (ND_uvq_elim t (IH G (uvq p') H0)).

(*red_exq_intro*)
intros d d' t p H IH G q H0.
elim (exq_intro_inv H0).
intro H1. rewrite H1. clear H0 H1. intro H0.
exact (ND_exq_intro t p (IH G (subst_frm 0 p t) H0)).

(*red_exq_elim_1*)
intros d d' e H IH G p H0.
elim (exq_elim_inv H0); clear H0.
intros r H0; elim H0; clear H0; intros H0 H1.
exact (ND_exq_elim p (IH G (exq r) H0) H1).

(*red_exq_elim_2*)
intros d d' e H IH G p H0.
elim (exq_elim_inv H0); clear H0.
intros r H0; elim H0; clear H0; intros H0 H1.
exact (ND_exq_elim p H0 (IH (r :: lift_cxt 0 G) (lift_frm 0 p) H1)).

Qed.

End subject_reduction.


(***************************************************************************
* Safety for STLC with Patterns - Definitions                             *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN Max.

(***************************************************************************)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_prod  : typ -> typ -> typ.

(** Grammar of patterns. *)

Inductive pat : Set :=
  | pat_bvar : nat -> pat
  | pat_fvar : var -> pat
  | pat_wild : pat
  | pat_pair : pat -> pat -> pat.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_let  : pat -> trm -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_pair : trm -> trm -> trm.

(** Arity of a pattern. *)

Fixpoint pat_arity (p : pat) : nat :=
  match p with
  | pat_bvar n     => n+1
  | pat_fvar x     => 0
  | pat_wild       => 0
  | pat_pair p1 p2 => max (pat_arity p1) (pat_arity p2)
(*  | pat_alias n p1 => max (n+1) (pat_arity p1) *)
  end.

(** Opening of a pattern. *)

Definition pat_nth n xs := List.nth n xs var_default.

Fixpoint open_pat (xs : list var) (p : pat) {struct p} : pat :=
  match p with
  | pat_fvar x     => pat_fvar x
  | pat_bvar n     => pat_fvar (pat_nth n xs)
  | pat_wild       => pat_wild
  | pat_pair p1 p2 => pat_pair (open_pat xs p1) (open_pat xs p2)
  end.

(** Default term and nth function on term lists *)

Definition trm_def := trm_bvar 0 0.

Definition trm_nth n ts := List.nth n ts trm_def.

(** Opening up abstractions *)

Fixpoint opens_rec (k : nat) (us : list trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => If k = i then (trm_nth j us) else (trm_bvar i j)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (opens_rec (S k) us t1)
  | trm_let p1 t1 t2 => trm_let p1 (opens_rec k us t1)
                                   (opens_rec (S k) us t2)
  | trm_app t1 t2 => trm_app (opens_rec k us t1) (opens_rec k us t2)
  | trm_pair t1 t2 => trm_pair (opens_rec k us t1) (opens_rec k us t2)
  end.

Definition opens t us := opens_rec 0 us t.
Definition open t u := opens t (u::nil).
Definition trm_fvars := List.map trm_fvar.

Notation "{ k ~> u } t" := (opens_rec k u t) (at level 67).
Notation "t ^^ us" := (opens t us) (at level 67).
Notation "t ^ xs" := (opens t (trm_fvars xs)).

(** Patterns are well-formed pre-patterns *)

Inductive pat_binds : pat -> vars -> Prop :=
  | pat_binds_var : forall x,
      pat_binds (pat_fvar x) \{x}
  | pat_binds_wild :
      pat_binds (pat_wild) \{}
  | pat_binds_pair : forall p1 p2 s1 s2,
      pat_binds p1 s1 ->
      pat_binds p2 s2 ->
      disjoint s1 s2 ->
      pat_binds (pat_pair p1 p2) (s1 \u s2).
(*
  | pat_binds_alias : forall n p s1,
      pat_binds p s1 ->
      disjoint \{n} s1 ->
      pat_binds (pat_alias n p) (\{n} \u s1).
*)

Definition pattern p :=
  exists L, forall xs, fresh L (pat_arity p) xs ->
  pat_binds (open_pat xs p) (from_list xs).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, fresh L 1 (x::nil) ->
        term (t1 ^ (x::nil))) ->
      term (trm_abs t1)
  | term_let : forall L p1 t1 t2,
      pattern p1 ->
      term t1 ->
      (forall xs, fresh L (pat_arity p1) xs -> term (t2 ^ xs)) ->
      term (trm_let p1 t1 t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2)
  | term_pair : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_pair t1 t2).

(** Definition of [bodys n t] as [t ^ xs] is a term when [|xs|=n] *)

Definition bodys n t :=
  exists L, forall xs, fresh L n xs -> term (t ^ xs).

(** Environment is an associative list mapping variables to types. *)

Definition env := environment typ.

(** Typing relation for patterns: if Ts are the types of the
    bound variables in the pattern p, then the pattern p matches
    values of type T. *)

Reserved Notation "E \= p ~: T" (at level 69).

Inductive pat_typing : env -> pat -> typ -> Prop :=
  | pat_typing_var : forall x T,
     (x ~ T) \= pat_fvar x ~: T
  | pat_typing_wild : forall T,
     empty \= pat_wild ~: T
  | pat_typing_pair : forall p1 p2 T1 T2 E1 E2,
     E1 \= p1 ~: T1 ->
     E2 \= p2 ~: T2 ->
     disjoint (dom E1) (dom E2) ->
     (E1 & E2) \= (pat_pair p1 p2) ~: (typ_prod T1 T2)

where "E \= p ~: T" := (pat_typing E p T).

(** Typing relation for terms *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
       (forall x, fresh L 1 (x::nil) ->
       (E & x ~ U) |= t1 ^ (x::nil) ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_let : forall L E Us R T p1 t1 t2,
      E |= t1 ~: T ->
      length Us = pat_arity p1 ->
      (forall xs, fresh L (pat_arity p1) xs ->
        (xs ~* Us) \= (open_pat xs p1) ~: T) ->
      (forall xs, fresh L (pat_arity p1) xs ->
        (E & xs ~* Us) |= (t2 ^ xs) ~: R) ->
      E |= (trm_let p1 t1 t2) ~: R
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_pair : forall E t1 t2 T1 T2,
      E |= t1 ~: T1 ->
      E |= t2 ~: T2 ->
      E |= (trm_pair t1 t2) ~: (typ_prod T1 T2)

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      bodys 1 t1 ->
      value (trm_abs t1)
  | value_pair : forall v1 v2,
     value v1 ->
     value v2 ->
     value (trm_pair v1 v2).

(** Pattern matching. *)

Definition inst := environment trm.

Inductive pat_match : pat -> trm -> inst -> Prop :=
  | pat_match_var : forall x v,
      term v ->
      pat_match (pat_fvar x) v (x ~ v)
  | pat_match_wild : forall v,
      term v ->
      pat_match pat_wild v empty
  | pat_match_pair : forall p1 p2 v1 v2 i1 i2,
      pat_match p1 v1 i1 ->
      pat_match p2 v2 i2 ->
      disjoint (dom i1) (dom i2) ->
      pat_match (pat_pair p1 p2) (trm_pair v1 v2) (i1 & i2).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ (t2::nil))
  | red_let : forall L p1 t1 t2 ts,
      value t1 ->
      length ts = pat_arity p1 ->
      bodys (pat_arity p1) t2 ->
      (forall xs, fresh L (pat_arity p1) xs ->
        pat_match (open_pat xs p1) t1 (xs ~* ts)) ->
      red (trm_let p1 t1 t2) (t2 ^^ ts)
  | red_app_1 : forall t1 t1' t2,
      red t1 t1' ->
      term t2 ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2')
  | red_let_1 : forall p1 t1 t1' t2,
      red t1 t1' ->
      pattern p1 ->
      bodys (pat_arity p1) t2 ->
      red (trm_let p1 t1 t2) (trm_let p1 t1' t2)
  | red_pair_1 : forall t1 t1' t2,
      red t1 t1' ->
      term t2 ->
      red (trm_pair t1 t2) (trm_pair t1' t2)
  | red_pair_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_pair t1 t2) (trm_pair t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


Require Export JMeq Program.
Set Implicit Arguments.

Create HintDb MoreJMeq.
Hint Extern 1 => progress subst : MoreJMeq.

Definition eq_proj1_sig_eq A (P : A -> Prop) (n m : sig P) :
  n = m -> ` n = ` m := ltac:(intuition).
Hint Resolve functional_extensionality eq_proj1_sig_eq : MoreJMeq.

Definition proj1_sig_eq_eq A (P : A -> Prop) (n m : sig P) :
  ` n = ` m -> n = m := ltac:(intros; apply subset_eq; trivial).
Hint Resolve proj1_sig_eq_eq : MoreJMeq.

Definition eq_JMeq T (l r : T) : l = r -> l ~= r := ltac:(auto with MoreJMeq).
Hint Resolve JMeq_eq eq_JMeq : MoreJMeq.

Definition JMeq_extensionality_l A B C (l : A -> C) (r : B -> C) :
  (forall L R, L ~= R -> l L = r R) -> A = B -> l ~= r := ltac:(eauto with MoreJMeq).
Hint Resolve JMeq_extensionality_l : MoreJMeq.

Theorem JMeq_extensionality_r A B C (l : A -> B) (r : A -> C) :
  (forall L R, L = R -> l L ~= r R) -> B = C -> l ~= r.
  intros; subst.
  apply eq_JMeq; apply functional_extensionality.
  intros; erewrite H; eauto.
Qed.
Hint Resolve JMeq_extensionality_r : MoreJMeq.

Theorem JMeq_extensionality A B C D (l : A -> B) (r : C -> D) :
  (forall L R, L ~= R -> l L ~= r R) -> A = C -> B = D -> l ~= r.
  intros; subst.
  apply eq_JMeq; apply functional_extensionality.
  intros; erewrite H; eauto.
Qed.
Hint Resolve JMeq_extensionality : MoreJMeq.

Definition JMeq_type_eq A B (a : A) (b : B) (H : a ~= b) : A = B := ltac:(inversion H;trivial).
Hint Resolve JMeq_type_eq : MoreJMeq.

Definition eq_proj1_JMeq T (A B : T -> Prop) (l : sig A) (r : sig B) :
  A = B -> ` l = ` r -> l ~= r := ltac:(intuition).

Definition JMeq_proj1_eq T (A B : T -> Prop) (l : sig A) (r : sig B) :
  A = B -> l ~= r -> ` l = ` r := ltac:(intuition).

Hint Resolve JMeq_eq JMeq_proj1_eq JMeq_proj1_eq : MoreJMeq.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Pseudo-registers and register states.

  This library defines the type of pseudo-registers (also known as
  "temporaries" in compiler literature) used in the RTL
  intermediate language.  We also define finite sets and finite maps
  over pseudo-registers. *)

Require Import Coqlib.
Require Import AST.
Require Import Maps.
Require Import Ordered.
Require Import Sets.

Definition reg: Type := positive.

Module Reg.

Definition eq := peq.

Definition typenv := PMap.t typ.

End Reg.

(** Mappings from registers to some type. *)

Module Regmap := PMap.

Set Implicit Arguments.

Definition regmap_optget
    (A: Type) (or: option reg) (dfl: A) (rs: Regmap.t A) : A :=
  match or with
  | None => dfl
  | Some r => Regmap.get r rs
  end.

Definition regmap_optset
    (A: Type) (or: option reg) (v: A) (rs: Regmap.t A) : Regmap.t A :=
  match or with
  | None => rs
  | Some r => Regmap.set r v rs
  end.

Notation "a # b" := (Regmap.get b a) (at level 1).
Notation "a ## b" := (List.map (fun r => Regmap.get r a) b) (at level 1).
Notation "a # b <- c" := (Regmap.set b c a) (at level 1, b at next level).

(** Sets of registers *)

Module Regset := PSet.


Arguments Nat.sub n m : simpl nomatch.
About Nat.sub.
Arguments Nat.sub n / m : simpl nomatch.
About Nat.sub.
Arguments Nat.sub !n / m : simpl nomatch.
About Nat.sub.
Arguments Nat.sub !n !m /.
About Nat.sub.
Arguments Nat.sub !n !m.
About Nat.sub.
Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) :=
  fun x => (f (fst x), g (snd x)).
Delimit Scope foo_scope with F.
Arguments pf {D1%F C1%type} f [D2 C2] g x : simpl never.
About pf.
Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x).
Arguments fcomp {_ _ _}%type_scope f g x /.
About fcomp.
Definition volatile := fun x : nat => x.
Arguments volatile / _.
About volatile.
Set Implicit Arguments.
Section S1.
Variable T1 : Type.
Section S2.
Variable T2 : Type.
Fixpoint f (x : T1) (y : T2) n (v : unit) m {struct n} : nat :=
  match n, m with
  | 0,_ => 0
  | S _, 0 => n
  | S n', S m' => f x y n' v m' end.
About f.
Global Arguments f x y !n !v !m.
About f.
End S2.
About f.
End S1.
About f.
Eval cbn in forall v, f 0 0 5 v 3 = 2.
Eval cbn in f 0 0 5 tt 3 = 2.
Arguments f : clear implicits and scopes.
About f.
Record r := { pi :> nat -> bool -> unit }.
Notation "$" := 3 (only parsing) : foo_scope.
Notation "$" := true (only parsing) : bar_scope.
Delimit Scope bar_scope with B.
Arguments pi _ _%F _%B.
Check (forall w : r, pi w $ $ = tt).
Fail Check (forall w : r, w $ $ = tt).
Axiom w : r.
Arguments w  _%F _%B : extra scopes.
Check (w $ $ = tt).
Fail Arguments w  _%F _%B.


(* Submitted by Robert Schneck *)

Parameters A B C D : Prop.
Axiom X : A -> B -> C /\ D.

Lemma foo : A -> B -> C.
Proof.
intros.
destruct X. (* Should find axiom X and should handle arguments of X *)
assumption.
assumption.
assumption.
Qed.

(* Simplification of bug 711 *)

Parameter f : true = false.
Goal let p := f in True.
intro p.
set (b := true) in *.
(* Check that it doesn't fail with an anomaly *)
(* Ultimately, adapt destruct to make it succeeding *)
try destruct b.
Abort.

(* Used to fail with error "n is used in conclusion" before revision 9447 *)

Goal forall n, n = S n.
induction S.
Abort.

(* Check that elimination with remaining evars do not raise an bad
   error message *)

Theorem Refl : forall P, P <-> P. tauto. Qed.
Goal True.
case Refl || ecase Refl.
Abort.

(* Submitted by B. Baydemir (bug #1882) *)

Require Import List.

Definition alist R := list (nat * R)%type.

Section Properties.
  Variable A : Type.
  Variable a : A.
  Variable E : alist A.

  Lemma silly : E = E.
  Proof.
    clear. induction E.  (* this fails. *)
  Abort.

End Properties.

(* This used not to work before revision 11944 *)

Goal forall P:(forall n, 0=n -> Prop), forall H: 0=0, P 0 H.
destruct H.
Abort.

(* The calls to "destruct" below did not work before revision 12356 *)

Variable A0:Type.
Variable P:A0->Type.
Require Import JMeq.
Goal forall a b (p:P a) (q:P b),
  forall H:a = b, eq_rect a P p b H = q -> JMeq (existT _ a p) (existT _ b q).
intros.
destruct H.
destruct H0.
reflexivity.
Qed.