(*******************************************************************
 * Este archivo especifica el estado.
 *
 ******************************************************************)

(* Shortcut notation for partial functions *)
Definition partial a b := a -> option b.
Notation "a ⇸ b" := (partial a b) (at level 51, right associativity).

Section State.

  (** Identificadores de OSs e Hypercalls *)
  Parameter os_ident : Set.
  Parameter os_ident_eq : forall oi1 oi2 : os_ident, {oi1 = oi2} + {oi1 <> oi2}.

  Parameter Hyperv_call : Set.

  (* Memoria y direcciones *)

  (** Direcciones Virtuales. **)
  Parameter vadd : Set.
  Parameter vadd_eq : forall va1 va2 : vadd, {va1 = va2} + {va1 <> va2}.

  (** Direcciones de Máquina. **)
  Parameter madd :  Set.
  Parameter madd_eq : forall ma1 ma2 : madd, {ma1 = ma2} + {ma1 <> ma2}.

  (** Direcciones Físicas **)
  Parameter padd : Set.
  Parameter padd_eq : forall pa1 pa2 : padd, {pa1 = pa2} + {pa1 <> pa2}.

  (** Memory values. **)
  Parameter value : Set.
  Parameter value_eq : forall val1 val2 : value, {val1 = val2} + {val1 <> val2}.

  (* Environment *)
  Record context : Set :=
    Context {
        (** una dirección virtual es accesible, no está reserveda por el HV **)
        ctxt_vadd_accessible: vadd -> bool;
        (** guest Oss (Confiable/No Confiable) **)
        ctxt_oss : os_ident -> bool
      }.

  (* Operative Systems *)
  Record os := mk_os { curr_page : padd; hcall : option Hyperv_call }.

  Definition oss_map := os_ident ⇸ os.

  (* Execution Modes *)
  Inductive exec_mode := usr | svc.
  Inductive os_activity := running | waiting.

  (* Memory Mappings *)
  Definition hypervisor_map := os_ident ⇸ padd ⇸ madd.

  Inductive content :=
  | RW (v : option value)
  | PT (va_to_ma : vadd ⇸ madd)
  | Other.

  Definition is_RW c :=
    match c with
    | RW _ => True
    | _ => False
    end.

  Inductive page_owner :=
  | Hyp
  | Os (osi : os_ident)
  | No_Owner.

  Record page := mk_page { page_content : content; page_owned_by : page_owner }.

  Definition system_memory := madd ⇸ page.

  Definition update mem addr page : system_memory :=
    fun addr' => if madd_eq addr' addr
                 then Some page
                 else mem addr'.

  (* States *)
  Record State :=
    mk_State {
        active_os : os_ident;
        aos_exec_mode : exec_mode;
        aos_activity : os_activity;
        oss : oss_map;
        hypervisor : hypervisor_map;
        memory : system_memory
      }.

  Definition va_mapped_to_ma (s : State) (va : vadd) (ma : madd) :=
    exists (curr_os : os)           (* SO actual *)
           (ph_map : padd ⇸ madd)  (* mappings del HV para el SO actual *)
           (curr_pt_addr : madd)    (* dirección  de la PT del SO actual *)
           (pt : page)              (* PT del SO actual *)
           (vt_map : vadd ⇸ madd), (* mappings de la PT del SO actual *)
      oss s (active_os s) = Some curr_os
      /\ hypervisor s (active_os s) = Some ph_map
      /\ ph_map (curr_page curr_os) = Some curr_pt_addr
      /\ memory s curr_pt_addr = Some pt
      /\ page_content pt = PT vt_map
      /\ vt_map va = Some ma.

  Definition trusted_os (ctxt : context) (s : State) : Prop :=
    ctxt_oss ctxt (active_os s) = true.

End State.


From iris.program_logic Require Export language ectx_language ectxi_language.
From st.prelude Require Export autosubst generic lang_base.

(** The syntax of expressions *)
Inductive expr :=
| Var (x : var)
| LetIn (e1 : expr) (e2 : {bind 1 of expr})
| Lam (e : {bind 1 of expr})
(* | Fix (e : expr) *)
(* | Rec (e : {bind 2 of expr}) *)
| App (e1 e2 : expr)
(* Base Types *)
| Lit (l : base_lit)
| BinOp (op : bin_op) (e1 e2 : expr)
| If (e0 e1 e2 : expr)
| Seq (e1 e2 : expr)
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
(* Sums *)
| InjL (e : expr)
| InjR (e : expr)
| Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
(* Recursive Types *)
| Fold (e : expr)
| Unfold (e : expr)
(** Polymorphic Types *)
(* | TLam (e : expr) *)
(* | TApp (e : expr). *)
(* Virt Step *)
| VirtStep (e : expr).

Coercion LitInt : Z >-> base_lit.
Coercion LitBool : bool >-> base_lit.
Coercion Lit : base_lit >-> expr.
Coercion App : expr >-> Funclass.
Coercion Var : var >-> expr.

Declare Scope expr_no_st_scope.
Delimit Scope expr_no_st_scope with Eₙₒ.
Notation "% x" := (Var x%nat) (at level 8, format "% x") : expr_no_st_scope.

Notation "()" := (Lit LitUnit) : expr_no_st_scope.
Notation "( e1 , e2 , .. , en )" := (Pair .. (Pair e1 e2) .. en) : expr_no_st_scope.

Notation "e1 + e2" := (BinOp PlusOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 - e2" := (BinOp MinusOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 < e2" := (BinOp LtOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.
Notation "e1 = e2" := (BinOp EqOp e1%Eₙₒ e2%Eₙₒ) : expr_no_st_scope.

Instance Var_Inj : Inj eq eq Var. intros x1 x2 eq. by inversion eq. Qed.

Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

Lemma Var_closed_n_lt (x : var) n (p : Closed_n n (Var x)) : x < n.
Proof. apply ids_lt_Closed_n. apply p. Qed.

(** Values for STLang *)
Inductive val :=
| LamV (e : {bind 1 of expr})
(* | RecV (e : {bind 2 of expr}) *)
(* | TLamV (e : {bind 1 of expr}) *)
| LitV (v : base_lit)
| PairV (v1 v2 : val)
| InjLV (v : val)
| InjRV (v : val)
| FoldV (v : val).

Coercion LitV : base_lit >-> val.

Declare Scope val_no_st_scope.
Delimit Scope val_no_st_scope with Vₙₒ.

Notation "()" := (LitV LitUnit) : val_no_st_scope.
Notation "( v1 , v2 , .. , vn )" := (PairV .. (PairV v1 v2) .. vn) : val_no_st_scope.

Fixpoint of_val (v : val) : expr :=
 match v with
 | LamV e => Lam e
 (* | RecV e => Rec e *)
 (* | TLamV e => TLam e *)
 | LitV v => Lit v
 | PairV v1 v2 => Pair (of_val v1) (of_val v2)
 | InjLV v => InjL (of_val v)
 | InjRV v => InjR (of_val v)
 | FoldV v => Fold (of_val v)
 end.

(* Notation "# v" := (of_val v%Vₙₒ) (at level 8, format "# v") : expr_no_st_scope. *)
Coercion of_val : val >-> expr.

Definition subst_list_val (vs : list val) : var → expr := subst_list (map of_val vs).

Lemma subst_list_val_cons v vs : of_val v .: subst_list_val vs = subst_list_val (v :: vs).
Proof. intros. by asimpl. Qed.

Lemma subst_list_val_snoc vs v : subst_list_val (vs ++ [v]) = (upn (length vs) (of_val v .: ids)) >> (subst_list_val vs).
Proof. by rewrite /subst_list_val map_app subst_list_snoc map_length. Qed.

(* Lemma var_subst_list_val_lt_length (vs : list val) (x : var) (p : x < length vs) : *)
(*   (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v). *)
(* Proof. *)
(*   destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=. *)
(*   assert (length vs ≤ x). by apply lookup_ge_None. lia. *)
(* Qed. *)
Lemma Var_subst_list_closed_n_length (vs : list val) (x : var) (p : Closed_n (length vs) (Var x)) :
  (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v).
Proof.
  destruct (vs !! x) eqn:eq. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=.
  assert (length vs ≤ x). by apply lookup_ge_None.
  assert (x < length vs). by apply ids_lt_Closed_n. lia.
Qed.

Lemma Var_subst_list_val_lookup (x : var) (ts : list val) t (H : ts !! x = Some t) :
  (ids x).[subst_list_val ts] = t.
Proof. rewrite /subst_list_val. apply ids_subst_list_lookup. by rewrite list_lookup_fmap H. Qed.

(* Lemma var_subst_list_val (vs : list val) (x : var) : *)
(*   (exists v : val, vs !! x = Some v ∧ (Var x).[subst_list_val vs] = v) ∨ (vs !! x = None). *)
(* Proof. *)
(*   destruct (vs !! x) eqn:eq. *)
(*   - left. exists v. split; auto. apply ids_subst_list_lookup. by rewrite list_lookup_fmap eq /=. *)
(*   - by right. *)
(* Qed. *)

Fixpoint to_val (e : expr) : option val :=
 match e with
 | Lam e => Some (LamV e)
 (* | Rec e => Some (RecV e) *)
 (* | TLam e => Some (TLamV e) *)
 | Lit e => Some (LitV e)
 | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
 | InjL e => InjLV <$> to_val e
 | InjR e => InjRV <$> to_val e
 | Fold e => v ← to_val e; Some (FoldV v)
 | _ => None
 end.

Fixpoint val_subst (v : val) (σ : var → expr) : val :=
  match v with
  | LamV e => LamV (e.[up σ])
  | LitV v => LitV v
  | PairV v1 v2 => PairV (val_subst v1 σ) (val_subst v2 σ)
  | InjLV v => InjLV (val_subst v σ)
  | InjRV v => InjRV (val_subst v σ)
  | FoldV v => FoldV (val_subst v σ)
  end.

Notation "v .{ sigma }" := (val_subst v sigma)
  (at level 2, sigma at level 200, left associativity,
   format "v .{ sigma }" ).

Notation "v .{ t /}" := (val_subst v (t .: ids))
  (at level 2, t at level 200, left associativity,
   format "v .{ t /}") : subst_scope.

Lemma val_subst_valid (v : val) (σ : var → expr) : (of_val v).[σ] = (val_subst v σ).
Proof. induction v; asimpl; try done; (by rewrite IHv1 IHv2) || by rewrite IHv. Qed.

Lemma val_subst_comp (v : val) (σ σ' : var → expr) : v.{σ}.{σ'} = v.{σ >> σ'}.
Proof. induction v; asimpl; try done; (by rewrite IHv1 IHv2) || by rewrite IHv. Qed.

Lemma to_of_val v : to_val (of_val v) = Some v.
Proof.
 by induction v; try simplify_option_eq; repeat f_equal; try apply (proof_irrel _).
Qed.
Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
 revert v; induction e; intros v ?; simplify_option_eq; auto with f_equal.
Qed.

(** Equality and other typeclass stuff *)
Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
Instance bin_op_eq_dec : EqDecision bin_op.
Proof. solve_decision. Defined.
Instance expr_eq_dec : EqDecision expr.
Proof. solve_decision. Defined.
Instance val_eq_dec : EqDecision val.
Proof.
 refine (λ v v', cast_if (decide (of_val v = of_val v')));
   abstract naive_solver.
Defined.

Global Instance val_inhabited : Inhabited val := populate ()%Vₙₒ.
(* Instance expr_inhabited : Inhabited expr := populate (Lit LitUnit). *)
(* Instance val_inhabited : Inhabited val := populate (LitV LitUnit). *)
(* Canonical Structure stateC := leibnizO state. *)
(* Canonical Structure valC := leibnizO val. *)
(* Canonical Structure eff_valC := leibnizO eff_val. *)
(* Canonical Structure exprC := leibnizO expr. *)

(** Evaluation contexts *)
Inductive ectx_item :=
(* | FixCtx *)
| LetInCtx (e2 : expr)
| AppLCtx (e2 : expr)
| AppRCtx (v1 : val)
(* | TAppCtx *)
| PairLCtx (e2 : expr)
| PairRCtx (v1 : val)
| FstCtx
| SndCtx
| InjLCtx
| InjRCtx
| CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
| IfCtx (e2 : expr) (e3 : expr)
| BinOpLCtx (op : bin_op) (e2 : expr)
| BinOpRCtx (op : bin_op) (v1 : val)
| SeqCtx (e2 : expr)
| FoldCtx
| UnfoldCtx
| VirtStepCtx.

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
 match Ki with
 (* | FixCtx => Fix e *)
 | LetInCtx e2 => LetIn e e2
 | AppLCtx e2 => App e e2
 | AppRCtx v1 => App (of_val v1) e
 (* | TAppCtx => TApp e *)
 | PairLCtx e2 => Pair e e2
 | PairRCtx v1 => Pair (of_val v1) e
 | FstCtx => Fst e
 | SndCtx => Snd e
 | InjLCtx => InjL e
 | InjRCtx => InjR e
 | CaseCtx e1 e2 => Case e e1 e2
 | IfCtx e1 e2 => If e e1 e2
 | BinOpLCtx op e2 => BinOp op e e2
 | BinOpRCtx op v1 => BinOp op (of_val v1) e
 | SeqCtx e2 => Seq e e2
 | FoldCtx => Fold e
 | UnfoldCtx => Unfold e
 | VirtStepCtx => VirtStep e
 end.

(** The stepping relation *)

Definition bin_op_eval (op : bin_op) (z1 z2 : Z) : val :=
 match op with
 | PlusOp => LitV $ LitInt (z1 + z2)%Z
 | MinusOp => LitV $ LitInt (z1 - z2)
 | LeOp => LitV $ LitBool $ bool_decide (z1 ≤ z2)%Z
 | LtOp => LitV $ LitBool $ bool_decide (z1 < z2)%Z
 | EqOp => LitV $ LitBool $ bool_decide (z1 = z2)
 end.

Definition state : Type := ().

Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
(* β *)
  LetIn_head_step e1 v1 e2 σ :
   to_val e1 = Some v1 →
   head_step (LetIn e1 e2) σ [] e2.[e1/] σ []
| App_Lam_head_step e1 e2 v2 σ :
   to_val e2 = Some v2 →
   head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
(* | App_Rec_head_step e1 e2 v2 σ : *)
   (* to_val e2 = Some v2 → *)
   (* head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ [] *)
(* fix *)
(* | Fix_head_step e σ : *)
    (* head_step (Fix (Lam e)) σ [] e.[Fix (Lam e)/] σ [] *)
(* binary operation *)
| BinOp_head_step op e1 e2 z1 z2 σ :
   to_val e1 = Some (LitV $ LitInt z1) → to_val e2 = Some (LitV $ LitInt z2) →
   head_step (BinOp op e1 e2) σ [] (of_val (bin_op_eval op z1 z2)) σ []
(* if *)
| If_True_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool true) e1 e2) σ [] e1 σ []
| If_False_head_step e1 e2 σ :
   head_step (If (Lit $ LitBool false) e1 e2) σ [] e2 σ []
