(* -*- mode: coq; coq-prog-args: ("-nois") -*- *)

Declare ML Module "ltac_plugin".

Global Set Default Proof Mode "Classic".

Global Unset Elimination Schemes.

Module Pre.
 Delimit Scope type_scope with type.

 Open Scope type_scope.

 Notation "x -> y"
   := (forall (_ : x), y) (at level 99, right associativity, y at level 200) : type_scope.

 Tactic Notation "rf" uconstr(x) := refine x.
End Pre.

Module Function.
 Import Pre.

 Definition idmap A : A -> A := fun x => x.

 Definition const A B : A -> B -> A := fun x _ => x.

 Definition compose A B C : (B -> C) -> (A -> B) -> A -> C := fun f g x => f (g x).

 Definition flip A B C : (B -> A -> C) -> A -> B -> C := fun f x y => f y x.

 Definition dep A B : (A -> A -> B) -> A -> B := fun f x => f x x.
End Function.

Module Unit.
 Inductive unit : Type :=
 | I : unit
 .

 Scheme unit_ind := Induction for unit Sort Type.
 Scheme unit_rec := Minimality for unit Sort Type.
 Definition unit_rect := unit_ind.
End Unit.

Module Empty.
 Import Pre.

 Inductive empty : Type :=
 .

 Scheme empty_ind := Induction for empty Sort Type.
 Scheme empty_rec := Minimality for empty Sort Type.
 Definition empty_rect := empty_ind.

 Definition not (A : Type) : Type := A -> empty.

 Notation "~ x" := (not x) (at level 75, right associativity) : type_scope.

 Definition exfalso := empty_rec.

 Definition absurd A B : A -> ~ A -> B := fun H nH => exfalso B (nH H).
End Empty.

Module And.
 Import Pre.

 Inductive and (A B : Type) : Type :=
 | prod : A -> B -> and A B
 .

 Scheme and_ind := Induction for and Sort Type.
 Scheme and_rec := Minimality for and Sort Type.
 Definition and_rect := and_ind.

 Notation "x /\ y" := (and x y) (at level 80, right associativity) : type_scope.

 Definition first A B : A /\ B -> A := fun H => match H with prod _ _ Ha _ => Ha end.

 Definition second A B : A /\ B -> B := fun H => match H with prod _ _ _ Hb => Hb end.
End And.

Module Or.
 Import Pre.

 Inductive or (A B : Type) : Type :=
 | left : A -> or A B
 | right : B -> or A B
 .

 Scheme or_ind := Induction for or Sort Type.
 Scheme or_rec := Minimality for or Sort Type.
 Definition or_rect := or_ind.

 Notation "x \/ y" := (or x y) (at level 85, right associativity) : type_scope.
End Or.

Module Iff.
 Import Pre And.

 Definition iff A B := A -> B /\ B -> A.

 Notation "x <-> y" := (iff x y) (at level 95, no associativity) : type_scope.
End Iff.

Module Eq.
 Import Pre.

 Inductive eq (A : Type) (a : A) : A -> Type :=
 | eq_refl : eq A a a
 .

 Scheme eq_ind := Induction for eq Sort Type.
 Scheme eq_rec := Minimality for eq Sort Type.
 Definition eq_rect := eq_ind.

 Definition eq_sym A x y : eq A x y -> eq A y x.
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (eq_refl A x).
 Defined.

 Definition eq_trans A x y z : eq A x y -> eq A y z -> eq A x z.
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (fun q => _).
  rf (match q with eq_refl _ _ => _ end).
  rf (eq_refl A x).
 Defined.

 Definition eq_stepl A x y z : eq A z x -> eq A z y -> eq A x y.
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (fun q => _).
  rf (match q with eq_refl _ _ => _ end).
  rf (eq_refl A z).
 Defined.

 Definition eq_stepr := eq_trans.

 Definition eq_stepc A x y z w : eq A z w -> eq A z x -> eq A w y -> eq A x y.
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (eq_stepl A x y z).
 Defined.
End Eq.

Module Ex.
 Import Pre.

 Inductive ex (A : Type) (P : A -> Type) : Type :=
 | ex_intro : forall x, P x -> ex A P
 .

 Scheme ex_ind := Induction for ex Sort Type.
 Scheme ex_rec := Minimality for ex Sort Type.
 Definition ex_rect := ex_ind.
End Ex.

Module Nat.
 Import Pre.

 Inductive nat : Type :=
 | O : nat
 | S : nat -> nat
 .

 Scheme nat_ind := Induction for nat Sort Type.
 Scheme nat_rec := Minimality for nat Sort Type.
 Definition nat_rect := nat_ind.
End Nat.

Module Path.
 Import Pre Eq.

 Definition eq_eq_stepl A x y p : eq (eq A x x) (eq_stepl A x x y p p) (eq_refl A x).
 Proof.
  rf (match p with eq_refl _ _ => _ end).
  cbn.
  rf (eq_refl (eq A y y) (eq_refl A y)).
 Defined.

 Definition inverse := eq_sym.

 Definition concat := eq_trans.

 Definition transport A (P : A -> Type) x y : eq A x y -> P x -> P y.
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (fun H => H).
 Defined.

 Definition ap A B (f : A -> B) x y : eq A x y -> eq B (f x) (f y).
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (eq_refl B (f x)).
 Defined.

 Definition ap01 := ap.

 Definition apD10 A B f g : eq (forall x : A, B x) f g -> forall x, eq (B x) (f x) (g x).
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (fun x => eq_refl (B x) (f x)).
 Defined.

 Definition ap10 A B f g : eq (A -> B) f g -> forall x, eq B (f x) (g x).
 Proof.
  rf (apD10 A (fun _ => B) f g).
 Defined.

 Definition ap11 A B f g : eq (A -> B) f g -> forall x y, eq A x y -> eq B (f x) (g y).
 Proof.
  rf (fun p => _).
  rf (match p with eq_refl _ _ => _ end).
  rf (fun x y q => _).
  rf (match q with eq_refl _ _ => _ end).
  rf (eq_refl B (f x)).
 Defined.

 Definition wiskerL A x y z (p : eq A z x) (q r : eq A z y)
     : eq (eq A z y) q r -> eq (eq A x y) (eq_stepl A x y z p q) (eq_stepl A x y z p r).
 Proof.
  rf (fun s => _).
  rf (match s with eq_refl _ _ => _ end).
  rf (eq_refl (eq A x y) (eq_stepl A x y z p q)).
 Defined.

 Definition eq_pointwise A (P : A -> Type) (f g : forall x, P x) x := eq (P x) (f x) (g x).
End Path.

Module Contr.
 Import Pre Ex Eq Path.

 Definition contr (A : Type) : Type := ex A (fun x => forall y, eq A x y).

 Definition eq_contr A : contr A -> forall x y, eq A x y.
 Proof.
  rf (fun H x y => _).
  rf (match H with ex_intro _ _ Hc HH => _ end).
  rf (eq_stepl A x y Hc _ _).
  -
   rf (HH x).
  -
   rf (HH y).
 Defined.

 Definition eq_eq_contr A : forall H x y (p : eq A x y), eq (eq A x y) (eq_contr A H x y) p.
 Proof.
  rf (fun H x y p => _).
  rf (match H with ex_intro _ _ Hc HH => _ end).
  cbn.
  rf (match p with eq_refl _ _ => _ end).
  rf (eq_eq_stepl A x Hc (HH x)).
 Defined.

 Definition contr_eq_contr A : contr A -> forall x y, contr (eq A x y).
 Proof.
  rf (fun H x y => _).
  rf (ex_intro (eq A x y) (fun p => forall q, eq (eq A x y) p q) (eq_contr A H x y) _).
  rf (fun p => eq_eq_contr A H x y p).
 Defined.
End Contr.

Module Trunc.
 Export Pre Ex Nat Eq Contr.

 Definition trunc : nat -> Type -> Type :=
  nat_ind (fun _ => Type -> Type)
   (fun      A => contr A)
   (fun _ IH A => forall x y, IH (eq A x y))
 .

 Definition trunc_succ : forall n A, trunc n A -> trunc (S n) A.
 Proof.
  rf (nat_ind (fun n => forall A, trunc n A -> forall x y, trunc n (eq A x y)) _ _).
  -
   rf (fun A H x y => _).
   rf (contr_eq_contr A H x y).
  -
   rf (fun np go A H x y => _).
   rf (go (eq A x y) _).
   rf (H x y).
 Defined.

 Definition hprop_forall A : (forall x y, eq A x y) -> trunc (S O) A.
 Proof.
  rf (fun H x y => _).
  rf (contr_eq_contr A _ x y).
  rf (ex_intro A (fun x => forall y, eq A x y) x _).
  rf (H x).
 Defined.
End Trunc.

Module Truncs.
 Export Trunc.
 Import Unit Empty.

 Definition contr_unit : contr unit.
 Proof.
  rf (ex_intro unit (fun x => forall y, eq unit x y) I _).
  rf (fun u => match u with I => _ end).
  rf (eq_refl unit I).
 Defined.

 Definition trunc_unit : trunc O unit := contr_unit.

 Definition trunc_empty : trunc (S O) empty.
 Proof.
  rf (fun x y => _).
  rf (exfalso (trunc O (eq empty x y)) x).
 Defined.
End Truncs.

Module Collapse.
 Export Trunc Path.
 Import Unit Empty Or.

 Definition constant A B (f : A -> B) := forall x y, eq B (f x) (f y).

 Definition collapsable A := ex (A -> A) (fun f => constant A A f).

 Definition collapse A : collapsable A -> A -> A
     := fun H => match H with ex_intro _ _ f _ => f end.

 Definition collapse_H A : forall c x y, eq A (collapse A c x) (collapse A c y).
 Proof.
  rf (fun c x y => _).
  rf (match c with ex_intro _ _ cf cH => _ end).
  cbn.
  rf (cH x y).
 Defined.

 Definition path_collapsable A := forall x y, collapsable (eq A x y).

 Definition path_collapse A x y : path_collapsable A -> eq A x y -> eq A x y
     := fun H => collapse (eq A x y) (H x y).

 Definition path_collapse_H A x y
     : forall c p q, eq (eq A x y) (path_collapse A x y c p) (path_collapse A x y c q).
 Proof.
  rf (fun c p q => _).
  rf (collapse_H (eq A x y) (c x y) p q).
 Defined.

 Definition collapse_ansym A x y c p
     := eq_stepl A x y x (path_collapse A x x c (eq_refl A x)) (path_collapse A x y c p).

 Definition collapse_k A x y c p : eq (eq A x y) (collapse_ansym A x y c p) p.
 Proof.
  rf (match p with eq_refl _ _ => _ end).
  rf (eq_eq_stepl A x x (path_collapse A x x c (eq_refl A x))).
 Defined.

 Definition trunc_path_collapsable A : path_collapsable A -> trunc (S (S O)) A.
 Proof.
  rf (fun c x y => _).
  rf (hprop_forall (eq A x y) _).
  rf (fun p q => _).
  rf (eq_stepc (eq A x y) p q (collapse_ansym A x y c p) (collapse_ansym A x y c q) _ _ _).
  -
   rf (let p_co t p := path_collapse A x t c p in _).
   rf (wiskerL A x y x (p_co x (eq_refl A x)) (p_co y p) (p_co y q) _).
   rf (path_collapse_H A x y c p q).
  -
   rf (collapse_k A x y c p).
  -
   rf (collapse_k A x y c q).
 Defined.
End Collapse.


Require Export BoilerplateSyntax.
Require Export SpecSemantics.
Set Implicit Arguments.

Lemma PTyping_bindPat_dom {Γ p T Δ} (wp: PTyping Γ p T Δ) :
  bindPat p = dom Δ.
Proof.
  induction wp; isimpl; try rewrite dom_append; congruence.
Qed.

Lemma weakenTy_hplus T k1 k2 :
  weakenTy T (k1 + k2) = weakenTy (weakenTy T k1) k2.
Proof.
  revert T k1. induction k2; simpl; congruence.
Qed.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma weakenTy_tshiftTy c T Δ :
  tshiftTy (c + dom Δ) (weakenTy T (dom Δ)) =
  weakenTy (tshiftTy c T) (dom Δ).
Proof.
  induction Δ; isimpl; now f_equal.
Qed.
Hint Rewrite weakenTy_tshiftTy : interaction.

