From RecoveryRefinement Require Import Lib.
Require Export Maybe.
Require Export Disk.
Require Import TwoDiskAPI.

Import RelationNotations.
Import TwoDisk.
Import Helpers.RelationAlgebra.
Import RelationNotations.

Section specs.

  (** Simple wrapper specs that just capture the exact semantics of the operations.
     We use these exclusively in this file to prove higher level specs below. *)
  Lemma read_op_ok :
    forall i a,
      proc_hspec TDBaseDynamics (td.read i a) (op_spec TDBaseDynamics (op_read i a)).
  Proof. intros. eapply op_spec_sound. Qed.

  Lemma write_op_ok :
    forall i a b,
      proc_hspec TDBaseDynamics (td.write i a b) (op_spec TDBaseDynamics (op_write i a b)).
  Proof. intros. eapply op_spec_sound. Qed.

  Lemma size_op_ok :
    forall i,
      proc_hspec TDBaseDynamics (td.size i) (op_spec TDBaseDynamics (op_size i)).
  Proof. intros. eapply op_spec_sound. Qed.

  Hint Resolve read_op_ok : core.
  Hint Resolve write_op_ok : core.
  Hint Resolve size_op_ok : core.

  (** We now define easier-to-use specifications written in terms of
  [maybe_holds] (the ?|= notation) for the TwoDisk layer.  The fact that at least
  one disk is always functioning is encoded in the inductive type
  [TwoDiskBaseAPI.State] itself; it has only three cases, for both disks, only
  disk 0, and only disk 1.  *)

  Definition other (i : diskId) :=
    match i with
    | d0 => d1
    | d1 => d0
    end.

  Definition read_spec (i : diskId) (a : addr) : _ -> Specification _ (unit) State :=
    fun '(d, F) state => {|
      pre :=
        get_disk i         state ?|= eq d /\
        get_disk (other i) state ?|= F;
      post := fun state' r =>
        match r with
        | Working v =>
          get_disk i         state' ?|= eq d /\
          get_disk (other i) state' ?|= F /\
          index d a ?|= eq v
        | Failed =>
          get_disk i         state' ?|= missing /\
          get_disk (other i) state' ?|= F
        end;
      alternate := fun state' r =>
        get_disk i         state' ?|= eq d /\
        get_disk (other i) state' ?|= F;
    |}.

  Definition write_spec (i : diskId) (a : addr) (b : block)
    : _ -> Specification (DiskResult unit) unit _ :=
    fun '(d, F) state => {|
      pre :=
        get_disk i         state ?|= eq d /\
        get_disk (other i) state ?|= F;
      post := fun state' r =>
        match r with
        | Working _ =>
          get_disk i         state' ?|= eq (assign d a b) /\
          get_disk (other i) state' ?|= F
        | Failed =>
          get_disk i         state' ?|= missing /\
          get_disk (other i) state' ?|= F
        end;
      alternate := fun state' _ =>
        (get_disk i state' ?|= eq d \/
         get_disk i state' ?|= eq (assign d a b) /\ a < length d) /\
        get_disk (other i) state' ?|= F;
    |}.

  Definition size_spec (i : diskId) : _ -> Specification _ unit _ :=
    fun '(d, F) state => {|
      pre :=
        get_disk i         state ?|= eq d /\
        get_disk (other i) state ?|= F;
      post := fun state' r =>
        match r with
        | Working n =>
          get_disk i         state' ?|= eq d /\
          get_disk (other i) state' ?|= F /\
          n = length d
        | Failed =>
          get_disk i         state' ?|= missing /\
          get_disk (other i) state' ?|= F
        end;
      alternate := fun state' _ =>
        get_disk i         state' ?|= eq d /\
        get_disk (other i) state' ?|= F;
    |}.

    Ltac inv_step :=
    match goal with
    | [ H: op_step _ _ _ _ |- _ ] =>
      inversion H; subst; clear H;
      repeat sigT_eq;
      safe_intuition
    end.

  Ltac inv_bg :=
    match goal with
    | [ H: bg_failure _ _ _ |- _ ] =>
      inversion H; subst; clear H
    end.

  Theorem maybe_holds_stable : forall state state' F0 F1 i,
    get_disk (other i) state ?|= F0 ->
    get_disk i state ?|= F1 ->
    bg_failure state state' tt ->
    get_disk (other i) state' ?|= F0 /\
    get_disk i state' ?|= F1.
  Proof.
    intros.
    destruct i; inv_bg; simpl in *; eauto.
  Qed.

  Lemma identity_unfold S (s s': S) T (v: T) :
      identity s s' v ->
      s' = s.
  Proof.
    unfold identity; auto.
  Qed.

  Ltac cleanup :=
    repeat match goal with
           | [ |- forall _, _ ] => intros
           | |- _ /\ _ => split; [ solve [ eauto || congruence ] | ]
           | |- _ /\ _ => split; [ | solve [ eauto || congruence ] ]
           | [ H: identity _ _ _ |- _ ] => apply identity_unfold in H
           | [ H: Working _ = Working _ |- _ ] => inversion H; subst; clear H
           | [ H: 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
           | [ H: ?A * ?B |- _ ] => destruct H
           | [ H: DiskResult _ |- _ ] => destruct H
           | _ => deex
           | _ => destruct_tuple
           | _ => progress autounfold in *
           | _ => progress simpl in *
           | _ => progress subst
           | _ => progress safe_intuition
           | _ => solve [ eauto ]
           | _ => congruence
           | _ => inv_step
           | H: context[match ?expr with _ => _ end] |- _ =>
             destruct expr eqn:?; [ | solve [ repeat cleanup ] ]
           | H: context[match ?expr with _ => _ end] |- _ =>
             destruct expr eqn:?; [ solve [ repeat cleanup ] | ]
           end.

  Ltac prim :=
    intros;
    eapply proc_hspec_impl; [ unfold spec_impl | eauto ]; eexists;
    intuition eauto; cleanup;
    intuition eauto; cleanup.

  Hint Resolve holds_in_some_eq : core.
  Hint Resolve holds_in_none_eq : core.
  Hint Resolve pred_missing : core.

  Hint Resolve tt : core.

  Theorem read_ok : forall i a dF, proc_hspec TDBaseDynamics (td.read i a) (read_spec i a dF).
  Proof.
    unshelve prim; eauto.
  Qed.

  Ltac destruct_all :=
    repeat match goal with
           | _ => solve [ auto ]
           | [ i: diskId |- _ ] => destruct i
           | [ |- context[match ?s with
                         | BothDisks _ _ => _
                         | OnlyDisk0 _ => _
                         | OnlyDisk1 _ => _
                         end] ] => destruct s
           | _ => simpl in *
           end.

  Theorem write_ok : forall i a v dF, proc_hspec TDBaseDynamics (td.write i a v) (write_spec i a v dF).
  Proof.
    unshelve prim; eauto;
      try solve [ destruct_all ].
    match goal with
    | |- context[S a <= length ?d] => destruct (le_dec (S a) (length d))
    end.
    - destruct_all.
    - autorewrite with array.
      destruct_all.
  Qed.

  Theorem size_ok : forall i dF, proc_hspec TDBaseDynamics (td.size i) (size_spec i dF).
  Proof.
    unshelve prim.
  Qed.
End specs.

Global Hint Resolve write_ok size_ok read_ok : core.


From Undecidability Require Import L.Util.L_facts.

From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
Require Import List.

Require Import Undecidability.TM.Util.TM_facts.

From Undecidability Require Import ProgrammingTools LM_heap_def WriteValue CaseList Copy ListTM Hoare.
From Undecidability.TM.L Require Import JumpTargetTM Alphabets M_LHeapInterpreter.
From Undecidability Require Import L.AbstractMachines.FlatPro.LM_heap_correct.

Require Import List.

Import Vector.VectorNotations.
Import ListNotations ResourceMeasures.

From Undecidability.TM.L Require Import UnfoldClos.

Require Import Equations.Prop.DepElim.

Import CasePair Code.CaseList.

Set Default Proof Using "Type".

Module EvalL.
Section Fix.

  Variable Σ : finType.

  Definition Σintern :Type := sigStep + sigList (sigPair sigHClos sigNat).

  Context (retr_eval : Retract Σintern Σ) (retr_pro : Retract sigPro Σ).

  Definition retr_unfolder : Retract (sigList (sigPair sigHClos sigNat)) Σ := ComposeRetract retr_eval _.
  Definition retr_interpreter : Retract sigStep Σ := ComposeRetract retr_eval _.

  Local Instance retr_closs_intrp : Retract (sigList (sigHClos)) Σ := ComposeRetract retr_interpreter _.
  Local Instance retr_clos_intrp : Retract sigHClos Σ := ComposeRetract retr_closs_intrp _.
  Local Instance retr_pro_intrp : Retract sigPro Σ := ComposeRetract retr_clos_intrp _.

  Local Instance retr_nat_clos_ad' : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
  Local Instance retr_nat_clos_ad : Retract sigNat Σ := ComposeRetract _ retr_nat_clos_ad'.
  Local Instance retr_heap : Retract sigHeap Σ := ComposeRetract retr_interpreter _.

  (*
    auxiliary tapes:

    0    : T
    1    : V
    2    : H
    3-4  : aux for init
    5-12 : aux for loop
    13   : t
   *)

  Definition M : pTM (Σ^+) unit 11 :=
    Translate retr_pro retr_pro_intrp @ [|Fin0|];;
    CopyValue _ @ [|Fin0;Fin1|];;
    Reset _ @[|Fin0|];;
    WriteValue 0 ⇑ retr_nat_clos_ad @ [| Fin0|];;
    Constr_pair _ _ ⇑ retr_clos_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin0|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin0|];;
    Constr_cons _ ⇑ retr_closs_intrp @ [|Fin0;Fin1|];;
    Reset _ @ [|Fin1|];;
    WriteValue ( []%list) ⇑ retr_closs_intrp @ [| Fin1|];;
    WriteValue ( []%list ) ⇑ retr_heap @ [| Fin2|];;
    M_LHeapInterpreter.Loop ⇑ retr_interpreter;;
    Reset _ @ [|Fin0|];;
    CaseList _ ⇑ retr_closs_intrp @ [| Fin1;Fin0 |];;
    Reset _ @ [|Fin1|];;
    UnfoldClos.M retr_unfolder retr_heap retr_clos_intrp @ [| Fin0;Fin2;Fin1;Fin3;Fin4;Fin5;Fin6;Fin7;Fin8;Fin9|];;
    Reset _ @ [|Fin2|];;
    Translate (UnfoldClos.retr_pro _) retr_pro @ [|Fin0|].

  Arguments "+" : simpl never.
  Arguments "*" : simpl never.

  Definition steps (s : term) (k:nat) (t:term) Hcl (HR:evalIn k s t):=
    1 + Translate_steps (compile s) +
    (1 + CopyValue_steps (compile s) +
    (1 + Reset_steps (compile s) +
      (1 + WriteValue_steps (size 0) +
      (1 + Constr_pair_steps 0 +
        (1 + Reset_steps 0 +
        (1 + WriteValue_steps (size []%list) +
          (1 + Constr_cons_steps (0, compile s) +
          (1 + Reset_steps (0, compile s) +
            (1 + WriteValue_steps (size []%list) +
            (1 + WriteValue_steps (size []%list) +
              (1 + Loop_steps [(0, compile s)] [] []%list (3 * k + 1) +
              (1 + Reset_steps []%list +
                let (g,tmp) := completenessTimeInformative (proj2 (timeBS_evalIn _ _ _) HR) Hcl in
                let (H,_):= tmp in
                (1 + CaseList_steps [g] +
                (1 + Reset_steps []%list +
                  (1 + UnfoldClos.steps H g t +
                  (1 + Reset_steps H + Translate_steps (compile t))))))))))))))))).
  Arguments steps : clear implicits.

  Lemma SpecT s k t (Hcl: closed s) (HR:evalIn k s t):
    TripleT ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      (steps s k t Hcl HR) M
      (fun _ => ≃≃([],[|Contains retr_pro (compile t)|] ++ Vector.const Void _)).
  Proof.
    unfold steps. destruct completenessTimeInformative as (g&H&?&?). clear HR.
    eapply ConsequenceT_pre. 2:reflexivity.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep_seq;[| | ] .
    { refine (TripleT_RemoveSpace _). intros. eapply Interpreter_SpecT. eassumption. inversion 1. }
    now cbn; tspec_ext.
    do 2 (hstep_seq;[]).
    hintros _ _.
    hstep_seq;[].
    hstep_seq;[|].
    { eapply UnfoldClos.SpecT. eassumption. }
    cbn.
    do 2 (hstep_seq;[]). reflexivity.
    unfold steps. reflexivity.
  Qed.

  Lemma Spec s :
   closed s ->
    Triple ≃≃([],[|Contains retr_pro (compile s)|] ++ Vector.const Void _)
      M
      (fun _ t => exists s', t ≃≃ ([s ⇓ s']%list,[|Contains retr_pro (compile s')|] ++ Vector.const Void _)).
  Proof.
    intros cls.
    unfold M.
    do 11 (hstep_seq;[]). cbn.
    hstep.
    {
      eapply Consequence with (Q1:= fun y => _) (Q2:= fun y => _).
      eapply ChangeAlphabet_Spec_ex with (Q:= fun y x => _) (Q':= fun y x => _) (Ctx:= fun x (H:Prop) => (steps_k (snd x) _ (fst x) /\ halt_state (fst x)) /\
        (fst (fst (fst x)) = []%list ->
        H)).
      now refine (Interpreter_Spec [(0,compile s)] [] [])%list. now unfold "==>",Proper,Basics.impl. now cbn; tspec_ext. cbn;intros _. apply reflexivity.
    }
    cbn. intros _.
    eapply Triple_exists_pre. intros [[[T' V'] H'] k'];cbn.
    eapply Triple_and_pre. intros [HR Hhalt].
    unfold steps_k in*.
    edestruct soundness with (1:=cls) as (?&?&?&Heq&?&?). {split. now eapply pow_star. eassumption. }
    injection Heq as [= -> -> ->].
    eapply Triple_forall_pre. exists eq_refl.
    do 2 (hstep_seq;[]).
    hintros ? _.
    do 2 hstep_seq;[|].
    { refine (TripleT_Triple _). refine (UnfoldClos.SpecT _ _ _ _). eassumption. }
    cbn.
    hstep_seq.
    eapply Triple_exists_con. eexists _.
    change (fun x => ?h x) with h.
    eapply Consequence_post.
    now hsteps_cbn.
    cbn. intros _. tspec_ext. easy.
  Qed.

End Fix.
End EvalL.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz. (* for lia *)
Import ListNotations.

(* Type soundness for lambda calculus with mutable references, recursive functions λf(x).t, and subtyping, quick and dirty.

   - Variables in locally nameless, deBruijn _levels_ for free vars.
   - Implements substitution in terms of opening.

   Nice to have: automation, automation, automation!
 *)

(* ### Syntax ### *)

Definition id := nat.
Definition loc := nat. (* store locations *)

(* locally nameless for binders in terms *)
Inductive var : Type :=
| varF : id -> var (* free var (deBruijn level) *)
| varB : id -> var (* locally-bound variable (deBruijn index) *)
.

Notation "# i" := (varB i) (at level 0).
Notation "$ i" := (varF i) (at level 0).

Inductive ty : Type :=
| TUnit : ty
| TFun  : ty -> ty -> ty
| TRef  : ty -> ty
.

Inductive tm : Type :=
| tunit    : tm
| tvar    : var -> tm
| tabs    : tm  -> tm (* convention: #0: self-ref #1: argument *)
| tapp    : tm  -> tm -> tm
| tloc    : loc -> tm
| tref    : tm  -> tm
| tderef  : tm  -> tm
| tassign : tm  -> tm -> tm
.

Notation "& l" := (tloc l) (at level 0).
Notation "! t" := (tderef t) (at level 0).
Coercion tvar : var >-> tm. (*lightens the notation of term variables*)

(* ### Representation of Bindings ### *)

(* An environment is a list of values, indexed by decrementing ids. *)

(* Look up a free variable (deBruijn level) in env   *)
Fixpoint indexr {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' =>
      if (beq_nat n (length l')) then Some a else indexr n l'
  end.

Lemma indexr_head : forall {A} {x : A} {xs}, indexr (length xs) (x :: xs) = Some x.
  intros. simpl. destruct (Nat.eqb (length xs) (length xs)) eqn:Heq. auto.
  apply beq_nat_false in Heq. contradiction.
Qed.

Lemma indexr_length : forall {A B} {xs : list A} {ys : list B}, length xs = length ys -> forall {x}, indexr x xs = None <-> indexr x ys = None.
Proof.
  intros A B xs.
  induction xs; intros; destruct ys; split; simpl in *; intros; eauto; try lia.
  - inversion H. destruct (PeanoNat.Nat.eqb x (length xs)). discriminate.
    specialize (IHxs _ H2 x). destruct IHxs. auto.
  - inversion H. rewrite <- H2 in H0. destruct (PeanoNat.Nat.eqb x (length xs)). discriminate.
    specialize (IHxs _ H2 x). destruct IHxs. auto.
Qed.

Lemma indexr_skip : forall {A} {x : A} {xs : list A} {i}, i <> length xs -> indexr i (x :: xs) = indexr i xs.
Proof.
  intros.
  rewrite <- PeanoNat.Nat.eqb_neq in H. auto.
  simpl. rewrite H. reflexivity.
Qed.

Lemma indexr_skips : forall {A} {xs' xs : list A} {i}, i < length xs -> indexr i (xs' ++ xs) = indexr i xs.
  induction xs'; intros; intuition.
  replace ((a :: xs') ++ xs) with (a :: (xs' ++ xs)).
  rewrite indexr_skip. eauto. rewrite app_length. lia. auto.
Qed.

Lemma indexr_var_some :  forall {A} {xs : list A} {i}, (exists x, indexr i xs = Some x) <-> i < length xs.
Proof.
  induction xs; intros; split; intros. inversion H. inversion H0.
  inversion H. inversion H. simpl in H0. destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  apply beq_nat_true in Heq. rewrite Heq. auto. inversion H.
  simpl in H. rewrite Heq in H. apply IHxs in H. simpl. lia.
  simpl. destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  exists a. reflexivity. apply beq_nat_false in Heq. simpl in H.
  apply IHxs. lia.
Qed.

(* easier to use for assumptions without existential quantifier *)
Lemma indexr_var_some' :  forall {A} {xs : list A} {i x}, indexr i xs = Some x -> i < length xs.
Proof.
  intros. apply indexr_var_some. exists x. auto.
Qed.

Lemma indexr_var_none :  forall {A} {xs : list A} {i}, indexr i xs = None <-> i >= length xs.
Proof.
  induction xs; intros; split; intros.
  simpl in *. lia. auto.
  simpl in H.
  destruct (PeanoNat.Nat.eqb i (length xs)) eqn:Heq.
  discriminate. apply IHxs in H. apply beq_nat_false in Heq. simpl. lia.
  assert (Hleq: i >= length xs). {
    simpl in H. lia.
  }
  apply IHxs in Hleq. rewrite <- Hleq.
  apply indexr_skip. simpl in H. lia.
Qed.

Lemma indexr_insert_ge : forall {A} {xs xs' : list A} {x} {y}, x >= (length xs') -> indexr x (xs ++ xs') = indexr (S x) (xs ++ y :: xs').
  induction xs; intros.
  - repeat rewrite app_nil_l. pose (H' := H).
    rewrite <- indexr_var_none in H'.
    rewrite H'. symmetry. apply indexr_var_none. simpl. lia.
  - replace ((a :: xs) ++ xs') with (a :: (xs ++ xs')); auto.
    replace ((a :: xs) ++ y :: xs') with (a :: (xs ++ y :: xs')); auto.
    simpl. replace (length (xs ++ y :: xs')) with (S (length (xs ++ xs'))).
    destruct (Nat.eqb x (length (xs ++ xs'))) eqn:Heq; auto.
    repeat rewrite app_length. simpl. lia.
Qed.

Lemma indexr_insert_lt : forall {A} {xs xs' : list A} {x} {y}, x < (length xs') -> indexr x (xs ++ xs') = indexr x (xs ++ y :: xs').
  intros.
  rewrite indexr_skips; auto.
  erewrite indexr_skips.
  erewrite indexr_skip. auto.
  lia. simpl. lia.
Qed.

Lemma indexr_insert:  forall {A} {xs xs' : list A} {y}, indexr (length xs') (xs ++ y :: xs') = Some y.
  intros. induction xs.
  - replace ([] ++ y :: xs') with (y :: xs'); auto. apply indexr_head.
  - simpl. rewrite IHxs. rewrite app_length. simpl.
    destruct (PeanoNat.Nat.eqb (length xs') (length xs + S (length xs'))) eqn:Heq; auto.
    apply beq_nat_true in Heq. lia.
Qed.

Definition tenv := list ty. (* Γ environment: static *)
Definition senv := list ty. (* Sigma store typing *)

Definition extends {A} (l1 l2 : list A): Prop := exists l', l1 = l' ++ l2.
Notation "x ⊇ y" := (extends x y) (at level 0).

Lemma extends_refl : forall {A}, forall{l : list A}, extends l l.
  intros. unfold extends. exists []. auto.
Qed.

Lemma extends_cons : forall {A}, forall{l : list A}, forall{a:A}, extends (a :: l) l.
  intros. unfold extends. exists [a]. auto.
Qed.

Lemma extends_length : forall {A}, forall{l1 l2 : list A}, extends l1 l2 -> length l1 >= length l2.
  intros. unfold extends in H. destruct H as [l' Heq]. subst. rewrite app_length. lia.
Qed.

(* Opening a term *)
Fixpoint open_rec_tm (k : nat) (u : tm) (t : tm) {struct t} : tm :=
  match t with
  | tunit            => tunit
  | tvar   (varF x) => tvar (varF x)
  | tvar   (varB x) => if beq_nat k x then u else tvar (varB x)
  | tabs    t       => tabs    (open_rec_tm (S (S k)) u t)
  | tapp    t1 t2   => tapp    (open_rec_tm k u t1) (open_rec_tm k u t2)
  | tloc    l       => tloc l
  | tref    t       => tref    (open_rec_tm k u t)
  | tderef  t       => tderef  (open_rec_tm k u t)
  | tassign t1 t2   => tassign (open_rec_tm k u t1) (open_rec_tm k u t2)
  end
.
(*simultaneous opening with self-ref and argument: *)
Definition open_tm (u u' : tm) t := open_rec_tm 1 u' (open_rec_tm 0 u t).
Definition open_tm' {A : Type} (env : list A) t :=
  open_rec_tm 1 (varF (S (length env))) (open_rec_tm 0 (varF (length env)) t).

Lemma open_rec_tm_commute : forall t i j x y, i <> j -> open_rec_tm i (varF x) (open_rec_tm j (varF y) t) = open_rec_tm j (varF y) (open_rec_tm i (varF x) t).
  induction t; intros; simpl; eauto;
    try solve [rewrite IHt1; eauto; rewrite IHt2; eauto | rewrite IHt; eauto].
  destruct v. intuition.
  destruct (Nat.eqb i i0) eqn:Hii0; destruct (Nat.eqb j i0) eqn:Hji0; simpl;
    try rewrite Hii0; try rewrite Hji0; auto.
  apply beq_nat_true in Hii0. apply beq_nat_true in Hji0. subst. contradiction.
Qed.

(* measure for induction over terms *)
Fixpoint tm_size (t : tm) : nat :=
  match t with
  | tunit          => 0
  | tvar    _     => 0
  | tabs    t     => S (tm_size t)
  | tapp    t1 t2 => S (tm_size t1 + tm_size t2)
  | tloc    _     => 0
  | tref    t     => S (tm_size t)
  | tderef  t     => S (tm_size t)
  | tassign t1 t2 => S (tm_size t1 + tm_size t2)
  end.

Lemma open_preserves_size: forall t x j, tm_size t = tm_size (open_rec_tm j (tvar x) t).
  induction t; intros; simpl; eauto.
  destruct v. auto. destruct (Nat.eqb j i); auto.
Qed.

Inductive closed_tm: nat(*B*) -> nat(*F*) -> nat(*Loc*) -> tm -> Prop :=
| cl_tsct : forall b f l,
    closed_tm b f l tunit
| cl_tvarb: forall b f l x,
    x < b ->
    closed_tm b f l (tvar (varB x))
| cl_tvarf: forall b f l x,
    x < f ->
    closed_tm b f l (tvar (varF x))
| cl_tabs:  forall b f l tm,
    closed_tm (S (S b)) f l tm ->
    closed_tm b f l (tabs tm)
| cl_tapp:  forall b f l tm1 tm2,
    closed_tm b f l tm1 ->
    closed_tm b f l tm2 ->
    closed_tm b f l (tapp tm1 tm2)
| cl_tloc: forall b f l l',
    l' < l ->
    closed_tm b f l (tloc l')
| cl_tref:  forall b f l tm,
    closed_tm b f l tm ->
    closed_tm b f l (tref tm)
| cl_tderef:  forall b f l tm,
    closed_tm b f l tm ->
    closed_tm b f l (tderef tm)
| cl_tassign:  forall b f l tm1 tm2,
    closed_tm b f l tm1 ->
    closed_tm b f l tm2 ->
    closed_tm b f l (tassign tm1 tm2)
.
Hint Constructors closed_tm : dsub.

Inductive stp : tenv -> senv -> ty -> ty -> Prop :=
| s_base : forall Γ Σ,
    stp Γ Σ TUnit TUnit
| s_ref : forall Γ Σ T, (* TODO: generalize to equivalence*)
    stp Γ Σ (TRef T) (TRef T)
| s_fun : forall Γ Σ T1 T3 T2 T4,  (*TODO: this becomes less trivial with the qualifiers *)
    stp Γ Σ T3 T1 ->
    stp Γ Σ T2 T4 ->
    stp Γ Σ (TFun T1 T2) (TFun T3 T4)
.

Inductive has_type : tenv -> senv -> tm -> ty -> Prop :=
| t_base : forall Γ Σ,
    has_type Γ Σ tunit TUnit

| t_var : forall Γ Σ x T,
    indexr x Γ = Some T ->
    has_type Γ Σ (tvar (varF x)) T

| t_abs: forall Γ Σ T1 T2 t,
    closed_tm 2 (length Γ) (length Σ) t ->
    has_type (T1 :: (TFun T1 T2) :: Γ) Σ (open_tm' Γ t) T2 ->
    has_type Γ Σ (tabs t) (TFun T1 T2)

| t_app : forall Γ Σ t1 t2 T1 T2,
    has_type Γ Σ t1 (TFun T1 T2) ->
    has_type Γ Σ t2 T1 ->
    has_type Γ Σ (tapp t1 t2) T2

| t_loc : forall Γ Σ l T,
    indexr l Σ = Some T ->
    has_type Γ Σ (tloc l) (TRef T)

| t_ref: forall Γ Σ T t,
    has_type Γ Σ t T ->
    has_type Γ Σ (tref t) (TRef T)

| t_deref: forall Γ Σ T t,
    has_type Γ Σ t (TRef T) ->
    has_type Γ Σ (tderef t) T

| t_assign: forall Γ Σ T t1 t2,
    has_type Γ Σ t1 (TRef T) ->
    has_type Γ Σ t2 T ->
    has_type Γ Σ (tassign t1 t2) TUnit

| t_sub: forall Γ Σ e T1 T2,
    has_type Γ Σ e T1 ->
    stp Γ Σ T1 T2 ->
    has_type Γ Σ e T2
.

Hint Constructors has_type : dsub.
Hint Constructors stp : dsub.

Lemma bound_vars_untypable : forall {Γ Σ T i}, has_type Γ Σ #i T -> False.
  intros Γ Σ T i HT. remember (tvar #i) as t. induction HT; try discriminate.
  intuition.
Qed.

Lemma closed_tm_monotone : forall {t b l f}, closed_tm b f l t -> forall {b' f' l'}, b <= b' -> f <= f' -> l <= l' -> closed_tm b' f' l' t.
  intros T b f l H. induction H; intuition.
Qed.

Lemma closed_tm_open_id : forall {t b f l}, closed_tm b f l t -> forall {n}, b <= n -> forall {x}, (open_rec_tm n x t) = t.
  intros t b f l H. induction H; intros; simpl; auto;
    try solve [erewrite IHclosed_tm1; eauto; erewrite IHclosed_tm2; eauto; lia | erewrite IHclosed_tm; eauto; lia].
  destruct (Nat.eqb n x) eqn:Heq; auto. apply beq_nat_true in Heq. lia.
Qed.

Lemma closed_tm_open : forall {T b f l}, closed_tm (S b) f l T -> forall {x}, x < f -> closed_tm b f l (open_rec_tm b (varF x) T).
  induction T; intros; simpl; intuition; inversion H; subst; try constructor;
  try solve [apply IHT1; auto | apply IHT2; auto | apply IHT; auto ].
  destruct (Nat.eqb b x0) eqn:Heq; intuition.
  apply beq_nat_false in Heq. constructor. lia. auto. auto.
Qed.

Lemma closed_tm_open' : forall {T b f l}, closed_tm (S b) f l T -> forall {x}, x <= f -> forall {t}, closed_tm 0 x l t -> closed_tm b f l (open_rec_tm b t T).
  induction T; intros; simpl; intuition; inversion H; subst; try constructor;
  try solve [eapply IHT1; eauto | eapply IHT2; eauto | eapply IHT; eauto ].
  destruct (Nat.eqb b x0) eqn:Heq; intuition. eapply closed_tm_monotone; eauto; lia.
  apply beq_nat_false in Heq. constructor. lia. auto. auto.
Qed.

Lemma closed_tm_open_ge : forall {T b f l}, closed_tm (S b) f l T -> forall {x}, f <= x -> closed_tm b (S x) l (open_rec_tm b (varF x) T).
  induction T; intros; simpl; intuition; inversion H; subst; try constructor;
      try solve [eapply IHT1; eauto | eapply IHT2; eauto | eapply IHT; eauto ].
  destruct (Nat.eqb b x0) eqn:Heq. intuition.
  apply beq_nat_false in Heq. inversion H. subst.
  constructor. lia. lia. auto.
Qed.

Lemma closed_open_succ : forall {T b f l}, closed_tm b f l T -> forall {j}, closed_tm b (S f) l (open_rec_tm j (varF f) T).
  induction T; intros; simpl; intuition; inversion H; subst; try constructor;
    try solve [eapply IHT1; eauto | eapply IHT2; eauto | eapply IHT; eauto ].
    destruct (Nat.eqb j x) eqn:Heq. intuition.
    apply beq_nat_false in Heq. inversion H. subst. intuition. lia. auto.
Qed.

Lemma open_rec_tm_commute' : forall t i j x t' f l, i <> j -> closed_tm 0 f l t' -> open_rec_tm i (varF x) (open_rec_tm j t' t) = open_rec_tm j t' (open_rec_tm i (varF x) t).
  induction t; intros; simpl; eauto;
    try solve [erewrite IHt1; eauto; erewrite IHt2; eauto | erewrite IHt; eauto].
  - destruct v. intuition.
    destruct (Nat.eqb i i0) eqn:Hii0; destruct (Nat.eqb j i0) eqn:Hji0; simpl;
      try rewrite Hii0; try rewrite Hji0; auto.
    apply beq_nat_true in Hii0. apply beq_nat_true in Hji0. subst. contradiction.
    eapply closed_tm_open_id; eauto. lia.
Qed.

Lemma open_rec_tm_commute'' : forall t i j t' t'' f l, i <> j -> closed_tm 0 f l t' -> closed_tm 0 f l t'' -> open_rec_tm i t'' (open_rec_tm j t' t) = open_rec_tm j t' (open_rec_tm i t'' t).
  induction t; intros; simpl; eauto;
    try solve [erewrite IHt1; eauto; erewrite IHt2; eauto | erewrite IHt; eauto].
  - destruct v. intuition.
    destruct (Nat.eqb i i0) eqn:Hii0; destruct (Nat.eqb j i0) eqn:Hji0; simpl;
      try rewrite Hii0; try rewrite Hji0; auto.
    apply beq_nat_true in Hii0. apply beq_nat_true in Hji0. subst. contradiction.
    symmetry. eapply closed_tm_open_id; eauto. lia. eapply closed_tm_open_id; eauto. lia.
Qed.

Lemma has_type_var_length : forall {Γ Σ x T}, has_type Γ Σ (tvar (varF x)) T -> x < length Γ.
  intros. dependent induction H; eauto.
  apply indexr_var_some' in H. auto.
Qed.

Fixpoint has_type_closed  {Γ Σ t T} (ht  : has_type Γ Σ t T) : closed_tm 0 (length Γ) (length Σ) t.

  destruct ht; intuition; try apply has_type_closed in ht; try apply has_type_closed in ht1;
    try apply has_type_closed in ht2; intuition.
  + apply indexr_var_some' in H. intuition.
  + apply indexr_var_some' in H. intuition.
Qed.

Require Import Coq.Arith.Compare_dec.

Fixpoint splice (n : nat) (t : tm) {struct t} : tm :=
  match t with
  | tunit           => tunit
  | tvar (varF i)  =>
    if le_lt_dec n i then tvar (varF (S i))
    else tvar (varF i)
  | tvar (varB i)  => tvar    (varB i)
  | tabs    t      => tabs    (splice n t)
  | tapp    t1 t2  => tapp    (splice n t1) (splice n t2)
  | tloc    l      => tloc     l
  | tref    t      => tref    (splice n t)
  | tderef  t      => tderef  (splice n t)
  | tassign t1 t2  => tassign (splice n t1) (splice n t2)
  end.

Lemma splice_id : forall {T b f l}, closed_tm b f l T -> (splice f T ) = T.
  induction T; intros; inversion H; subst; simpl; auto;
    try solve [erewrite IHT1; eauto; erewrite IHT2; eauto | erewrite IHT; eauto].
    destruct (le_lt_dec f x) eqn:Heq. lia. auto.
Qed.

Lemma splice_open : forall {T j n m}, splice n (open_rec_tm j (varF (m + n)) T) = open_rec_tm j (varF (S (m + n))) (splice n T).
  induction T; intros; simpl; auto;
    try solve [erewrite IHT1; eauto; erewrite IHT2; eauto | erewrite IHT; eauto].
  destruct v; simpl. destruct (le_lt_dec n i) eqn:Heq; auto.
  destruct (PeanoNat.Nat.eqb j i) eqn:Heq; auto.
  simpl. destruct (le_lt_dec n (m + n)) eqn:Heq'. auto. lia.
Qed.

Lemma splice_open' :  forall {T} {A} {D : A} {ρ ρ'}, splice (length ρ') (open_tm' (ρ ++ ρ') T) = open_tm' (ρ ++ D :: ρ') (splice (length ρ') T).
  intros. unfold open_tm'.
  replace (length (ρ ++ ρ')) with ((length ρ) + (length ρ')).
  replace (S (length (ρ ++ D :: ρ'))) with (S (S (length ρ) + (length ρ'))).
  replace (length (ρ ++ D :: ρ')) with (S ((length ρ) + (length ρ'))).
  rewrite <- splice_open.
  rewrite <- splice_open.
  reflexivity.
  all: rewrite app_length; simpl; lia.
Qed.

Lemma splice_closed : forall {T b n m l}, closed_tm b (n + m) l T -> closed_tm b (S (n + m)) l (splice m T).
  induction T; simpl; intros; inversion H; subst; intuition.
  destruct (le_lt_dec m x) eqn:Heq; intuition.
Qed.

Lemma splice_closed' : forall {T b l} {A} {D : A} {ρ ρ'},
    closed_tm b (length (ρ ++ ρ')) l T ->  closed_tm b (length (ρ ++ D :: ρ')) l (splice (length ρ') T).
  intros. rewrite app_length in H.
  replace (length (ρ ++ D :: ρ')) with (S (length ρ) + (length ρ')).
  apply splice_closed. auto. simpl. rewrite app_length. simpl. lia.
Qed.

Lemma splice_open_succ : forall {T b n l j}, closed_tm b n l T -> splice n (open_rec_tm j (varF n) T) = open_rec_tm j (varF (S n)) T.
  induction T; simpl; intros; inversion H; subst; auto;
    try solve [erewrite IHT1; eauto; erewrite IHT2; eauto | erewrite IHT; eauto].
  destruct (PeanoNat.Nat.eqb j x) eqn:Heq; auto. simpl.
  destruct (le_lt_dec n n) eqn:Heq'; auto. lia.
  simpl. destruct (le_lt_dec n x) eqn:Heq; auto. lia.
Qed.

Inductive value : tm -> Prop :=
| value_abs : forall t, value (tabs t)
| value_cst : value tunit
| value_loc : forall l, value (tloc l)
.

Definition store := list tm.

Fixpoint update (σ : store) (l : loc) (v : tm) : store :=
  match σ with
  | [] => σ
  | a :: σ' =>
      if (beq_nat l (length σ')) then (v :: σ') else (a :: (update σ' l v ))
  end.

Lemma update_length : forall {σ l v}, length σ = length (update σ l v).
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Heq; intuition.
  simpl. congruence.
Qed.

Lemma update_indexr_miss : forall {σ l v l'}, l <> l' ->  indexr l' (update σ l v) = indexr l' σ.
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Hls; destruct (Nat.eqb l' (length σ)) eqn:Hl's.
  apply beq_nat_true in Hls. apply beq_nat_true in Hl's. rewrite <- Hl's in Hls. contradiction.
  simpl. rewrite Hl's. auto.
  simpl. rewrite <- update_length. rewrite Hl's. auto.
  simpl. rewrite <- update_length. rewrite Hl's. apply IHσ. auto.
Qed.

Lemma update_indexr_hit : forall {σ l v}, l < length σ -> indexr l (update σ l v) = Some v.
  induction σ; simpl; intuition.
  destruct (Nat.eqb l (length σ)) eqn:Hls.
  apply beq_nat_true in Hls. rewrite Hls. apply indexr_head.
  simpl. rewrite <- update_length. rewrite Hls. apply beq_nat_false in Hls.
  apply IHσ. lia.
Qed.

Inductive step : tm -> store -> tm -> store -> Prop :=
(*contraction rules*)
| step_beta : forall t v σ,
    value v ->
    step (tapp (tabs t) v) σ (open_tm (tabs t) v t) σ
| step_ref : forall v σ,
    value v ->
    step (tref v) σ (tloc (length σ)) (v :: σ)
| step_deref : forall σ l v,
    indexr l σ = Some v ->
    value v ->
    step (tderef (tloc l)) σ v σ
| step_assign : forall σ l v,
    l < (length σ) ->
    value v ->
    step (tassign (tloc l) v) σ tunit (update σ l v)
(*congruence rules*)
| step_c_ref : forall t t' σ σ',
    step t σ t' σ' ->
    step (tref t) σ (tref t') σ'
| step_c_deref : forall t t' σ σ',
    step t σ t' σ' ->
    step (tderef t) σ (tderef t') σ'
| step_c_app_l : forall t1 t1' t2 σ σ',
    step t1 σ t1' σ' ->
    step (tapp t1 t2) σ (tapp t1' t2) σ'
| step_c_app_r : forall v t2 t2' σ σ',
    value v ->
    step t2 σ t2' σ' ->
    step (tapp v t2) σ (tapp v t2') σ'
| step_c_assign_l : forall t1 t1' t2 σ σ',
    step t1 σ t1' σ' ->
    step (tassign t1 t2) σ (tassign t1' t2) σ'
| step_c_assign_r : forall v t2 t2' σ σ',
    value v ->
    step t2 σ t2' σ' ->
    step (tassign v t2) σ (tassign v t2') σ'
.

Lemma values_stuck : forall {v}, value v -> forall {t σ σ'}, step v σ t σ' -> False.
  intros. inversion H0; subst; inversion H.
Qed.

Lemma stp_refl : forall {T Γ Σ}, stp Γ Σ T T.
  induction T; intros; intuition.
Qed.

Lemma stp_trans : forall {T2 T1 T3 Γ Σ}, stp Γ Σ T1 T2 -> stp Γ Σ T2 T3 -> stp Γ Σ T1 T3.
  induction T2; intros; try inversion H0; try inversion H; intuition.
Qed.

(* Inversion lemmas abstracting over subsumption steps *)
Lemma typ_inv_unit : forall {Γ Σ T}, has_type Γ Σ tunit T -> T = TUnit.
  intros Γ Σ T HT. remember tunit as t. induction HT; try solve [discriminate].
  auto. intuition. subst. inversion H. subst. auto.
Qed.

Lemma typ_inv_varf : forall {Γ Σ i T}, has_type Γ Σ $i T -> exists U, indexr i Γ = Some U /\ stp Γ Σ U T.
  intros Γ Σ i T HT. remember (tvar $i) as v. induction HT; inversion Heqv; subst.
  - exists T. intuition. apply stp_refl.
  - intuition. destruct H1 as [U [Hlookup UsubT1]].
    exists U. intuition. eapply stp_trans; eauto.
Qed.

Lemma typ_inv_loc : forall {Γ Σ l T}, has_type Γ Σ &l T -> exists U, indexr l Σ = Some U /\ stp Γ Σ (TRef U) T.
  intros Γ Σ l T HT. remember &l as v. induction HT; inversion Heqv; subst.
  - exists T. intuition.
  - intuition. destruct H1 as [U [Hlookup UsubT1]].
    exists U. intuition. eapply stp_trans; eauto.
Qed.

Lemma typ_inv_ref : forall {Γ Σ t T}, has_type Γ Σ (tref t) T -> exists U, T = TRef U /\ has_type Γ Σ t U.
  intros Γ Σ t T HT. remember (tref t) as ref. induction HT; inversion Heqref; subst.
  - exists T. intuition.
  - intuition. destruct H1 as [U [HRef Ht]]. subst.
    inversion H. subst. exists U. intuition.
Qed.

Lemma typ_inv_deref : forall {Γ Σ t T}, has_type Γ Σ !t T -> exists U, has_type Γ Σ t (TRef U) /\ stp Γ Σ U T.
  intros Γ Σ t T HT. remember !t as ref. induction HT; inversion Heqref; subst.
  - exists T. intuition. apply stp_refl.
  - intuition. destruct H1 as [U [Ht Hstp]].
    exists U. intuition. eapply stp_trans; eauto.
Qed.

Lemma typ_inv_abs : forall {Γ Σ t T},
    has_type Γ Σ (tabs t) T ->
    exists T1 T2, closed_tm 2 (length Γ) (length Σ) t /\ has_type (T1 :: (TFun T1 T2) :: Γ) Σ (open_tm' Γ t) T2 /\ stp Γ Σ (TFun T1 T2) T.
  intros Γ Σ t T HT. remember (tabs t) as abs. induction HT; inversion Heqabs; subst.
  - exists T1. exists T2. intuition. apply stp_refl.
  - intuition. destruct H1 as [T1' [T2' [Hc [Ht Hstp]]]]. exists T1'. exists T2'.
    intuition. inversion Hstp. subst. inversion H. subst. eapply stp_trans; eauto.
Qed.

Lemma typ_inv_app : forall {Γ Σ t1 t2 T},
    has_type Γ Σ (tapp t1 t2) T ->
    exists T1, has_type Γ Σ t1 (TFun T1 T) /\ has_type Γ Σ t2 T1.
  intros Γ Σ t1 t2 T HT. remember (tapp t1 t2) as app. induction HT; inversion Heqapp; subst.
  - exists T1. intuition.
  - intuition. destruct H1 as [T' [Ht1 Ht2]].
    exists T'. split. eapply t_sub. eauto. constructor. apply stp_refl. auto.
    auto.
Qed.

Lemma typ_inv_assign : forall {Γ Σ t1 t2 T},
    has_type Γ Σ (tassign t1 t2) T -> T = TUnit /\ exists U, has_type Γ Σ t1 (TRef U) /\ has_type Γ Σ t2 U.
  intros Γ Σ t1 t2 T HT. remember (tassign t1 t2) as ass. induction HT; inversion Heqass; subst.
  - intuition. exists T. intuition.
  - intuition. subst. inversion H. subst. auto.
Qed.

Lemma weaken_stp_gen : forall {Γ1 Γ2 Σ T1 T2},
    stp (Γ1 ++ Γ2) Σ T1 T2 ->
    forall T', stp (Γ1 ++ T' :: Γ2) Σ T1 T2.
  intros Γ1 Γ2 Σ T1 T2 Hstp. induction Hstp; intuition.
Qed.

Lemma weaken_stp : forall {Γ Σ T1 T2}, stp Γ Σ T1 T2 -> forall T', stp (T' :: Γ) Σ T1 T2.
  intros. specialize (@weaken_stp_gen [] Γ Σ T1 T2) as Hsp.
  simpl in *. intuition.
Qed.

Lemma weaken_stp' : forall {Γ Σ T1 T2}, stp Γ Σ T1 T2 -> forall Γ', stp (Γ' ++ Γ) Σ T1 T2.
  intros. induction Γ'.
  - simpl. auto.
  - replace ((a :: Γ') ++ Γ) with (a :: (Γ' ++ Γ)).
    apply weaken_stp. auto. simpl. auto.
Qed.

Lemma weaken_gen : forall {n t Γ1 Γ2 Σ T}, tm_size t < n ->
    closed_tm 0 (length (Γ1 ++ Γ2)) (length Σ) t ->
    has_type (Γ1 ++ Γ2) Σ t T ->
    forall T', has_type (Γ1 ++ T' :: Γ2) Σ (splice (length Γ2) t) T.
  induction n; try lia; intros; destruct t; simpl.
  - apply typ_inv_unit in H1. subst. constructor.
  - destruct v; inversion H0; subst; try lia.
    apply typ_inv_varf in H1. destruct H1 as [U [Hlookup Hstp]].
    destruct (le_lt_dec (length Γ2) i) eqn:Heq.
    rewrite (@indexr_insert_ge _ Γ1 Γ2 i T' l) in Hlookup.
    2 : rewrite (@indexr_insert_lt _ Γ1 Γ2 i T' l) in Hlookup.
    all: eapply t_sub.
    1,3: constructor; apply Hlookup.
    all: apply weaken_stp_gen; auto.
  - (*tabs*) simpl in H. inversion H0; subst.
    apply typ_inv_abs in H1. destruct H1 as [T1 [T2 [Hc [Ht Hstp]]]].
    inversion Hstp. subst. eapply t_sub. apply t_abs.
    3: apply weaken_stp_gen; eapply Hstp.
    apply splice_closed'. auto.
    rewrite <- splice_open'.
    replace (T1 :: TFun T1 T2 :: Γ1 ++ T' :: Γ2) with ((T1 :: TFun T1 T2 :: Γ1) ++ T' :: Γ2).
    eapply IHn; eauto. unfold open_tm'. rewrite <- open_preserves_size. rewrite <- open_preserves_size. lia.
    simpl. eapply closed_tm_monotone. eapply has_type_closed; eauto. lia. simpl. lia. auto.
    intuition.
  - simpl in H. inversion H0; subst. apply typ_inv_app in H1.
    destruct H1 as [U [Ht1 Ht2]]. eapply t_app.
    eapply IHn; eauto. lia. eapply IHn; eauto. lia.
  - apply typ_inv_loc in H1. destruct H1 as [U [Hlookup Hstp]].
    eapply t_sub. apply t_loc. eauto. apply weaken_stp_gen. auto.
  - simpl in H. apply typ_inv_ref in H1. destruct H1 as [U [Heq Ht]].
    subst. inversion H0. subst. apply t_ref. eapply IHn; eauto. lia.
  - simpl in H. inversion H0; subst. apply typ_inv_deref in H1.
    destruct H1 as [U [Ht Hstp]]. eapply t_sub. apply t_deref. eapply IHn; eauto. lia.
    apply weaken_stp_gen. auto.
  - simpl in H. inversion H0; subst. apply typ_inv_assign in H1.
    destruct H1 as [Heq [U [Ht1 Ht2]]]. subst.
    eapply t_assign. eapply IHn; eauto; lia. eapply IHn; eauto; lia.
Qed.

Lemma weaken : forall {Γ Σ t T}, has_type Γ Σ t T -> forall {T'}, has_type (T' :: Γ) Σ t T.
  intros Γ Σ t T HT. specialize (@weaken_gen (S (tm_size t)) t [] Γ Σ T) as Hsp. simpl in *.
  replace (splice (length Γ) t) with t in Hsp.
  apply Hsp; auto. eapply has_type_closed; eauto.
  symmetry. eapply splice_id. eapply has_type_closed; eauto.
Qed.

Lemma weaken' : forall {Γ Σ t T}, has_type Γ Σ t T -> forall {Γ'}, has_type (Γ' ++ Γ) Σ t T.
  intros. induction Γ'.
  - simpl. auto.
  - replace ((a :: Γ') ++ Γ) with (a :: (Γ' ++ Γ)).
    apply weaken. auto. simpl. auto.
Qed.

Lemma weaken_stp_store : forall {Γ Σ T1 T2}, stp Γ Σ T1 T2 -> forall {Σ'}, Σ' ⊇ Σ -> stp Γ Σ' T1 T2.
  intros Γ Σ T1 T2 HST. induction HST; intuition.
Qed.

Lemma weaken_store : forall {Γ Σ t T}, has_type Γ Σ t T -> forall {Σ'}, Σ' ⊇ Σ -> has_type Γ Σ' t T.
  intros Γ Σ t T HT. induction HT; intros; intuition.
  - apply t_abs. eapply closed_tm_monotone; eauto. apply extends_length. auto.
    apply IHHT. auto.
  - eapply t_app. eapply IHHT1; auto. eapply IHHT2; auto.
  - eapply t_loc. unfold extends in H0. destruct H0. rewrite H0.
    rewrite indexr_skips. auto. eapply indexr_var_some'. eauto.
  - eapply t_assign. eapply IHHT1; auto. eapply IHHT2; auto.
  - eapply t_sub; eauto. eapply weaken_stp_store; eauto.
Qed.

(* canonical forms *)
Lemma canonical_unit : forall {Σ t}, has_type [] Σ t TUnit -> value t -> t = tunit.
  intros. remember [] as Γ. remember TUnit as T. induction H; intuition; try discriminate;
                                                   inversion H0; subst; auto.
  all: inversion H1; subst; intuition.
Qed.

Lemma canonical_fun : forall {Σ t T1 T2}, has_type [] Σ t (TFun T1 T2) -> value t -> exists t', t = (tabs t').
  intros. remember [] as Γ. remember (TFun T1 T2) as T. induction H; intuition; try discriminate;
                                                          inversion H0; subst.
  - exists t. auto.
  - exists t. auto.
  - apply typ_inv_unit in H. subst. inversion H1.
  - apply typ_inv_loc in H. repeat destruct H. inversion H3. subst. inversion H1.
Qed.

Lemma canonical_ref : forall {Σ t T}, has_type [] Σ t (TRef T) -> value t -> exists l, t = &l.
  intros. remember [] as Γ. remember (TRef T) as R. induction H; intuition; try discriminate;
                                                          inversion H0; subst.
  - exists l. auto.
  - apply typ_inv_abs in H. destruct H as [T2 [T3 [Hc [Ht Hstp]]]].
    inversion Hstp. subst. inversion H1.
  - apply typ_inv_unit in H. subst. inversion H1.
  - exists l. auto.
Qed.

Lemma narrowing_stp_gen : forall{Γ1 U Γ2 Σ T1 T2}, stp (Γ1 ++ U :: Γ2) Σ T1 T2 -> forall {V}, stp Γ2 Σ V U -> stp (Γ1 ++ V :: Γ2) Σ T1 T2.
  intros Γ1 U Γ2 Σ T1 T2 HST. remember (Γ1 ++ U :: Γ2) as Γ. generalize dependent Γ1; induction HST; intros; subst; intuition.
Qed.

Lemma narrowing_stp : forall{Γ U Σ T1 T2}, stp (U :: Γ) Σ T1 T2 -> forall {V}, stp Γ Σ V U -> stp (V :: Γ) Σ T1 T2.
  intros. specialize (@narrowing_stp_gen [] U Γ Σ T1 T2) as narrow. simpl in *. eapply narrow; eauto.
Qed.

Lemma narrowing_gen : forall{Γ1 U Γ2 Σ t T}, has_type (Γ1 ++ U :: Γ2) Σ t T -> forall {V}, stp Γ2 Σ V U -> has_type (Γ1 ++ V :: Γ2) Σ t T.
  intros Γ1 U Γ2 Σ t T HT. remember (Γ1 ++ U :: Γ2) as Γ. generalize dependent Γ1; induction HT; intros; subst; intuition.
  - destruct (PeanoNat.Nat.lt_trichotomy x (length Γ2)) as [Hlen | [Hlen | Hlen] ].
    + apply t_var. rewrite <- (indexr_insert_lt Hlen). rewrite <- (indexr_insert_lt Hlen) in H. auto.
    + rewrite Hlen in *. rewrite indexr_insert in H. inversion H. subst.
      apply (t_sub _ _ $(length Γ2) V T). apply t_var. rewrite indexr_insert. auto. eapply weaken_stp_gen.
      apply weaken_stp'. auto.
    + inversion Hlen. apply t_var. rewrite <- indexr_insert_ge; eauto. rewrite <- H1 in H.
      rewrite <- indexr_insert_ge in H; eauto. rewrite <- H2 in H.
      apply t_var. rewrite <- indexr_insert_ge; eauto. rewrite <- indexr_insert_ge in H; eauto. lia. lia.
  - apply t_abs. replace (length (Γ1 ++ V :: Γ2)) with (length (Γ1 ++ U :: Γ2)). auto.
    repeat rewrite app_length. simpl. auto.
    replace (T1 :: TFun T1 T2 :: Γ1 ++ V :: Γ2) with ((T1 :: TFun T1 T2 :: Γ1) ++ V :: Γ2); intuition.
    replace (open_tm' (Γ1 ++ V :: Γ2) t) with (open_tm' (Γ1 ++ U :: Γ2) t); eauto.
    unfold open_tm'. repeat rewrite app_length. simpl. auto.
  - eapply t_app. eapply IHHT1; eauto. eapply IHHT2; eauto.
  - eapply t_assign. eapply IHHT1; eauto. eapply IHHT2; eauto.
  - eapply t_sub; eauto. eapply narrowing_stp_gen; eauto.
Qed.

Lemma narrowing : forall{Γ U Σ t T}, has_type (U :: Γ) Σ t T -> forall {V}, stp Γ Σ V U -> has_type (V :: Γ) Σ t T.
  intros. specialize (@narrowing_gen [] U Γ Σ t T) as narrow. simpl in *. eapply narrow; eauto.
Qed.

Lemma strengthen_stp : forall {Γ1 T1 Γ2 Σ T2 T3}, stp (Γ1 ++ T1 :: Γ2) Σ T2 T3 -> stp (Γ1 ++ Γ2) Σ T2 T3.
  intros Γ1 T1 Γ2 Σ T2 T3 HST. induction HST; intuition.
Qed.

(* This pops up in the general substitution lemma when we deal with lambdas. *)
Lemma substitution_closed :  forall {k t b m n l i j}, tm_size t < k -> i <> j ->
    closed_tm (S (S b)) (m + S (S n)) l (open_rec_tm (S (S j)) $(S n) (open_rec_tm (S (S i)) $n (splice (S n) (splice n t)))) ->
    forall {tx tf}, closed_tm 0 n l tx -> closed_tm 0 n l tf ->
               closed_tm (S (S b)) (m + n) l (open_rec_tm (S (S j)) tx (open_rec_tm (S (S i)) tf t)).
  induction k; try lia; destruct t; intros; simpl in *; try solve [inversion H1; subst; constructor; auto; eapply IHk; eauto; lia].
  destruct v. simpl in *. constructor. destruct (le_lt_dec n i0) eqn:Hlt.
  replace (splice (S n) $(S i0)) with (tvar $(S (S i0))) in H1.
  simpl in *. inversion H1. subst. lia. unfold splice. destruct (le_lt_dec (S n) (S i0)). auto. lia. lia.
  simpl in *. destruct i0 eqn:Hi0. simpl in *. inversion H1. subst. intuition.
  destruct i1 eqn:Hi1. simpl. inversion H1. subst. intuition.
  destruct (PeanoNat.Nat.eqb i n0) eqn:Hin0. simpl in *. erewrite closed_tm_open_id; eauto.
  eapply closed_tm_monotone; eauto; lia. lia. simpl in *.
  destruct (PeanoNat.Nat.eqb j n0) eqn:Hjn0. eapply closed_tm_monotone; eauto. lia.
  inversion H1. subst. intuition. inversion H1. subst. intuition.
Qed.

Lemma substitution_gen : forall{n t}, tm_size t < n ->
    forall {Γ' Tf Tx Γ Σ T i j}, has_type (Γ' ++ Tx :: Tf :: Γ) Σ (open_rec_tm j $(S (length Γ)) (open_rec_tm i $(length Γ) (splice (S (length Γ)) (splice (length Γ) t)))) T -> i <> j ->
                        forall {tf}, has_type Γ Σ tf Tf ->
                        forall {tx}, has_type Γ Σ tx Tx ->
                                has_type (Γ' ++ Γ) Σ (open_rec_tm j tx (open_rec_tm i tf t)) T.
  induction n; try lia; destruct t; intros; simpl in *.
  - apply typ_inv_unit in H0. subst. intuition.
  - destruct v.
    + destruct (le_lt_dec (length Γ) i0) eqn:Hle.
      * replace (splice (S (length Γ)) (tvar $(S i0))) with (tvar $(S (S i0))) in H0.
        simpl in *. apply typ_inv_varf in H0. destruct H0 as [U [Hl Hstp]]. apply (t_sub _ _ _ U T).
        apply t_var. erewrite indexr_insert_ge; eauto. erewrite indexr_insert_ge; eauto. simpl. lia.
        eapply strengthen_stp; eauto. eapply strengthen_stp; eauto.
        unfold splice. destruct (le_lt_dec (S (length Γ)) (S i0)) eqn:Heq. auto. lia.
      * erewrite splice_id in H0; intuition. simpl in *.
        apply typ_inv_varf in H0. destruct H0 as [U [Hl Hstp]]. apply (t_sub _ _ _ U T).
        apply t_var. erewrite indexr_insert_lt; eauto. erewrite indexr_insert_lt; eauto. simpl. lia.
        eapply strengthen_stp; eauto. eapply strengthen_stp; eauto.
        Unshelve. auto. auto.
    + simpl in *. destruct (Nat.eqb i i0) eqn:Heq; simpl in *.
      * apply typ_inv_varf in H0. destruct H0 as [U [Hl Hstp]].
        replace (Γ' ++ Tx :: Tf :: Γ) with ((Γ' ++ [Tx]) ++ Tf :: Γ) in Hl.
        rewrite indexr_insert in Hl. inversion Hl. subst. pose (Hc := H2). apply has_type_closed in Hc.
        erewrite closed_tm_open_id; eauto. apply (t_sub _ _ _ U T).
        eapply weaken'; eauto. eapply strengthen_stp; eauto. eapply strengthen_stp; eauto. lia.
        rewrite <- app_assoc. auto.
      * destruct (Nat.eqb j i0) eqn:Heqj. apply typ_inv_varf in H0. destruct H0 as [U [Hl Hstp]].
        replace (S (length Γ)) with (length (Tf :: Γ)) in Hl; eauto.
        rewrite indexr_insert in Hl. inversion Hl. subst. pose (Hc := H3). apply has_type_closed in Hc.
        apply (t_sub _ _ _ U T). eapply weaken'; eauto. eapply strengthen_stp; eauto. eapply strengthen_stp; eauto.
        apply bound_vars_untypable in H0. contradiction.
  - specialize (has_type_closed H2) as Hcltf. specialize (has_type_closed H3) as Hcltx.
    apply typ_inv_abs in H0. destruct H0 as [T3 [T4 [Hc [HTt Hstp]]]]. inversion Hstp. subst.
    apply (t_sub _ _ _ (TFun T3 T4) (TFun T0 T5)). apply t_abs.
    rewrite app_length in *. simpl in *.
    eapply substitution_closed; eauto.
    (* We must swap the openings in the subject so that the IHn on the body t becomes applicable. *)
    unfold open_tm' in *.
    erewrite open_rec_tm_commute' with (t':=tx); eauto. erewrite open_rec_tm_commute' with (t':=tx); eauto.
    erewrite open_rec_tm_commute' with (t':=tf); eauto. erewrite open_rec_tm_commute' with (t':=tf); eauto.
    replace (T3 :: TFun T3 T4 :: Γ' ++ Γ) with ((T3 :: TFun T3 T4 :: Γ') ++ Γ); eauto.
    replace (T3 :: TFun T3 T4 :: Γ' ++ Tx :: Tf :: Γ) with ((T3 :: TFun T3 T4 :: Γ') ++ Tx :: Tf :: Γ) in HTt; eauto.
    eapply IHn; eauto. rewrite <- open_preserves_size. rewrite <- open_preserves_size. lia.
    (* Then, shuffle around the openings/splicings so that they match HTt:*)
    rewrite app_length in *. simpl in *.
    replace (S (length Γ' + length Γ)) with ((S (length Γ')) + length Γ); eauto.
    rewrite splice_open. rewrite splice_open.
    replace (S (S (length Γ') + length Γ)) with (S (length Γ') + (S (length Γ))); eauto.
    rewrite splice_open.
    replace (S (length Γ' + length Γ)) with ((length Γ') + (S (length Γ))); eauto.
    rewrite splice_open.
    erewrite <- open_rec_tm_commute' with (t':=$(length Γ)); intuition.
    erewrite <- open_rec_tm_commute' with (t':=$(length Γ)); intuition.
    erewrite <- open_rec_tm_commute' with (t':=$(S (length Γ))); intuition.
    erewrite <- open_rec_tm_commute' with (t':=$(S (length Γ))); intuition.
    replace (S (S (length Γ') + S (length Γ))) with (S (length Γ' + S (S (length Γ)))); eauto.
    replace (S (length Γ' + S (length Γ))) with (length Γ' + S (S (length Γ))).
    apply HTt. auto. lia. eapply strengthen_stp. eapply strengthen_stp; eauto. Unshelve.
    all: auto.
  - apply typ_inv_app in H0. destruct H0 as [T3 [Hfun Harg]].
    apply (t_app _ _ _ _ T3 T). eapply IHn; eauto. lia. eapply IHn; eauto. lia.
  - apply typ_inv_loc in H0. destruct H0 as [U [Hl Hstp]]. inversion Hstp. subst.
    apply t_loc. auto.
  - apply typ_inv_ref in H0. destruct H0 as [U [Heq HTU]]. subst. apply t_ref.
    eapply IHn; eauto. lia.
  - apply typ_inv_deref in H0. destruct H0 as [U [HTU Hstp]].
    apply (t_sub _ _ _ U T). apply t_deref. eapply IHn; eauto. lia.
    eapply strengthen_stp; eauto. eapply strengthen_stp; eauto.
  - apply typ_inv_assign in H0. destruct H0 as [Heq [U [HTlhs HTrhs]]]. subst.
    apply t_assign with (T:=U); eapply IHn; eauto; lia.
Qed.

Lemma substitution : forall{Γ Tf Tx T Σ t},
    closed_tm 2 (length Γ) (length Σ) t ->
    has_type (Tx :: Tf :: Γ) Σ (open_tm' Γ t) T ->
    forall {tf}, has_type Γ Σ tf Tf -> forall {tx}, has_type Γ Σ tx Tx -> has_type Γ Σ (open_tm tf tx t) T.
  intros. unfold open_tm' in *. unfold open_tm in *. replace Γ with ([] ++ Γ); eauto.
  eapply substitution_gen; eauto. erewrite (@splice_id t); eauto. erewrite splice_id; eauto.
  eapply closed_tm_monotone; eauto; lia.
Qed.

Definition CtxOK (Γ : tenv) (Σ : senv) (σ : store) : Prop :=
  length Σ = length σ /\ forall l v T, indexr l Σ = Some T -> indexr l σ = Some v -> value v /\ has_type Γ Σ v T.

Lemma CtxOK_ext : forall {Γ Σ σ}, CtxOK Γ Σ σ -> forall {v T}, has_type Γ Σ v T -> value v -> CtxOK Γ (T :: Σ) (v :: σ).
  intros. unfold CtxOK in *. split. simpl. lia.
  intros. destruct H as [Hlen Hprev]. destruct (beq_nat l (length σ)) eqn:Heql.
  + simpl in *. rewrite Heql in *. inversion H3. subst.
    rewrite <- Hlen in Heql. rewrite Heql in H2. inversion H2. subst. intuition.
    eapply weaken_store; eauto. apply extends_cons.
  + simpl in *. rewrite Heql in *. rewrite <- Hlen in Heql. rewrite Heql in H2.
    specialize (Hprev _ _ _ H2 H3) as Hprev. intuition.
    eapply weaken_store; eauto. apply extends_cons.
Qed.

Lemma CtxOK_update : forall {Γ Σ σ}, CtxOK Γ Σ σ -> forall {l T}, l < length σ -> indexr l Σ = Some T -> forall {v}, has_type Γ Σ v T -> value v -> CtxOK Γ Σ (update σ l v).
  intros. unfold CtxOK in *. destruct H as [Hlen Hprev].
  split. rewrite <- update_length. auto.
  intros. destruct (Nat.eqb l l0) eqn:Heq.
  - apply beq_nat_true in Heq. subst.
    apply (@update_indexr_hit σ l0 v) in H0. rewrite H1 in H. inversion H. subst.
    rewrite H4 in H0. inversion H0. subst. intuition.
  - apply beq_nat_false in Heq. apply (@update_indexr_miss σ l v l0) in Heq.
    rewrite Heq in H4. eapply Hprev; eauto.
Qed.

Lemma progress : forall {Σ t T}, has_type [] Σ t T -> value t \/ forall {σ}, CtxOK [] Σ σ -> exists t' σ', step t σ t' σ'.
  intros Σ t T HT. remember [] as Γ; induction HT; subst; try solve [left; constructor].
  - inversion H.
  - (*tapp*) right; intuition.
    + specialize (canonical_fun HT1 H1) as Hlam. destruct Hlam as [t' Heq]. subst.
      exists (open_tm (tabs t') t2 t'). exists σ. constructor. auto.
    + apply H1 in H. destruct H as [t' [σ' Hstep]]. exists (tapp t' t2). exists σ'. constructor. auto.
    + apply H0 in H. destruct H as [t' [σ' Hstep]]. exists (tapp t1 t'). exists σ'. constructor; auto.
    + apply H1 in H. destruct H as [t' [σ' Hstep]]. exists (tapp t' t2). exists σ'. constructor. auto.
  - (*tref*) right; intuition.
    + exists &(length σ). exists (t :: σ). constructor. auto.
    + apply H0 in H. destruct H as [t' [σ' Hstep]]. exists (tref t'). exists σ'. constructor. auto.
  - (*tderef*) right; intuition.
    + specialize (canonical_ref HT H0) as Hc. destruct Hc as [l Heq]. subst.
      apply typ_inv_loc in HT. destruct HT as [U [Hlookup Hstp]].
      pose (Hl:=Hlookup).
      unfold CtxOK in H. intuition. apply indexr_var_some' in Hl.
      rewrite H1 in Hl. rewrite <- indexr_var_some in Hl.
      destruct Hl as [v Hl]. exists v. exists σ. constructor. auto.
      specialize (H2 l v U Hlookup Hl). intuition.
    + apply H0 in H. destruct H as [t' [σ' Hstep]]. exists (tderef t'). exists σ'. constructor. auto.
  - (*tassign*) right; intuition.
    + specialize (canonical_ref HT1 H1) as Href. destruct Href as [l Heq]. subst.
      exists tunit. exists (update σ l t2). constructor. apply typ_inv_loc in HT1.
      destruct HT1 as [U [Hl Hstp]]. unfold CtxOK in H. intuition. rewrite <- H2.
      eapply indexr_var_some'. eauto. auto.
    + apply H1 in H. destruct H as [t' [σ' Hstep]]. exists (tassign t' t2). exists σ'. constructor. auto.
    + apply H0 in H. destruct H as [t' [σ' Hstep]]. exists (tassign t1 t'). exists σ'. constructor; auto.
    + apply H1 in H. destruct H as [t' [σ' Hstep]]. exists (tassign t' t2). exists σ'. constructor. auto.
  - (*tsub*) intuition.
Qed.

Lemma preservation : forall {Γ Σ t T}, has_type Γ Σ t T -> forall{σ}, CtxOK Γ Σ σ -> forall {t' σ'}, step t σ t' σ' -> exists Σ', Σ' ⊇ Σ /\ CtxOK Γ Σ' σ' /\ has_type Γ Σ' t' T .
  intros Γ Σ t T HT. induction HT; intros; try solve [inversion H0]; try solve [inversion H1].
  - (*tapp*) inversion H0; subst.
    + (*beta*) inversion H0; subst. pose (Ht2c := HT2). apply has_type_closed in Ht2c.
      * exists Σ. intuition. apply extends_refl.
        apply typ_inv_abs in HT1. destruct HT1 as [T3 [T4 [Hc [HTt Hstp]]]].
        inversion Hstp. subst.
        apply weaken_stp with (T' := TFun T3 T4) in H9.
        specialize (narrowing HTt H9) as HTt'.
        apply (t_sub _ _ _ T4 T2); eauto.
        eapply substitution; eauto.
        apply t_abs; eauto.
      * inversion H7.
      * specialize (values_stuck H6 H8) as Hsp. contradiction.
    + apply (IHHT1 σ H t1' σ') in H6. destruct H6 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition. eapply t_app; eauto. eapply weaken_store; eauto.
    + apply (IHHT2 σ H t2' σ') in H7. destruct H7 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition. eapply t_app; eauto. eapply weaken_store; eauto.
  - (* tref *) inversion H0; subst.
    + exists (T :: Σ). intuition. apply extends_cons. apply CtxOK_ext; auto.
      apply t_loc. unfold CtxOK in H. intuition. rewrite <- H1. apply indexr_head.
    + apply (IHHT σ H t'0 σ') in H2. destruct H2 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition.
  - (* tderef *) inversion H0; subst.
    + exists Σ. intuition. apply extends_refl. apply typ_inv_loc in HT. destruct HT as [U [Hlook Hstp]].
      unfold CtxOK in H. intuition. specialize (H4 _ _ _ Hlook H2). intuition.
      eapply t_sub. eauto. inversion Hstp. subst. apply stp_refl.
    + apply (IHHT σ H t'0 σ') in H2. destruct H2 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition.
  - (* tassign *) inversion H0; subst.
    + exists Σ. intuition. apply extends_refl. eapply CtxOK_update; eauto.
      apply typ_inv_loc in HT1. destruct HT1 as [U [Hl Hstp]].
      inversion Hstp. subst. auto.
    + apply (IHHT1 σ H t1' σ') in H6. destruct H6 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition. eapply t_assign; eauto. eapply weaken_store; eauto.
    + apply (IHHT2 σ H t2' σ') in H7. destruct H7 as [Σ' [Hext [HOK Ht']]].
      exists Σ'. intuition. eapply t_assign; eauto. eapply weaken_store; eauto.
  - (* tsub *) apply (IHHT σ H0 t' σ') in H1. destruct H1 as [Σ' [Hext [HOK Ht']]].
    exists Σ'. intuition. eapply t_sub; eauto. eapply weaken_stp_store; eauto.
Qed.


Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Ordinal.
Require Import Relation.
Require Import Ofe.
Require Import Syntax.
Require Import SimpSub.
Require Import Hygiene.
Require Import Uniform.
Require Import Urelsp.
Require Import Intensional.
Require Import Dynamic.
Require Import Equivalence.
Require Import Equivalences.
Require Import Candidate.
Require Import Model.
Require Import Ceiling.
Require Import Truncate.
Require Import Standard.
Require Import MapTerm.
Require Import Extend.
Require Import System.
Require Import Page.
Require Export PreSpacify.
Require Import Spaces.
Require Import SemanticsKnot.
Require Import ProperClosed.
Require Import ProperEquiv.
Require Import ProperFun.
Require Import ProperDownward.
Require Import ProperLevel.
Require Import Constructor.
Require Import Semantics.
Require Import SemanticsUniv.
Require Import SemanticsPi.
Require Import SemanticsFut.
Require Import SemanticsSimple.
Require Import SemanticsProperty.
Require Import SemanticsSigma.

Lemma interp_kext_kext :
  forall pg i K,
    level K <<= cin pg
    -> interp_kext pg i (kext stop K) (approx i K).
Proof.
intros pg i K Hlev.
so (le_ord_succ _ _ (le_ord_trans _#3 Hlev (cin_top pg))) as fit.
exists (expair K (space_inhabitant _)), fit.
do2 3 split; auto using kext_hygiene.
unfold kext.
unfold stop.
rewrite -> (lt_ord_dec_is _ _ fit).
apply star_refl.
Qed.

Lemma interp_uext_uext :
  forall pg i w (R : wurel w),
    w <<= cin pg
    -> interp_uext pg i (uext stop R) (ceiling (S i) (extend_urel w (cin pg) R)).
Proof.
intros pg i w R Hlev.
so (le_ord_succ _ _ (le_ord_trans _#3 Hlev (cin_top pg))) as fit.
exists w, (iubase R), fit.
do2 3 split; auto using uext_hygiene.
unfold uext.
unfold stop.
rewrite -> (lt_ord_dec_is _ _ fit).
apply star_refl.
Qed.

Local Ltac prove_hygiene :=
  repeat (first [ apply hygiene_shift_permit
                | apply hygiene_sumbool
                | apply hygiene_auto; cbn [row_rect nat_rect]; repeat2 split; auto
                ]);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1, fromsp_hygiene, tosp_hygiene, kext_hygiene, uext_hygiene, pagelit_closed;
  try (apply hygiene_var; cbn; auto; done).

Lemma cty_formation :
  forall pg i j a b,
    rel (univ_urel the_system i pg) j a b
    -> rel (con_urel pg (qtype (cin pg))) j (cty a) (cty b).
Proof.
intros pg i j a b Hab.
destruct Hab as (Hj & R & Ha & Hb).
rewrite -> sint_unroll in Ha, Hb.
cbn.
so (interp_level_internal _#5 (cin_stop pg) Ha) as (R' & ->).
unfold con_action.
cbn [approx].
exists R'.
split.
  {
  apply cinterp_eval_refl.
  apply interp_cty; auto.
  }

  {
  apply cinterp_eval_refl.
  apply interp_cty; auto.
  }
Qed.

Lemma con_formation :
  forall pg i lv lv' j a b,
    j <= i
    -> pginterp lv pg
    -> pginterp lv' pg
    -> rel (con_urel pg (qtype (cin pg))) j a b
    -> rel (univ_urel the_system i pg) j (con lv a) (con lv' b).
Proof.
intros pg i lv lv' j a b Hj Hlv Hlv' Hab.
destruct Hab as (R & Ha & Hb).
cbn [approx] in R, Ha, Hb.
split; auto.
unfold spcar in R; cbn [space] in R.
exists (extend_iurel (cin_stop pg) R).
rewrite -> sint_unroll.
split.
  {
  apply interp_eval_refl.
  apply interp_con; auto using le_page_refl.
  }

  {
  apply interp_eval_refl.
  apply interp_con; auto using le_page_refl.
  }
Qed.

Definition spacification pg i K A :=
  K = approx i K
  /\
  (forall j u v,
     j <= i
     -> j <= u
     -> j <= v
     -> rel (arrow_urel stop i (den A) (con_urel pg K)) j
          (tosp stop pg (approx u K)) (tosp stop pg (approx v K)))
  /\
  (forall j u v,
     j <= i
     -> j <= u
     -> j <= v
     -> rel (arrow_urel stop i (con_urel pg K) (den A)) j
          (fromsp stop pg (approx u K)) (fromsp stop pg (approx v K)))
  /\
  (forall j m p,
     j <= i
     -> rel (den A) j m p
     -> rel (den A) j (app (fromsp stop pg K) (app (tosp stop pg K) m)) p)
  /\
  (forall j a b,
     j <= i
     -> rel (con_urel pg K) j a b
     -> rel (con_urel pg K) j (app (tosp stop pg K) (app (fromsp stop pg K) a)) b).

Lemma spacify_main :
  forall pg s i k K,
    kinterp pg s i k K
    -> exists A, interp toppg s i k A /\ spacification pg i K A.
Proof.
exploit
  (semantics_ind the_system
     (fun pg s i k K =>
        exists A,
          interpv toppg s i k A
          /\
          (forall j u v,
             j <= i
             -> j <= u
             -> j <= v
             -> rel (arrow_urel stop i (den A) (con_urel pg K)) j
                  (tosp stop pg (approx u K)) (tosp stop pg (approx v K)))
          /\
          (forall j u v,
             j <= i
             -> j <= u
             -> j <= v
             -> rel (arrow_urel stop i (con_urel pg K) (den A)) j
                  (fromsp stop pg (approx u K)) (fromsp stop pg (approx v K)))
          /\
          (forall j m p,
             j <= i
             -> rel (den A) j m p
             -> rel (den A) j (app (fromsp stop pg K) (app (tosp stop pg K) m)) p)
          /\
          (forall j a b,
             j <= i
             -> rel (con_urel pg K) j a b
             -> rel (con_urel pg K) j (app (tosp stop pg K) (app (fromsp stop pg K) a)) b))
     (fun _ _ _ _ _ => True)
     (fun _ _ _ _ _ => True)
     (fun pg s i k K =>
        exists A,
          interp toppg s i k A
          /\
          (forall j u v,
             j <= i
             -> j <= u
             -> j <= v
             -> rel (arrow_urel stop i (den A) (con_urel pg K)) j
                  (tosp stop pg (approx u K)) (tosp stop pg (approx v K)))
          /\
          (forall j u v,
             j <= i
             -> j <= u
             -> j <= v
             -> rel (arrow_urel stop i (con_urel pg K) (den A)) j
                  (fromsp stop pg (approx u K)) (fromsp stop pg (approx v K)))
          /\
          (forall j m p,
             j <= i
             -> rel (den A) j m p
             -> rel (den A) j (app (fromsp stop pg K) (app (tosp stop pg K) m)) p)
          /\
          (forall j a b,
             j <= i
             -> rel (con_urel pg K) j a b
             -> rel (con_urel pg K) j (app (tosp stop pg K) (app (fromsp stop pg K) a)) b))
     (fun _ _ _ _ _ => True)
     (fun _ _ _ _ _ => True)
     (fun _ _ _ _ _ _ => True)) as Hind; auto.

(* unit *)
{
intros ps s i.
eexists.
do2 4 split.
  {
  apply interp_unit.
  }

  {
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; auto; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  exists tt.
  split; apply cinterp_eval_refl; apply interp_cunit.
  }

  {
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; auto; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  apply property_action_triv; auto.
  omega.
  }

  {
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  cbn in Hmp.
  destruct Hmp as (_ & _ & _ & _ & _ & Hp).
  cbn.
  do2 5 split; auto using star_refl.
  prove_hygiene.
  }

  {
  intros j a b Hj Hab.
  cbn [fromsp tosp].
  so (urel_closed _#5 Hab) as (Hcla & Hclb).
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv.
    {
    prove_hygiene.
    }
  destruct Hab as (R & Ha & Hb).
  cbn [approx] in R, Ha, Hb.
  exists R.
  split; auto.
  cbn in R.
  destruct R.
  apply cinterp_eval_refl.
  apply interp_cunit.
  }
}

(* type *)
{
intros pg s i lv Hintpg.
so (pginterp_str_top _ _ Hintpg) as Hstr.
so (pginterp_cex_top _ _ Hintpg) as Hcex.
so (pginterp_impl_pagelit _ _ Hintpg) as Hpg.
eexists.
do2 4 split.
  {
  apply interp_univ; eauto.
  }

  {
  intros u v w Hu Hv Hw.
  cbn [tosp approx].
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  eapply (cty_formation _ i); auto.
  }

  {
  intros u v w Hu Hv Hw.
  cbn [fromsp approx].
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  apply con_formation; simpsub; auto.
  omega.
  }

  {
  intros j m p Hj Hmp.
  cbn [fromsp tosp].
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_con; [apply equiv_refl |].
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  cbn in Hmp.
  destruct Hmp as (_ & R & Hm & Hp).
  cbn.
  split; auto.
  exists R.
  split; auto.
  rewrite -> sint_unroll in Hm |- *.
  so (interp_level_internal _#5 (cin_stop pg) Hm) as (R' & ->).
  apply interp_eval_refl.
  apply interp_con; auto using le_page_refl.
  apply cinterp_eval_refl.
  apply interp_cty; auto.
  }

  {
  intros j a b Hj Hab.
  cbn [fromsp tosp].
  so (urel_closed _#5 Hab) as (Hcla & Hclb).
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_cty.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv.
    {
    prove_hygiene.
    }
  destruct Hab as (R & Ha & Hb).
  cbn [approx] in R, Ha, Hb.
  exists R.
  split; auto.
  apply cinterp_eval_refl.
  apply interp_cty.
  apply interp_eval_refl.
  apply interp_con; auto using le_page_refl.
  }
}

(* karrow *)
{
intros pg s i k l K L Hk IH1 Hl IH2.
destruct IH1 as (A & HintA & IH1a & IH1b & IH1c & IH1d).
destruct IH2 as (B & HintB & IH2a & IH2b & IH2c & IH2d).
so (kinterp_level_bound _#5 Hk) as HlevK.
so (kinterp_level_bound _#5 Hl) as HlevL.
eexists.
do2 4 split.
  {
  apply interp_karrow_type; eauto.
  }

  (* karrow tosp *)
  {
  clear IH1a IH1c IH1d IH2b IH2c IH2d.
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; try prove_hygiene.
  intros j p q Hj Hpq.
  simpsub.
  so (urel_closed _#5 Hpq) as (Hclp & Hclq).
  apply con_urel_raise.
  cbn [approx].
  apply clam_formation; auto using interp_kext_kext.
    {
    symmetry.
    apply approx_idem.
    }

    {
    relquest.
      {
      apply interp_kext_kext.
      eapply le_ord_trans; eauto using approx_level.
      }
    rewrite -> approx_combine_le; auto.
    omega.
    }

    {
    relquest.
      {
      apply interp_kext_kext.
      eapply le_ord_trans; eauto using approx_level.
      }
    rewrite -> approx_combine_le; auto.
    omega.
    }
  intros j' c d Hj' Hcd.
  simpsub.
  assert (j' <= u) as Hj'_u by omega.
  apply con_urel_raise.
  rewrite -> approx_combine_le; auto.
  apply con_urel_lower.
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_u (IH2a u v w Hu Hv Hw)) _).
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj' Hpq) _).
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_u (IH1b u v w Hu Hv Hw)) _).
  apply con_urel_raise.
  so (con_urel_lower _#5 Hcd) as H.
  rewrite -> approx_combine_le in H; auto.
  }

  (* karrow fromsp *)
  {
  clear IH1b IH1c IH1d IH2a IH2c IH2d.
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; try prove_hygiene.
  intros j m n Hj Hmn.
  simpsub.
  so (urel_closed _#5 Hmn) as (Hclm & Hcln).
  apply arrow_action_lam; try prove_hygiene.
    {
    omega.
    }
  intros j' p q Hj' Hpq.
  simpsub.
  assert (j' <= u) as Hj'_u by omega.
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_u (IH2b u v w Hu Hv Hw)) _).
  apply (capp_formation _ K).
    {
    apply (urel_downward_leq _#3 j); auto.
    }
  exact (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_u (IH1a u v w Hu Hv Hw)) Hpq).
  }

  (* karrow beta *)
  {
  clear IH1d IH2d.
  so (IH1a i i i (le_refl _) (le_refl _) (le_refl _)) as IH1ai.
  so (IH1b i i i (le_refl _) (le_refl _) (le_refl _)) as IH1bi.
  so (IH2a i i i (le_refl _) (le_refl _) (le_refl _)) as IH2ai.
  so (IH2b i i i (le_refl _) (le_refl _) (le_refl _)) as IH2bi.
  rewrite <- (kbasic_impl_approx _#6 Hk) in IH1ai, IH1bi.
  rewrite <- (kbasic_impl_approx _#6 Hl) in IH2ai, IH2bi.
  clear IH1a IH1b IH2a IH2b.
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  cbn [fromsp tosp].
  rewrite -> den_iuarrow.
  match goal with
  | |- rel _ _ ?X _ =>
      eassert (equiv X _) as Hequiv
  end.
    {
    eapply equiv_trans.
      {
      apply steps_equiv.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    eapply equiv_trans.
      {
      apply equiv_lam.
      apply equiv_app; [apply equiv_refl |].
      apply equiv_capp; [| apply equiv_refl].
      apply steps_equiv.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    replace (1 + 1) with 2 by omega.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ (equiv_symm _#3 Hequiv) _).
    {
    prove_hygiene.
    }
  clear Hequiv.
  refine (arrow_action_lam1 _#8 _ Hmp _).
    {
    prove_hygiene.
    }
  intros j' n q Hj' Hnq.
  simpsub.
  so (le_trans _#3 Hj' Hj) as Hj'_i.
  so (IH1c j' n q Hj'_i Hnq) as Hetan_q.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj' Hmp) Hetan_q) as Hmetan_pq.
  so (IH2c j' _ _ Hj'_i Hmetan_pq) as Hetametan_pq.
  exploit (capp_clam_beta_double pg (approx j' K) (approx j' L) j' (kext stop K)
             (app (tosp stop pg L) (app (subst sh1 m) (app (fromsp stop pg K) (var 0))))
             (app (tosp stop pg L) (app (subst sh1 p) (app (fromsp stop pg K) (var 0))))
             (app (tosp stop pg K) n)
             (app (tosp stop pg K) q)) as H.
    {
    symmetry.
    apply approx_idem.
    }

    {
    apply interp_kext_kext; auto.
    }

    {
    intros j'' c d Hj'' Hcd.
    simpsub.
    so (le_trans _#3 Hj'' Hj'_i) as Hj''_i.
    apply con_urel_raise.
    rewrite -> approx_combine_le; auto.
    apply con_urel_lower.
    refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj''_i IH2ai) _).
    refine (arrow_action_app _#9 (urel_downward_leq _#6 (le_trans _#3 Hj'' Hj') Hmp) _).
    refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj''_i IH1bi) _).
    so (con_urel_lower _#5 Hcd) as H.
    rewrite -> approx_combine_le in H; auto.
    apply con_urel_raise; auto.
    }

    {
    apply con_urel_lower.
    exact (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_i IH1ai) Hnq).
    }
  simpsubin H.
  so (con_urel_raise _#5 (H andel)) as Hredex.
  so (con_urel_raise _#5 (H ander)) as Hcontractum.
  clear H.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_i IH2bi) Hredex) as Hfromredex.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_i IH2bi) Hcontractum) as Hfromcontractum.
  exact (urel_zigzag _#7 Hfromredex Hfromcontractum Hetametan_pq).
  }

  (* karrow eta *)
  {
  clear IH1a IH1b IH1c IH2a IH2b IH2c.
  intros j a b Hj Hab.
  so (urel_closed _#5 Hab) as (Hcla & Hclb).
  cbn [tosp fromsp].
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    apply equiv_clam; [apply equiv_refl |].
    apply equiv_app; [apply equiv_refl |].
    eapply equiv_trans.
      {
      apply equiv_app; [| apply equiv_refl].
      eapply equiv_trans.
        {
        apply steps_equiv.
        apply star_one.
        apply step_app2.
        }
      simpsub.
      replace (1 + 1) with 2 by omega.
      apply equiv_refl.
      }
    eapply equiv_trans.
      {
      apply steps_equiv.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  clear Hequiv.
  so (con_urel_lower _#5 Hab) as H.
  cbn in H.
  so (clam_capp_eta _#7 (eqsymm (approx_idem _ _)) (interp_kext_kext pg j K HlevK) H) as H12; clear H.
  exploit (clam_formation pg (approx j K) (approx j L) j (kext stop K) (kext stop K) (capp (subst sh1 a) (var 0)) (capp (subst sh1 b) (var 0))) as H13; auto using interp_kext_kext.
    {
    symmetry.
    apply approx_idem.
    }

    {
    intros j' c d Hj' Hcd.
    simpsub.
    apply con_urel_lower'; auto.
    apply (capp_formation _ K).
      {
      eapply urel_downward_leq; eauto.
      }

      {
      apply (con_urel_raise' _#6 Hj'); auto.
      }
    }
  exploit (clam_formation pg (approx j K) (approx j L) j (kext stop K) (kext stop K) (app (tosp stop pg L) (app (fromsp stop pg L) (capp (subst sh1 a) (app (tosp stop pg K) (app (fromsp stop pg K) (var 0)))))) (capp (subst sh1 b) (var 0))) as H43; auto using interp_kext_kext.
    {
    symmetry.
    apply approx_idem.
    }

    {
    intros j' c d Hj' Hcd.
    simpsub.
    apply con_urel_lower'; auto.
    apply IH2d; [omega |].
    apply (capp_formation _ K); eauto using urel_downward_leq.
    apply IH1d; [omega |].
    apply (con_urel_raise' _#3 j); auto.
    }
  so (urel_zigzag _#7 H43 H13 H12) as H.
  apply con_urel_raise.
  exact H.
  }
}

(* ktarrow *)
{
intros pg s i a k A K Ha _ Hk IH.
destruct IH as (B & HintB & IHa & IHb & IHc & IHd).
so (kinterp_level_bound _#5 Hk) as HlevK.
set (l := cin pg) in *.
set (fit := cin_stop pg) in *.
so (le_ord_succ _ _ (le_ord_trans _#3 HlevK (cin_top pg))) as kfit.
change (level K << stop) in kfit.
eexists.
do2 4 split.
  {
  apply interp_arrow; eauto.
  exact (interp_increase _#6 (toppg_max pg) Ha).
  }

  (* ktarrow tosp *)
  {
  clear IHb IHc IHd.
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  apply con_urel_raise.
  cbn [approx].
  rewrite <- den_iutruncate.
  assert (interp_uext pg j (uext stop (den A)) (den (iutruncate (S j) A))) as Huext.
    {
    so (interp_uext_uext pg j l (den A) (le_ord_refl _)) as H.
    rewrite -> extend_urel_id in H.
    rewrite -> den_iutruncate.
    exact H.
    }
  apply ctlam_formation; auto using interp_kext_kext; try prove_hygiene.
    {
    relquest.
      {
      apply interp_uext_uext.
      apply le_ord_refl.
      }
    rewrite -> den_iutruncate.
    rewrite -> extend_urel_id.
    rewrite -> ceiling_combine_le; auto.
    omega.
    }

    {
    relquest.
      {
      apply interp_uext_uext.
      apply le_ord_refl.
      }
    rewrite -> den_iutruncate.
    rewrite -> extend_urel_id.
    rewrite -> ceiling_combine_le; auto.
    omega.
    }

    {
    relquest.
      {
      apply interp_kext_kext.
      eapply le_ord_trans; eauto using approx_level.
      }
    rewrite -> approx_combine_le; auto.
    omega.
    }

    {
    relquest.
      {
      apply interp_kext_kext.
      eapply le_ord_trans; eauto using approx_level.
      }
    rewrite -> approx_combine_le; auto.
    omega.
    }
  intros j' n q Hnq.
  simpsub.
  rewrite -> den_iutruncate in Hnq.
  destruct Hnq as (H & Hnq).
  assert (j' <= j) as Hj' by omega; clear H.
  apply con_urel_lower'; auto.
  refine (arrow_action_app _#9 (urel_downward_leq _#6 (le_trans _#3 Hj' Hj) (IHa u v w Hu Hv Hw)) _).
  apply (arrow_action_app stop i (extend_urel _ _ (den A))); auto.
  exact (urel_downward_leq _#6 Hj' Hmp).
  }

  (* ktarrow fromsp *)
  {
  clear IHa IHc IHd.
  intros u v w Hu Hv Hw.
  cbn [fromsp approx].
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  rewrite -> den_iuarrow.
  apply arrow_action_lam; try prove_hygiene.
    {
    omega.
    }
  intros j' n q Hj' Hnq.
  simpsub.
  refine (arrow_action_app _#9 (urel_downward_leq _#6 (le_trans _#3 Hj' Hj) (IHb u v w Hu Hv Hw)) _).
  apply (ctapp_formation _ (den A)).
    {
    exact (urel_downward_leq _#6 Hj' Hmp).
    }

    {
    exact Hnq.
    }
  }

  (* ktarrow beta *)
  {
  so (IHa i i i (le_refl _) (le_refl _) (le_refl _)) as IHai.
  so (IHb i i i (le_refl _) (le_refl _) (le_refl _)) as IHbi.
  rewrite <- (kbasic_impl_approx _#6 Hk) in IHai, IHbi.
  clear IHa IHb IHd.
  intros j m p Hj Hmp.
  rewrite -> den_iuarrow in Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  rewrite -> den_iuarrow.
  rewrite -> den_extend_iurel.
  cbn [fromsp tosp].
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_lam.
    apply equiv_app; [apply equiv_refl |].
    apply equiv_ctapp; [| apply equiv_refl].
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    replace (1 + 1) with 2 by omega.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv.
    {
    prove_hygiene.
    }
  apply (arrow_action_lam1 _#6 m); auto.
    {
    prove_hygiene.
    }
  intros j' n q Hj' Hnq.
  simpsub.
  exploit (ctapp_ctlam_beta_double pg (ceiling (S j') (den A)) (approx j' K) j' (uext stop (den A))
             (app (tosp stop pg K) (app (subst sh1 m) (var 0)))
             (app (tosp stop pg K) (app (subst sh1 p) (var 0)))
             (kext stop K)
             n q); auto using interp_kext_kext; try prove_hygiene.
    {
    so (interp_uext_uext pg j' l (den A) (le_ord_refl _)) as H.
    rewrite -> extend_urel_id in H.
    exact H.
    }

    {
    intros j'' r t Hrt.
    simpsub.
    destruct Hrt as (H & Hrt).
    assert (j'' <= j') as Hj'' by omega; clear H.
    assert (j'' <= i) as Hj''_i by omega.
    apply con_urel_lower'; auto.
    refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj''_i IHai) _).
    exact (arrow_action_app _#9 (urel_downward_leq _#6 (le_trans _#3 Hj'' Hj') Hmp) Hrt).
    }

    {
    split; auto.
    }
  simpsubin H.
  destruct H as (H1 & H2).
  so (con_urel_raise _#5 H1) as Hredex.
  so (con_urel_raise _#5 H2) as Hcontractum.
  clear H1 H2.
  assert (j' <= i) as Hj'_i by omega.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_i IHbi) Hredex) as H.
  renameover H into Hredex.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj'_i IHbi) Hcontractum) as H.
  renameover H into Hcontractum.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj' Hmp) Hnq) as Hmn_pq.
  so (IHc _#3 Hj'_i Hmn_pq) as H.
  exact (urel_zigzag _#7 Hredex Hcontractum H).
  }

  (* ktarrow eta *)
  {
  clear IHa IHb IHc.
  intros j b c Hj Hbc.
  so (urel_closed _#5 Hbc) as (Hb & Hc).
  cbn [tosp fromsp].
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_ctlam; [apply equiv_refl | | apply equiv_refl].
    apply equiv_app; [apply equiv_refl |].
    eapply equiv_trans.
      {
      apply equiv_app; [| apply equiv_refl].
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv.
    {
    prove_hygiene.
    }
  so (interp_uext_uext pg j l (den A) (le_ord_refl _)) as Huext.
  rewrite -> extend_urel_id in Huext.
  so (con_urel_lower _#5 Hbc) as H.
  cbn [approx] in H.
  so (ctlam_ctapp_eta _#8 (interp_kext_kext pg j K HlevK) Huext H) as Heta; clear H.
  change (rel (con_urel pg (approx j (qtarrow (cin pg) (den A) K))) j (ctlam (uext stop (den A)) (ctapp (subst sh1 b) (var 0)) (kext stop K)) c) in Heta.
  so (con_urel_raise _#5 Heta) as H; renameover H into Heta.
  refine (urel_zigzag _#4 (ctlam (uext stop (den A)) (ctapp (subst sh1 c) (var 0)) (kext stop K)) _ _ _ _ Heta).
    {
    apply con_urel_raise.
    cbn [approx].
    apply ctlam_formation; auto using interp_kext_kext; try prove_hygiene.
    intros j' m p Hmp.
    simpsub.
    so Hmp as (H & _).
    assert (j' <= j) as Hj' by omega; clear H.
    apply con_urel_lower'; auto.
    apply IHd.
      {
      omega.
      }
    apply (ctapp_formation _ (den A)).
      {
      eapply urel_downward_leq; eauto.
      }

      {
      exact (Hmp ander).
      }
    }

    {
    apply con_urel_raise.
    cbn [approx].
    apply ctlam_formation; auto using interp_kext_kext; try prove_hygiene.
    intros j' m p Hmp.
    simpsub.
    so Hmp as (H & _).
    assert (j' <= j) as Hj' by omega; clear H.
    apply con_urel_lower'; auto.
    apply (ctapp_formation _ (den A)).
      {
      eapply urel_downward_leq; eauto.
      }

      {
      exact (Hmp ander).
      }
    }
  }
}

(* kprod *)
{
intros pg s i k l K L Hk IH1 Hl IH2.
destruct IH1 as (A & HintA & IH1a & IH1b & IH1c & IH1d).
destruct IH2 as (B & HintB & IH2a & IH2b & IH2c & IH2d).
so (kinterp_level_bound _#5 Hk) as HlevK.
so (kinterp_level_bound _#5 Hl) as HlevL.
eexists.
do2 4 split.
  {
  apply interp_prod; eauto.
  }

  (* kprod tosp *)
  {
  clear IH1b IH1c IH1d IH2b IH2c IH2d.
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; try prove_hygiene.
  intros j p q Hj Hpq.
  simpsub.
  so (urel_closed _#5 Hpq) as (Hclp & Hclq).
  apply cpair_formation.
    {
    eapply arrow_action_app.
      {
      apply IH1a; omega.
      }

      {
      eapply prod_action_ppi1.
      exact Hpq.
      }
    }

    {
    eapply arrow_action_app.
      {
      apply IH2a; omega.
      }

      {
      eapply prod_action_ppi2.
      exact Hpq.
      }
    }
  }

  (* kprod fromsp *)
  {
  clear IH1a IH1c IH1d IH2a IH2c IH2d.
  intros u v w Hu Hv Hw.
  cbn.
  apply arrow_action_lam; try prove_hygiene.
  intros j p q Hj Hpq.
  simpsub.
  so (urel_closed _#5 Hpq) as (Hclp & Hclq).
  apply prod_action_ppair.
    {
    eapply arrow_action_app.
      {
      apply IH1b; omega.
      }
    eapply cpi1_formation; eauto.
    }

    {
    eapply arrow_action_app.
      {
      apply IH2b; omega.
      }
    eapply cpi2_formation; eauto.
    }
  }

  (* kprod beta *)
  {
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  clear IH1d IH2d.
  so (IH1a i i i (le_refl _) (le_refl _) (le_refl _)) as IH1ai.
  so (IH1b i i i (le_refl _) (le_refl _) (le_refl _)) as IH1bi.
  so (IH2a i i i (le_refl _) (le_refl _) (le_refl _)) as IH2ai.
  so (IH2b i i i (le_refl _) (le_refl _) (le_refl _)) as IH2bi.
  rewrite <- (kbasic_impl_approx _#6 Hk) in IH1ai, IH1bi.
  rewrite <- (kbasic_impl_approx _#6 Hl) in IH2ai, IH2bi.
  cbn [fromsp tosp].
  match goal with
  | |- rel _ _ ?X _ =>
       eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_ppair.
      {
      apply equiv_app; [apply equiv_refl |].
      eapply equiv_trans.
        {
        apply equiv_cpi1.
        apply steps_equiv; apply star_one; apply step_app2.
        }
      simpsub.
      apply equiv_refl.
      }

      {
      apply equiv_app; [apply equiv_refl |].
      eapply equiv_trans.
        {
        apply equiv_cpi2.
        apply steps_equiv; apply star_one; apply step_app2.
        }
      simpsub.
      apply equiv_refl.
      }
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv; try prove_hygiene.
  so (prod_action_ppi1 _#6 Hmp) as Hmp1.
  so (prod_action_ppi2 _#6 Hmp) as Hmp2.
  refine (prod_action_ppair1 _#8 _ Hmp _ _); try prove_hygiene.
    {
    apply (urel_zigzag _#4 (app (fromsp stop pg K) (app (tosp stop pg K) (ppi1 p))) (app (fromsp stop pg K) (app (tosp stop pg K) (ppi1 m)))); auto.
      {
      eapply arrow_action_app.
        {
        exact (urel_downward_leq _#6 Hj IH1bi).
        }
      eapply cpi1_cpair_beta; eauto.
        {
        eapply arrow_action_app; eauto.
        exact (urel_downward_leq _#6 Hj IH1ai).
        }
      eapply arrow_action_app; eauto.
      exact (urel_downward_leq _#6 Hj IH2ai).
      }

      {
      eapply arrow_action_app.
        {
        exact (urel_downward_leq _#6 Hj IH1bi).
        }
      eapply arrow_action_app; eauto.
      exact (urel_downward_leq _#6 Hj IH1ai).
      }
    }

    {
    apply (urel_zigzag _#4 (app (fromsp stop pg L) (app (tosp stop pg L) (ppi2 p))) (app (fromsp stop pg L) (app (tosp stop pg L) (ppi2 m)))); auto.
      {
      eapply arrow_action_app.
        {
        exact (urel_downward_leq _#6 Hj IH2bi).
        }
      eapply cpi2_cpair_beta; eauto.
        {
        eapply arrow_action_app; eauto.
        exact (urel_downward_leq _#6 Hj IH1ai).
        }
      eapply arrow_action_app; eauto.
      exact (urel_downward_leq _#6 Hj IH2ai).
      }

      {
      eapply arrow_action_app.
        {
        exact (urel_downward_leq _#6 Hj IH2bi).
        }
      eapply arrow_action_app; eauto.
      exact (urel_downward_leq _#6 Hj IH2ai).
      }
    }
  }

  (* kprod eta *)
  {
  clear IH1a IH1b IH1c IH2a IH2b IH2c.
  intros j a b Hj Hab.
  so (urel_closed _#5 Hab) as (Hcla & Hclb).
  cbn [fromsp tosp].
  match goal with
  | |- rel _ _ ?X _ =>
       eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_cpair.
      {
      apply equiv_app; [apply equiv_refl |].
      eapply equiv_trans.
        {
        apply equiv_ppi1.
        apply steps_equiv; apply star_one; apply step_app2.
        }
      simpsub.
      apply steps_equiv; apply star_one; apply step_ppi12.
      }

      {
      apply equiv_app; [apply equiv_refl |].
      eapply equiv_trans.
        {
        apply equiv_ppi2.
        apply steps_equiv; apply star_one; apply step_app2.
        }
      simpsub.
      apply steps_equiv; apply star_one; apply step_ppi22.
      }
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); clear Hequiv; try prove_hygiene.
  apply (urel_zigzag _#4 (cpair (cpi1 b) (cpi2 b)) (cpair (cpi1 a) (cpi2 a))).
    {
    apply cpair_formation.
      {
      exact (IH1d j _ _ Hj (cpi1_formation _#6 Hab)).
      }

      {
      exact (IH2d j _ _ Hj (cpi2_formation _#6 Hab)).
      }
    }

    {
    apply cpair_formation; eauto using cpi1_formation, cpi2_formation.
    }

    {
    apply cpair_cpi_eta; auto.
    }
  }
}

(* kfut zero *)
{
intros pg s k Hclk.
eexists.
do2 4 split.
  {
  apply interp_fut_zero; auto.
  }

  {
  intros u v w Hu Hv Hw.
  replace (approx v (qfut qone)) with (qfut qone).
  2:{
    destruct v; auto.
    }
  replace (approx w (qfut qone)) with (qfut qone).
  2:{
    destruct w; auto.
    }
  cbn [tosp approx].
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  assert (j = 0) by omega; subst j.
  apply cnext_formation_zero; prove_hygiene.
  }

  {
  intros u v w Hu Hv Hw.
  replace (approx v (qfut qone)) with (qfut qone).
  2:{
    destruct v; auto.
    }
  replace (approx w (qfut qone)) with (qfut qone).
  2:{
    destruct w; auto.
    }
  cbn [fromsp approx].
  apply arrow_action_lam; try prove_hygiene.
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  assert (j = 0) by omega; subst j.
  cbn.
  apply fut_action_next_zero; try prove_hygiene.
  }

  {
  cbn [fromsp tosp].
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  assert (j = 0) by omega; subst j.
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  cbn in Hmp.
  decompose Hmp.
  intros _ q _ _ _ _ Hsteps _.
  do 2 eexists.
  do2 5 split; auto.
    {
    prove_hygiene.
    }

    {
    apply star_refl.
    }

    {
    exact Hsteps.
    }

    {
    intro H; omega.
    }
  }

  {
  cbn [fromsp tosp].
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  assert (j = 0) by omega; subst j.
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  exists tt.
  split.
    {
    apply cinterp_eval_refl.
    apply interp_cnext_zero.
    prove_hygiene.
    }

    {
    destruct Hmp as (x & _ & Hp).
    cbn in x.
    destruct x.
    exact Hp.
    }
  }
}

(* kfut *)
{
intros pg s i k K Hk IH.
destruct IH as (A & HA & IHa & IHb & IHc & IHd).
eexists.
do2 4 split.
  {
  apply interp_fut; eauto.
  }

  {
  clear IHb IHc IHd.
  assert (forall u,
            exists m,
              hygiene (permit clo) m
              /\ tosp stop pg (approx u (qfut K)) = lam (cnext m)) as Hform.
    {
    intros u.
    destruct u as [| u].
      {
      cbn.
      eexists.
      split.
      2:{
        reflexivity.
        }
      prove_hygiene.
      }

      {
      cbn.
      eexists.
      split.
      2:{
        reflexivity.
        }
      prove_hygiene.
      }
    }
  intros u v w Hu Hv Hw.
  destruct u as [| u].
    {
    so (Hform v) as (a & Hcla & Heqa).
    so (Hform w) as (b & Hclb & Heqb).
    rewrite -> Heqa, -> Heqb; clear Heqa Heqb.
    apply arrow_action_lam; try prove_hygiene.
    intros j m p Hj Hmp.
    so (urel_closed _#5 Hmp) as (Hclm & Hclp).
    assert (j = 0) by omega; subst j.
    simpsub.
    apply cnext_formation_zero; auto using hygiene_subst1.
    }
  assert (u <= i) as H by omega; renameover H into Hu.
  destruct v as [| v].
    {
    omega.
    }
  assert (u <= v) as H by omega; renameover H into Hv.
  destruct w as [| w].
    {
    omega.
    }
  assert (u <= w) as H by omega; renameover H into Hw.
  cbn [tosp approx].
  apply arrow_action_lam; try prove_hygiene.
    {
    cbn; omega.
    }
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  destruct j as [| j].
    {
    apply cnext_formation_zero; prove_hygiene.
    }
  assert (j <= u) as H by omega; renameover H into Hj.
  apply cnext_formation.
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj (IHa u v w Hu Hv Hw)) _).
  eapply fut_action_prev; eauto.
  exact Hmp.
  }

  {
  clear IHa IHc IHd.
  assert (forall u,
            exists m,
              hygiene (permit clo) m
              /\ fromsp stop pg (approx u (qfut K)) = lam (next m)) as Hform.
    {
    intros u.
    destruct u as [| u].
      {
      cbn.
      eexists.
      split.
      2:{
        reflexivity.
        }
      prove_hygiene.
      }

      {
      cbn.
      eexists.
      split.
      2:{
        reflexivity.
        }
      prove_hygiene.
      }
    }
  intros u v w Hu Hv Hw.
  destruct u as [| u].
    {
    so (Hform v) as (a & Hcla & Heqa).
    so (Hform w) as (b & Hclb & Heqb).
    rewrite -> Heqa, -> Heqb; clear Heqa Heqb.
    apply arrow_action_lam; try prove_hygiene.
    intros j m p Hj Hmp.
    so (urel_closed _#5 Hmp) as (Hclm & Hclp).
    assert (j = 0) by omega; subst j.
    simpsub.
    cbn.
    apply fut_action_next_zero; try prove_hygiene; auto using hygiene_subst1.
    }
  assert (u <= i) as H by omega; renameover H into Hu.
  destruct v as [| v].
    {
    omega.
    }
  assert (u <= v) as H by omega; renameover H into Hv.
  destruct w as [| w].
    {
    omega.
    }
  assert (u <= w) as H by omega; renameover H into Hw.
  cbn [fromsp approx].
  apply arrow_action_lam; try prove_hygiene.
    {
    cbn; omega.
    }
  intros j m p Hj Hmp.
  simpsub.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  rewrite -> den_iufut.
  destruct j as [| j].
    {
    apply fut_action_next_zero; try prove_hygiene.
    }
  assert (j <= u) as H by omega; renameover H into Hj.
  apply fut_action_next.
    {
    cbn; omega.
    }
  refine (arrow_action_app _#9 (urel_downward_leq _#6 Hj (IHb u v w Hu Hv Hw)) _).
  apply cprev_formation; auto.
  }

  {
  so (IHa i i i (le_refl _) (le_refl _) (le_refl _)) as IHai.
  so (IHb i i i (le_refl _) (le_refl _) (le_refl _)) as IHbi.
  rewrite <- (kbasic_impl_approx _#6 Hk) in IHai, IHbi.
  clear IHa IHb IHd.
  intros j m p Hj Hmp.
  so (urel_closed _#5 Hmp) as (Hclm & Hclp).
  cbn [fromsp tosp].
  rewrite -> den_iufut in Hmp |- *.
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_next.
    apply equiv_app; [apply equiv_refl |].
    apply equiv_cprev.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_refl.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _).
    {
    prove_hygiene.
    }
  so Hmp as (_ & p' & _ & _ & _ & _ & Hp' & _).
  destruct j as [| j].
    {
    so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hp' Hclp)) as H; cbn in H.
    destruct H as (Hclp' & _).
    refine (urel_equiv_2 _#6 Hclp (equiv_symm _#3 (steps_equiv _#3 Hp')) _).
    apply fut_action_next_zero; try prove_hygiene.
    }
  assert (j <= i) as H by omega; renameover H into Hj.
  so (fut_action_prev _#6 Hmp) as Hpm_pp.
  so (IHc _ _ _ Hj Hpm_pp) as Hftpm_pp.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj IHai) Hpm_pp) as Htpm_tpp.
  so (cprev_cnext_beta _#5 Htpm_tpp) as Hpntpm_tpp.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj IHbi) Htpm_tpp) as Hftpm_ftpp.
  so (arrow_action_app _#9 (urel_downward_leq _#6 Hj IHbi) Hpntpm_tpp) as Hfpntpm_ftpp.
  so (urel_zigzag _#7 Hfpntpm_ftpp Hftpm_ftpp Hftpm_pp) as Hfpntpm_pp.
  eassert _ as H; [refine (fut_action_next _ (S i) _#4 _ Hfpntpm_pp) |].
    {
    cbn; omega.
    }
  refine (urel_equiv_2 _ (fut_urel stop (S i) (den A)) _#4 Hclp _ H); clear H.
  apply (equiv_trans _ _ (next p')).
  2:{
    apply equiv_symm.
    apply steps_equiv; auto.
    }
  apply equiv_next.
  eapply equiv_trans.
    {
    apply equiv_prev.
    apply steps_equiv; eauto.
    }
  apply steps_equiv; apply star_one.
  apply step_prev2.
  }

  {
  clear IHa IHb IHc.
  intros j a b Hj Hab.
  so (urel_closed _#5 Hab) as (Hcla & Hclb).
  cbn [fromsp tosp].
  match goal with
  | |- rel _ _ ?X _ =>
     eassert (equiv _ X) as Hequiv
  end.
    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply equiv_cnext.
    apply equiv_app; [apply equiv_refl |].
    eapply equiv_trans.
      {
      apply equiv_prev.
      apply steps_equiv; apply star_one; apply step_app2.
      }
    simpsub.
    apply steps_equiv; apply star_one.
    apply step_prev2.
    }
  refine (urel_equiv_1 _#6 _ Hequiv _); try prove_hygiene; clear Hequiv.
  destruct j as [| j].
    {
    destruct Hab as (x & Ha & Hb).
    exists x.
    split; auto.
    apply cinterp_eval_refl.
    cbn in x.
    destruct x.
    cbn.
    apply interp_cnext_zero.
    prove_hygiene.
    }
  assert (j <= i) as H by omega; renameover H into Hj.
  so (cnext_formation _#5 (IHd _ _ _ Hj (cprev_formation _#5 Hab))) as Hntfpa_npb.
  so (cnext_cprev_eta _#5 Hab) as Hnpa_b.
  so (cnext_formation _#5 (cprev_formation _#5 Hab)) as Hnpa_npb.
  exact (urel_zigzag _#7 Hntfpa_npb Hnpa_npb Hnpa_b).
  }
}

(* krec *)
{
intros pg s i k K _ IH.
destruct IH as (A & HA & H).
exists A.
split.
  {
  apply interp_rec; auto.
  }
exact H.
}

(* kinterp *)
{
intros pg s i k l K Hcl Hstepsl HintK IH.
destruct IH as (A & HA & H).
exists A.
split.
  {
  eapply interp_eval; eauto.
  }
exact H.
}

(* wrapup *)
{
intros pg s i k K HK.
destruct Hind as (H & _).
so (H _#5 HK) as (A & HA & Hspace).
exists A.
do2 2 split; auto.
eapply kbasic_impl_approx; eauto.
}
Qed.

Lemma spacify :
  forall pg s i k K A,
    kinterp pg s i k K
    -> interp toppg s i k A
    -> spacification pg i K A.
Proof.
intros pg s i k K A HK HA.
so (spacify_main _#5 HK) as (A' & HA' & H).
so (basic_fun _#7 HA HA'); subst A'.
exact H.
Qed.

Lemma spacification_tosp :
  forall pg i K A,
    spacification pg i K A
    -> rel (arrow_urel stop i (den A) (con_urel pg K)) i
         (tosp stop pg K) (tosp stop pg K).
Proof.
intros pg i K A Hspace.
destruct Hspace as (HeqK & Htosp & _).
so (Htosp i i i (le_refl _) (le_refl _) (le_refl _)) as H.
rewrite <- HeqK in H.
exact H.
Qed.

Lemma spacification_fromsp :
  forall pg i K A,
    spacification pg i K A
    -> rel (arrow_urel stop i (con_urel pg K) (den A)) i
          (fromsp stop pg K) (fromsp stop pg K).
Proof.
intros pg i K A Hspace.
destruct Hspace as (HeqK & _ & Hfromsp & _).
so (Hfromsp i i i (le_refl _) (le_refl _) (le_refl _)) as H.
rewrite <- HeqK in H.
exact H.
Qed.