(* seq *)
| Seq_Unit_head_step e1 e2 σ :
    to_val e1 = Some ()%Vₙₒ →
    head_step (Seq e1 e2) σ [] e2 σ []
(* Products *)
| Fst_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Fst (Pair e1 e2)) σ [] e1 σ []
| Snd_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 → to_val e2 = Some v2 →
   head_step (Snd (Pair e1 e2)) σ [] e2 σ []
(* Sums *)
| Case_InjL_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
| Case_InjR_head_step e0 v0 e1 e2 σ :
   to_val e0 = Some v0 →
   head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
(* Recursive Types *)
| Unfold_Fold_head_step e v σ :
   to_val e = Some v →
   head_step (Unfold (Fold e)) σ [] e σ []
(* Polymorphic Types *)
(* | TBeta e σ : *)
   (* head_step (TApp (TLam e)) σ [] e σ []. *)
| VirtStep_Lam_head_step e σ :
   head_step (VirtStep (Lam e)) σ [] (Lam (VirtStep ((Lam e).[ren (+1)] (VirtStep %0))))%Eₙₒ σ []
| VirtStep_Lit_head_step bl σ :
   head_step (VirtStep (Lit bl)) σ [] (Lit bl) σ []
| VirtStep_Pair_head_step e1 v1 e2 v2 σ :
   to_val e1 = Some v1 →
   to_val e2 = Some v2 →
   head_step (VirtStep (Pair e1 e2)) σ [] (Pair (VirtStep e1) (VirtStep e2)) σ []
| VirtStep_InjL_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (InjL e)) σ [] (InjL (VirtStep e)) σ []
| VirtStep_InjR_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (InjR e)) σ [] (InjR (VirtStep e)) σ []
| VirtStep_Fold_head_step e v σ :
   to_val e = Some v →
   head_step (VirtStep (Fold e)) σ [] (Fold (VirtStep e)) σ [].