Lemma weakenTy_tsubstTy X S T Δ :
  tsubstTy (X + dom Δ) S (weakenTy T (dom Δ)) =
  weakenTy (tsubstTy X S T) (dom Δ).
Proof.
  induction Δ; isimpl; now f_equal.
Qed.
Hint Rewrite weakenTy_tsubstTy : interaction.

Lemma shift_etvar_ptyping {Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → PTyping Γ2 p (tshiftTy c T) (tshiftEnv c Δ).
Proof.
  induction wp; intros; isimpl; econstructor; isimpl; eauto.
  specialize (IHwp2 (c + dom Δ1)); isimpl; eauto.
Qed.
Hint Resolve shift_etvar_ptyping.

Lemma shift_etvar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → Typing Γ2 (tshiftTm c t) (tshiftTy c T).
Proof.
  induction wt; intros; try (isimpl; econstructor; eauto; fail); simpl.
  - specialize (IHwt (HSm c) (evar Γ2 (tshiftTy c T1))).
    isimpl; constructor; eauto.
  - specialize (IHwt c Γ2 H1).
    isimpl; constructor; eauto.
  - specialize (IHwt2 (HSm (HSy c)) (evar (etvar Γ2) (tshiftTy (HSy c) T12))).
    isimpl; econstructor; eauto.
  - rewrite (PTyping_bindPat_dom H).
    specialize (IHwt2 (c + dom Δ) (append Γ2 (tshiftEnv c Δ))
                  (weaken_shift_etvar Δ H0)).
    econstructor; repeat (isimpl; eauto).
Qed.

Lemma shift_evar_ptyping {Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → PTyping Γ2 p T Δ.
Proof.
  induction wp; intros; isimpl; econstructor; isimpl; eauto.
Qed.
Hint Resolve shift_evar_ptyping.

Lemma shift_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Typing Γ2 (shiftTm c t) T.
Proof.
  induction wt; intros; try (isimpl; econstructor; eauto; fail).
  - simpl; rewrite (PTyping_bindPat_dom H).
    econstructor; eauto using shift_evar_ptyping.
Qed.

Lemma weaken_typing {Γ} Δ :
  ∀ {t T}, Typing Γ t T →
           Typing (append Γ Δ) (weakenTm t (dom Δ)) (weakenTy T (dom Δ)).
Proof.
  induction Δ; intros; simpl; eauto using shift_evar_typing, shift_etvar_typing.
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Inductive subst_etvar : hnat → Ty → Env → Env → Prop :=
  | tse_here {Γ T} :
      wfTy Γ T → subst_etvar HO T (etvar Γ) Γ
  | tse_var {Γ1 Γ2 T' T X} :
      subst_etvar X T' Γ1 Γ2 →
      subst_etvar (HSm X) T' (evar Γ1 T) (evar Γ2 (tsubstTy X T' T))
  | tse_bound {Γ1 Γ2 X T'} :
      subst_etvar X T' Γ1 Γ2 →
      subst_etvar (HSy X) T' (etvar Γ1) (etvar Γ2).
Hint Constructors subst_etvar.

Lemma weaken_subst_etvar {T} (Δ : Env) :
  ∀ {x Γ1 Γ2},
    subst_etvar x T Γ1 Γ2 →
    subst_etvar (x + dom Δ) T (append Γ1 Δ) (append Γ2 (tsubstEnv x T Δ)).
Proof.
  induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_subst_etvar.

Lemma subst_etvar_lookup_etvar {X T' Γ1 Γ2} (esub: subst_etvar X T' Γ1 Γ2) :
  ∀ {Y}, lookup_etvar Γ1 Y → wfTy Γ2 (tsubstIndex X T' Y).
Proof.
  induction esub; inversion 1; simpl; eauto.
Qed.

Lemma subst_etvar_wfty {Γ1 T' T} (wT: wfTy Γ1 T) :
  ∀ {X Γ2}, subst_etvar X T' Γ1 Γ2 → wfTy Γ2 (tsubstTy X T' T).
Proof.
  induction wT; simpl; eauto using subst_etvar_lookup_etvar.
Qed.
Hint Resolve subst_etvar_wfty.

Lemma subst_etvar_lookup_evar  {X T' Γ1 Γ2} (esub: subst_etvar X T' Γ1 Γ2) :
  ∀ {x T}, lookup_evar Γ1 x T → lookup_evar Γ2 x (tsubstTy X T' T).
Proof.
  induction esub; inversion 1; isimpl; eauto.
Qed.
Hint Resolve subst_etvar_lookup_evar.

Inductive subst_evar : hnat → Tm → Env → Env → Prop :=
  | se_here {Γ s S} :
      Typing Γ s S → subst_evar HO s (evar Γ S) Γ
  | se_var {Γ1 Γ2 T s x} :
      subst_evar x s Γ1 Γ2 →
      subst_evar (HSm x) s (evar Γ1 T) (evar Γ2 T)
  | se_bound {Γ1 Γ2 x s} :
      subst_evar x s Γ1 Γ2 →
      subst_evar (HSy x) s (etvar Γ1) (etvar Γ2).
Hint Constructors subst_evar.

Lemma weaken_subst_evar {t} (Δ : Env) :
  ∀ {x Γ1 Γ2},
    subst_evar x t Γ1 Γ2 →
    subst_evar (x + dom Δ) t (append Γ1 Δ) (append Γ2 Δ).
Proof.
  induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_subst_evar.

Lemma subst_evar_lookup_etvar {x s Γ1 Γ2} (esub: subst_evar x s Γ1 Γ2) :
  ∀ {Y}, lookup_etvar Γ1 Y → lookup_etvar Γ2 Y.
Proof.
  induction esub; inversion 1; simpl; eauto.
Qed.

Lemma subst_evar_wftyp {Γ1 T} (wT: wfTy Γ1 T) :
  ∀ {x s Γ2}, subst_evar x s Γ1 Γ2 → wfTy Γ2 T.
Proof.
  induction wT; simpl; eauto using subst_evar_lookup_etvar.
Qed.
Hint Resolve subst_evar_wftyp.

Lemma subst_etvar_ptyping {S Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {X Γ2}, subst_etvar X S Γ1 Γ2 →
    PTyping Γ2 p (tsubstTy X S T) (tsubstEnv X S Δ).
Proof.
  induction wp; intros; isimpl; econstructor; isimpl; eauto.
  specialize (IHwp2 (X + dom Δ1)); isimpl; eauto.
Qed.

Lemma subst_etvar_typing {T' Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {X Γ2}, subst_etvar X T' Γ1 Γ2 →
    Typing Γ2 (tsubstTm X T' t) (tsubstTy X T' T).
Proof.
  induction wt; intros; try (isimpl; econstructor; eauto; fail); simpl.
  - specialize (IHwt (HSm X) (evar Γ2 (tsubstTy X T' T1))).
    isimpl; constructor; eauto.
  - specialize (IHwt X Γ2 H1).
    isimpl; constructor; eauto.
  - specialize (IHwt2 (HSm (HSy X))).
    isimpl; econstructor; eauto.
  - rewrite (PTyping_bindPat_dom H).
    specialize (IHwt2 (X + dom Δ)).
    econstructor; repeat (isimpl; eauto using subst_etvar_ptyping).
Qed.

Lemma subst_evar_lookup_evar {x t Γ1 Γ2} (esub: subst_evar x t Γ1 Γ2) :
  ∀ {y U}, lookup_evar Γ1 y U → Typing Γ2 (substIndex x t y) U.
Proof.
  induction esub; inversion 1; subst; simpl;
    eauto using T_Var, shift_etvar_typing, shift_evar_typing.
Qed.

Lemma subst_evar_ptyping {s Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {X Γ2}, subst_evar X s Γ1 Γ2 →
    PTyping Γ2 p T Δ.
Proof.
  induction wp; intros; isimpl; econstructor; isimpl; eauto.
Qed.

Lemma subst_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {x t' Γ2}, subst_evar x t' Γ1 Γ2 → Typing Γ2 (substTm x t' t) T.
Proof.
  induction wt; simpl; eauto using subst_evar_lookup_evar; econstructor;
    try rewrite (PTyping_bindPat_dom H); eauto using subst_evar_ptyping.
Qed.


From iris.heap_lang Require Import proofmode.

Lemma big_opL_forall' {M: ofeT} {o: M -> M -> M} {H': Monoid o} {A B: Type}
      R f g (l: list A) (l': list B):
  Reflexive R ->
  Proper (R ==> R ==> R) o ->
  length l = length l' ->
  (forall k y y', l !! k = Some y -> l' !! k = Some y' -> R (f k y) (g k y')) ->
  R ([^o list] k ↦ y ∈ l, f k y) ([^o list] k ↦ y ∈ l', g k y).
Proof.
  intros ??. revert l' f g. induction l as [|x l IH]=> l' f g HLen HHyp //=.
  all: destruct l'; inversion HLen; eauto.
  simpl. f_equiv; eauto.
Qed.

Lemma big_sepL_forall_2 {PROP: bi} {A B: Type}
      (f: nat -> A -> PROP) (g: nat -> B -> PROP)
      (l: list A) (l': list B):
  length l = length l' ->
  (∀ (k : nat) y y', l !! k = Some y → l' !! k = Some y' → f k y ≡ g k y') ->
  ([∗ list] k ↦ y ∈ l, f k y)%I ≡ ([∗ list] k ↦ y ∈ l', g k y)%I.
Proof. intros. apply big_opL_forall'; eauto; try apply _. Qed.

Lemma big_sepL_list_alter {PROP: bi} {A: Type} {P: nat -> A -> PROP} (f: A -> A) v i x':
  v !! i = Some x' ->
  ([∗ list] k ↦ x ∈ v, P k x) -∗
  (P i (f x')) -∗
  (P i x' ∗ [∗ list] k ↦ x ∈ alter f i v, P k x).
Proof.
  iIntros (?) "HList HVal".
  assert (i < length v)%nat as HLength by (apply lookup_lt_is_Some_1; eauto).
  assert (i = (length (take i v) + 0)%nat) as HCidLen.
  { rewrite take_length_le. by rewrite -plus_n_O. lia. }
  replace (alter _ i) with (@alter _ _ _ list_alter f (length (take i v) + 0)%nat) by auto.
  remember (length _ + 0)%nat as K.
  replace v with (take i v ++ x' :: drop (S i) v) by (rewrite take_drop_middle; auto).
  subst K.
  rewrite alter_app_r.
  rewrite big_opL_app. rewrite big_opL_app. simpl.
  iDestruct "HList" as "[HListPre [HListMid HListSuf]]".
  rewrite -HCidLen.
  by iFrame.
Qed.

Lemma big_opL_irrelevant_element (M: ofeT) (o: M -> M -> M) (H': Monoid o)
      {A: Type} n (P: nat -> M) (l: list A):
  ([^o list] i ↦ _ ∈ l, P (n+i)%nat)%I =
  ([^o list] i ∈ seq n (length l), P i%nat)%I.
Proof.
  assert (length l = length (seq n (length l))) as HSeqLen
      by (rewrite seq_length; auto).
  apply big_opL_forall'; try apply _. done.
  intros ? ? ? _ HElem.
  assert (k < length l)%nat as HKLt.
  { rewrite HSeqLen. apply lookup_lt_is_Some. by eexists. }
  apply nth_lookup_Some with (d:=O) in HElem.
  rewrite seq_nth in HElem; subst; done.
Qed.

Lemma big_opL_replicate_irrelevant_element
      (M: ofeT) (o: M -> M -> M) (H': Monoid o)
      {A: Type} (P: nat -> A -> M) (a: A) n:
  ([^o list] i ↦ k ∈ replicate n a, P i k)%I =
  ([^o list] i ↦ _ ∈ replicate n a, P i a)%I.
Proof.
  apply big_opL_gen_proper; try apply _.
  intros ? ?; rewrite lookup_replicate; case; by intros ->.
Qed.

Lemma big_opL_irrelevant_element'
      (M: ofeT) (o: M -> M -> M) (H': Monoid o)
      {A: Type} (P: nat -> M) (l: list A):
  ([^o list] i ↦ k ∈ l, P i)%I = ([^o list] i ∈ seq 0 (length l), P i%nat)%I.
Proof. by rewrite -big_opL_irrelevant_element. Qed.

Lemma big_opL_take_drop_middle (M: ofeT) (o : M → M → M) (H': Monoid o) (A: Type)
      (f: nat → A → M) (l: list A) (id: nat) (x: A):
  l !! id = Some x →
  ([^o list] k ↦ y ∈ l, f k y) ≡
    (o ([^o list] k ↦ y ∈ take id l, f k y)
       (o (f id x) ([^o list] k ↦ y ∈ drop (S id) l, f (id + S k) y))).
Proof.
  intros HEl.
  erewrite <-(take_drop_middle l); last done.
  assert (id < length l)%nat by (eapply lookup_lt_Some; eassumption).
  rewrite big_opL_app take_app_alt.
  rewrite drop_app_ge.
  all: rewrite take_length_le //=; try lia.
  replace (S id - id)%nat with 1 by lia. simpl.
  by rewrite drop_0 Nat.add_0_r.
Qed.

Lemma big_sepL_lookup_alter {PROP: bi} {A: Type} i s f (P: nat -> A -> PROP) (l: list A) v:
  l !! i = Some v ->
  ([∗ list] i ↦ k ∈ l, P (s+i)%nat k) -∗
  (P (s+i)%nat v ∗ (P (s+i)%nat (f v) -∗
                      [∗ list] i ↦ k ∈ (alter f i l), P (s+i)%nat k)).
Proof.
  iIntros (HEl) "HList".
  iInduction l as [|x l'] "IH" forall (s i HEl); first by inversion HEl.
  destruct i; simpl in *.
  - inversion HEl; subst.
    rewrite Nat.add_0_r. iDestruct "HList" as "[$ $]".
    by iIntros "$".
  - iDestruct "HList" as "[$ HList]".
    rewrite -plus_n_Sm.
    iDestruct ("IH" $! (S s) i HEl with "[HList]") as "[$ HLst] /=".
    { iDestruct (big_sepL_mono with "HList") as "$".
      iIntros (? ? ?) "HAp". by rewrite -plus_n_Sm. }
    iIntros "HPs". iDestruct ("HLst" with "HPs") as "HLst".
    iDestruct (big_sepL_mono with "HLst") as "$".
    iIntros (? ? ?) "HAp". by rewrite -plus_n_Sm.
Qed.

Lemma big_sepL_lookup_alter_abort {PROP: bi} {A: Type} i s f (P: nat -> A -> PROP) (l: list A) v:
  l !! i = Some v ->
  ([∗ list] i ↦ k ∈ l, P (s+i)%nat k) -∗
  (P (s+i)%nat v ∗ ((P (s+i)%nat v -∗ [∗ list] i ↦ k ∈ l, P (s+i)%nat k) ∧
                    (P (s+i)%nat (f v) -∗
                       [∗ list] i ↦ k ∈ (alter f i l), P (s+i)%nat k))).
Proof.
  iIntros (HEl) "HList".
  iInduction l as [|x l'] "IH" forall (s i HEl); first by inversion HEl.
  destruct i; simpl in *.
  - inversion HEl; subst.
    rewrite Nat.add_0_r. iDestruct "HList" as "[$ $]".
    iSplit; by iIntros "$".
  - iDestruct "HList" as "[$ HList]".
    rewrite -plus_n_Sm.
    iDestruct ("IH" $! (S s) i HEl with "[HList]") as "[$ HLst] /=".
    { iDestruct (big_sepL_mono with "HList") as "$".
      iIntros (? ? ?) "HAp". by rewrite -plus_n_Sm. }
    iSplit; iIntros "HPs".
    1: iDestruct "HLst" as "[HLst _]".
    2: iDestruct "HLst" as "[_ HLst]".
    all: iDestruct ("HLst" with "HPs") as "HLst".
    all: iDestruct (big_sepL_mono with "HLst") as "$".
    all: iIntros (? ? ?) "HAp". all: by rewrite -plus_n_Sm.
Qed.

From iris.algebra Require Import cmra gset numbers.

Lemma big_opL_op_prodR r (A B : ucmraT) (C : Type)
      (f : nat → C → A) (g : nat → C → B) (l : list C):
  ([^op list] k↦x ∈ l, ((f (r + k) x, g (r + k) x) : prodR A B)) ≡
  (([^op list] k↦x ∈ l, f (r + k) x), ([^op list] k↦x ∈ l, g (r + k) x)).
Proof.
  generalize dependent r.
  induction l as [|v l']=> //= r.
  setoid_rewrite <-plus_n_Sm.
  by rewrite Nat.add_0_r pair_op (IHl' (S r)).
Qed.

Lemma big_opL_op_ucmra_unit (A: ucmraT) (C : Type) (l : list C):
  ([^op list] _ ∈ l, (ε: A)) ≡ ε.
Proof. induction l=>//=. rewrite IHl ucmra_unit_left_id //. Qed.

Lemma big_opL_op_gset n m:
  GSet (set_seq n m) ≡ [^op list] x ∈ seq n m, GSet {[x]}.
Proof.
  move: m n. elim=> //= m IHm n. rewrite -(IHm (S n)).
  rewrite -gset_op_union gset_disj_union //=.
  apply set_seq_S_start_disjoint.
Qed.

Global Instance max_monoid: Monoid max.
Proof.
  apply (Build_Monoid natO max 0)=> //; try apply _.
  - intros x y z. rewrite leibniz_equiv_iff. apply Max.max_assoc.
  - intros x y. rewrite leibniz_equiv_iff. apply Max.max_comm.
Defined.

Global Instance max_nat_homomorphism:
  MonoidHomomorphism max op equiv MaxNat.
Proof.
  econstructor; last done.
  econstructor; try apply _.
  intros. by rewrite max_nat_op_max.
Qed.

Lemma big_opL_op_max_nat {A: Type} (f: nat → A -> max_natR) (l: list A):
  MaxNat ([^max list] k ↦ x ∈ l, max_nat_car (f k x)) ≡
  ([^op list] k ↦ x ∈ l, f k x).
Proof.
  rewrite (big_opL_commute _). apply big_opL_proper. intros. by destruct (f _ _).
Qed.

Lemma big_opL_op_nat {A: Type} (f: nat → A -> natR) (l: list A):
  ([^Nat.add list] k ↦ x ∈ l, f k x) ≡
  ([^op list] k ↦ x ∈ l, f k x).
Proof. done. Qed.

Lemma big_opL_op_nat' {A: Type} (i: nat) (l: list A):
  length l * i ≡ ([^op list] k ↦ x ∈ l, i).
Proof. induction l=> //=. by rewrite IHl. Qed.


(******************************************************************************)
(*   Copyright (c) 2019--2021 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Lia.
Require Import Arith.
Require Import Relations.
Require Import Equality.
Require Import Local.Prelude.
Require Import Local.Syntax.
Require Import Local.Metatheory.
Require Import Local.Context.
Require Import Local.Reduction.

(** ** Residuals *)

Inductive redexes: Set :=
  | redexes_type
  | redexes_prop
  | redexes_base
  | redexes_void
  | redexes_bound (n: nat)
  | redexes_negation (ts: list pseudoterm)
  | redexes_jump (r: bool) (f: pseudoterm) (xs: list pseudoterm)
  | redexes_placeholder (f: pseudoterm) (xs: list pseudoterm)
  | redexes_bind (b: redexes) (ts: list pseudoterm) (c: redexes).

Fixpoint mark (e: pseudoterm): redexes :=
  match e with
  | type =>
    redexes_type
  | prop =>
    redexes_prop
  | base =>
    redexes_base
  | void =>
    redexes_void
  | bound n =>
    redexes_bound n
  | negation ts =>
    redexes_negation ts
  | jump f xs =>
    redexes_jump false f xs
  | bind b ts c =>
    redexes_bind (mark b) ts (mark c)
  end.

Fixpoint unmark (e: redexes): pseudoterm :=
  match e with
  | redexes_type =>
    type
  | redexes_prop =>
    prop
  | redexes_base =>
    base
  | redexes_void =>
    void
  | redexes_bound n =>
    n
  | redexes_negation ts =>
    negation ts
  | redexes_jump r f xs =>
    jump f xs
  | redexes_placeholder f xs =>
    jump f xs
  | redexes_bind b ts c =>
    bind (unmark b) ts (unmark c)
  end.

Lemma unmark_mark_is_sound:
  forall e,
  unmark (mark e) = e.
Proof.
  induction e; simpl; auto.
  rewrite IHe1, IHe2; auto.
Qed.

Fixpoint redexes_lift i k e: redexes :=
  match e with
  | redexes_jump r f xs =>
    redexes_jump r (lift i k f) (map (lift i k) xs)
  | redexes_placeholder f xs =>
    redexes_placeholder (lift i k f) (map (lift i k) xs)
  | redexes_bind b ts c =>
    redexes_bind
      (redexes_lift i (S k) b)
      (traverse_list (lift i) k ts)
      (redexes_lift i (k + length ts) c)
  | _ =>
    mark (lift i k (unmark e))
  end.

Fixpoint redexes_subst y k e: redexes :=
  match e with
  | redexes_jump r f xs =>
    redexes_jump r (subst y k f) (map (subst y k) xs)
  | redexes_placeholder f xs =>
    redexes_placeholder (subst y k f) (map (subst y k) xs)
  | redexes_bind b ts c =>
    redexes_bind
      (redexes_subst y (S k) b)
      (traverse_list (subst y) k ts)
      (redexes_subst y (k + length ts) c)
  | _ =>
    mark (subst y k (unmark e))
  end.

Fixpoint redexes_apply_parameters ys k e: redexes :=
  match ys with
  | [] => e
  | y :: ys => redexes_apply_parameters ys k (redexes_subst y (k + length ys) e)
  end.

Fixpoint redexes_flow y a k e: redexes :=
  match e with
  | redexes_placeholder (bound n) xs =>
    if Nat.eq_dec n k then
      if Nat.eq_dec a (length xs) then
        redexes_apply_parameters xs 0
          (redexes_lift (S n) (length xs) y)
      else
        e
    else
      e
  | redexes_bind b ts c =>
    redexes_bind
      (redexes_flow y a (S k) b)
      ts
      (redexes_flow y a (k + length ts) c)
  | _ =>
    e
  end.

Fixpoint redexes_full e: redexes :=
  match e with
  | redexes_bind b ts c =>
    redexes_bind
      (redexes_flow (redexes_full c) (length ts) 0
        (redexes_full b)) ts (redexes_full c)
  | _ =>
    e
  end.

(* -------------------------------------------------------------------------- *)

(*
Lemma redexes_lift_lift_permutation:
  forall e i j k l,
  k <= l ->
  redexes_lift i k (redexes_lift j l e) =
    redexes_lift j (i + l) (redexes_lift i k e).
Proof.
  induction e; simpl; intros.
  - f_equal.
    apply lift_lift_permutation; auto.
  - f_equal.
    + apply lift_lift_permutation; auto.
    + induction xs; auto.
      simpl; f_equal; auto.
      apply lift_lift_permutation; auto.
  - f_equal.
    + apply lift_lift_permutation; auto.
    + induction xs; auto.
      simpl; f_equal; auto.
      apply lift_lift_permutation; auto.
  - f_equal.
    + replace (S (i + l)) with (i + S l); try lia.
      apply IHe1; lia.
    + clear IHe1 IHe2.
      induction ts; auto.
      simpl; f_equal; auto.
      do 4 rewrite traverse_list_length.
      rewrite lift_lift_permutation; try lia.
      f_equal; lia.
    + do 2 rewrite traverse_list_length.
      replace (i + l + length ts) with (i + (l + length ts)); try lia.
      apply IHe2; lia.
Qed.

Lemma redexes_lift_addition_distributes_over_flow:
  forall b i k p a c,
  redexes_lift i (p + S k) (redexes_flow c a p b) =
    redexes_flow (redexes_lift i (k + a) c) a p (redexes_lift i (p + S k) b).
Proof.
  induction b; simpl; intros.
  - reflexivity.
  - reflexivity.
  - destruct f; try reflexivity.
    destruct (Nat.eq_dec n p).
    + rewrite lift_bound_lt; try lia.
      rewrite map_length.
      destruct (Nat.eq_dec a (length xs)).
      * destruct (Nat.eq_dec n p); try lia.
        rewrite redexes_lift_distributes_over_apply_parameters.
        f_equal; symmetry.
        rewrite redexes_lift_lift_permutation; try lia.
        f_equal; lia.
      * destruct (Nat.eq_dec n p); try lia.
        simpl.
        rewrite lift_bound_lt; try lia.
        reflexivity.
    + destruct (le_gt_dec (p + S k) n).
      * rewrite lift_bound_ge; try lia.
        destruct (Nat.eq_dec (i + n) p); try lia.
        simpl.
        rewrite lift_bound_ge; try lia.
        reflexivity.
      * rewrite lift_bound_lt; try lia.
        destruct (Nat.eq_dec n p); try lia.
        simpl.
        rewrite lift_bound_lt; try lia.
        reflexivity.
  - f_equal.
    + replace (S (p + S k)) with (S p + S k); try lia.
      apply IHb1.
    + rewrite traverse_list_length.
      replace (p + S k + length ts) with (p + length ts + S k); try lia.
      apply IHb2.
Qed.

Lemma redexes_lift_distributes_over_flow:
  forall b i k a c,
  redexes_lift i (S k) (redexes_flow c a 0 b) =
    redexes_flow (redexes_lift i (k + a) c) a 0 (redexes_lift i (S k) b).
Proof.
  intros.
  apply redexes_lift_addition_distributes_over_flow with (p := 0).
Qed.
*)

Lemma redexes_lift_addition_distributes_over_apply_parameters:
  forall ys i k p e,
  redexes_lift i (p + k) (redexes_apply_parameters ys p e) =
    redexes_apply_parameters (map (lift i k) ys) p
      (redexes_lift i (p + length ys + k) e).
Proof.
  induction ys; simpl; intros.
  - f_equal; lia.
  - rewrite IHys; f_equal.
    rewrite map_length.
    admit.
Admitted.

Lemma redexes_lift_distributes_over_apply_parameters:
  forall ys i k e,
  redexes_lift i k (redexes_apply_parameters ys 0 e) =
  redexes_apply_parameters (map (lift i k) ys) 0
    (redexes_lift i (length ys + k) e).
Proof.
  intros.
  apply redexes_lift_addition_distributes_over_apply_parameters with (p := 0).
Qed.

Lemma redexex_lift_lift_simplification:
  forall e i j k l,
  k <= l + j ->
  l <= k ->
  redexes_lift i k (redexes_lift j l e) = redexes_lift (i + j) l e.
Proof.
  induction e; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - destruct (le_gt_dec l n).
    + rewrite lift_bound_ge; auto.
      rewrite lift_bound_ge; auto.
      simpl.
      rewrite lift_bound_ge; try lia.
      simpl; f_equal; lia.
    + rewrite lift_bound_lt; auto.
      rewrite lift_bound_lt; auto.
      simpl.
      rewrite lift_bound_lt; try lia.
      simpl; auto.
  - f_equal.
    induction ts; simpl; auto.
    f_equal; auto.
    do 3 rewrite traverse_list_length.
    apply lift_lift_simplification; lia.
  - rewrite map_map.
    rewrite lift_lift_simplification; auto.
    f_equal; list induction over xs.
    apply lift_lift_simplification; auto.
  - rewrite lift_lift_simplification; auto.
    f_equal; list induction over xs.
    apply lift_lift_simplification; auto.
  - f_equal.
    + apply IHe1; lia.
    + list induction over ts.
      do 3 rewrite traverse_list_length.
      rewrite lift_lift_simplification; try lia.
      reflexivity.
    + rewrite traverse_list_length.
      apply IHe2; lia.
Qed.

Lemma redexes_flow_and_lift_commute:
  forall e y a k p i,
  k <= p ->
  redexes_flow y a (i + p) (redexes_lift i k e) =
    redexes_lift i k (redexes_flow y a p e).
Proof.
  induction e; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - destruct (le_gt_dec k n).
    + rewrite lift_bound_ge; auto.
    + rewrite lift_bound_lt; auto.
  - reflexivity.
  - reflexivity.
  - destruct f; auto.
    destruct (le_gt_dec k n).
    + rewrite lift_bound_ge; try lia.
      rewrite map_length.
      destruct (Nat.eq_dec a (length xs));
      destruct (Nat.eq_dec n p);
      destruct (Nat.eq_dec (i + n) (i + p));
      simpl; try lia.
      * rewrite redexes_lift_distributes_over_apply_parameters.
        rewrite redexex_lift_lift_simplification; try lia.
        f_equal; f_equal; lia.
      * rewrite lift_bound_ge; auto.
      * rewrite lift_bound_ge; auto.
      * rewrite lift_bound_ge; auto.
    + rewrite lift_bound_lt; try lia.
      rewrite map_length.
      destruct (Nat.eq_dec a (length xs));
      destruct (Nat.eq_dec n p);
      destruct (Nat.eq_dec n (i + p));
      simpl; try lia.
      * rewrite lift_bound_lt; auto.
      * rewrite lift_bound_lt; auto.
  - f_equal.
    + rewrite plus_n_Sm.
      apply IHe1; lia.
    + rewrite traverse_list_length.
      rewrite <- Nat.add_assoc.
      apply IHe2; lia.
Qed.

Lemma redexes_flow_addition_distributes_over_itself:
  forall b a1 a2 p k c1 c2,
  redexes_flow c2 a1 (p + S k) (redexes_flow c1 a2 p b) =
    redexes_flow (redexes_flow c2 a1 (k + a2) c1)
      a2 p (redexes_flow c2 a1 (p + S k) b).
Proof.
  induction b; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - (* Huh, some ugly case analysis... I should have a math simpl tactic! *)
    destruct f; auto;
    do 2 (destruct (Nat.eq_dec n p);
          destruct (Nat.eq_dec n (p + S k));
          destruct (Nat.eq_dec a1 (length xs));
          destruct (Nat.eq_dec a2 (length xs));
          simpl; auto; try lia).
    + admit.
    + admit.
    + admit.
    + admit.
  - f_equal.
    + replace (S (p + S k)) with (S p + S k); try lia.
      apply IHb1.
    + replace (p + S k + length ts) with (p + length ts + S k); try lia.
      apply IHb2.
Admitted.

Lemma redexes_flow_commute:
  forall b a1 a2 k c1 c2,
  redexes_flow c2 a1 (S k) (redexes_flow c1 a2 0 b) =
    redexes_flow (redexes_flow c2 a1 (k + a2) c1)
      a2 0 (redexes_flow c2 a1 (S k) b).
Proof.
  intros.
  apply redexes_flow_addition_distributes_over_itself with (p := 0).
Qed.

Lemma redexes_lift_is_sound:
  forall e i k,
  redexes_lift i k (mark e) = mark (lift i k e).
Proof.
  induction e; simpl; auto; intros.
  f_equal.
  - apply IHe1.
  - apply IHe2.
Qed.

Lemma redexes_subst_is_sound:
  forall e y k,
  redexes_subst y k (mark e) = mark (subst y k e).
Proof.
  induction e; simpl; auto; intros.
  f_equal.
  - apply IHe1.
  - apply IHe2.
Qed.

Lemma redexes_apply_parameters_is_sound:
  forall xs k e,
  redexes_apply_parameters xs k (mark e) = mark (apply_parameters xs k e).
Proof.
  induction xs; simpl; intros.
  - reflexivity.
  - rewrite redexes_subst_is_sound.
    rewrite IHxs; auto.
Qed.

(* -------------------------------------------------------------------------- *)

Inductive compatible: relation redexes :=
  | compatible_type:
    compatible redexes_type redexes_type
  | compatible_prop:
    compatible redexes_prop redexes_prop
  | compatible_base:
    compatible redexes_base redexes_base
  | compatible_void:
    compatible redexes_void redexes_void
  | compatible_bound:
    forall n,
    compatible (redexes_bound n) (redexes_bound n)
  | compatible_negation:
    forall ts,
    compatible (redexes_negation ts) (redexes_negation ts)
  | compatible_jump:
    forall r1 r2 f xs,
    compatible (redexes_jump r1 f xs) (redexes_jump r2 f xs)
  | compatible_placeholder:
    forall f xs,
    compatible (redexes_placeholder f xs) (redexes_placeholder f xs)
  | compatible_bind:
    forall b1 b2 ts c1 c2,
    compatible b1 b2 ->
    compatible c1 c2 ->
    compatible (redexes_bind b1 ts c1) (redexes_bind b2 ts c2).

Global Hint Constructors compatible: cps.

Lemma compatible_refl:
  forall e,
  compatible e e.
Proof.
  induction e; auto with cps.
Qed.

Global Hint Resolve compatible_refl: cps.

Lemma compatible_sym:
  forall a b,
  compatible a b -> compatible b a.
Proof.
  induction 1; auto with cps.
Qed.

Global Hint Resolve compatible_sym: cps.

Lemma compatible_trans:
  forall a b,
  compatible a b ->
  forall c,
  compatible b c -> compatible a c.
Proof.
  induction 1; inversion_clear 1; auto with cps.
Qed.

Global Hint Resolve compatible_trans: cps.

Lemma compatible_lift:
  forall a b,
  compatible a b ->
  forall i k,
  compatible (redexes_lift i k a) (redexes_lift i k b).
Proof.
  induction 1; simpl; auto with cps.
Qed.

Lemma compatible_subst:
  forall a b,
  compatible a b ->
  forall y k,
  compatible (redexes_subst y k a) (redexes_subst y k b).
Proof.
  induction 1; simpl; auto with cps.
Qed.

Lemma compatible_apply_parameters:
  forall ys k a b,
  compatible a b ->
  compatible (redexes_apply_parameters ys k a)
    (redexes_apply_parameters ys k b).
Proof.
  induction ys; simpl; intros.
  - assumption.
  - apply IHys.
    apply compatible_subst.
    assumption.
Qed.

Lemma compatible_flow:
  forall b1 b2 c1 c2 a,
  compatible c1 c2 ->
  compatible b1 b2 ->
  forall k,
  compatible (redexes_flow c1 a k b1) (redexes_flow c2 a k b2).
Proof.
  induction 2; simpl; auto with cps.
  (* Case: placeholder. *)
  intros.
  destruct f; try constructor.
  destruct (Nat.eq_dec n k); try constructor.
  destruct (Nat.eq_dec a (length xs)); try constructor.
  apply compatible_apply_parameters.
  apply compatible_lift.
  assumption.
Qed.

Inductive residuals: redexes -> redexes -> redexes -> Prop :=
  | residuals_type:
    residuals redexes_type redexes_type redexes_type
  | residuals_prop:
    residuals redexes_prop redexes_prop redexes_prop
  | residuals_base:
    residuals redexes_base redexes_base redexes_base
  | residuals_void:
    residuals redexes_void redexes_void redexes_void
  | residuals_bound:
    forall n,
    residuals (redexes_bound n) (redexes_bound n) (redexes_bound n)
  | residuals_negation:
    forall ts,
    residuals (redexes_negation ts) (redexes_negation ts) (redexes_negation ts)
  | residuals_jump:
    forall r k xs,
    residuals
      (redexes_jump r k xs)
      (redexes_jump false k xs)
      (redexes_jump r k xs)
  | residuals_mark:
    forall r k xs,
    residuals
      (redexes_jump r k xs)
      (redexes_jump true k xs)
      (redexes_placeholder k xs)
  | residuals_placeholder:
    forall k xs,
    residuals
      (redexes_placeholder k xs)
      (redexes_placeholder k xs)
      (redexes_placeholder k xs)
  | residuals_bind:
    forall b1 b2 b3 ts c1 c2 c3,
    residuals b1 b2 b3 ->
    residuals c1 c2 c3 ->
    residuals
      (redexes_bind b1 ts c1)
      (redexes_bind b2 ts c2)
      (* We shall postpone replacements in b3 here. *)
      (redexes_bind b3 ts c3).

Global Hint Constructors residuals: cps.

Lemma residuals_is_unique:
  forall a b c1,
  residuals a b c1 ->
  forall c2,
  residuals a b c2 -> c1 = c2.
Proof.
  induction 1; intros.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H; auto.
  - dependent destruction H1.
    replace b5 with b3; auto.
    replace c5 with c3; auto.
Qed.

Lemma compatible_residuals:
  forall a b c,
  residuals a b c ->
  compatible a b.
Proof.
  induction 1; auto with cps.
Qed.

Global Hint Resolve compatible_residuals: cps.

Lemma residuals_preserve_compatible:
  forall a1 a2,
  compatible a1 a2 ->
  forall b c1,
  residuals a1 b c1 ->
  forall c2,
  residuals a2 b c2 -> compatible c1 c2.
Proof.
  induction 1; intros.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H.
    + dependent destruction H0.
      constructor.
    + dependent destruction H0.
      constructor.
  - dependent destruction H.
    dependent destruction H0.
    constructor.
  - dependent destruction H1.
    dependent destruction H2.
    assert (compatible b4 b6); eauto.
    assert (compatible c4 c6); eauto.
    constructor; auto.
Qed.

Global Hint Resolve residuals_preserve_compatible: cps.

Lemma residuals_mark_term:
  forall e,
  residuals (mark e) (mark e) (mark e).
Proof.
  induction e; simpl; constructor; auto.
Qed.

Global Hint Resolve residuals_mark_term: cps.

Lemma residuals_lift:
  forall a b c,
  residuals a b c ->
  forall i k,
  residuals (redexes_lift i k a) (redexes_lift i k b) (redexes_lift i k c).
Proof.
  induction 1; simpl; auto with cps.
Qed.

Global Hint Resolve residuals_lift: cps.

Lemma residuals_subst:
  forall a b c,
  residuals a b c ->
  forall y k,
  residuals (redexes_subst y k a) (redexes_subst y k b) (redexes_subst y k c).
Proof.
  induction 1; simpl; auto with cps.
Qed.

Global Hint Resolve residuals_subst: cps.

Lemma residuals_apply_parameters:
  forall ys k a b c,
  residuals a b c ->
  residuals (redexes_apply_parameters ys k a) (redexes_apply_parameters ys k b)
    (redexes_apply_parameters ys k c).
Proof.
  induction ys; simpl; auto with cps.
Qed.

Global Hint Resolve residuals_apply_parameters: cps.

Lemma residuals_compatible:
  forall b1 b2,
  compatible b1 b2 ->
  exists b3,
  residuals b1 b2 b3.
Proof.
  induction 1; simpl; intros.
  - eexists; constructor.
  - eexists; constructor.
  - eexists; constructor.
  - eexists; constructor.
  - eexists; constructor.
  - eexists; constructor.
  - destruct r2.
    + eexists; constructor.
    + eexists; constructor.
  - eexists; constructor.
  - destruct IHcompatible1 as (b3, ?); auto.
    destruct IHcompatible2 as (c3, ?); auto.
    eexists; constructor; eauto.
Qed.

Global Hint Resolve residuals_compatible: cps.

Lemma cube:
  forall a r b,
  residuals a r b ->
  forall p c,
  residuals a p c ->
  forall rp,
  residuals r p rp ->
  forall pr,
  residuals p r pr ->
  forall d,
  residuals b pr d -> residuals c rp d.
Proof.
  induction 1; inversion_clear 1; intros.
  (* Case: (type, type). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (prop, prop). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (base, base). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (void, void). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (bound, bound). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (negation, negation). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (jump, jump). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (jump, mark). *)
  - dependent destruction H.
    dependent destruction H0.
    dependent destruction H1.
    constructor.
  (* Case: (mark, jump). *)
  - dependent destruction H.
    dependent destruction H0.
    dependent destruction H1.
    constructor.
  (* Case: (mark, mark). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (placeholder, placeholder). *)
  - dependent destruction H.
    dependent destruction H0.
    assumption.
  (* Case: (bind, bind). *)
  - dependent destruction H1.
    dependent destruction H4.
    dependent destruction H5.
    (* Replacements are postponed... *)
    constructor; eauto.
Qed.

Inductive paving_result b c r p: Prop :=
  paving_result_mk
    (pr: redexes)
    (rp: redexes)
    (d: redexes)
    (H1: residuals p r pr)
    (H2: residuals r p rp)
    (H3: residuals b pr d)
    (H4: residuals c rp d).

Lemma paving:
  forall a r b,
  residuals a r b ->
  forall p c,
  residuals a p c ->
  paving_result b c r p.
Proof.
  intros.
  assert (compatible p r).
  - apply compatible_trans with a.
    + apply compatible_sym.
      apply compatible_residuals with c.
      assumption.
    + apply compatible_residuals with b.
      assumption.
  - assert (exists pr, residuals p r pr) as (pr, ?); eauto with cps.
    assert (exists rp, residuals r p rp) as (rp, ?); eauto with cps.
    assert (exists d, residuals b pr d) as (d, ?); eauto with cps.
    apply paving_result_mk with pr rp d; auto.
    apply cube with a r b p pr; auto.
Qed.

Lemma redexes_flow_mark_equals_mark:
  forall e y a k,
  redexes_flow y a k (mark e) = mark e.
Proof.
  induction e; auto; intros.
  simpl.
  rewrite IHe1.
  rewrite IHe2.
  reflexivity.
Qed.

Lemma redexes_full_mark_equals_mark:
  forall e,
  redexes_full (mark e) = mark e.
Proof.
  induction e; auto; simpl.
  rewrite IHe1.
  rewrite IHe2.
  rewrite redexes_flow_mark_equals_mark.
  reflexivity.
Qed.

Global Hint Resolve redexes_full_mark_equals_mark: cps.

(* TODO: these definitions should probably be moved up. *)

Definition residuals_full a b c: Prop :=
  exists2 c',
  residuals a b c' & redexes_full c' = c.

Inductive redexes_context: Set :=
  | redexes_context_hole
  | redexes_context_left
      (b: redexes_context) (ts: list pseudoterm) (c: redexes)
  | redexes_context_right
      (b: redexes) (ts: list pseudoterm) (c: redexes_context).

Fixpoint apply_redexes_context h e: redexes :=
  match h with
  | redexes_context_hole =>
    e
  | redexes_context_left b ts c =>
    redexes_bind (apply_redexes_context b e) ts c
  | redexes_context_right b ts c =>
    redexes_bind b ts (apply_redexes_context c e)
  end.

Coercion apply_redexes_context: redexes_context >-> Funclass.

Fixpoint mark_context h: redexes_context :=
  match h with
  | context_hole =>
    redexes_context_hole
  | context_left b ts c =>
    redexes_context_left (mark_context b) ts (mark c)
  | context_right b ts c =>
    redexes_context_right (mark b) ts (mark_context c)
  end.

Lemma mark_context_is_sound:
  forall h e,
  mark_context h (mark e) = mark (h e).
Proof.
  induction h; simpl; congruence.
Qed.

Lemma residuals_mark_context:
  forall a b c,
  residuals a b c ->
  forall h,
  residuals (mark_context h a) (mark_context h b) (mark_context h c).
Proof.
  induction h; simpl; auto with cps.
Qed.

Global Hint Resolve residuals_mark_context: cps.

Inductive redexes_same_path: relation redexes_context :=
  | redexes_same_path_hole:
    redexes_same_path redexes_context_hole redexes_context_hole
  | redexes_same_path_left:
    forall h r ts1 ts2 c1 c2,
    redexes_same_path h r ->
    length ts1 = length ts2 ->
    redexes_same_path
      (redexes_context_left h ts1 c1)
      (redexes_context_left r ts2 c2)
  | redexes_same_path_right:
    forall b1 b2 ts1 ts2 h r,
    redexes_same_path h r ->
    length ts1 = length ts2 ->
    redexes_same_path
      (redexes_context_right b1 ts1 h)
      (redexes_context_right b2 ts2 r).

Global Hint Constructors redexes_same_path: cps.

Lemma compatible_context_left_inversion:
  forall (h: redexes_context) e1 b,
  compatible (h e1) b ->
  exists r e2,
  redexes_same_path h r /\ b = r e2.
Proof.
  induction h; simpl; intros.
  - exists redexes_context_hole; simpl.
    exists b; auto with cps.
  - dependent destruction H.
    destruct IHh with e1 b2 as (r, (e2, (?, ?))); auto.
    exists (redexes_context_left r ts c2), e2; simpl.
    dependent destruction H2.
    firstorder with cps.
  - dependent destruction H.
    destruct IHh with e1 c2 as (r, (e2, (?, ?))); auto.
    exists (redexes_context_right b2 ts r), e2; simpl.
    dependent destruction H2.
    firstorder with cps.
Qed.

Lemma compatible_context_changing_hole:
  forall h r,
  redexes_same_path h r ->
  forall a b,
  compatible (h a) (r b) ->
  forall c d,
  compatible c d -> compatible (h c) (r d).
Proof.
  induction 1; simpl; intros.
  - assumption.
  - dependent destruction H1.
    constructor; auto.
    eapply IHredexes_same_path; eauto.
  - dependent destruction H1.
    constructor; auto.
    eapply IHredexes_same_path; eauto.
Qed.

Lemma redexes_flow_mark_context_simplification:
  forall h c a k e,
  redexes_flow c a k (mark_context h e) =
    mark_context h (redexes_flow c a (k + #h) e).
Proof.
  induction h; simpl; intros.
  - f_equal; lia.
  - f_equal.
    + rewrite IHh; f_equal; f_equal.
      lia.
    + apply redexes_flow_mark_equals_mark.
  - f_equal.
    + apply redexes_flow_mark_equals_mark.
    + rewrite IHh; f_equal; f_equal.
      lia.
Qed.

Lemma redexes_full_mark_context_simplification:
  forall h n,
  n >= #h ->
  forall xs,
  redexes_full (mark_context h (redexes_placeholder n xs)) =
    mark_context h (redexes_placeholder n xs).
Proof.
  induction h; simpl; intros.
  - reflexivity.
  - f_equal.
    + rewrite IHh; try lia.
      rewrite redexes_flow_mark_context_simplification.
      f_equal; simpl.
      destruct (Nat.eq_dec n #h); try lia.
      reflexivity.
    + apply redexes_full_mark_equals_mark.
  - f_equal.
    + rewrite IHh; try lia.
      rewrite redexes_full_mark_equals_mark.
      apply redexes_flow_mark_equals_mark.
    + apply IHh; lia.
Qed.

Lemma residuals_preserve_hole:
  forall h r a b,
  redexes_same_path h r ->
  forall c,
  residuals (h a) (r b) c ->
  exists s e,
  redexes_same_path h s /\ residuals a b e /\ c = s e.
Proof.
  induction 1; simpl; intros.
  - exists redexes_context_hole; simpl.
    exists c; firstorder with cps.
  - dependent destruction H1.
    destruct IHredexes_same_path with b3 as (s, (e, (?, (?, ?)))); auto.
    exists (redexes_context_left s ts2 c4), e; simpl.
    split; [| split ].
    + auto with cps.
    + assumption.
    + congruence.
  - dependent destruction H1.
    destruct IHredexes_same_path with c3 as (s, (e, (?, (?, ?)))); auto.
    exists (redexes_context_right b4 ts2 s), e; simpl.
    split; [| split ].
    + auto with cps.
    + assumption.
    + congruence.
Qed.

(* Huh, this is a mess. TODO: Clean up this file please. *)

Definition arities: Set :=
  list (option nat).

Inductive regular: arities -> redexes -> Prop :=
  | regular_type:
    forall g,
    regular g (redexes_type)
  | regular_prop:
    forall g,
    regular g (redexes_prop)
  | regular_base:
    forall g,
    regular g (redexes_base)
  | regular_void:
    forall g,
    regular g (redexes_void)
  | regular_bound:
    forall g n,
    regular g (redexes_bound n)
  | regular_negation:
    forall g ts,
    regular g (redexes_negation ts)
  | regular_jump:
    forall g n xs,
    regular g (redexes_jump false n xs)
  | regular_mark:
    forall g a n xs,
    item (Some a) g n ->
    a = length xs ->
    regular g (redexes_jump true n xs)
  | regular_placeholder:
    forall g a n xs,
    item (Some a) g n ->
    a = length xs ->
    regular g (redexes_placeholder n xs)
  | regular_bind:
    forall g b ts c,
    regular (Some (length ts) :: g) b ->
    regular (repeat None (length ts) ++ g) c ->
    regular g (redexes_bind b ts c).

Global Hint Constructors regular: cps.

Lemma regular_tail:
  forall g1 e,
  regular g1 e ->
  forall g2,
  regular (g1 ++ g2) e.
Proof.
  induction 1; intros.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - econstructor; eauto.
    apply item_insert_tail; auto.
  - econstructor; eauto.
    apply item_insert_tail; auto.
  - constructor.
    + simpl in IHregular1; auto.
    + rewrite app_assoc; auto.
Qed.

Lemma regular_mark_term:
  forall g e,
  regular g (mark e).
Proof.
  intros.
  replace g with ([] ++ g); auto.
  apply regular_tail.
  induction e; simpl; auto with cps.
  constructor.
  + eapply regular_tail in IHe1; eauto.
  + eapply regular_tail in IHe2; eauto.
Qed.

Global Hint Resolve regular_mark_term: cps.

Lemma regular_single_jump:
  forall h g xs,
  regular (g ++ [Some (length xs)])
    (mark_context h (redexes_jump true (length g + #h) xs)).
Proof.
  induction h; simpl; intros.
  - rewrite Nat.add_comm.
    econstructor; eauto.
    apply item_insert_head.
    constructor.
  - constructor.
    + rewrite app_comm_cons.
      rewrite Nat.add_succ_r.
      apply IHh.
    + apply regular_mark_term.
  - constructor.
    + apply regular_mark_term.
    + rewrite app_assoc.
      replace (length g + (#h + length ts)) with
        (length (repeat None (length ts) ++ g) + #h).
      * apply IHh.
      * rewrite app_length.
        rewrite repeat_length.
        lia.
Qed.

Fixpoint redexes_context_bvars h: nat :=
  match h with
  | redexes_context_hole =>
    0
  | redexes_context_left b _ _ =>
    S (redexes_context_bvars b)
  | redexes_context_right _ ts c =>
    redexes_context_bvars c + length ts
  end.

Lemma regular_cant_jump_too_far:
  forall n h g,
  n = length g + redexes_context_bvars h ->
  forall xs,
  ~regular g (h (redexes_jump true n xs)).
Proof.
  induction h; simpl; intros.
  - intro.
    dependent destruction H0.
    assert (n < length g).
    + eapply item_valid_index.
      eassumption.
    + lia.
  - intro.
    dependent destruction H0.
    eapply IHh; eauto; simpl.
    lia.
  - intro.
    dependent destruction H0.
    eapply IHh; eauto.
    rewrite app_length.
    rewrite repeat_length.
    lia.
Qed.

Lemma residuals_preserve_regular:
  forall a b c,
  residuals a b c ->
  forall g,
  regular g a -> regular g b -> regular g c.
Proof.
  induction 1; intros.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - dependent destruction H0.
    econstructor; eauto.
  - assumption.
  - dependent destruction H1.
    dependent destruction H2.
    constructor; auto.
Qed.

Global Hint Resolve residuals_preserve_regular: cps.

Lemma redexes_flow_regular_simplification:
  forall g x,
  regular g x ->
  forall c a k,
  k >= length g ->
  redexes_flow c a k x = x.
Proof.
  induction 1; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - assert (n < length g).
    + eapply item_valid_index.
      eassumption.
    + destruct (Nat.eq_dec n k); try lia.
      reflexivity.
  - f_equal.
    + apply IHregular1; simpl.
      lia.
    + apply IHregular2; simpl.
      rewrite app_length, repeat_length.
      lia.
Qed.

Lemma redexes_flow_preserve_regular:
  forall a g b h,
  regular (h ++ Some a :: g) b ->
  forall c,
  regular (repeat None a ++ g) c ->
  forall k,
  k = length h ->
  regular (h ++ Some a :: g) (redexes_flow c a k b).
Proof.
  induction b; simpl; intros.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - destruct f; auto.
    destruct (Nat.eq_dec n k); auto.
    destruct (Nat.eq_dec a (length xs)); auto.
    dependent destruction H.
    (* Aw crap, this must be true but it'll be annoying to prove. *)
    admit.
  - dependent destruction H.
    constructor.
    + rewrite app_comm_cons.
      apply IHb1; simpl; auto.
    + rewrite app_assoc.
      apply IHb2.
      * rewrite <- app_assoc.
        assumption.
      * assumption.
      * rewrite app_length, repeat_length.
        lia.
Admitted.

Lemma redexes_full_preserves_regular:
  forall g x,
  regular g x ->
  regular g (redexes_full x).
Proof.
  induction 1; simpl.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - econstructor; eauto.
  - econstructor; eauto.
  - constructor.
    + apply redexes_flow_preserve_regular with (h := []); auto.
    + assumption.
Qed.

Global Hint Resolve redexes_full_preserves_regular: cps.

(* -------------------------------------------------------------------------- *)
(* TODO: organize this file. So far, everything above is used to prove that   *)
(* parallel includes step. Everything below is needed to prove that star      *)
(* includes parallel. There might be a few unused lemmas I forgot to remove.  *)
(* -------------------------------------------------------------------------- *)

Fixpoint redexes_mark_count k r: nat :=
  match r with
  | redexes_jump true (bound n) _ =>
    if Nat.eq_dec k n then
      1
    else
      0
  | redexes_placeholder (bound n) _ =>
    if Nat.eq_dec k n then
      1
    else
      0
  | redexes_bind b ts c =>
    redexes_mark_count (S k) b + redexes_mark_count (k + length ts) c
  | _ =>
    0
  end.

Fixpoint redexes_mark_count_total r: nat :=
  match r with
  | redexes_jump true f xs =>
    1
  | redexes_placeholder f xs =>
    1
  | redexes_bind b ts c =>
    redexes_mark_count_total b + redexes_mark_count_total c
  | _ =>
    0
  end.

Lemma redexes_structural_mark_ind:
  forall P: redexes -> Prop,
  forall f1: (P redexes_type),
  forall f2: (P redexes_prop),
  forall f3: (P redexes_base),
  forall f4: (P redexes_void),
  forall f5: (forall n, P (redexes_bound n)),
  forall f6: (forall ts, P (redexes_negation ts)),
  forall f7: (forall r f xs, P (redexes_jump r f xs)),
  forall f8: (forall f xs, P (redexes_placeholder f xs)),
  forall f9: (forall b,
              P b ->
              forall ts c,
              P c ->
              (forall x,
               redexes_mark_count_total x <
                 redexes_mark_count_total (redexes_bind b ts c) ->
               P x) -> P (redexes_bind b ts c)),
  forall r, P r.
Proof.
  intros.
  assert (exists n, n >= redexes_mark_count_total r) as (n, ?); eauto.
  generalize dependent r.
  induction n using lt_wf_ind.
  induction r; intros.
  - apply f1.
  - apply f2.
  - apply f3.
  - apply f4.
  - apply f5.
  - apply f6.
  - apply f7.
  - apply f8.
  - simpl in H0.
    apply f9; intros.
    + apply IHr1; lia.
    + apply IHr2; lia.
    + simpl in H1.
      apply H with (redexes_mark_count_total x); lia.
Qed.

Lemma regular_ignore_unused_tail:
  forall e a g,
  regular (g ++ repeat None a) e ->
  regular g e.
Proof.
  induction e; intros.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - destruct r.
    + dependent destruction H.
      econstructor; eauto.
      destruct (le_gt_dec (length g) n).
      * exfalso.
        apply item_ignore_head in H; auto.
        apply item_repeat in H.
        discriminate.
      * eapply item_ignore_tail; auto.
        eauto.
    + constructor.
  - dependent destruction H.
    econstructor; eauto.
    destruct (le_gt_dec (length g) n).
    + exfalso.
      apply item_ignore_head in H; auto.
      apply item_repeat in H.
      discriminate.
    + eapply item_ignore_tail; auto.
      eauto.
  - dependent destruction H; constructor.
    + eapply IHe1; eauto.
    + rewrite app_assoc in H0.
      eapply IHe2; eauto.
Qed.

Lemma redexes_flow_ignore_unused_mark:
  forall e1 k,
  redexes_mark_count k e1 = 0 ->
  forall c a e2,
  redexes_flow c a k e1 = e2 ->
  e1 = e2.
Proof.
  induction e1; simpl; intros.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - destruct f; auto.
    destruct (Nat.eq_dec k n); try lia.
    destruct (Nat.eq_dec n k); try lia.
    assumption.
  - destruct e2; try discriminate.
    dependent destruction H0.
    f_equal.
    + eapply IHe1_1; eauto.
      lia.
    + eapply IHe1_2; eauto.
      lia.
Qed.

Lemma regular_ignore_unmarked_tail:
  forall a e g,
  regular (g ++ [Some a]) e ->
  redexes_mark_count (length g) e = 0 ->
  regular g e.
Proof.
  induction e; intros.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - constructor.
  - destruct r.
    + simpl in H0.
      dependent destruction H.
      destruct (Nat.eq_dec (length g) n); try lia.
      econstructor; eauto.
      assert (n < length (g ++ [Some a])).
      * eapply item_valid_index; eauto.
      * rewrite app_length in H1; simpl in H1.
        eapply item_ignore_tail; try lia.
        eassumption.
    + constructor.
  - simpl in H0.
    dependent destruction H.
    destruct (Nat.eq_dec (length g) n); try lia.
    econstructor; eauto.
    assert (n < length (g ++ [Some a])).
    + eapply item_valid_index; eauto.
    + rewrite app_length in H1; simpl in H1.
      eapply item_ignore_tail; try lia.
      eassumption.
  - simpl in H0.
    dependent destruction H.
    constructor.
    + rewrite app_comm_cons in H.
      apply IHe1; auto.
      simpl; lia.
    + rewrite app_assoc in H0.
      apply IHe2; auto.
      rewrite app_length.
      rewrite repeat_length.
      rewrite Nat.add_comm; lia.
Qed.

(*
Lemma residuals_preserve_no_mark:
  forall a b c,
  residuals a b c ->
  forall k,
  redexes_mark_count k a = 0 ->
  redexes_mark_count k b = 0 ->
  redexes_mark_count k c = 0.
Proof.
  induction 1; intros.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - assumption.
  - simpl in H1, H2 |- *.
    replace (redexes_mark_count (S k) b3) with 0; simpl.
    + apply IHresiduals2; lia.
    + symmetry.
      apply IHresiduals1; lia.
Qed.
*)

Lemma redexes_mark_leaves_unmarked:
  forall e k,
  redexes_mark_count k (mark e) = 0.
Proof.
  induction e; simpl; intros; auto.
  replace (redexes_mark_count (S k) (mark e1)) with 0; simpl.
  - apply IHe2.
  - symmetry.
    apply IHe1.
Qed.

Lemma regular_doesnt_jump_to_free_vars:
  forall e g,
  regular g e ->
  forall k,
  k >= length g ->
  redexes_mark_count k e = 0.
Proof.
  induction e; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - destruct r; auto.
    destruct f; auto.
    destruct (Nat.eq_dec k n); auto.
    exfalso.
    dependent induction H.
    assert (n < length g).
    + eapply item_valid_index; eauto.
    + lia.
  - destruct f; auto.
    destruct (Nat.eq_dec k n); auto.
    exfalso.
    dependent induction H.
    assert (n < length g).
    + eapply item_valid_index; eauto.
    + lia.
  - dependent destruction H.
    replace (redexes_mark_count (S k) e1) with 0; simpl.
    + eapply IHe2; eauto.
      rewrite app_length.
      rewrite repeat_length.
      lia.
    + symmetry.
      eapply IHe1; eauto.
      simpl; lia.
Qed.

Lemma residuals_partial_full_application:
  forall y,
  regular [] y ->
  forall x,
  regular [] x ->
  forall z,
  residuals_full x y z ->
  residuals_full (redexes_full x) (redexes_full y) z.
Proof.
  (* Hmm... *)
  admit.
Admitted.

Lemma positive_mark_count_implies_context:
  forall a b c,
  residuals (mark a) b c ->
  forall k,
  redexes_mark_count k b > 0 ->
  exists h r xs,
  redexes_same_path (mark_context h) r /\
    a = h (jump (k + #h) xs) /\
    b = r (redexes_jump true (k + #h) xs).
Proof.
  intros until 1.
  dependent induction H; simpl; intros.
  - exfalso; lia.
  - exfalso; lia.
  - exfalso; lia.
  - exfalso; lia.
  - exfalso; lia.
  - exfalso; lia.
  - exfalso; lia.
  - destruct a; try discriminate.
    dependent destruction x.
    destruct a; try lia.
    destruct (Nat.eq_dec k0 n); try lia.
    exists context_hole; simpl.
    rewrite Nat.add_0_r; destruct e.
    exists redexes_context_hole, xs0; eauto with cps.
  - exfalso.
    destruct a; discriminate.
  - destruct a; try discriminate.
    dependent destruction x.
    destruct (Nat.eq_dec (redexes_mark_count (k + length ts0) c2) 0).
    + clear IHresiduals2.
      edestruct IHresiduals1 with (k := S k); auto; try lia.
      destruct H2 as (r, (xs, (?, (?, ?)))).
      eexists (context_left _ _ _); simpl.
      eexists; eexists; simpl.
      split; [ | split ].
      * constructor; eauto.
      * f_equal.
        replace (k + S #x) with (S k + #x); try lia.
        eassumption.
      * simpl; f_equal.
        replace (k + S #x) with (S k + #x); try lia.
        assumption.
    + clear IHresiduals1.
      edestruct IHresiduals2 with (k := k + length ts0); auto; try lia.
      destruct H2 as (r, (xs, (?, (?, ?)))).
      eexists (context_right _ _ _); simpl.
      eexists; eexists; simpl.
      split; [ | split ].
      * constructor; eauto.
      * f_equal.
        replace (k + (#x + length ts0)) with (k + length ts0 + #x); try lia.
        eassumption.
      * simpl; f_equal.
        replace (k + (#x + length ts0)) with (k + length ts0 + #x); try lia.
        assumption.
Qed.

(*
Lemma redexes_mark_count_replacing_mark:
  forall (h: redexes_context) k xs n,
  redexes_mark_count k (h (redexes_jump true
    (k + redexes_context_bvars h) xs)) = 1 + n ->
  forall e m,
  redexes_mark_count (k + redexes_context_bvars h) e = m ->
  redexes_mark_count k (h e) = m + n.
Proof.
  induction h; simpl; intros.
  - rewrite Nat.add_0_r in H, H0.
    destruct (Nat.eq_dec k k); lia.
  - remember (h (redexes_jump true (k + S (redexes_context_bvars h)) xs)) as b.
    assert (exists o, redexes_mark_count (S k) b = S o) as (o, ?).
    + admit.
    + replace (redexes_mark_count (k + length ts) c) with (n - o); try lia.
      assert (redexes_mark_count (S k) (h e) = m + o).
      * rewrite <- Nat.add_succ_r in Heqb, H0.
        dependent destruction Heqb.
        eapply IHh; eauto.
      * lia.
  - remember (h (redexes_jump true
      (k + (redexes_context_bvars h + length ts)) xs)) as c.
    assert (exists o, redexes_mark_count (k + length ts) c = S o) as (o, ?).
    + admit.
    + replace (redexes_mark_count (S k) b) with (n - o); try lia.
      assert (redexes_mark_count (k + length ts) (h e) = m + o).
      * replace (k + (redexes_context_bvars h + length ts)) with
          (k + length ts + redexes_context_bvars h) in Heqc, H0; try lia.
        dependent destruction Heqc.
        eapply IHh; eauto.
      * lia.
Admitted.

Lemma redexes_mark_count_total_zero_implies_count_zero:
  forall e,
  redexes_mark_count_total e = 0 ->
  forall k,
  redexes_mark_count k e = 0.
Proof.
  induction e; simpl; intros.
  - reflexivity.
  - destruct r; auto.
    destruct f; auto.
    discriminate.
  - destruct f; auto.
    discriminate.
  - replace (redexes_mark_count (S k) e1) with 0; simpl.
    + apply IHe2; lia.
    + symmetry.
      apply IHe1; lia.
Qed.
*)

Lemma redexes_mark_count_total_lt_context:
  forall a b,
  redexes_mark_count_total a < redexes_mark_count_total b ->
  forall h: redexes_context,
  redexes_mark_count_total (h a) < redexes_mark_count_total (h b).
Proof.
  induction h; simpl; intros.
  - assumption.
  - lia.
  - lia.
Qed.

Lemma redexes_mark_count_total_mark_is_zero:
  forall e,
  redexes_mark_count_total (mark e) = 0.
Proof.
  induction e; simpl; lia.
Qed.

Lemma residuals_replacing_hole:
  forall h s,
  redexes_same_path h s ->
  forall t,
  redexes_same_path h t ->
  forall a b c,
  residuals (h a) (s b) (t c) ->
  forall x y z,
  residuals x y z ->
  residuals (h x) (s y) (t z).
Proof.
  induction 1; intros.
  - dependent destruction H; simpl.
    assumption.
  - dependent destruction H1.
    dependent destruction H3; simpl; constructor.
    + eapply IHredexes_same_path; eauto.
    + assumption.
  - dependent destruction H1.
    dependent destruction H3; simpl; constructor.
    + assumption.
    + eapply IHredexes_same_path; eauto.
Qed.

Lemma regular_jump_imply_correct_arity:
  forall (h: redexes_context) g a n xs,
  regular (g ++ [Some a]) (h (redexes_jump true n xs)) ->
  n = length g + redexes_context_bvars h ->
  length xs = a.
Proof.
  induction h; simpl; intros.
  - dependent destruction H.
    dependent destruction H0.
    apply item_ignore_head in H; try lia.
    replace (length g + 0 - length g) with 0 in H; try lia.
    dependent destruction H.
    reflexivity.
  - dependent destruction H.
    rewrite app_comm_cons in H.
    eapply IHh; eauto; simpl.
    dependent destruction H1.
    f_equal; lia.
  - dependent destruction H.
    rewrite app_assoc in H0.
    eapply IHh; eauto; simpl.
    dependent destruction H1.
    rewrite app_length.
    rewrite repeat_length.
    f_equal; lia.
Qed.

Lemma mark_context_bvars_and_path_are_sound:
  forall h s,
  redexes_same_path (mark_context h) s ->
  #h = redexes_context_bvars s.
Proof.
  intros.
  dependent induction H; simpl.
  - destruct h; try discriminate; auto.
  - destruct h; try discriminate; simpl.
    dependent destruction x; auto.
  - destruct h; try discriminate; simpl.
    dependent destruction x; auto.
Qed.

Lemma regular_preserved_replacing_jump_by_mark:
  forall (h: redexes_context) g a n xs,
  regular (g ++ [Some a]) (h (redexes_jump true n xs)) ->
  n = length g + redexes_context_bvars h ->
  forall e,
  regular (g ++ [Some a]) (h (mark e)).
Proof.
  induction h; simpl; intros.
  - apply regular_mark_term.
  - dependent destruction H.
    constructor; auto.
    rewrite app_comm_cons in H |- *.
    eapply IHh; eauto.
    dependent destruction H1; f_equal.
    simpl; lia.
  - dependent destruction H.
    constructor; auto.
    rewrite app_assoc in H0 |- *.
    eapply IHh; eauto.
    dependent destruction H1; f_equal.
    rewrite app_length.
    rewrite repeat_length.
    lia.
Qed.

(* In fact this could be generalized by any regular [] y, instead of simply
   having no marks. But I don't think we'll need that. *)

Lemma redexes_flow_preserved_by_single_unmarked_jump:
  forall h k n,
  n = k + redexes_context_bvars h ->
  forall y xs e,
  redexes_flow (mark y) (length xs) k
    (redexes_full (h (redexes_placeholder n xs))) = e ->
  redexes_flow (mark y) (length xs) k
    (redexes_full (h (mark (apply_parameters xs 0
      (lift (S n) (length xs) y))))) = e.
Proof.
  induction h; simpl; intros.
  - destruct (Nat.eq_dec n k); try lia.
    destruct (Nat.eq_dec (length xs) (length xs)); try lia.
    rewrite redexes_full_mark_equals_mark.
    rewrite redexes_flow_mark_equals_mark.
    rewrite <- redexes_apply_parameters_is_sound.
    rewrite <- redexes_lift_is_sound.
    assumption.
  - dependent destruction H0.
    f_equal.
    do 2 rewrite redexes_flow_commute.
    f_equal.
    apply IHh; auto.
    lia.
  - dependent destruction H0.
    f_equal.
    + do 2 rewrite redexes_flow_commute.
      f_equal.
      apply IHh; auto.
      lia.
    + apply IHh; auto.
      lia.
Qed.

(* -------------------------------------------------------------------------- *)

Lemma mark_unmark_is_sound_given_no_marks:
  forall e,
  redexes_mark_count_total e = 0 ->
  e = mark (unmark e).
Proof.
  induction e; simpl; intros.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - destruct r.
    + discriminate.
    + reflexivity.
  - discriminate.
  - rewrite <- IHe1; try lia.
    rewrite <- IHe2; try lia.
    reflexivity.
Qed.

Lemma residuals_full_preserve_no_mark:
  forall b,
  regular [] b ->
  forall a,
  redexes_mark_count_total a = 0 ->
  forall c,
  residuals_full a b c ->
  redexes_mark_count_total c = 0.
Proof.
  intros.
  destruct H1 as (c', ?, ?).
  (* Hmm, by the structure and number of marks in b? *)
  admit.
Admitted.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Setoid_ring.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Export Setoid_ring_theory.
Require Export Quote.
Require Export Setoid_ring_normalize.
Declare ML Module "ring_plugin".


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.

From Paco Require Import paco paco2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import MPST.Common.
Require Import MPST.Global.Tree.

Definition R_only (R : ig_ty -> ig_ty -> Prop)
           L0 (C C' : lbl -> option (mty * ig_ty)) :=
  (forall L1 K, L0 != L1 -> C L1 = Some K <-> C' L1 = Some K)
  /\ exists Ty G0 G1,
    C L0 = Some (Ty, G0)
    /\ C' L0 = Some (Ty, G1)
    /\ R G0 G1.

Unset Elimination Schemes.
Inductive step : act -> ig_ty -> ig_ty -> Prop :=
(* Basic rules *)
| st_send L F T C Ty G :
    C L = Some (Ty, G) ->
    step (mk_act l_send F T L Ty) (ig_msg None F T C) (ig_msg (Some L) F T C)
| st_recv L F T C Ty G :
    C L = Some (Ty, G) ->
    step (mk_act l_recv T F L Ty) (ig_msg (Some L) F T C) G
(* Struct *)
| st_amsg1 a L F T C0 C1 :
    subject a != F ->
    subject a != T ->
    (exists Ty G, C0 L = Some (Ty, G)) ->
    same_dom C0 C1 ->
    R_all (step a) C0 C1 ->
    step a (ig_msg None F T C0) (ig_msg None F T C1)
| st_amsg2 a L F T C0 C1 :
    subject a != T ->
    same_dom C0 C1 ->
    R_only (step a) L C0 C1 ->
    step a (ig_msg (Some L) F T C0) (ig_msg (Some L) F T C1)
| st_unr a CG G :
    step a (rg_unr CG) G ->
    step a (ig_end CG) G
.
Set Elimination Schemes.

Derive Inversion step_inv with (forall a G G', step a G G') Sort Prop.

Scheme step_ind1 := Induction for step Sort Prop.

Lemma step_ind
  (P : forall (a : act) (i i0 : ig_ty), step a i i0 -> Prop):
  (forall L F T C Ty G (e: C L = Some (Ty, G)),
    P (mk_act l_send F T L Ty) (ig_msg None F T C) (ig_msg (Some L) F T C)
      (st_send F T e) )
  ->
  (forall L F T C Ty G (e: C L = Some (Ty, G)),
    P (mk_act l_recv T F L Ty) (ig_msg (Some L) F T C) G (st_recv F T e))
  ->
  (forall a L F T C0 C1 (i : subject a != F) (i0 : subject a != T)
        (ne : exists Ty G, C0 L = Some (Ty, G))
        (s : same_dom C0 C1) (r : R_all (step a) C0 C1),
      (forall (L : lbl) (Ty : mty) (G G' : ig_ty)
         (e : C0 L = Some (Ty, G)) (e0 : C1 L = Some (Ty, G')),
       P a G G' (r L Ty G G' e e0)) ->
      P a (ig_msg None F T C0) (ig_msg None F T C1) (st_amsg1 i i0  ne s r))
  ->
  (*new property, mirroring R_only...*)
  (forall (a : act) (L : lbl) (F T : role)
        (C0 C1 : lbl -> option (mty * ig_ty)) (i : subject a != T)
        (s : same_dom C0 C1) (r : R_only (step a) L C0 C1),
    ((forall (L' : lbl) (K : mty * ig_ty),
    L != L' -> C0 L' = Some K <-> C1 L' = Some K) /\
    (exists (Ty : mty) (G0 G1 : ig_ty),
    C0 L = Some (Ty, G0) /\ C1 L = Some (Ty, G1)
    /\ (exists (r: step a G0 G1), P a G0 G1 r)))
    ->
    (*... with dependent types*)
    P a (ig_msg (Some L) F T C0) (ig_msg (Some L) F T C1)
        (st_amsg2 F i s r))
    ->
   (forall (a : act) (CG : rg_ty) (G : ig_ty) (s : step a (rg_unr CG) G),
      P a (rg_unr CG) G s -> P a (ig_end CG) G (st_unr s))
-> forall (a : act) (i i0 : ig_ty) (s : step a i i0), P a i i0 s.
Proof.
move=> P_send P_recv P_amsg1 P_amsg2 P_unr; fix Ih 4.
move=> a G G'; case; [by[]|by[]| | | ].
+ move=> a0 L F T C0 C1 nF nT NE samed rall.
  by apply: P_amsg1 =>//=.
+ move=> a0 L F T C0 C1 nT samed ronly.
  apply: P_amsg2 =>//=; split.
  - by move: ronly; rewrite /R_only; elim=> hp _.
  - move: ronly; rewrite /R_only; elim=> hp.
    elim=> Ty; elim=> G0; elim=> G1; elim=> C0L; elim=> C1L r.
    exists Ty, G0, G1; split; [by[]|split; [by[]| exists r]].
    by apply Ih.
+ move=> a0 CG G0 s; apply: P_unr =>//=.
Qed.

Definition gtrc_rel := trace act -> ig_ty -> Prop.
Inductive g_lts_ (r : gtrc_rel) : gtrc_rel :=
| eg_end : @g_lts_ r (tr_end act) (ig_end rg_end)
| eg_trans a t G G' :
    step a G G' ->
    r t G' ->
    g_lts_ r (tr_next a t) G.
Hint Constructors g_lts_.
Definition g_lts t g := paco2 g_lts_ bot2 t g.

Lemma g_lts_monotone : monotone2 g_lts_.
Proof. pmonauto. Qed.
Hint Resolve g_lts_monotone : paco.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal32.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq lst (rotate (len x) (append (append x y) (Cons n Nil)))
  (append y (Cons n x)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_smallclam_lf_goal32_rotate_len_append_51_append_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


Require Import POCS.
Require Import TwoDisk.TwoDiskAPI.

(** Hoare-style specifications for the TwoDisk primitives.

These specifications are written in a stylized manner using the notation from
MaybeHolds. The preconditions relate both disks to the provided ghost state, and
then the postconditions are expressed entirely in terms of ghost state. This
style of specification automates well, easily carrying forward information in
proofs across several operations.

These proofs should completely specify the behavior of the TwoDisk operations,
in that any step the primitives could do can be expressed using these
specifications. The proofs of course guarantee that the primitives follow the
specifications here, but there is a possibility that the specifications are more
restrictive. While we have tried to avoid doing so, we do not prove completeness
below.
 *)

(* help out type inference *)
Implicit Type (state:TD.State).

Theorem maybe_holds_stable : forall state state' F0 F1,
    TD.disk0 state ?|= F0 ->
    TD.disk1 state ?|= F1 ->
    TD.bg_failure state state' ->
    TD.disk0 state' ?|= F0 /\
    TD.disk1 state' ?|= F1.
Proof.
  intros.
  TD.inv_bg; simpl in *; eauto.
Qed.

Ltac cleanup :=
  repeat match goal with
         | [ |- forall _, _ ] => intros
         | |- _ /\ _ => split; [ solve [ eauto || congruence ] | ]
         | |- _ /\ _ => split; [ | solve [ eauto || congruence ] ]
         | [ H: Working _ = Working _ |- _ ] => inversion H; subst; clear H
         | [ H: TD.bg_failure _ _ |- _ ] =>
           eapply maybe_holds_stable in H;
           [ | solve [ eauto ] | solve [ eauto ] ]; destruct_ands
         | [ H: _ ?|= eq _, H': _ = Some _ |- _ ] =>
                  pose proof (holds_some_inv_eq _ H' H); clear H
         | _ => deex
         | _ => destruct_tuple
         | _ => progress unfold pre_step in *
         | _ => progress unfold TD.wipe in *
         | _ => progress simpl in *
         | _ => progress subst
         | _ => progress safe_intuition
         | _ => solve [ eauto ]
         | _ => congruence
         end.

Ltac prim :=
  intros; eapply prim_spec; cleanup;
  try TD.inv_step;
  try solve [ destruct matches in *; cleanup ].

Hint Resolve holds_in_some_eq.
Hint Resolve holds_in_none_eq.
Hint Resolve pred_missing.

Theorem TDRead0_ok : forall (i: Interface TD.API) a,
    prog_spec
      (fun '(d_0, F) state =>
         {|
           pre := TD.disk0 state ?|= eq d_0 /\
                  TD.disk1 state ?|= F;
           post :=
             fun r state' =>
               match r with
               | Working v => TD.disk0 state' ?|= eq d_0 /\
                              TD.disk1 state' ?|= F /\
                              d_0 a ?|= eq v
               | Failed => TD.disk0 state' ?|= missing /\
                           TD.disk1 state' ?|= F
               end;
           recover :=
             fun _ state' => TD.disk0 state' ?|= eq d_0 /\
                             TD.disk1 state' ?|= F;
         |})
      (Prim i (TD.Read d0 a))
      (irec i)
      (interface_abs i).
Proof.
  prim.
Qed.

Theorem TDRead1_ok : forall (i: Interface TD.API) a,
    prog_spec
      (fun '(F, d_1) state =>
         {|
           pre := TD.disk0 state ?|= F /\
                  TD.disk1 state ?|= eq d_1;
           post :=
             fun r state' =>
               match r with
               | Working v => TD.disk0 state' ?|= F /\
                              TD.disk1 state' ?|= eq d_1 /\
                              d_1 a ?|= eq v
               | Failed => TD.disk0 state' ?|= F /\
                           TD.disk1 state' ?|= missing
               end;
           recover :=
             fun _ state' => TD.disk0 state' ?|= F /\
                             TD.disk1 state' ?|= eq d_1;
         |})
      (Prim i (TD.Read d1 a))
      (irec i)
      (interface_abs i).
Proof.
  prim.
Qed.

Theorem TDWrite0_ok : forall (i: Interface TD.API) a b,
    prog_spec
      (fun '(d_0, F) state =>
         {|
           pre := TD.disk0 state ?|= eq d_0 /\
                  TD.disk1 state ?|= F;
           post :=
             fun r state' =>
               match r with
               | Working _ => TD.disk0 state' ?|= eq (diskUpd d_0 a b) /\
                              TD.disk1 state' ?|= F
               | Failed => TD.disk0 state' ?|= missing /\
                           TD.disk1 state' ?|= F
               end;
           recover :=
             fun _ state' =>
               (TD.disk0 state' ?|= eq d_0 \/
                a < size d_0 /\ TD.disk0 state' ?|= eq (diskUpd d_0 a b)) /\
               TD.disk1 state' ?|= F;
         |})
      (Prim i (TD.Write d0 a b))
      (irec i)
      (interface_abs i).
Proof.
  prim.

  destruct matches in *; cleanup.

  match goal with
  | |- context[diskUpd ?d_0 _ _] =>
    destruct (lt_dec a (size d_0));
      autorewrite with upd in *;
      eauto
  end.
Qed.

Theorem TDWrite1_ok : forall (i: Interface TD.API) a b,
    prog_spec
      (fun '(F, d_1) state =>
         {|
           pre := TD.disk0 state ?|= F /\
                  TD.disk1 state ?|= eq d_1;
           post :=
             fun r state' =>
               match r with
               | Working _ => TD.disk0 state' ?|= F /\
                              TD.disk1 state' ?|= eq (diskUpd d_1 a b)
               | Failed => TD.disk0 state' ?|= F /\
                           TD.disk1 state' ?|= missing
               end;
           recover :=
             fun _ state' =>
               TD.disk0 state' ?|= F /\
               (TD.disk1 state' ?|= eq d_1 \/
                a < size d_1 /\ TD.disk1 state' ?|= eq (diskUpd d_1 a b));
         |})
      (Prim i (TD.Write d1 a b))
      (irec i)
      (interface_abs i).
Proof.
  prim.

  destruct matches in *; cleanup.
  match goal with
  | |- context[diskUpd ?d_1 _ _] =>
    destruct (lt_dec a (size d_1));
      autorewrite with upd in *;
      eauto
  end.
Qed.

Theorem TDDiskSize0_ok : forall (i: Interface TD.API),
    prog_spec
      (fun '(d_0, F) state =>
         {|
           pre := TD.disk0 state ?|= eq d_0 /\
                  TD.disk1 state ?|= F;
           post :=
             fun r state' =>
               match r with
               | Working n => n = size d_0 /\
                              TD.disk0 state' ?|= eq d_0 /\
                              TD.disk1 state' ?|= F
               | Failed => TD.disk0 state' ?|= missing /\
                           TD.disk1 state' ?|= F
               end;
           recover :=
             fun _ state' =>
               TD.disk0 state' ?|= eq d_0 /\
               TD.disk1 state' ?|= F;
         |})
      (Prim i (TD.DiskSize d0))
      (irec i)
      (interface_abs i).
Proof.
  prim.
Qed.

Theorem TDDiskSize1_ok : forall (i: Interface TD.API),
    prog_spec
      (fun '(F, d_1) state =>
         {|
           pre := TD.disk0 state ?|= F /\
                  TD.disk1 state ?|= eq d_1;
           post :=
             fun r state' =>
               match r with
               | Working n => n = size d_1 /\
                              TD.disk0 state' ?|= F /\
                              TD.disk1 state' ?|= eq d_1
               | Failed => TD.disk0 state' ?|= F /\
                           TD.disk1 state' ?|= missing
               end;
           recover :=
             fun _ state' =>
               TD.disk0 state' ?|= F /\
               TD.disk1 state' ?|= eq d_1;
         |})
      (Prim i (TD.DiskSize d1))
      (irec i)
      (interface_abs i).
Proof.
  prim.
Qed.

Hint Resolve
     TDRead0_ok
     TDRead1_ok
     TDWrite0_ok
     TDWrite1_ok
     TDDiskSize0_ok
     TDDiskSize1_ok.


Set Implicit Arguments.

#[export] Hint Extern 4 => exact _ : core.

Ltac inv H := inversion H; subst; clear H.

Definition dec (X: Prop) : Type := {X} + {~ X}.

Coercion dec2bool P (d: dec P) := if d then true else false.
Definition is_true (b : bool) := b = true.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  is_true (Dec X) <-> X.
Proof.
  destruct d as [A|A]; cbv in *; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> is_true (Dec X).
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

(* Lemma Dec_auto_not (X: Prop) (d: dec X) : *)
(*   ~ X -> ~ Dec X. *)
(* Proof. *)
(*   destruct d as [A|A]; cbn; tauto. *)
(* Qed. *)

(* Hint Resolve Dec_auto Dec_auto_not : core. *)
#[export] Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  decide P; cbv in *; firstorder.
  congruence.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  decide P; cbv in *; firstorder.
  congruence.
Qed.

#[export] Hint Extern 4 =>
match goal with
  [ H : dec2bool (Dec ?P) = true  |- _ ] => apply Dec_true in  H
| [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_false in H
end : core.

(* Decided propositions behave classically *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

(* Propagation rules for decisions *)

Fact dec_transfer P Q :
  P <-> Q -> dec P -> dec Q.
Proof.
  unfold dec. tauto.
Qed.

#[global]
Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Qed.

#[global]
Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Qed.

#[global]
Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Qed.

#[global]
Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Qed.

#[global]
Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Qed.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

#[global]
Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. auto.
Qed.

#[global]
Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. auto.
Qed.

(* Discrete types *)

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

#[global]
Existing Instance eqType_dec.

#[global]
Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold dec. decide equality.
Qed.

#[global]
Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold dec. decide equality.
Defined.

#[global]
Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold dec. decide equality.
Qed.

#[global]
Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Qed.

#[global]
Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Qed.