Lemma App_Lam_head_step' (e' e1 e2 : expr) v2 (eq : e1.[e2/] = e') σ (H : to_val e2 = Some v2) :
  head_step (Lam e1 e2) σ [] e' σ [].
Proof. rewrite -eq. by eapply App_Lam_head_step. Qed.

Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.
Lemma fill_item_val Ki e :
 is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.
Lemma val_stuck e1 σ1 κ e2 σ2 efs :
 head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; done. Qed.
Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
 head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
Proof.
 destruct Ki; inversion_clear 1; simplify_option_eq; eauto.
Qed.
Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
 to_val e1 = None → to_val e2 = None →
 fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
 destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
  repeat match goal with
  | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
  end; auto.
Qed.

Lemma st_ectxi_lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; eauto using to_of_val, of_to_val,
  val_stuck, fill_item_val, fill_item_no_val_inj,
 head_ctx_step_val, fill_item_inj.
Qed.

Canonical Structure STLCmuVS_ectxi_lang : ectxiLanguage := EctxiLanguage st_ectxi_lang_mixin.
Canonical Structure STLCmuVS_ectx_lang : ectxLanguage := EctxLanguageOfEctxi STLCmuVS_ectxi_lang.
Canonical Structure STLCmuVS_lang : language := LanguageOfEctx STLCmuVS_ectx_lang.

Lemma fill_val (e : expr) (K : list ectx_item):
  is_Some (to_val (fill K e)) -> is_Some (to_val e).
Proof.
  move=> [v h]. destruct (to_val e) eqn:eq.
    by exists v0.
    have fill_not_val: to_val (fill K e) = None. eauto using fill_not_val.
    congruence.
Qed.

Canonical Structure valO := valO STLCmuVS_lang.
Canonical Structure exprO := exprO STLCmuVS_lang.

(* Arguments val_stuck {_ _ _ _ _} _. *)
(* Arguments fill_val {_ _} _. *)

(* Wrapper around prim_step *)

Definition STLCmuVS_step (e1 e2 : expr) : Prop := prim_step e1 tt [] e2 tt [].

(* We do not use forks, nor prophecy variables. *)

Lemma head_step_no_forks e σ κ e' σ' efs : head_step e σ κ e' σ' efs → efs = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_forks (e : expr) σ κ e' σ' efs : prim_step e σ κ e' σ' efs → efs = [].
Proof. intros H. inversion H. by eapply head_step_no_forks. Qed.

Lemma head_step_no_obs e σ κ e' σ' efs : head_step e σ κ e' σ' efs → κ = [].
Proof. intros H. by inversion H. Qed.

Lemma prim_step_no_obs (e : expr) σ κ e' σ' efs : prim_step e σ κ e' σ' efs → κ = [].
Proof. intros H. inversion H. by eapply head_step_no_obs. Qed.

(* Our language is deterministic *)

Lemma head_step_det e e1 σ1 κ1 σ1' efs1 e2 σ2 κ2 σ2' efs2 : head_step e σ1 κ1 e1 σ1' efs1 → head_step e σ2 κ2 e2 σ2' efs2 → e1 = e2.
Proof. intros H1 H2. inversion H1; inversion H2; ((by simplify_eq) || (try done) || simplify_eq; inversion G2). Qed.

Lemma prim_step_det (e e1 e2 : expr) σ κ : prim_step e σ κ e1 σ [] → prim_step e σ κ e2 σ [] → e1 = e2.
Proof.
  intros H1 H2.
  inversion H1. inversion H2. simplify_eq. simpl in *.
  assert (K = K0) as <-.
  { destruct (step_by_val K K0 _ _ σ κ e2'0 σ [] H4) as [Kred eq] ; try done; try by eapply val_stuck.
    assert (H4' : fill K0 e1'0 = fill K e1'); first done.
    destruct (step_by_val K0 K _ _ σ κ e2' σ [] H4') as [Kred' eq'] ; try done; try by eapply val_stuck.
    rewrite eq in eq'. simpl in *. assert (length K = length (Kred' ++ Kred ++ K)). simpl in *. by rewrite -eq'.
    do 2 rewrite app_length in H. assert (Kred = []) as ->. apply length_zero_iff_nil. lia. by rewrite eq. }
  f_equal. assert (e1' = e1'0) as ->. apply (fill_inj K _ _ H4). by eapply head_step_det.
Qed.

(* Our language is pure *)

Lemma prim_step_pure (e1 e2 : expr) σ1 σ2 κ efs : prim_step e1 σ1 κ e2 σ2 efs → pure_step e1 e2.
Proof.
  intros Hprim.
  assert (efs = []) as ->. by eapply prim_step_no_forks.
  assert (κ = []) as ->. by eapply prim_step_no_obs.
  destruct σ1, σ2.
  split.
  intros σ. destruct σ. rewrite /reducible_no_obs. by exists e2, tt, [].
  intros.
  assert (efs = []) as ->. by eapply prim_step_no_forks.
  assert (κ = []) as ->. by eapply prim_step_no_obs.
  destruct σ1, σ2. by erewrite (prim_step_det _ _ _ _ _ H).
Qed.

(* Wrappers around lemmas *)

Lemma STLCmuVS_pure e1 e2 : STLCmuVS_step e1 e2 <-> pure_step e1 e2.
Proof.
  split. apply prim_step_pure. intro H. inversion H.
  destruct (pure_step_safe tt) as [e2' [σ [efs Hp]]].
  destruct σ. by destruct (pure_step_det _ _ _ _ _ Hp) as [a [b [-> ->]]].
Qed.

Lemma STLCmuVS_step_ctx K `{!LanguageCtx K} e1 e2 : STLCmuVS_step e1 e2 → STLCmuVS_step (K e1) (K e2).
Proof. intro. apply STLCmuVS_pure. apply pure_step_ctx. auto. by apply STLCmuVS_pure. Qed.

Lemma rtc_STLCmuVS_step_ctx K `{!LanguageCtx K} e1 e2 : rtc STLCmuVS_step e1 e2 → rtc STLCmuVS_step (K e1) (K e2).
Proof. eauto using rtc_congruence, STLCmuVS_step_ctx. Qed.

Lemma nsteps_STLCmuVS_step_ctx K `{!LanguageCtx K} n e1 e2 : nsteps STLCmuVS_step n e1 e2 → nsteps STLCmuVS_step n (K e1) (K e2).
Proof. eauto using nsteps_congruence, STLCmuVS_step_ctx. Qed.

Lemma nsteps_PureExec (e1 e2 : expr) n : nsteps STLCmuVS_step n e1 e2 <-> PureExec True n e1 e2.
Proof.
  split. intros s t. eapply nsteps_congruence with (f := id). by apply STLCmuVS_pure. auto.
  intro H. eapply nsteps_congruence with (f := id). apply STLCmuVS_pure. apply pure_exec. auto.
Qed.

Lemma rtc_PureExec (e1 e2 : expr) : rtc STLCmuVS_step e1 e2 <-> ∃ n, PureExec True n e1 e2.
Proof.
  split.
  intro H. assert (H' : rtc pure_step e1 e2).
  eapply rtc_subrel. by apply STLCmuVS_pure. auto. destruct (iffLR (rtc_nsteps _ _) H') as [n H'']. exists n. intros _. done.
  intro d. destruct d as [n H]. eapply rtc_nsteps. exists n. by eapply nsteps_PureExec.
Qed.

Lemma step_PureExec (e1 e2 : expr) : STLCmuVS_step e1 e2 → PureExec True 1 e1 e2.
Proof. intros s t. apply nsteps_once. by apply STLCmuVS_pure. Qed.

Definition STLCmuVS_halts (e : STLCmuVS.lang.expr) : Prop :=
  ∃ (v : STLCmuVS.lang.val), rtc STLCmuVS_step e (STLCmuVS.lang.of_val v).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	Diagonal Functor (used in the definition of Cartesian) 		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export PROD.
Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

Section diag.

Variable C : Category.

Definition Diag_ob (c : C) := Build_POb c c.

 Section diag_map_def.

 Variable a b : C.

 Definition Diag_mor (f : a --> b) :=
   Build_Pmor (u:=Diag_ob a) (t:=Diag_ob b) f f.

 Lemma Diag_map_law : Map_law Diag_mor.
 Proof.
 unfold Map_law, Diag_mor in |- *; simpl in |- *.
 intros f g H; unfold Equal_Pmor in |- *; simpl in |- *.
 split; trivial.
 Qed.

 Canonical Structure Diag_map := Build_Map Diag_map_law.

 End diag_map_def.

Lemma Diag_comp_law : Fcomp_law Diag_map.
Proof.
unfold Fcomp_law, Diag_map, Diag_mor in |- *; simpl in |- *.
unfold Equal_Pmor in |- *; simpl in |- *.
intros a b c f g; split; apply Refl.
Qed.

Lemma Diag_id_law : Fid_law Diag_map.
Proof.
unfold Fid_law, Diag_map, Diag_mor in |- *; simpl in |- *.
unfold Equal_Pmor, Id_PROD in |- *; simpl in |- *.
intro a; split; apply Refl.
Qed.

Canonical Structure Diag := Build_Functor Diag_comp_law Diag_id_law.

End diag.


(** * Functors to cat are pseudofunctors *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import Functor.Identity.
Require Import Pseudofunctor.Core.
Require Import Cat.Core.
Require Import FunctorCategory.Core.
Require Import FunctorCategory.Morphisms NaturalTransformation.Isomorphisms.
Require Import Category.Morphisms NaturalTransformation.Paths.
Require Import Basics.PathGroupoids Basics.Trunc.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope path_scope.
Local Open Scope morphism_scope.

(** Every functor to Cat is a pseudofunctor *)
Section of_functor.
  Context `{Funext}.
  Variable C : PreCategory.
  Context `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation cat := (@sub_pre_cat _ P HP).

  Variable F : Functor C cat.

  Definition path_functor_helper A B (F1 F2 : Functor A B) (pf1 pf2 : F1 = F2)
  : P A -> P B -> pf1 = pf2
    := fun PA PB => @path_ishprop _ (@HP A B PA PB F1 F2) _ _.

  Local Hint Extern 0 (P ?x.1) => exact x.2 : core.

  Local Tactic Notation "transitivity_idtoiso" open_constr(hyp) :=
    lazymatch goal with
      | [ |- ?f (Category.Morphisms.idtoiso ?C _) = _ ] => etransitivity (f (Category.Morphisms.idtoiso C hyp));
                                       [ do 2 refine (ap _ _); (* https://coq.inria.fr/bugs/show_bug.cgi?id=3626 *)
                                         apply path_functor_helper;
                                         simpl; trivial
                                       | path_natural_transformation ]
    end.

  Local Ltac pseudofunctor_t :=
    intros;
    unfold natural_transformation_of_natural_isomorphism;
    rewrite ?idtoiso_whisker_r, ?idtoiso_whisker_l;
    repeat (
        let C := match goal with |- @paths (@NaturalTransformation ?C ?D ?F ?G) _ _ => constr:((C -> D)%category) end in
        first [ eapply (@iso_moveL_pV C)
              | eapply (@iso_moveL_Vp C)
              | eapply (@iso_moveL_pM C)
              | eapply (@iso_moveL_Mp C) ];
        simpl
      );
    rewrite ?idtoiso_inv;
    simpl;
    change @NaturalTransformation.Composition.Core.compose
    with (fun C D F G H => Category.Core.compose (C := C -> D) (s := F) (d := G) (d' := H));
    cbv beta;
    rewrite ?idtoiso_comp;
    first [ transitivity_idtoiso (Functor.Composition.Laws.left_identity _)
          | transitivity_idtoiso ((Functor.Composition.Laws.left_identity _)^)
          | transitivity_idtoiso (Functor.Composition.Laws.right_identity _)
          | transitivity_idtoiso ((Functor.Composition.Laws.right_identity _)^)
          | transitivity_idtoiso (Functor.Composition.Laws.associativity _ _ _)
          | transitivity_idtoiso ((Functor.Composition.Laws.associativity _ _ _)^) ];
    rewrite eta_idtoiso;
    simpl;
    rewrite ?ap_V, ?Functor.Composition.Laws.left_identity_fst, ?Functor.Composition.Laws.right_identity_fst, ?Functor.Composition.Laws.associativity_fst;
    try reflexivity.

  (* The following helpers were generated with
<<
intros.
    repeat match goal with
             | [ |- context[idtoiso ?C (?f ?x)] ] => generalize (f x); intro
             | [ |- context[MorphismOf ?F ?f] ] => generalize dependent (MorphismOf F f); repeat (let x := fresh "x" in intro x)
             | [ |- context[ObjectOf ?F ?f] ] => generalize dependent (ObjectOf F f); repeat (let x := fresh "x" in intro x)
           end.
    simpl in *.
    unfold SubPreCatCat.
    simpl in *.
    clear.
    destruct_head_hnf @sig.
    simpl in *.
    repeat match goal with
             | [ H : _ |- _ ] => revert H
           end.
    intros H P.
>> *)

  Lemma pseudofunctor_of_functor__composition_of
        {x0 x1 x2 x : PreCategory}
        {x7 x11 : Functor x0 x1}
        {x12 : x7 = x11}
        {x6 : Functor x0 x2} {x9 : Functor x2 x1}
        {x14 : x11 = (x9 o x6)%functor}
        {x4 : Functor x0 x} {x5 : Functor x x1}
        {x8 : x7 = (x5 o x4)%functor} {x10 : Functor x x2}
        {x13 : x6 = (x10 o x4)%functor} {x15 : x5 = (x9 o x10)%functor}
        (H0' : P x0) (H1' : P x1) (H2' : P x2) (H' : P x)
  : ((associator_1 x9 x10 x4)
       o ((idtoiso (x -> x1) x15 : morphism _ _ _)
            oR x4
            o (idtoiso (x0 -> x1) x8 : morphism _ _ _)))%natural_transformation
    = (x9
         oL (idtoiso (x0 -> x2) x13 : morphism _ _ _)
         o ((idtoiso (x0 -> x1) x14 : morphism _ _ _)
              o (idtoiso (x0 -> x1) x12 : morphism _ _ _)))%natural_transformation.
  Proof.
    clear F.
    symmetry; simpl; pseudofunctor_t.
  Qed.

  Lemma pseudofunctor_of_functor__left_identity_of
        {x0 x : PreCategory}
        {x2 : Functor x x} {x3 : x2 = 1%functor}
        {x4 x5 : Functor x0 x} {x6 : x4 = x5} {x7 : x4 = (x2 o x5)%functor}
        (H0' : P x0) (H' : P x)
  : ((Category.Morphisms.idtoiso (x -> x) x3 : morphism _ _ _)
       oR x5
       o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation
    = ((NaturalTransformation.Composition.Laws.left_identity_natural_transformation_2 x5)
         o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation.
  Proof.
    clear F.
    simpl; pseudofunctor_t.
  Qed.

  Lemma pseudofunctor_of_functor__right_identity_of
        {x0 x : PreCategory}
        {x4 : Functor x0 x0} {x5 : x4 = 1%functor}
        {x2 x3 : Functor x0 x} {x6 : x2 = x3} {x7 : x2 = (x3 o x4)%functor}
        (H0' : P x0) (H' : P x)
  : (x3
       oL (Category.Morphisms.idtoiso (x0 -> x0) x5 : morphism _ _ _)
       o (Category.Morphisms.idtoiso (x0 -> x) x7 : morphism _ _ _))%natural_transformation
    = ((NaturalTransformation.Composition.Laws.right_identity_natural_transformation_2 x3)
         o (Category.Morphisms.idtoiso (x0 -> x) x6 : morphism _ _ _))%natural_transformation.
  Proof.
    clear F.
    simpl; pseudofunctor_t.
  Qed.

  Definition pseudofunctor_of_functor : Pseudofunctor C
    := Build_Pseudofunctor
         C
         (fun x => pr1 (F x))
         (fun s d m => F _1 m)
         (fun s d d' m0 m1 => Category.Morphisms.idtoiso (_ -> _) (composition_of F _ _ _ m1 m0))
         (fun x => Category.Morphisms.idtoiso (_ -> _) (identity_of F x))
         (fun w x y z _ _ _ => pseudofunctor_of_functor__composition_of (F w).2 (F z).2 (F y).2 (F x).2)
         (fun x y _ => pseudofunctor_of_functor__left_identity_of (F x).2 (F y).2)
         (fun x y _ => pseudofunctor_of_functor__right_identity_of (F x).2 (F y).2).
End of_functor.

Definition FunctorToCat `{Funext} {C} `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}
  := Functor C (@sub_pre_cat _ P HP).
Identity Coercion functor_to_cat_id : FunctorToCat >-> Functor.
Definition pseudofunctor_of_functor_to_cat `(F : @FunctorToCat H C P HP)
  := @pseudofunctor_of_functor _ C P HP F.


(** * Axioms used in the ITree library. *)

(** Other ITree modules should import this to avoid accidentally using more
   axioms elsewhere. *)

From Coq Require Import
  Logic.Classical_Prop
  Logic.ClassicalChoice
  Logic.EqdepFacts
  Logic.FunctionalExtensionality
.

(* Must be imported to use [ddestruction] *)
From Coq Require Export
  Program.Equality
.

Set Implicit Arguments.

(* The following tactics may be used:
   - [dependent destruction]
   - [dependent induction] *)
Ltac ddestruction :=
  repeat lazymatch goal with | H : existT _ _ _ = _ |- _ => dependent destruction H end.

(* Consequence of UIP; used by tactic [dependent destrcution] *)
Definition eq_rect_eq := Eqdep.Eq_rect_eq.eq_rect_eq.

Definition classic := Classical_Prop.classic.

Definition choice := ClassicalChoice.choice.

Definition functional_extensionality := @FunctionalExtensionality.functional_extensionality.

(* From Coq.Logic.ChoiceFacts *)
Definition GuardedFunctionalChoice_on {A B} :=
  forall P : A -> Prop, forall R : A -> B -> Prop,
    inhabited B ->
    (forall x : A, P x -> exists y : B, R x y) ->
    (exists f : A->B, forall x, P x -> R x (f x)).
Axiom guarded_choice : forall {A B}, @GuardedFunctionalChoice_on A B.

Inductive mwitness : Type :=
| Witness (P : Type) (_ : P)
| NoWitness.

Lemma classicT_inhabited : inhabited (forall (P : Type), P + (P -> False)).
Proof.
  destruct (choice (fun (P : Type) (b : mwitness) =>
    match b with @Witness Q _ => P = Q | NoWitness => P -> False end)) as [f H].
  { intros P; destruct (classic (inhabited P)) as [[x] | ];
      [exists (Witness x) | exists NoWitness]; auto. }
  constructor. intros P; specialize (H P); destruct (f P); [subst | ]; auto.
Qed.


(***
 *** A version of the computation monad using the option-set monad
 ***)

From Coq Require Export Morphisms Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts.
From Paco Require Import paco.

Infix ">>=" := ITree.bind (at level 58, left associativity).
Notation "m1 >> m2" := (m1 >>= fun _ => m2) (at level 58, left associativity).

Variant SpecEvent (E:Type -> Type) (A:Type) : Type :=
| Spec_vis : E A -> SpecEvent E A
| Spec_forall : SpecEvent E A
| Spec_exists : SpecEvent E A
.

Arguments Spec_vis {E A}.
Arguments Spec_forall {E A}.
Arguments Spec_exists {E A}.

(* An ITree that defines a set of ITrees *)
Definition itree_spec E A : Type := itree (SpecEvent E) A.

(* The body of an itree_spec, inside the observe projection *)
Definition itree_spec' E A : Type := itree' (SpecEvent E) A.

Inductive satisfiesF {E A} (satisfies : itree_spec E A -> itree E A -> Prop)
  : itree_spec' E A -> itree' E A -> Prop :=
| Satisfies_Ret a : satisfiesF satisfies (RetF a) (RetF a)
| Satisfies_Tau spec tree :
    satisfies spec tree ->
    satisfiesF satisfies (TauF spec) (TauF tree)
| Satisfies_TauL spec tree :
    satisfiesF satisfies (observe spec) tree ->
    satisfiesF satisfies (TauF spec) tree
| Satisfies_TauR spec tree :
    satisfiesF satisfies spec (observe tree) ->
    satisfiesF satisfies spec (TauF tree)
| Satisfies_Vis X (e:E X) spec tree :
    (forall x, satisfies (spec x) (tree x)) ->
    satisfiesF satisfies (VisF (Spec_vis e) spec) (VisF e tree)
| Satisfies_Forall X spec tree :
    (forall x:X, satisfies (spec x) tree) ->
    satisfiesF satisfies (VisF Spec_forall spec) (observe tree)
| Satisfies_Exists X spec tree :
    (exists x:X, satisfies (spec x) tree) ->
    satisfiesF satisfies (VisF Spec_exists spec) (observe tree)
.

Hint Constructors satisfiesF.

Instance Proper_satisfies_satisfiesF {E A} :
  Proper (pointwise_relation _ (pointwise_relation _ Basics.impl) ==>
          eq ==> eq ==> Basics.impl) (@satisfiesF E A).
Proof.
  intros R1 R2 implR spec1 spec2 e_spec tree1 tree2 e_tree sats.
  rewrite <- e_spec; rewrite <- e_tree.
  clear e_spec spec2 e_tree tree2.
  induction sats; constructor; intros; try (apply implR; apply H); try assumption.
  destruct H as [ x H ]. exists x. apply implR; assumption.
Qed.

Lemma satisfiesF_mono {E A} (sats1 sats2:itree_spec E A -> itree E A -> Prop)
         (sub_sats:forall spec tree, sats1 spec tree -> sats2 spec tree) :
  forall spec tree,
    satisfiesF sats1 spec tree -> satisfiesF sats2 spec tree.
Proof.
  intros.
  apply (Proper_satisfies_satisfiesF sats1 sats2 sub_sats _ _ eq_refl _ _ eq_refl H).
Qed.

Definition satisfies_ {E A} satisfies spec tree :=
  @satisfiesF E A satisfies (observe spec) (observe tree).

Lemma satisfies__mono E A : monotone2 (@satisfies_ E A).
Proof.
  intros spec tree r1 r2 sats sub12. unfold satisfies_.
  induction sats; constructor; try assumption.
  { apply sub12; assumption. }
  { intros; apply sub12. apply H. }
  { intros; apply sub12. apply H. }
  { destruct H as [ x H ]. exists x. apply sub12. apply H. }
Qed.

Hint Resolve satisfies__mono : paco.

Definition satisfies {E A} spec tree := paco2 (@satisfies_ E A) bot2 spec tree.

Instance Proper_observing_paco2_satisfies_impl E A r :
  Proper (observing eq ==> observing eq ==> iff) (paco2 (@satisfies_ E A) r).
Proof.
  intros spec1 spec2 [ Rspec ] tree1 tree2 [ Rtree ].
  split; intro; punfold H; pfold; unfold satisfies_;
    [ rewrite <- Rtree; rewrite <- Rspec | rewrite Rtree; rewrite Rspec ];
    apply H.
Qed.

Instance Proper_observing_satisfies E A :
  Proper (observing eq ==> observing eq ==> iff) (@satisfies E A).
Proof.
  apply Proper_observing_paco2_satisfies_impl.
Qed.

Ltac simpobs x := apply simpobs in x.

Ltac weaken_bis Hb := match type of Hb with ?x ≅ ?y => assert (x ≈ y); try (rewrite Hb; reflexivity) end.

Lemma satisfies_eutt_spec_tau_vis_aux: forall (E : Type -> Type) (A u : Type) (e : SpecEvent E u)
                                         (k1 k2 : u -> itree (SpecEvent E) A),
    (forall v : u, paco2 (eqit_ eq true true id) bot2 (k1 v) (k2 v)) ->
    forall (r : itree_spec E A -> itree E A -> Prop) (tree0 : itree E A),
      (forall (P1 P2 : itree_spec E A) (tree : itree E A),
          satisfies P1 tree -> P1 ≈ P2 -> r P2 tree) ->
      satisfiesF (upaco2 satisfies_ bot2) (VisF e k1) (observe tree0) ->
      satisfiesF (upaco2 satisfies_ r) (VisF e k2) (observe tree0).
Proof.
  intros E A u e k1 k2 REL r tree0 CIH H.
  dependent induction H.
  - rewrite <- x. constructor. eapply IHsatisfiesF; eauto.
  - rewrite <- x. constructor. intros. right.
    pclearbot. eapply CIH; eauto. apply H.
  - rewrite <- x. constructor. right. pclearbot; eapply CIH; eauto.
    apply H.
  - rewrite <- x. constructor. destruct H as [x' Hx' ]. pclearbot.
    exists x'. right. eapply CIH; eauto.
Qed.

Lemma satisfiesF_TauL: forall (E : Type -> Type) (A : Type) (t1 : itree (SpecEvent E) A)
                         (tree0 : itree E A),
    satisfiesF (upaco2 satisfies_ bot2) (TauF t1) (observe tree0) ->
    satisfiesF (upaco2 satisfies_ bot2) (observe t1) (observe tree0).
Proof.
  intros E A t1 tree0 H.
  dependent induction H; auto.
  - pclearbot. rewrite <- x. constructor. punfold H.
  - rewrite <- x. constructor. eapply IHsatisfiesF; eauto.
Qed.

(* Requires coinduction because the forall and exist states *)
Lemma satisfies_TauR:
  forall (E : Type -> Type) (A : Type) (P : itree_spec E A) (t : itree E A),
    satisfies P (Tau t) ->
    satisfies P t.
Proof.
  intros E A. pcofix CIH. intros P t HP.
  pfold. red.
  punfold HP. red in HP. dependent induction HP; pclearbot; auto.
  - rewrite <- x. constructor. pstep_reverse. eapply paco2_mon; eauto.
    intuition.
  - rewrite <- x. constructor. eapply IHHP; eauto.
  - pstep_reverse. clear IHHP. eapply paco2_mon with (r := bot2); intuition.
  - rewrite <- x0. cbn in x. constructor. right.
    eapply CIH; eauto. pfold. red. cbn. rewrite <- x. pstep_reverse.
  - rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot.
    exists x'. right. eapply CIH. pfold. red. rewrite <- x. pstep_reverse.
Qed.

Lemma satisfies_eutt_spec_l E A (P1 P2:itree_spec E A) tree :
  satisfies P1 tree -> eutt eq P1 P2 -> satisfies P2 tree.
Proof.
  revert P1 P2 tree. pcofix CIH. intros P1 P2 tree HP HP12.
  punfold HP. red in HP. pfold. red. punfold HP12. red in HP12.
  dependent induction HP.
  - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12; auto.
    + rewrite <- x. constructor.
    + rewrite <- x. constructor. eapply IHHP12; eauto.
  - pclearbot.
    remember (observe P2) as oP2. clear HeqoP2 P2.
    assert ((exists P2', oP2 = TauF P2') \/ (forall P2', oP2 <> TauF P2') ).
    { destruct oP2; eauto; right; repeat intro; discriminate. }
    rewrite <- x. rewrite <- x0 in HP12. clear x0 x.
    destruct H0 as [ [P2' HP2'] | HP2' ].
    + subst. constructor. right. eapply CIH; eauto.
      rewrite <- tau_eutt. setoid_rewrite <- tau_eutt at 3.
      pfold. auto.
    + inversion HP12; try (exfalso; eapply HP2'; eauto; fail); subst.
       clear HP12. punfold H. red in H.
       dependent induction REL; intros; subst;
       try (exfalso; eapply HP2'; eauto; fail).
       * constructor. rewrite <- x in H.
         clear CIH HP2' x. dependent induction H; try constructor.
         ++ rewrite <- x. constructor.
         ++ rewrite <- x. constructor. apply IHsatisfiesF; auto.
       * rewrite <- x in H. constructor. pclearbot.
         eapply satisfies_eutt_spec_tau_vis_aux; eauto.
       * eapply IHREL; auto. rewrite <- x in H.
         eapply satisfiesF_TauL; eauto.
  - eapply IHHP; eauto. rewrite <- x in HP12.
    assert (Tau spec ≈ P2); try (pfold; auto; fail).
    rewrite tau_eutt in H. punfold H.
  - rewrite <- x. constructor. eapply IHHP; eauto.
  - rewrite <- x. rewrite <- x0 in HP12. dependent induction HP12.
    + rewrite <- x. constructor. pclearbot. intros.  right. eapply CIH; eauto.
      apply H.
    + rewrite <- x. constructor. eapply IHHP12; eauto.
  - rewrite <- x0 in HP12. dependent induction HP12.
    + rewrite <- x. constructor. pclearbot. intros. right. eapply CIH; eauto.
      pfold. red. rewrite <- x1.
      specialize (H x2). punfold H.
    + rewrite <- x. constructor. eapply IHHP12; eauto.
  - rewrite <- x0 in HP12. rewrite <- x. clear x tree. dependent induction HP12.
    + rewrite <- x. constructor. destruct H as [x' Hx']. pclearbot.
      exists x'. right. eapply CIH; eauto.
    + rewrite <- x. constructor. eapply IHHP12; eauto.
Qed.

Lemma satisfies_eutt_spec_r E A (P:itree_spec E A) (t1 t2 : itree E A) :
  satisfies P t1 -> t1 ≈ t2 -> satisfies P t2.
Proof.
  revert P t1 t2. pcofix CIH. intros P t1 t2 HP Ht12.
  pfold. red. punfold Ht12. red in Ht12. punfold HP. red in HP.
  dependent induction Ht12.
  - rewrite <- x. rewrite <- x0 in HP. clear x x0.
    dependent induction HP; auto;
    try (rewrite <- x; auto).
    + rewrite <- x0. pclearbot. constructor.
      intros. right. eapply CIH; try apply H. reflexivity.
    + rewrite <- x0. constructor. destruct H as [x' Hx']. pclearbot.
      exists x'. right. eapply CIH; eauto. reflexivity.
      (* Tau Tau case *)
  - pclearbot. remember (observe P) as oP. clear HeqoP P.
    assert ( (exists P, oP = TauF P) \/ (forall P, oP <> TauF P) ).
    { destruct oP; eauto; right; repeat intro; discriminate. }
    destruct H as [ [P HoP] | HoP].
    + subst. rewrite <- x. constructor. right. eapply CIH; eauto.
      apply satisfies_TauR. pfold. red. apply satisfiesF_TauL. simpl.
      rewrite x0. auto.
    + rewrite <- x. rewrite <- x0 in HP.
      inversion HP; try (exfalso; eapply HoP; eauto; fail).
      * subst. clear HP. clear x x0. punfold REL. red in REL. constructor.
        dependent induction H1; try (exfalso; eapply HoP; eauto; fail).
        ++ rewrite <- x in REL. clear x. dependent induction REL;
           try (rewrite <- x; auto).
        ++ eapply IHsatisfiesF; auto. pstep_reverse.
           assert (m1 ≈ m2); try (pfold; auto; fail). simpobs x. rewrite x in H.
           rewrite tau_eutt in H. auto.
        ++ rewrite <- x in REL. clear x. dependent induction REL.
           ** rewrite <- x; auto. constructor. right.
              pclearbot. eapply CIH; eauto. apply H.
           ** rewrite <- x. constructor. eapply IHREL; eauto.
        ++ pclearbot. constructor. right. eapply CIH; eauto. pfold. red.
           rewrite <- x. pstep_reverse.
        ++ constructor. destruct H as [x' Hx']. pclearbot. exists x'. right.
           eapply CIH; eauto. simpobs x. rewrite <- itree_eta in x. rewrite <- x.
           pfold. auto.
      * constructor. constructor. right. pclearbot. eapply CIH; eauto.
        apply satisfies_TauR. pfold. red. cbn. rewrite <- H. pstep_reverse.
      * constructor. constructor. destruct H1 as [x' Hx' ]. pclearbot.
        exists x'. right. eapply CIH; eauto. symmetry in H. simpobs H.
        rewrite H. rewrite tau_eutt. auto.
  - rewrite <- x. rewrite <- x0 in HP. clear x x0. dependent induction HP.
    + rewrite <- x. constructor. eapply IHHP; eauto.
    + rewrite <- x. constructor. intros. right.
      pclearbot. eapply CIH; eauto. apply H.
    + rewrite <- x0. pclearbot.
      assert (VisF e k2 = observe (Vis e k2) ); auto. rewrite H0.
      constructor. intros. right. eapply CIH; try apply H.
      symmetry in x. simpobs x. rewrite x.
      pfold. red. constructor. auto.
    + rewrite <- x0. assert (VisF e k2 = observe (Vis e k2) ); auto.
      rewrite H0. constructor. destruct H as [x' Hx']. pclearbot.
      exists x'. right. eapply CIH; eauto. symmetry in x. simpobs x.
      rewrite x. pfold. constructor. left. auto.
  - eapply IHHt12; auto. rewrite <- x in HP. pstep_reverse.
    apply satisfies_TauR. pfold. auto.
  - rewrite <- x. constructor.
    eapply IHHt12; eauto.
Qed.

Instance proper_eutt_satisfies E R : Proper (@eutt (SpecEvent E) R R eq ==> eutt eq ==> iff) satisfies.
Proof.
  intros P Q HPQ t1 t2 Ht12. split; intros.
  - eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto.
  - symmetry in HPQ. symmetry in Ht12. eapply satisfies_eutt_spec_r; eauto. eapply satisfies_eutt_spec_l; eauto.
Qed.

(* infinte forall exist chains *)

CoFixpoint top_spec {E: Type -> Type} {A : Type} : itree_spec E A := Vis Spec_forall (fun _ : unit => top_spec).

Lemma top_spec_is_top : forall E R (t : itree E R), satisfies top_spec t.
Proof.
  intros E R. pcofix CIH. intros. pfold. red. cbn. constructor. intros. right. auto.
Qed.

Definition bottom_spec {E : Type -> Type} {A : Type} : itree_spec E A := Vis Spec_exists (fun v : void => match v with end).

Lemma bottom_spec_is_bottom : forall E R (t : itree E R), ~ satisfies bottom_spec t.
Proof.
  intros E R t Hcontra. punfold Hcontra. red in Hcontra. cbn in *. dependent induction Hcontra; eauto.
  destruct H as [ [] _ ].
Qed.

Definition and_spec {E : Type -> Type} {A : Type} (P Q : itree_spec E A) :=
  Vis Spec_forall (fun b : bool => if b then P else Q).

Definition or_spec {E : Type -> Type} {A : Type} (P Q : itree_spec E A) :=
  Vis Spec_exists (fun b : bool => if b then P else Q).

Lemma and_spec_is_and : forall E R (t : itree E R) (P Q : itree_spec E R),
    satisfies (and_spec P Q) t <-> (satisfies P t /\ satisfies Q t).
Proof.
  split; [split | idtac]; intros.
  - punfold H. red in H. pfold. red. cbn in H. dependent induction H.
    + rewrite <- x. constructor. eauto.
    + simpobs x. rewrite <- itree_eta in x. pclearbot. pstep_reverse.
      specialize (H true). cbn in *. rewrite x. auto.
  - punfold H. red in H. pfold. red. cbn in H. dependent induction H.
    + rewrite <- x. constructor. eauto.
    + simpobs x. rewrite <- itree_eta in x. pclearbot. pstep_reverse.
      specialize (H false). cbn in *. rewrite x. auto.
  - destruct H. pfold. red. cbn. constructor. intros; destruct x; left; auto.
Qed.

Lemma or_spec_is_or : forall E R (t : itree E R) (P Q : itree_spec E R),
    satisfies (or_spec P Q) t <-> (satisfies P t \/ satisfies Q t).
Proof.
  split; intros; [idtac | destruct H] .
  - punfold H. red in H. cbn in *. dependent induction H; [ simpobs x | idtac ].
    + setoid_rewrite x. setoid_rewrite tau_eutt. eapply IHsatisfiesF; eauto.
    + simpobs x. rewrite <- itree_eta in x. setoid_rewrite x.
      destruct H as [ [ | ] H ]; pclearbot; eauto.
  - pfold. red. cbn. constructor. exists true. auto.
  - pfold. red. cbn. constructor. exists false. auto.
Qed.

Lemma or_spec_bind : forall E R S (P Q : itree_spec E R) (k : R -> itree_spec E S),
    (or_spec P Q) >>= k ≈ or_spec (P >>= k) (Q >>= k).
Proof.
  intros. unfold or_spec. rewrite bind_vis. pfold. constructor.
  intros; left.
  enough ( (if v then P else Q) >>= k ≈ if v then P >>= k else Q >>= k ); auto.
  destruct v; reflexivity.
Qed.

Lemma and_spec_bind : forall E R S (P Q : itree_spec E R) (k : R -> itree_spec E S),
    (and_spec P Q) >>= k ≈ and_spec (P >>= k) (Q >>= k).
Proof.
  intros. unfold and_spec.
  pfold. red. cbn. constructor.
  intros; left.
  enough ( (if v then P else Q) >>= k ≈ if v then P >>= k else Q >>= k ); auto.
  destruct v; reflexivity.
Qed.

(*
Definition imp_spec {E R} (P Q : itree_spec E R) :=
  Vis Spec_forall (fun _ : satisfies P t => Q)
*)

(* The proposition that a is returned by an itree along some path *)
Inductive is_itree_retval' {E A} : itree' E A -> A -> Prop :=
| iirv_ret a : is_itree_retval' (RetF a) a
| iirv_tau tree a :
    is_itree_retval' (observe tree) a -> is_itree_retval' (TauF tree) a
| iirv_vis {X} (ev:E X) tree a x :
    is_itree_retval' (observe (tree x)) a ->
    is_itree_retval' (VisF ev tree) a
.

Definition is_itree_retval {E A} tree a := @is_itree_retval' E A (observe tree) a.

Instance Proper_observing_is_itree_retval E A :
  Proper (observing eq ==> eq ==> iff) (@is_itree_retval E A).
Proof.
  intros m1 m2 [ em ] a1 a2 ea. rewrite <- ea. unfold is_itree_retval.
  rewrite em. reflexivity.
Qed.

Lemma bind_satisfies_bind E A B (P:itree_spec E A) (Q:A -> itree_spec E B)
      (m:itree E A) (f:A -> itree E B) :
  satisfies P m ->
  (forall a, is_itree_retval m a -> satisfies (Q a) (f a)) ->
  satisfies (P >>= Q) (m >>= f).
Proof.
  intro sats; revert P m sats. pcofix CIH.
  intros P m sats satsQ; punfold sats. unfold satisfies_ at 1 in sats.
  remember (observe P) as obsP eqn: e_obsP.
  remember (observe m) as obsm eqn: e_obsm.
  revert P m e_obsP e_obsm satsQ. induction sats; intros.
  { rewrite <- (observing_intros _ (Ret a) _ e_obsP).
    rewrite <- (observing_intros _ (Ret a) _ e_obsm).
    repeat rewrite bind_ret_.
    eapply paco2_mon_bot; [ apply satsQ | intros; eassumption ].
    rewrite <- (observing_intros _ (Ret a) _ e_obsm). constructor. }
  { rewrite <- (observing_intros _ (Tau _) _ e_obsP).
    rewrite <- (observing_intros _ (Tau _) _ e_obsm).
    repeat rewrite bind_tau_.
    pfold. apply Satisfies_Tau. right. pclearbot. apply CIH; [ assumption | ].
    intros a iirv. apply satsQ.
    rewrite <- (observing_intros _ (Tau _) _ e_obsm).
    constructor. assumption. }
  { rewrite <- (observing_intros _ (Tau _) _ e_obsP). rewrite bind_tau_.
    pfold. apply Satisfies_TauL.
    set (IHapp := IHsats spec m eq_refl e_obsm satsQ). punfold IHapp. }
  { rewrite <- (observing_intros _ (Tau _) _ e_obsm). rewrite bind_tau_.
    pfold. apply Satisfies_TauR.
    assert (paco2 satisfies_ r (P >>= Q) (tree >>= f)) as IHapp;
      [ | punfold IHapp ].
    apply IHsats; [ assumption | reflexivity | ].
    intros. apply satsQ. rewrite <- (observing_intros _ (Tau _) _ e_obsm).
    constructor. assumption. }
  { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP).
    rewrite <- (observing_intros _ (Vis _ _) _ e_obsm).
    repeat rewrite bind_vis_. pfold.
    apply Satisfies_Vis. intro x. right. apply CIH.
    - pclearbot. apply H.
    - intros. apply satsQ. rewrite <- (observing_intros _ (Vis _ _) _ e_obsm).
      econstructor. eassumption. }
  { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP).
    rewrite <- (observing_intros _ _ _ e_obsm).
    rewrite bind_vis_. pfold. apply Satisfies_Forall. intro x. right. apply CIH.
    - pclearbot. apply H.
    - intros. apply satsQ.
      rewrite <- (observing_intros _ _ _ e_obsm). assumption. }
  { rewrite <- (observing_intros _ (Vis _ _) _ e_obsP).
    rewrite <- (observing_intros _ _ _ e_obsm).
    rewrite bind_vis_. pfold.
    destruct H as [ x H ]. apply Satisfies_Exists. exists x. right. apply CIH.
    - pclearbot. apply H.
    - intros. apply satsQ.
      rewrite <- (observing_intros _ _ _ e_obsm). assumption. }
Qed.

Notation " x : T <- m1 ;; m2" := (ITree.bind m1 (fun x : T=> m2) ) (at level 40).

Section l_bind_satisfies_bind_counter.
  Variant NonDet : Type -> Type := Choose : NonDet bool.

  Definition m_counter : itree NonDet unit :=
    x : bool <- ITree.trigger Choose ;;
    if x then Ret tt else y : bool <- ITree.trigger Choose;; Ret tt.

  Definition P_counter : itree_spec NonDet unit :=
    x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt.

  Definition Q_counter : unit -> itree_spec NonDet unit :=
    fun _ => or_spec (Ret tt) ( x : bool <- ITree.trigger (Spec_vis Choose);; Ret tt  ).

  Lemma m_counter_sats_P_bind_Q_counter : satisfies (P_counter >>= Q_counter) m_counter.
  Proof.
    pfold. red. cbn. constructor. left. destruct x.
    - pfold. red. cbn.
      assert (RetF (E:= NonDet) tt = observe (Ret tt)); auto.
      rewrite H. constructor. exists true. left. pfold; constructor.
    - pfold. red. cbn. assert (VisF Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) =
                               observe (Vis Choose (fun x : bool => _ : bool <- Ret x;; Ret tt) ) ); auto.
      rewrite H. constructor. exists false. left. pfold. red. cbn.
      rewrite H. constructor. intros [ | ]; left; pfold; red; cbn; auto.
   Qed.

  Lemma satifies_P_counter : forall m, satisfies P_counter m ->
                                  m ≈ (x : bool <- ITree.trigger Choose;; Ret tt).
  Proof.
    intros. unfold P_counter in *. punfold H. red in H. pfold. red. cbn in *.
    dependent induction H.
    - rewrite <- x. constructor; auto.
    - rewrite <- x. constructor. left. pclearbot. specialize (H v).
      assert (satisfies (_ : bool <- Ret v;; Ret tt) (tree v) ); auto.
      enough (tree v ≈ ( _ : bool <- Ret v;; Ret tt) ); auto. rewrite bind_ret_l.
      rewrite bind_ret_l in H0. symmetry. clear x H m.
      pfold. red. punfold H0. red in H0. cbn in *.
      remember (observe (tree v) ) as ot. clear Heqot tree v. dependent induction H0; auto.
  Qed.

  Definition m0_counter : itree NonDet unit := x : bool <- ITree.trigger Choose;; Ret tt.

  Lemma m0_counter_no_continuation : forall k,
      ~ m0_counter >>= k ≈ m_counter .
  Proof.
    unfold m0_counter, m_counter.
    intros k Hcontra. repeat rewrite bind_trigger in Hcontra.
    rewrite bind_vis in Hcontra. apply eqit_inv_vis in Hcontra as [_ Hcontra] .
    specialize (Hcontra true) as Hktrue. specialize (Hcontra false) as Hkfalse.
    cbn in *. rewrite bind_ret_l in Hktrue. rewrite bind_ret_l in Hkfalse.
    rewrite Hktrue in Hkfalse. pinversion Hkfalse.
  Qed.

  Lemma not_l_bind_satisfies_bind_aux : exists E R S
               (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R),
      satisfies (P >>= Q) m /\ (forall m0 k, satisfies P m0 -> ~ (m0 >>= k ≈ m) ).
    Proof.
      exists NonDet, unit, unit, m_counter, P_counter, Q_counter.
      split; try apply m_counter_sats_P_bind_Q_counter.
      intros. apply satifies_P_counter in H. rewrite H. fold m0_counter.
      apply m0_counter_no_continuation.
    Qed.

End l_bind_satisfies_bind_counter.

Lemma not_l_bind_satisfies_bind : ~ forall E R S
            (m : itree E R) (P : itree_spec E S) (Q : S -> itree_spec E R),
       satisfies (P >>= Q) m -> exists m0 k, satisfies P m0 /\ (forall a, is_itree_retval m0 a -> satisfies (Q a) (k a) ) /\ (m0 >>= k ≈ m).
Proof.
  destruct not_l_bind_satisfies_bind_aux as [ E [R [S [m [P [Q  [H0 H1] ] ] ] ] ] ].
  intros Hcontra. specialize (Hcontra E R S m P Q H0).
  destruct Hcontra as [m0 [k [Hsat [ _ Heutt] ] ] ]. eapply H1; eauto.
Qed.

(* Our event type = errors *)
Inductive CompMEvent : Type -> Type :=
| ErrorEvent : CompMEvent False
.

(* Our computations are sets of ITrees. That is, they are really more like
specifications of computations *)
Definition CompM (A:Type) : Type := itree_spec CompMEvent A.


Require Import List.
Import ListNotations.

Require Import FSets FSets.FMapAVL FSets.FMapFacts.

From Verbatim Require Import state.
From Verbatim Require Import memo.
From Verbatim Require Import ltac.
From Verbatim Require Import Orders.
From Verbatim Require Import tape.

Module FMemo (STT : state.T) <: MEMO STT.

  Import STT.Ty.
  Import STT.Defs.
  Import STT.R.Defs.

  Module Pointer_as_UOT <: UsualOrderedType := UOT_from_UCT Pointer_as_UCT.
  Module FM := FMapAVL.Make Pointer_as_UOT.
  Module FMF := FMapFacts.Facts FM.

  Definition Memo : Type := @Tape (FM.t (option (String * String * index))).
  Definition emptyMemo : Memo := ([],[]).

  Definition get_Memo (M : Memo) (pnt : Pointer) (i : index)
    : option (option (String * String * index)) :=
    match get_Tape (index2nat i) M with
    | None => None
    | Some MP => FM.find pnt MP
    end.

  Definition set_Memo (M : Memo) (pnt : Pointer) (i : index)
             (o : (option (String * String * index))) : Memo :=
    match get_Tape (index2nat i) M with
    | None => set_Tape (FM.add pnt o (@FM.empty (option (String * String * index))))
                      (index2nat i)
                      M
    | Some MP => set_Tape (FM.add pnt o (MP)) (index2nat i) M
    end.

  Lemma correct_Memo : forall M ptr i o, get_Memo (set_Memo M ptr i o) ptr i = Some o.
  Proof.
    intros. unfold get_Memo. unfold set_Memo. repeat dm.
    - rewrite get_of_set_eq in E; repeat inj_all. apply FMF.add_eq_o; auto.
    - rewrite get_of_set_eq in E; repeat inj_all. apply FMF.add_eq_o; auto.
    - rewrite get_of_set_eq in E; discriminate.
    - rewrite get_of_set_eq in E; discriminate.
  Qed.

  Lemma bar : forall i i', i <> i' -> index2nat i <> index2nat i'.
  Admitted.

  Lemma correct_Memo_moot : forall M ptr ptr' i i' o,
      (ptr <> ptr' \/ i <> i')
      ->
      get_Memo (set_Memo M ptr' i' o) ptr i = get_Memo M ptr i.
  Proof.
    intros. unfold get_Memo. unfold set_Memo.
    destruct (Pointer_as_UOT.eq_dec ptr ptr') eqn:E;
      destruct (index_eq_dec i i'); destruct H;
        repeat dm; try contradiction.
  Admitted.

  Lemma correct_emptyMemo : forall stt z, get_Memo emptyMemo stt z = None.
  Proof.
    intros. unfold get_Memo. unfold emptyMemo. unfold get_Tape. repeat dm.
    sis.
  Admitted.

End FMemo.

Module memoTFn (STT' : state.T) <: memo.T.
  Module STT := STT'.
  Module MemTy <: MEMO STT := FMemo STT.
  Module Defs := memo.MemoDefsFn STT MemTy.
End memoTFn.


Module Type TIT.

Inductive X:Set:=
 b:X.
End TIT.

Module Type TOTO.
Declare Module t:TIT.
Inductive titi:Set:=
 a:t.X->titi.
End TOTO.

Module toto (ta:TOTO).
Module ti:=ta.t.

Definition ex1:forall (c d:ti.X), (ta.a d)=(ta.a c) -> d=c.
intros.
injection H.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export cequiv_props2.
Require Export compare_cterm.
Require Export cequiv_bind.
Require Export subst_tacs.

Lemma hasvaluec_mkc_try_implies {o} :
  forall lib t n v (c : @CVTerm o [v]),
    hasvaluec lib (mkc_try t n v c)
    ->
    (
      {u : CTerm
       & reduces_toc lib t u
       # iscvalue u
       # reduces_toc lib (mkc_try t n v c) (mkc_atom_eq n n u mkc_bottom)
      }
      [+]
      {m : CTerm
       & {u : CTerm
       & reduces_toc lib t (mkc_exception m u)
       # reduces_toc lib (mkc_try t n v c) (mkc_atom_eq n m (substc u v c) (mkc_exception m u))
      } }
    ).
Proof.
  introv hv.
  destruct_cterms; simpl in *.
  unfold reduces_toc; simpl.
  unfold hasvaluec in *; simpl in *.
  unfold hasvalue in hv; exrepnd.
  unfold computes_to_value in hv0; repnd.
  unfold reduces_to in hv1; exrepnd.
  unfold iscvalue; simpl.

  revert dependent x0.

  induction k; introv ispx0 r.

  {
    allrw @reduces_in_atmost_k_steps_0; subst.
    inversion hv0; subst; simpl in *; tcsp.
  }

  {
    allrw @reduces_in_atmost_k_steps_S; exrepnd.

    csunf r1; simpl in *.

    destruct x0 as [z|F|op bs]; ginv.

    {
      left.
      exists (mk_ct (sterm F) ispx0); simpl.
      dands; eauto 3 with slow.
    }

    {
      dopid op as [can|ncan|exc|abs] Case; simpl; ginv; auto.

      - left.
        exists (mk_ct (oterm (Can can) bs) ispx0); simpl.
        dands; eauto 3 with slow.

      - remember (compute_step lib (oterm (NCan ncan) bs)) as cs.
        destruct cs; simpl in *; ginv.
        symmetry in Heqcs.
        fold_terms.
        applydup @preserve_compute_step in Heqcs; eauto 2 with slow.
        applydup IHk in r0; auto; eauto 2 with slow;[].
        repndors; exrepnd; destruct_cterms; simpl in *.

        + left.
          exists (mk_ct x0 i0); simpl; dands; auto.

          * eapply reduces_to_if_split2; eauto.

          * eapply reduces_to_trans;[|eauto].
            apply reduces_to_prinarg; eauto 2 with slow.

        + right.
          exists (mk_ct x2 i2) (mk_ct x0 i0); simpl; dands; auto.

          * eapply reduces_to_if_split2; eauto.

          * eapply reduces_to_trans;[|eauto].
            apply reduces_to_prinarg; eauto 2 with slow.

      - destruct bs as [|b1 bs]; simpl in *; ginv.
        destruct b1 as [l1 t1]; simpl in *; ginv.
        destruct l1 as [|v1 l1]; simpl in *; ginv.
        destruct bs as [|b2 bs]; simpl in *; ginv.
        destruct b2 as [l2 t2]; simpl in *; ginv.
        destruct l2 as [|v2 l2]; simpl in *; ginv.
        destruct bs as [|]; simpl in *; ginv.
        fold_terms.
        right.

        allrw @isprog_exception_iff; repnd.
        exists (mk_ct t1 ispx1) (mk_ct t2 ispx0); simpl.
        dands; eauto 2 with slow.

      - remember (compute_step lib (oterm (Abs abs) bs)) as cs.
        destruct cs; simpl in *; ginv.
        symmetry in Heqcs.
        fold_terms.
        applydup @preserve_compute_step in Heqcs; eauto 2 with slow.
        applydup IHk in r0; auto; eauto 2 with slow;[].
        repndors; exrepnd; destruct_cterms; simpl in *.

        + left.
          exists (mk_ct x0 i0); simpl; dands; auto.

          * eapply reduces_to_if_split2; eauto.

          * eapply reduces_to_trans;[|eauto].
            apply reduces_to_prinarg; eauto 2 with slow.

        + right.
          exists (mk_ct x2 i2) (mk_ct x0 i0); simpl; dands; auto.

          * eapply reduces_to_if_split2; eauto.

          * eapply reduces_to_trans;[|eauto].
            apply reduces_to_prinarg; eauto 2 with slow.
    }
  }
Qed.

Lemma computes_to_valc_excc_false {o} :
  forall lib (a b n c : @CTerm o),
    computes_to_valc lib a b
    -> computes_to_excc lib n a c
    -> False.
Proof.
  introv compv compe.
  destruct_cterms; simpl in *.
  unfold computes_to_valc in *; unfold computes_to_excc in *; simpl in *.
  destruct compv as [r iv].
  eapply reduces_to_eq_val_like in compe; try (exact r); eauto 3 with slow.
  subst.
  inversion iv; subst; simpl in *; auto.
Qed.

Lemma hasvaluec_mkc_try2_implies {o} :
  forall lib t1 t2 n1 n2 v (c1 c2 : @CVTerm o [v]),
    hasvaluec lib (mkc_try t1 n1 v c1)
    -> hasvaluec lib (mkc_try t2 n2 v c2)
    -> cequivc lib t1 t2
    ->
    (
      {u1 : CTerm
       & {u2 : CTerm
       & reduces_toc lib t1 u1
       # reduces_toc lib t2 u2
       # iscvalue u1
       # iscvalue u2
       # cequivc lib u1 u2
       # reduces_toc lib (mkc_try t1 n1 v c1) (mkc_atom_eq n1 n1 u1 mkc_bottom)
       # reduces_toc lib (mkc_try t2 n2 v c2) (mkc_atom_eq n2 n2 u2 mkc_bottom)
      }}
      [+]
      {m1 : CTerm
       & {m2 : CTerm
       & {u1 : CTerm
       & {u2 : CTerm
       & reduces_toc lib t1 (mkc_exception m1 u1)
       # reduces_toc lib t2 (mkc_exception m2 u2)
       # reduces_toc lib (mkc_try t1 n1 v c1) (mkc_atom_eq n1 m1 (substc u1 v c1) (mkc_exception m1 u1))
       # reduces_toc lib (mkc_try t2 n2 v c2) (mkc_atom_eq n2 m2 (substc u2 v c2) (mkc_exception m2 u2))
      }}}}
    ).
Proof.
  introv hv1 hv2 ceqt.
  apply hasvaluec_mkc_try_implies in hv1.
  apply hasvaluec_mkc_try_implies in hv2.
  repndors; exrepnd.

  - left.
    exists u0 u; dands; auto.
    eapply cequivc_trans;
      [apply cequivc_sym;
       apply reduces_toc_implies_cequivc;
       eauto
      |].
    eapply cequivc_trans;[eauto|].
    apply reduces_toc_implies_cequivc.
    eauto.

  - assert False; tcsp.
    eapply cequivc_trans in ceqt;
      [|apply cequivc_sym;
        apply reduces_toc_implies_cequivc;
        eauto].
    apply cequivc_sym in ceqt.
    eapply cequivc_trans in ceqt;
      [|apply cequivc_sym;
        apply reduces_toc_implies_cequivc;
        eauto].
    apply cequivc_sym in ceqt.
    apply (cequivc_mkc_exception _ _ _ m u0) in ceqt;
      [|destruct_cterms;
        unfold computes_to_excc; simpl;
        apply computes_to_exception_refl].
    exrepnd.
    apply (computes_to_valc_refl lib) in hv3.

    eapply computes_to_valc_excc_false in ceqt0; eauto.

  - assert False; tcsp.
    eapply cequivc_trans in ceqt;
      [|apply cequivc_sym;
        apply reduces_toc_implies_cequivc;
        eauto].
    apply cequivc_sym in ceqt.
    eapply cequivc_trans in ceqt;
      [|apply cequivc_sym;
        apply reduces_toc_implies_cequivc;
        eauto].
    apply (cequivc_mkc_exception _ _ _ m u) in ceqt;
      [|destruct_cterms;
        unfold computes_to_excc; simpl;
        apply computes_to_exception_refl].
    exrepnd.
    apply (computes_to_valc_refl lib) in hv4.

    eapply computes_to_valc_excc_false in ceqt0; eauto.

  - right.
    exists m0 m u0 u; dands; auto.
Qed.

Lemma approx_star_bterm_nobnd_iff {o} :
  forall lib op (a b : @NTerm o),
    op <> NCan NFresh
    -> approx_star_bterm lib op (nobnd a) (nobnd b)
       <=> approx_star lib a b.
Proof.
  introv opd.
  unfold approx_star_bterm, blift_sub.
  split; intro h; exrepnd.

  - repndors; repnd; tcsp.
    apply alpha_eq_bterm_nobnd in h2.
    apply alpha_eq_bterm_nobnd in h0.
    exrepnd.
    unfold nobnd in *; ginv.
    eapply approx_star_alpha_fun_l;[|apply alpha_eq_sym;eauto].
    eapply approx_star_alpha_fun_r;[|apply alpha_eq_sym;eauto].
    auto.

  - exists ([] : list NVar) a b.
    dands; auto.
Qed.

Lemma implies_approx_try {o} :
  forall lib a1 a2 b1 b2 v (t1 t2 : @NTerm o),
    isprog a1
    -> isprog a2
    -> isprog b1
    -> isprog b2
    -> isprog_vars [v] t1
    -> isprog_vars [v] t2
    -> cequiv lib a1 a2
    -> cequiv lib b1 b2
    -> (forall u : NTerm, isprog u -> cequiv lib (subst t1 v u) (subst t2 v u))
    -> approx lib (mk_try a1 b1 v t1) (mk_try a2 b2 v t2).
Proof.
  introv ispa1 ispa2 ispb1 ispb2 isp1 isp2 ceqa ceqb imp.

  apply howetheorem1;
    try (apply isprogram_try);
    eauto 3 with slow;
    try (complete (apply isprog_vars_eq in isp1; tcsp));
    try (complete (apply isprog_vars_eq in isp2; tcsp)).

  apply approx_star_congruence; unfold num_bvars; simpl; auto.

  allrw @approx_starbts_cons.
  dands; auto;
    try (apply approx_star_bterm_nobnd_iff;
         auto; try (complete (intro xx; inversion xx)));
    eauto 3 with slow.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqa; tcsp.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqb; tcsp.

  - unfold approx_star_bterm, blift_sub.
    exists [v] t1 t2; dands; auto.
    left; dands; auto; try (complete (intro xx; inversion xx)).

    apply approx_star_iff_approx_open.
    apply approx_open_simpler_equiv.

    unfold simpl_olift.
    dands; eauto 3 with slow.
    introv ps ispt1 ispt2.

    applydup @isprog_vars_eq in isp1.
    applydup @isprog_vars_eq in isp2.
    repnd.

    pose proof (cl_lsubst_trim_select t1 sub [v] mk_axiom) as q1.
    simpl in q1.
    repeat (autodimp q1 hyp); eauto 3 with slow.

    {
      introv i.
      split; intro q; repndors; subst; tcsp.
      - apply isprogram_lsubst_iff in ispt1; repnd.
        apply ispt1 in i; exrepnd.
        apply sub_find_some in i1.
        apply in_sub_eta in i1; tcsp.
      - apply subvars_eq in isp5; apply isp5 in i; simpl in i; auto.
    }

    pose proof (cl_lsubst_trim_select t2 sub [v] mk_axiom) as q2.
    simpl in q2.
    repeat (autodimp q2 hyp); eauto 3 with slow.

    {
      introv i.
      split; intro q; repndors; subst; tcsp.
      - apply isprogram_lsubst_iff in ispt2; repnd.
        apply ispt2 in i; exrepnd.
        apply sub_find_some in i1.
        apply in_sub_eta in i1; tcsp.
      - apply subvars_eq in isp4; apply isp4 in i; simpl in i; auto.
    }

    rewrite q1, q2.
    pose proof (imp (sub_find_def sub v mk_axiom)) as q.
    autodimp q hyp.

    { apply implies_isprog_sub_find_def; auto. }

    destruct q; tcsp.
Qed.

Lemma implies_approxc_try {o} :
  forall lib a1 a2 b1 b2 v (t1 t2 : @CVTerm o [v]),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> (forall u : CTerm, cequivc lib (substc u v t1) (substc u v t2))
    -> approxc lib (mkc_try a1 b1 v t1) (mkc_try a2 b2 v t2).
Proof.
  introv ceqa ceqb imp.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allunfold @approxc; allsimpl.

  apply implies_approx_try; auto.
  introv isp.
  apply isprogram_eq in isp.
  pose proof (imp (mk_cterm u isp)) as k; allsimpl; auto.
Qed.

Lemma implies_cequivc_try {o} :
  forall lib a1 a2 b1 b2 v (t1 t2 : @CVTerm o [v]),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> (forall u : CTerm, cequivc lib (substc u v t1) (substc u v t2))
    -> cequivc lib (mkc_try a1 b1 v t1) (mkc_try a2 b2 v t2).
Proof.
  introv ceqa ceqb imp.
  apply cequivc_iff_approxc; dands.
  - apply implies_approxc_try; auto.
  - apply implies_approxc_try; auto; introv; apply cequivc_sym; auto.
Qed.

Lemma implies_approx_atom_eq {o} :
  forall lib (a1 a2 b1 b2 c1 c2 d1 d2 : @NTerm o),
    isprog a1
    -> isprog a2
    -> isprog b1
    -> isprog b2
    -> isprog c1
    -> isprog c2
    -> isprog d1
    -> isprog d2
    -> cequiv lib a1 a2
    -> cequiv lib b1 b2
    -> cequiv lib c1 c2
    -> cequiv lib d1 d2
    -> approx lib (mk_atom_eq a1 b1 c1 d1) (mk_atom_eq a2 b2 c2 d2).
Proof.
  introv ispa1 ispa2 ispb1 ispb2 ispc1 ispc2 ispd1 ispd2; introv ceqa ceqb ceqc ceqd.

  apply howetheorem1;
    try (apply isprogram_mk_atom_eq; dands; eauto 2 with slow).

  apply approx_star_congruence; unfold num_bvars; simpl; auto.

  allrw @approx_starbts_cons.
  dands; auto;
    try (apply approx_star_bterm_nobnd_iff;
         auto; try (complete (intro xx; inversion xx)));
    eauto 3 with slow.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqa; tcsp.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqb; tcsp.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqc; tcsp.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqd; tcsp.
Qed.

Lemma implies_approxc_atom_eq {o} :
  forall lib (a1 a2 b1 b2 c1 c2 d1 d2 : @CTerm o),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> cequivc lib c1 c2
    -> cequivc lib d1 d2
    -> approxc lib (mkc_atom_eq a1 b1 c1 d1) (mkc_atom_eq a2 b2 c2 d2).
Proof.
  introv ceqa ceqb ceqc ceqd.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allunfold @approxc; allsimpl.

  apply implies_approx_atom_eq; auto.
Qed.

Lemma implies_cequivc_atom_eq {o} :
  forall lib (a1 a2 b1 b2 c1 c2 d1 d2 : @CTerm o),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> cequivc lib c1 c2
    -> cequivc lib d1 d2
    -> cequivc lib (mkc_atom_eq a1 b1 c1 d1) (mkc_atom_eq a2 b2 c2 d2).
Proof.
  introv ceqa ceqb ceqc ceqd.
  apply cequivc_iff_approxc; dands.
  - apply implies_approxc_atom_eq; auto.
  - apply implies_approxc_atom_eq; auto; introv; apply cequivc_sym; auto.
Qed.

Lemma cover_vars_atom_eq {o} :
  forall (a b c d : @NTerm o) sub,
    cover_vars (mk_atom_eq a b c d) sub
    <=> cover_vars a sub
        # cover_vars b sub
        # cover_vars c sub
        # cover_vars d sub.
Proof.
  sp; repeat (rw cover_vars_eq); simpl.
  repeat (rw remove_nvars_nil_l).
  repeat (rw app_nil_r).
  repeat (rw subvars_app_l); sp; split; sp.
Qed.

Lemma reduces_toc_iscvalue_implies_hasvaluec {o} :
  forall lib (t u : @CTerm o),
    reduces_toc lib t u
    -> iscvalue u
    -> hasvaluec lib t.
Proof.
  introv r i.
  unfold reduces_toc in r.
  unfold iscvalue in i.
  unfold hasvaluec.
  destruct_cterms; simpl in *.
  exists x.
  split; auto.
Qed.

Lemma implies_approx_exception {o} :
  forall lib (a1 a2 b1 b2 : @NTerm o),
    isprog a1
    -> isprog a2
    -> isprog b1
    -> isprog b2
    -> cequiv lib a1 a2
    -> cequiv lib b1 b2
    -> approx lib (mk_exception a1 b1) (mk_exception a2 b2).
Proof.
  introv ispa1 ispa2 ispb1 ispb2 ceqa ceqb.

  apply howetheorem1;
    try (apply isprogram_exception; dands; eauto 2 with slow).

  apply approx_star_congruence; unfold num_bvars; simpl; auto.

  allrw @approx_starbts_cons.
  dands; auto;
    try (apply approx_star_bterm_nobnd_iff;
         auto; try (complete (intro xx; inversion xx)));
    eauto 3 with slow.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqa; tcsp.

  - apply le_bin_rel_approx1_eauto; auto.
    destruct ceqb; tcsp.
Qed.

Lemma implies_approxc_exception {o} :
  forall lib (a1 a2 b1 b2 : @CTerm o),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> approxc lib (mkc_exception a1 b1) (mkc_exception a2 b2).
Proof.
  introv ceqa ceqb.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allunfold @approxc; allsimpl.
  apply implies_approx_exception; auto.
Qed.

Lemma implies_cequivc_exception {o} :
  forall lib (a1 a2 b1 b2 : @CTerm o),
    cequivc lib a1 a2
    -> cequivc lib b1 b2
    -> cequivc lib (mkc_exception a1 b1) (mkc_exception a2 b2).
Proof.
  introv ceqa ceqb.
  apply cequivc_iff_approxc; dands.
  - apply implies_approxc_exception; auto.
  - apply implies_approxc_exception; auto; introv; apply cequivc_sym; auto.
Qed.

Lemma simple_lsubstc_subst_ex2 {p} :
  forall (t : @NTerm p) x B ws s cs wt ct,
    {wb : wf_term B
     & {cb : cover_vars_upto B (csub_filter s [x]) [x]
     & alphaeqc
         (lsubstc (subst B x t) ws s cs)
         (substc (lsubstc t wt s ct) x (lsubstc_vars B wb (csub_filter s [x]) [x] cb))
    }}.
Proof.
  introv.

  pose proof (change_bvars_alpha_wspec (free_vars t) B) as q.
  destruct q as [B' [q1 q2] ].

  assert (wf_term (subst B' x t)) as wf.
  {
    allrw @wf_term_eq.
    unfold subst in *.
    allrw @nt_wf_lsubst_iff; repnd; dands; auto; simpl in *.
    { apply alphaeq_preserves_wf in q2; apply q2; auto. }
    introv i j.
    boolvar; ginv.
    apply alphaeq_preserves_free_vars in q2; rewrite <- q2 in i.
    eapply ws;[eauto|]; boolvar; auto.
  }

  assert (cover_vars (subst B' x t) s) as cov.
  {
    unfold cover_vars in *.
    unfold over_vars in *.

    eapply subvars_eqvars;[|apply eqvars_sym;apply eqvars_free_vars_disjoint].
    eapply subvars_eqvars in cs;[|apply eqvars_free_vars_disjoint].
    simpl in *.
    apply alphaeq_preserves_free_vars in q2; rewrite <- q2.
    auto.
  }

  pose proof (simple_lsubstc_subst_ex t x B' wf s cov wt ct q1) as h.
  exrepnd.

  assert (wf_term B) as wB.
  { apply lsubst_wf_term in ws; auto. }

  assert (cover_vars_upto B (csub_filter s [x]) [x]) as cB.
  {
    rw @cover_vars_eq in cs.
    unfold cover_vars_upto in *.
    apply alphaeq_preserves_free_vars in q2; rewrite q2.
    auto.
  }

  exists wB cB.

  unfold alphaeqc; simpl.

  pose proof (lsubst_alpha_congr2 (subst B x t) (subst B' x t) (csub2sub s)) as q.
  autodimp q hyp.
  { apply lsubst_alpha_congr2; auto. }
  eapply alpha_eq_trans;[exact q|]; clear q.

  assert (get_cterm (lsubstc (subst B' x t) wf s cov)
          = get_cterm (substc (lsubstc t wt s ct) x (lsubstc_vars B' wb (csub_filter s [x]) [x] cb))) as xx.
  { rewrite h1; auto. }
  simpl in xx.
  unfold csubst in xx.
  rewrite xx; clear xx.

  allrw @fold_csubst.
  apply lsubst_alpha_congr2.
  apply lsubst_alpha_congr2.
  apply alpha_eq_sym; auto.
Qed.

Lemma lsubstc_subst_snoc_aeq {o} :
  forall s (b : @NTerm o) x y a w1 w2 c1 c2,
    !LIn y (dom_csub s)
    -> (y <> x -> !LIn y (free_vars b))
    -> alphaeqc
         (lsubstc (subst b x (mk_var y)) w1 (snoc s (y, a)) c1)
         (substc a x (lsubstc_vars b w2 (csub_filter s [x]) [x] c2)).
Proof.
  introv ni d.

  pose proof (change_bvars_alpha_wspec [y] b) as q.
  destruct q as [b' [q1 q2] ].
  allrw disjoint_singleton_l.

  assert (wf_term b') as wfb'.
  {
    allrw @wf_term_eq.
    unfold subst in *.
    allrw @nt_wf_lsubst_iff; repnd; dands; auto; simpl in *.
    apply alphaeq_preserves_wf in q2; apply q2; auto.
  }

  assert (wf_term (subst b' x (mk_var y))) as wsb'.
  {
    allrw @wf_term_eq.
    unfold subst in *.
    allrw @nt_wf_lsubst_iff; repnd; dands; auto; simpl in *.
    introv i j.
    boolvar; ginv.
    eauto 3 with slow.
  }

  assert (cover_vars (subst b' x (mk_var y)) (snoc s (y, a))) as covsb'.
  {
    unfold cover_vars in *.
    unfold over_vars in *.

    eapply subvars_eqvars;[|apply eqvars_sym;apply eqvars_free_vars_disjoint].
    eapply subvars_eqvars in c1;[|apply eqvars_free_vars_disjoint].
    simpl in *.
    apply alphaeq_preserves_free_vars in q2; rewrite <- q2.
    auto.
  }

  assert (cover_vars_upto b' (csub_filter s [x]) [x]) as covub'.
  {
    unfold cover_vars_upto in *.
    apply alphaeq_preserves_free_vars in q2; rewrite <- q2; auto.
  }

  pose proof (lsubstc_subst_snoc_eq s b' x y a wsb' wfb' covsb' covub') as xx.
  repeat (autodimp xx hyp).
  { apply alphaeq_preserves_free_vars in q2; rewrite <- q2; auto. }

  assert (get_cterm (lsubstc (subst b' x (mk_var y)) wsb' (snoc s (y, a)) covsb')
          = get_cterm (substc a x (lsubstc_vars b' wfb' (csub_filter s [x]) [x] covub'))) as yy.
  { rewrite xx; auto. }
  clear xx; simpl in yy.

  destruct_cterms.
  unfold alphaeqc; simpl in *.
  unfold csubst in *; simpl in *.
  allrw @csub2sub_snoc; simpl in *.

  eapply alpha_eq_trans;
    [apply lsubst_alpha_congr2;
     apply lsubst_alpha_congr2;
     exact q2
    |].
  allrw @fold_subst.
  rewrite yy; clear yy.
  apply lsubst_alpha_congr2.
  apply lsubst_alpha_congr2.
  apply alpha_eq_sym; auto.
Qed.

Lemma cequivc_exception_implies {o} :
  forall lib (a1 a2 b1 b2 : @CTerm o),
    cequivc lib (mkc_exception a1 b1) (mkc_exception a2 b2)
    -> cequivc lib a1 a2 # cequivc lib b1 b2.
Proof.
  introv ceq.
  destruct_cterms.
  unfold cequivc in *; simpl in *.
  destruct ceq as [apr1 apr2].

  apply approx_exception in apr1.
  apply approx_exception in apr2.
  exrepnd.
  apply reduces_to_if_isvalue_like in apr4; eauto 3 with slow.
  apply reduces_to_if_isvalue_like in apr0; eauto 3 with slow.
  ginv.
  unfold cequiv.
  dands; auto.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties
        Subtyping_inversion
        Deterministic.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Coq.Strings.String.

Lemma TypedReduce_toparr_normal_typed : forall A B,
    topLike (t_arrow A B) -> Etyping nil (e_abs t_top e_top B) (t_arrow A B).
Proof.
  intros Ht A B.
  eapply Etyp_abs.
  intros x H.
  apply Etyp_top.
  solve_uniq.
  auto.
  inverts B.
  apply toplike_super_top.
  auto.
  Unshelve.
  pick fresh x.
  exact (singleton x).
Qed.

(* requires sub Top A -> toplike A *)
Lemma TypedReduce_trans : forall v v1 v2 A B,
    value v -> TypedReduce v A v1 -> TypedReduce v1 B v2 -> TypedReduce v B v2.
Proof.
  introv Val Red1 Red2.
  lets Lc: value_lc Val.
  gen B v2.
  induction* Red1;
    introv Red2.
  - (* v1 = v_top *)
    remember e_top.
    induction* Red2;
      try solve [inversion Heqe].
  - (* toparr *)
    remember (e_abs t_top e_top B).
    induction* Red2;
      inversion Heqe.
    subst.
    exfalso.
    apply H2.
    forwards*: toplike_sub H0 H4.
  - (* v1 = abs A e D *)
    remember (e_abs A e D).
    induction* Red2;
      try solve [inversion Heqe0];
      try solve [inversion Ord].
    inverts* Heqe0.
    constructor.
    inverts* H2.
    assumption.
    assumption.
    auto_sub.
  - (* v = v1,,v2 v1'~->v0 *)
    inverts* Val.
    inverts* Lc.
    induction Red2;
      eauto.
  - (* v = v1,,v2 v2'~->v0 *)
    inverts* Val.
    inverts* Lc.
    induction Red2;
      eauto.
  - (* and *)
    gen v0.
    induction B0; introv Red2;
      try solve [inverts* Red2];
      try solve [inversion Ord].
Qed.

Lemma consistent_afterTR : forall v A B C v1 v2, value v -> Etyping nil v C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistencySpec v1 v2.
Proof.
  intros v A B C v1 v2 Val Typ Red1 Red2.
  unfold consistencySpec.
  intros D v1' v2' Red1' Red2'.
  lets Lc: typing_regular_1 Typ.
  forwards*: TypedReduce_trans Red1 Red1'.
  forwards*: TypedReduce_trans Red2 Red2'.
  forwards*: TypedReduce_unique H H0.
Qed.

Lemma TypedReduce_prv_value: forall v A v',
    value v -> TypedReduce v A v' -> value v'.
Proof.
  intros v A v' Val Red.
  induction* Red.
  - inverts* Val.
    inverts* H4.
  - inverts* Val.
  - inverts* Val.
Qed.

Lemma TypedReduce_preservation: forall v A v' B,
    value v -> TypedReduce v A v'-> Etyping nil v B -> Etyping nil v' A.
Proof.
  introv Val Red.
  lets Red': Red.
  gen B.
  induction Red; introv Typ;
    lets Lc  : typing_regular_1 Typ;
    try solve [constructor*].
  - Case "toparr".
    forwards*: TypedReduce_toparr_normal_typed.
  - Case "absv".
    inverts Lc.
    assert (lc_exp (e_abs A e D)) by eauto.
    inverts Typ.
    sapply~ Etyp_abs;
      auto_sub.
  - Case "mergel".
    inverts Val.
    inverts Typ;
    forwards*: IHRed.
  - Case "merger".
    inverts Val.
    inverts Typ;
    forwards*: IHRed.
  - Case "merge_and".
    forwards: IHRed1 Val Red1 Typ.
    forwards: IHRed2 Val Red2 Typ.
    lets Con: consistent_afterTR Val Typ Red1 Red2.
    apply~ Etyp_mergev.
    constructor.
    forwards*: TypedReduce_prv_value Val Red1.
    forwards*: TypedReduce_prv_value Val Red2.
Qed.

Theorem preservation : forall e e' A,
    Etyping nil e A ->
    step e e' ->
    Etyping nil e' A.
Proof.
  introv Typ. gen e'.
  lets Typ' : Typ.
  inductions Typ;
    try solve [introv J; inverts* J].
  - Case "typing_app".
    introv J.
    inverts* J.
    (* e_absv A0 . e : B0->D  v *)
    inverts Typ2.
    eapply Etyp_anno.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
    subst.
    forwards*: TypedReduce_preservation H4.
    auto.
  - Case "typing_anno".
    introv J.
    inverts J.
    + forwards*: TypedReduce_preservation H4.
    + forwards*: IHTyp.
  - Case "typing_fix".
    introv J.
    inverts* J.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
  - Case "typing_mergev".
    introv J.
    inverts J.
    + inverts H0.
      forwards*: step_not_value H5 H6.
    + inverts H0.
      forwards*: step_not_value H7 H6.
Qed.

Lemma TypedReduce_progress: forall v A B,
    value v -> Etyping [] v A -> sub A B -> exists v', TypedReduce v B v'.
Proof.
  introv Val Typ Sub.
  gen A B.
  induction v; try solve [inverts* Val];
    intros;
    try solve [
      inverts Typ;
      match goal with
      | |- ( exists _ , TypedReduce _ ?B  _ ) =>
        induction B
      end;
      inverts* Sub;
      try solve [
      match goal with
      | _ : (sub t_top _) |- ( exists _ , TypedReduce _ (t_arrow _ _) _ ) =>
        ( exists;
          apply~ TReduce_toparr;
          apply~ toplike_super_top;
          destruct~ IHB2 as [v2 Tyr2] )
      | |- ( exists _ , TypedReduce _ (t_and _ _ ) _ ) =>
        ( destruct~ IHB1 as [v1 Tyr1];
          destruct~ IHB2 as [v2 Tyr2];
          exists*                     )
      end ] ].
  - Case "e_absv".
    lets* [C [? ?]]: abs_typing_canonical Typ.
    subst.
    lets Lc: value_lc Val.
    induction B0;
      try solve [inverts* Sub].
    + SCase "t_arr".
      lets [St | [S1 S2]]: sub_inversion_arrow Sub;
        destruct (toplike_decidable(t_arrow B0_1 B0_2));
        exists;
        try solve [
              apply~ TReduce_toparr;
              inverts* H ].
      * exfalso.
        apply H.
        constructor.
        apply~ toplike_super_top.
      * (* not toplike case *)
        apply~ TReduce_arrow.
        auto_sub.
      Unshelve.
      eauto.
    + SCase "t_and".
      destruct~ IHB0_1 as [v1 Tyr1].
      auto_sub.
      destruct~ IHB0_2 as [v2 Tyr2].
      auto_sub.
      exists*.
  - Case "e_merge".
    lets Lc: value_lc Val.
    inverts Val.
    induction B.
    + SSCase "B:=Int".
      inverts Typ;
      inverts* Sub.
      lets* [? ?]: IHv1 H6.
      lets* [? ?]: IHv2 H6.
      lets* [? ?]: IHv1 H8.
      lets* [? ?]: IHv2 H8.
    + SSCase "B:=Top".
      inverts Typ;
      assert (sub A0 t_top) by auto;
      lets* [? ?]: IHv1 H1 H.
    + SSCase "B:=Arrow".
      inverts Typ;
      try solve [lets* [S | S]: sub_inversion_andl_arrr Sub;
      [ forwards* [? ?]: IHv1 S | forwards* [? ?]: IHv2 S ] ].
    + SSCase "B:=B1&B2".
      inverts Typ;
      (lets* [vb1' Tyrb1] : IHB1; try auto_sub;
       lets* [vb2' Tyrb2] : IHB2; try auto_sub).
Qed.

Theorem progress : forall e A,
    Etyping nil e A ->
    value e \/ exists e', step e e'.
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ;
      lets Lc  : typing_regular_1 Typ';
      try solve [left*];
      try solve [right*].
  - Case "var".
    invert H0.
  - Case "app".
    right.
    destruct~ IHTyp2 as [Val1 | [e1' Red2]].
    destruct~ IHTyp1 as [Val2 | [e2' Red1]].
    inverts* Typ2;
      try solve [
            inverts Val1 ].
    + SCase "e_app (e_absv _ _) v2".
      lets* (v2' & Tyr): TypedReduce_progress Typ1 H4.
    + SCase "e_app v1 e2".
      inverts Lc.
      inverts* H1.
    + SCase "e_app e1 e2".
      forwards*: typing_regular_1 Typ1.
  - Case "merge".
    forwards*: typing_regular_1 Typ1.
    forwards*: typing_regular_1 Typ2.
    destruct~ IHTyp1 as [ Val1 | [t1' Red1]];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2]];
      subst.
    + SCase "e_merge v1 e2".
      inverts* Typ1.
    + SCase "e_merge e1 v2".
      inverts* Typ2.
    + SCase "e_merge e1 e2".
      inverts* Typ2.
  - Case "anno".
    right.
    destruct~ IHTyp as [ Val | [t' Red]].
    + SCase "e_anno v A".
      lets* (v1' & Tyr) : TypedReduce_progress Val Typ H.
    + SCase "e_anno e A".
      forwards*: Step_anno Red.
Qed.

Theorem preservation_multi_step : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    nil |= e' ~: A.
Proof.
  introv Typ Red.
  induction* Red.
  lets*: preservation Typ H.
Qed.

Theorem type_safety : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    value e \/ exists e'', step e e''.
Proof.
  introv Typ Red.
  induction Red.
  lets*: progress Typ.
  lets*: preservation Typ H.
Qed.