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.


(* En este archivo se demuestra la corrección de la acción stop *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section Stop.

Lemma stopCorrect : forall (s:System) (ic:iCmp) (sValid: validstate s),
    (pre (stop ic) s) -> post_stop ic s (stop_post ic s).
Proof.
    intros.
    unfold post_stop.
    split. simpl; auto.
    simpl in H.
    unfold pre_stop in H;simpl in H.
    destruct H.
    unfold stop_post.
    unfold insNotInState.
    simpl.
    split;intros.
    rewrite valueDropValue in H0.
    destruct H0.
    auto.
    split;intros.
    elim (classic (ic=ic'));intros.
    right;auto.
    left.
    apply valueDropValue.
    auto.
    split.
    apply dropPreservesCorrectness.
    apply runningCorrect;auto.
    split;intros.
    apply valueDropNotValue.
    unfold removeTPerms.
    split;intros.
    rewrite valueDropThenValue in H0.
    destruct H0.
    auto.
    split;intros.
    elim (classic (ic'=ic));intros.
    right;auto.
    left.
    apply valueDropThenValue.
    split;auto.
    unfold not;intros.
    apply H1.
    rewrite filter_In in H2.
    destruct H2.
    simpl in H3.
    destruct iCmp_eq in H3.
    auto.
    discriminate H3.
    split;intros.
    elim (classic (In (ic,cp,u) (filter (fun tuple : iCmp * CProvider * uri => if iCmp_eq ic (fst (fst tuple)) then true else false) (map_getKeys (delTPerms (state s))))));intros.
    apply valueDropAllNotValue.
    auto.
    assert (map_apply deltpermsdomeq (dropAll (iCmp * CProvider * uri) PType deltpermsdomeq (filter (fun tuple : iCmp * CProvider * uri => if iCmp_eq ic (fst (fst tuple)) then true else false) (map_getKeys (delTPerms (state s)))) (delTPerms (state s))) (ic, cp, u) = map_apply deltpermsdomeq (delTPerms (state s)) (ic,cp,u)).
    apply dropNotIn;auto.
    rewrite H1.
    unfold not;intros.
    apply H0.
    rewrite filter_In.
    simpl.
    split.
    unfold map_getKeys.
    rewrite in_map_iff.
    unfold is_Value in H2.
    case_eq (map_apply deltpermsdomeq (delTPerms (state s)) (ic, cp, u));intros.
    rewrite valueIffExists in H3.
    exists {| item_index := (ic, cp, u); item_info := p |}.
    simpl.
    auto.
    apply (delTPermsCorrect);auto.
    rewrite H3 in H2.
    inversion H2.
    destruct iCmp_eq;auto.

    repeat (split;auto).
    apply dropAllPreservesCorrectness.
    apply delTPermsCorrect;auto.
Qed.

Lemma notPreStopThenError : forall (s:System) (ic:iCmp), ~(pre (stop ic) s) -> validstate s -> exists ec : ErrorCode, response (step s (stop ic)) = error ec /\ ErrorMsg s (stop ic) ec /\ s = system (step s (stop ic)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_stop in H.
    unfold stop_safe.
    unfold stop_pre.
    case_eq(is_ValueBool (map_apply iCmp_eq (running (state s)) ic));intros.
    destruct H.
    unfold is_ValueBool in H1.
    case_eq ((map_apply iCmp_eq (running (state s)) ic));intros;rewrite H in H1;simpl in H1.
    exists c;auto.
    discriminate H1.
    exists instance_not_running.
    split;auto.
    split;auto.
    invertBool H1.
    intro;apply H1.
    unfold is_ValueBool.
    unfold is_Value in H2.
    case_eq ((map_apply iCmp_eq (running (state s)) ic));intros;rewrite H3 in H2;simpl in H2;auto.
Qed.

Lemma stopIsSound : forall (s:System) (ic:iCmp) (sValid: validstate s),
        exec s (stop ic) (system (step s (stop ic))) (response (step s (stop ic))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (stop ic) s));intro.
    left.
    simpl.
    assert(stop_pre ic s = None).
    unfold stop_pre.
    destruct H.
    unfold is_ValueBool.
    rewrite H.
    auto.

    unfold stop_safe;simpl.
    rewrite H0;simpl.
    split;auto.
    split;auto.
    apply stopCorrect;auto.
    right.
    apply notPreStopThenError;auto.

Qed.
End Stop.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableWalk.Spec.
Require Import AbsAccessor.Spec.
Require Import TableAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_unmap_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _level =>
      rely is_int64 (_level - 1);
      rely is_int64 _map_addr;
      when adt == table_walk_lock_unlock_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 (_level - 1)) adt;
      when'' _g_llt_base, _g_llt_ofst == get_wi_g_llt_spec  adt;
      rely is_int _g_llt_ofst;
      when' _index == get_wi_index_spec  adt;
      rely is_int64 _index;
      when _t'7 == is_null_spec (_g_llt_base, _g_llt_ofst) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _ll_table_base, _ll_table_ofst, adt == granule_map_spec (_g_llt_base, _g_llt_ofst) 5 adt;
        rely is_int _ll_table_ofst;
        when' _llt_pgte == pgte_read_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) adt;
        rely is_int64 _llt_pgte;
        if (_level <? 3) then
          when _t'6 == entry_is_table_spec (VZ64 _llt_pgte) adt;
          rely is_int _t'6;
          let _t'5 := (_t'6 =? 1) in
          if _t'5 then
            let _ret := 1 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
          else
            rely is_int64 (Z.land _llt_pgte 281474976706560);
            let _data_addr := (Z.land _llt_pgte 281474976706560) in
            rely is_int64 (Z.land _llt_pgte 504403158265495552);
            rely is_int64 ((Z.land _llt_pgte 504403158265495552) / 72057594037927936);
            let _ipa_state := ((Z.land _llt_pgte 504403158265495552) / 72057594037927936) in
            if (_ipa_state =? 2) then
              rely is_int64 (1 * 72057594037927936);
              rely is_int64 (Z.lor (1 * 72057594037927936) _data_addr);
              let _new_pgte := (Z.lor (1 * 72057594037927936) _data_addr) in
              rely is_int64 _new_pgte;
              when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _new_pgte) adt;
              if (_level =? 3) then
                when adt == invalidate_page_spec (VZ64 _map_addr) adt;
                let _ret := 0 in
                when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
                when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
                Some (adt, (VZ64 _ret))
              else
                when adt == invalidate_block_spec (VZ64 _map_addr) adt;
                let _ret := 0 in
                when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
                when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
                Some (adt, (VZ64 _ret))
            else
              let _ret := 1 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
        else
          let _t'5 := 0 in
          rely is_int64 (Z.land _llt_pgte 281474976706560);
          let _data_addr := (Z.land _llt_pgte 281474976706560) in
          rely is_int64 (Z.land _llt_pgte 504403158265495552);
          rely is_int64 ((Z.land _llt_pgte 504403158265495552) / 72057594037927936);
          let _ipa_state := ((Z.land _llt_pgte 504403158265495552) / 72057594037927936) in
          if (_ipa_state =? 2) then
            rely is_int64 (1 * 72057594037927936);
            rely is_int64 (Z.lor (1 * 72057594037927936) _data_addr);
            let _new_pgte := (Z.lor (1 * 72057594037927936) _data_addr) in
            rely is_int64 _new_pgte;
            when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _new_pgte) adt;
            if (_level =? 3) then
              when adt == invalidate_page_spec (VZ64 _map_addr) adt;
              let _ret := 0 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
            else
              when adt == invalidate_block_spec (VZ64 _map_addr) adt;
              let _ret := 0 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
          else
            let _ret := 1 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require compcert.backend.Mach.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Globalenvs.
Import Events.
Import Smallstep.
Import Locations.
Import Conventions.
Export Mach.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

(** Execution of Mach functions with Asm-style arguments (long long 64-bit integers NOT allowed) *)

Inductive initial_state (lm: regset) (init_sp: val) (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem): state -> Prop :=
| initial_state_intro
    b
    (Hb: Genv.find_symbol (Genv.globalenv p) i = Some b)
    (Hargs: extcall_arguments lm m init_sp sg args)
  :
      initial_state lm init_sp p i sg args m (Callstate nil b lm m)
.

Definition get_pair (p: rpair mreg) (m: regset): val :=
  match p with
    | One l => m l
    | Twolong l1 l2 => Val.longofwords (m l1) (m l2)
  end.

Inductive final_state (lm: regset) (sg: signature): state -> (val * mem) -> Prop :=
| final_state_intro
    rs
    v
    (Hv: v = get_pair (loc_result sg) rs)
    (** Callee-save registers.
        We use Val.lessdef instead of eq because the Stacking pass does not exactly preserve their values. *)
    (CALLEE_SAVE: forall r,
       ~ In r destroyed_at_call ->
       Val.lessdef (lm r) (rs r))
    m :
    final_state lm sg (Returnstate nil rs m) (v, m)
.

Definition semantics
           (return_address_offset: function -> code -> ptrofs -> Prop)
           (lm: regset) (init_sp init_ra: val)
           (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem) :=
  Semantics
    (Mach.step init_sp init_ra return_address_offset)
    (initial_state lm init_sp p i sg args m)
    (final_state lm sg)
    (Genv.globalenv p).

End WITHCONFIG.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.VotesCorrectInterface.
Require Import VerdiRaft.TermSanityInterface.
Require Import VerdiRaft.CroniesTermInterface.

Require Import VerdiRaft.RefinementCommonTheorems.

Require Import VerdiRaft.SpecLemmas.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.CandidateEntriesInterface.

Section CandidateEntriesProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {cti : cronies_term_interface}.
  Context {tsi : term_sanity_interface}.
  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.

  Lemma handleClientRequest_spec :
    forall h d client id c out d' l,
      handleClientRequest h d client id c = (out, d', l) ->
      currentTerm d' = currentTerm d /\
      type d' = type d /\
      l = [] /\
      (forall e, In e (log d') ->
            (In e (log d) \/ (e = (mkEntry
                                     h
                                     client
                                     id
                                     (S (maxIndex (log d)))
                                     (currentTerm d)
                                     c) /\ log d' = e :: log d /\ type d' = Leader))).
  Proof using.
    intros. unfold handleClientRequest in *.
    break_match; find_inversion; intuition.
    simpl in *. intuition. subst. auto.
  Qed.

  Lemma candidate_entries_client_request :
    refined_raft_net_invariant_client_request CandidateEntries.
  Proof using cci.
    unfold refined_raft_net_invariant_client_request, CandidateEntries.
    intros. subst.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros; simpl in *.
      eapply candidateEntries_ext; try eassumption.
      repeat find_higher_order_rewrite.
      unfold update_elections_data_client_request in *. repeat break_let. simpl in *.
      destruct (name_eq_dec h0 h); subst.
      + rewrite_update.
        unfold update_elections_data_client_request in *. repeat break_let. simpl in *.
        simpl in *. find_inversion.
        find_apply_lem_hyp handleClientRequest_spec; intuition eauto.
        find_apply_hyp_hyp.
        intuition.
        * rewrite_update.
          eapply candidateEntries_same; eauto; intuition;
          destruct (name_eq_dec h0 h); subst; rewrite_update; auto.
          repeat break_match; simpl; auto.
        * find_apply_lem_hyp cronies_correct_invariant.
          unfold candidateEntries. exists h.
          intuition; rewrite_update; simpl in *; try congruence.
          repeat find_rewrite. simpl in *.
          repeat break_match; simpl; pose won_election_cronies; eauto.
      + rewrite_update.
        find_apply_lem_hyp handleClientRequest_spec.
        eapply candidateEntries_same; eauto; intuition;
        destruct (name_eq_dec h1 h); subst; rewrite_update; auto;
        tuple_inversion; repeat find_rewrite;
        repeat break_match; simpl; auto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; try eassumption.
      find_apply_lem_hyp handleClientRequest_spec.
      intuition.
      subst. simpl in *.

      eapply_prop_hyp candidateEntries AppendEntries; eauto.
      + eapply candidateEntries_same; eauto; intuition;
        destruct (name_eq_dec h h0); subst; rewrite_update; auto.
        unfold update_elections_data_client_request; repeat break_match; simpl; auto.
      + find_apply_hyp_hyp. intuition.
  Qed.

  Lemma update_elections_data_timeout_leader_cronies_same :
    forall sigma h,
      type (snd (sigma h)) = Leader ->
      cronies (update_elections_data_timeout h (sigma h)) =
      cronies (fst (sigma h)).
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; subst; simpl in *; auto.
    unfold handleTimeout, tryToBecomeLeader in *.
    repeat break_match; try congruence; repeat find_inversion; simpl in *;
    unfold raft_data in *;
    congruence.
  Qed.

  Lemma handleTimeout_only_sends_RequestVotes :
    forall h d out d' l p,
      handleTimeout h d = (out, d', l) ->
      In p l ->
      exists t h' maxi maxt,
        snd p = RequestVote t h' maxi maxt.
  Proof using.
    unfold handleTimeout, tryToBecomeLeader.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; intuition;
    do_in_map; subst; simpl; eauto.
  Qed.

  Lemma handleTimeout_not_leader_inc_term :
    forall h d out d' l,
      handleTimeout h d = (out, d', l) ->
      type d <> Leader ->
      currentTerm d' = S (currentTerm d).
  Proof using.
    unfold handleTimeout, tryToBecomeLeader.
    intros. simpl in *.
    repeat break_match; try congruence; repeat find_inversion; auto.
  Qed.

  Lemma update_elections_data_timeout_cronies :
    forall h d out d' l t,
      handleTimeout h (snd d) = (out, d', l) ->
      cronies (update_elections_data_timeout h d) t = cronies (fst d) t \/
      (t = currentTerm d' /\
       cronies (update_elections_data_timeout h d) t = votesReceived d').
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; repeat find_inversion; simpl; auto.
    break_match; auto.
  Qed.

  Lemma handleTimeout_preserves_candidateEntries :
    forall net h e out d l,
      refined_raft_intermediate_reachable net ->
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (update_elections_data_timeout h (nwState net h), d)).
  Proof using cti.
    intros.
    destruct (serverType_eq_dec (type (snd (A:=electionsData) (B:=raft_data) (nwState net h))) Leader).
      + (* Leader case *)
        unfold handleTimeout, tryToBecomeLeader in *. simpl in *.
        find_rewrite. find_inversion.

        eapply candidateEntries_same; eauto;
        intros;
        repeat (rewrite update_fun_comm; simpl in * );
        update_destruct; subst; rewrite_update;
        auto using update_elections_data_timeout_leader_cronies_same.
      + (* non-Leader case *)

        unfold candidateEntries in *.
        break_exists. break_and.
        exists x.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm with (f := type); simpl.
        update_destruct; subst; rewrite_update; auto.
        split.
        * match goal with
          | [ H : handleTimeout _ _ = _ |- _ ] =>
            pose proof H;
              apply update_elections_data_timeout_cronies with (t := eTerm e) in H
          end.
          intuition; find_rewrite; auto.
          find_apply_lem_hyp wonElection_exists_voter.
          break_exists.
          find_apply_lem_hyp in_dedup_was_in.
          find_copy_apply_lem_hyp cronies_term_invariant; auto.
          find_copy_apply_lem_hyp handleTimeout_not_leader_inc_term; auto.
          simpl in *.
          lia.
        * intros.
          find_apply_lem_hyp wonElection_exists_voter.
          break_exists.
          find_apply_lem_hyp in_dedup_was_in.
          find_copy_apply_lem_hyp cronies_term_invariant; auto.
          find_copy_apply_lem_hyp handleTimeout_not_leader_inc_term; auto.
          simpl in *.
          lia.
  Qed.

  Lemma candidate_entries_timeout :
    refined_raft_net_invariant_timeout CandidateEntries.
  Proof using cti.
    unfold refined_raft_net_invariant_timeout, CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; try eassumption.
      repeat find_higher_order_rewrite.

        find_rewrite_lem update_fun_comm. simpl in *.
        find_rewrite_lem update_fun_comm. simpl in *.
        find_erewrite_lem handleTimeout_log_same.

        find_rewrite_lem_by update_nop_ext' auto.
        find_apply_hyp_hyp.
        eauto using handleTimeout_preserves_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      break_or_hyp.
      + eapply_prop_hyp pBody pBody; eauto.
        eauto using handleTimeout_preserves_candidateEntries.
      + do_in_map. subst. simpl in *.
        eapply handleTimeout_only_sends_RequestVotes in H8; eauto.
        break_exists. congruence.
  Qed.

  Lemma update_elections_data_appendEntries_cronies_same :
    forall h d t n pli plt es ci,
      cronies (update_elections_data_appendEntries h d t n pli plt es ci) =
      cronies (fst d).
  Proof using.
    unfold update_elections_data_appendEntries.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma handleAppendEntries_spec :
    forall h st t n pli plt es ci st' m,
      handleAppendEntries h st t n pli plt es ci = (st', m) ->
      (currentTerm st <= currentTerm st' /\
       (forall e,
          In e (log st') ->
          In e (log st) \/
          In e es /\ currentTerm st' = t) /\
       ~ is_append_entries m).
  Proof using.
    intros.
    unfold handleAppendEntries, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition; try solve [break_exists; congruence];
    in_crush; eauto using removeAfterIndex_in.
  Qed.

  Lemma handleAppendEntries_term_same_or_type_follower :
    forall h t n pli plt es ci d m st,
      handleAppendEntries h st t n pli plt es ci = (d, m) ->
      (currentTerm d = currentTerm st /\ type d = type st) \/ type d = Follower.
  Proof using.
    unfold handleAppendEntries in *.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto; try congruence.
  Qed.

  Lemma handleAppendEntries_preserves_candidate_entries :
    forall net h t n pli plt es ci d m e,
      handleAppendEntries h (snd (nwState net h)) t n pli plt es ci = (d, m) ->
      refined_raft_intermediate_reachable net ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h
                                 (update_elections_data_appendEntries
                                    h
                                    (nwState net h) t n pli plt es ci, d)).
  Proof using.
    unfold candidateEntries.
    intros. break_exists. break_and.
    exists x.
    split.
    - rewrite update_fun_comm. simpl.
      rewrite update_fun_comm. simpl.
      rewrite update_elections_data_appendEntries_cronies_same.
      destruct (name_eq_dec x h); subst; rewrite_update; auto.
    - intros.
      rewrite update_fun_comm. simpl.
      find_rewrite_lem update_fun_comm. simpl in *.
      destruct (name_eq_dec x h); subst; rewrite_update; auto.
      find_apply_lem_hyp handleAppendEntries_term_same_or_type_follower.
      intro; intuition;
      repeat find_rewrite; auto; discriminate.
  Qed.

  Lemma is_append_entries_intro :
    forall t n plt pli es ci,
      is_append_entries (AppendEntries t n pli plt es ci).
  Proof using.
    eauto 20.
  Qed.

  Lemma candidate_entries_append_entries :
    refined_raft_net_invariant_append_entries CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update;
      eapply handleAppendEntries_preserves_candidate_entries; eauto.
      find_copy_apply_lem_hyp handleAppendEntries_spec. break_and.
      find_apply_hyp_hyp. intuition eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + eapply handleAppendEntries_preserves_candidate_entries; eauto.
      + subst. simpl in *. find_apply_lem_hyp handleAppendEntries_spec.
        break_and.
        subst.
        exfalso.
        eauto using is_append_entries_intro.
  Qed.

  Lemma handleAppendEntriesReply_spec :
    forall h st h' t es r st' ms,
      handleAppendEntriesReply h st h' t es r = (st', ms) ->
      log st' = log st /\
      ((currentTerm st' = currentTerm st /\ type st' = type st)
       \/ type st' = Follower) /\
      (forall m, In m ms -> ~ is_append_entries (snd m)).
  Proof using.
    intros.
    unfold handleAppendEntriesReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition.
  Qed.

  Lemma handleAppendEntriesReply_preserves_candidate_entries :
    forall net h h' t es r st' ms e,
      handleAppendEntriesReply h (snd (nwState net h)) h' t es r = (st', ms) ->
      refined_raft_intermediate_reachable net ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (fst (nwState net h), st')).
  Proof using.
    unfold candidateEntries.
    intros. break_exists. break_and.
    exists x.
    split.
    - rewrite update_fun_comm. simpl.
      rewrite update_fun_comm. simpl.
      update_destruct; subst; rewrite_update; auto.
    - intros. update_destruct; subst; rewrite_update; auto.
      simpl in *.
      find_apply_lem_hyp handleAppendEntriesReply_spec.
      intuition; repeat find_rewrite; intuition.
      congruence.
  Qed.

  Ltac prove_in :=
    match goal with
      | [ _ : nwPackets ?net = _,
              _ : In ?p _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; do_in_app; intuition)
      | [ _ : nwPackets ?net = _,
              _ : pBody ?p = _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; intuition)
    end.

  Lemma candidate_entries_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply CandidateEntries.
  Proof using.
    red. unfold CandidateEntries. intros. intuition.
    - unfold candidateEntries_host_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct.
      + subst. rewrite_update.
        unfold candidateEntries in *.
        find_apply_lem_hyp handleAppendEntriesReply_spec. break_and.
        repeat find_rewrite.
        find_apply_hyp_hyp.
        break_exists; exists x; eauto.
        update_destruct; intuition; subst; rewrite_update; simpl in *; auto;
        repeat find_rewrite; intuition; congruence.
      + rewrite_update. find_apply_hyp_hyp.
        eauto using handleAppendEntriesReply_preserves_candidate_entries.
    - unfold candidateEntries_nw_invariant in *. intros. simpl in *.
      find_apply_hyp_hyp. intuition.
      + (* packet already in nw *)
        prove_in.
        eapply candidateEntries_ext; eauto.
        find_eapply_lem_hyp handleAppendEntriesReply_preserves_candidate_entries; eauto.
        subst. auto.
      + exfalso.
        do_in_map.
        find_eapply_lem_hyp handleAppendEntriesReply_spec; eauto.
        subst. simpl in *. find_rewrite.
        match goal with
          | H : ~ is_append_entries _ |- _ => apply H
        end.
        repeat eexists; eauto.
  Qed.

  Lemma update_elections_data_requestVote_cronies_same :
    forall h h' t lli llt st,
      cronies (update_elections_data_requestVote h h' t h' lli llt st) =
      cronies (fst st).
  Proof using.
    unfold update_elections_data_requestVote.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma advanceCurrentTerm_same_or_type_follower :
    forall st t,
      advanceCurrentTerm st t = st \/
      type (advanceCurrentTerm st t) = Follower.
  Proof using.
    unfold advanceCurrentTerm.
    intros. repeat break_match; auto.
  Qed.

  Lemma handleRV_advanceCurrentTerm_preserves_candidateEntries :
    forall net h h' t lli llt e,
      candidateEntries e (nwState net) ->
      candidateEntries e
                       (update name_eq_dec (nwState net) h
                               (update_elections_data_requestVote h h' t h' lli llt (nwState net h),
                                advanceCurrentTerm (snd (nwState net h)) t)).
  Proof using.
    intros.
    unfold candidateEntries in *.
    break_exists.  break_and.
    exists x.
    split; update_destruct; subst; rewrite_update; auto; simpl.
    + rewrite update_elections_data_requestVote_cronies_same. auto.
    + intros.
      match goal with
      | [ |- context [advanceCurrentTerm ?st ?t] ] =>
        pose proof advanceCurrentTerm_same_or_type_follower st t
      end.
      intuition; try congruence.
      repeat find_rewrite. auto.
  Qed.

  Lemma handleRequestVote_preserves_candidateEntries :
    forall net h h' t lli llt d e m,
      handleRequestVote h (snd (nwState net h)) t h' lli llt = (d, m) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h
                                 (update_elections_data_requestVote
                                    h h' t h' lli llt (nwState net h), d)).
  Proof using.
    unfold handleRequestVote.
    intros.
    repeat break_match; repeat find_inversion;
    auto using handleRV_advanceCurrentTerm_preserves_candidateEntries.
    - eapply candidateEntries_same; eauto;
        intros;
        repeat (rewrite update_fun_comm; simpl in * );
        update_destruct; subst; rewrite_update;
        auto using update_elections_data_requestVote_cronies_same.
    - do_bool. intuition. congruence.
    - unfold candidateEntries in *. break_exists. break_and. exists x.
      simpl.
      split.
      + rewrite update_fun_comm with (f := fst). simpl.
        rewrite update_fun_comm with (f := cronies). simpl.
        rewrite update_elections_data_requestVote_cronies_same.
        update_destruct; subst; rewrite_update; auto.
      + rewrite update_fun_comm with (f := snd). simpl.
        rewrite update_fun_comm with (f := currentTerm). simpl.
        rewrite update_fun_comm with (f := type). simpl.
        update_destruct; subst; rewrite_update; auto.
        match goal with
        | [ |- context [advanceCurrentTerm ?st ?t] ] =>
          pose proof advanceCurrentTerm_same_or_type_follower st t
        end.
        intuition; try congruence.
        repeat find_rewrite. auto.
  Qed.

  Lemma handleRequestVote_only_sends_RVR :
    forall d h h' t lli llt d' m,
      handleRequestVote h d t h' lli llt = (d', m) ->
      is_request_vote_reply m.
  Proof using.
    unfold handleRequestVote.
    intros.
    repeat break_match; repeat find_inversion; eauto.
  Qed.

  Lemma candidate_entries_request_vote :
    refined_raft_net_invariant_request_vote CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update; simpl in *;
      try find_erewrite_lem handleRequestVote_same_log;
      eapply handleRequestVote_preserves_candidateEntries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp. intuition.
      + eauto using handleRequestVote_preserves_candidateEntries.
      + subst. simpl in *.
        find_apply_lem_hyp handleRequestVote_only_sends_RVR.
        subst. break_exists. discriminate.
  Qed.

  Lemma candidate_entries_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply CandidateEntries.
  Proof using cci.
    red. unfold CandidateEntries. intros. intuition.
    - unfold candidateEntries_host_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct.
      + subst. rewrite_update.
        match goal with
          | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?r] =>
            remember (handleRequestVoteReply h st h' t r) as new_state
        end.
        find_copy_apply_lem_hyp handleRequestVoteReply_spec. break_and.
        match goal with
          | H : log _ = log _ |- _ => rewrite H in *
        end.
        find_apply_hyp_hyp.
        eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
      + rewrite_update.
        eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
  Qed.

  Lemma doLeader_in_entries :
    forall (h : name) d h os d' ms m t li pli plt es ci e,
      doLeader d h = (os, d', ms) ->
      snd m = AppendEntries t li pli plt es ci ->
      In m ms ->
      In e es ->
      In e (log d).
  Proof using.
    unfold doLeader.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; intuition.
    do_in_map.

    unfold replicaMessage in *. simpl in *. subst. simpl in *.
    find_inversion.
    eauto using findGtIndex_in.
  Qed.

  Lemma candidate_entries_do_leader :
    refined_raft_net_invariant_do_leader CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      update_destruct; subst; rewrite_update.
      + simpl in *.
        find_erewrite_lem doLeader_same_log.
        repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        pose doLeader_preserves_candidateEntries; eauto.
      + pose doLeader_preserves_candidateEntries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + pose doLeader_preserves_candidateEntries; eauto.
      + do_in_map. subst. simpl in *.
        eapply doLeader_preserves_candidateEntries; eauto.
        eapply_prop candidateEntries_host_invariant.
        match goal with
        | [ H : _ |- _ ] => rewrite H
        end.
        simpl.
        eauto using doLeader_in_entries.
  Qed.

  Lemma doGenericServer_same_type :
    forall h d os d' ms,
      doGenericServer h d = (os, d', ms) ->
      type d' = type d.
  Proof using.
    unfold doGenericServer.
    intros.
    repeat break_match; repeat find_inversion;
    use_applyEntries_spec; subst; simpl in *;
    auto.
  Qed.

  Lemma doGenericServer_spec :
    forall h d os d' ms,
      doGenericServer h d = (os, d', ms) ->
      (log d' = log d /\ currentTerm d' = currentTerm d /\
       (forall m, In m ms -> ~ is_append_entries (snd m))).
  Proof using.
    intros. unfold doGenericServer in *.
    repeat break_match; find_inversion; subst; intuition;
    use_applyEntries_spec; subst; simpl in *; auto.
  Qed.

  Lemma doGenericServer_preserves_candidateEntries :
    forall net gd d h os d' ms e,
      nwState net h = (gd, d) ->
      doGenericServer h d = (os, d', ms) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (gd, d')).
  Proof using.
    intros.
    eapply candidateEntries_same; eauto;
    intros;
    repeat (rewrite update_fun_comm; simpl in * );
    update_destruct; subst; rewrite_update; auto;
    repeat find_rewrite; simpl; auto.
    - find_copy_apply_lem_hyp doGenericServer_spec. break_and. auto.
    - eauto using doGenericServer_same_type.
  Qed.

  Lemma candidate_entries_do_generic_server :
    refined_raft_net_invariant_do_generic_server CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      update_destruct; subst; rewrite_update.
      + simpl in *.
        find_copy_apply_lem_hyp doGenericServer_spec. break_and.
        find_rewrite.
        repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        eauto using doGenericServer_preserves_candidateEntries.
      + eauto using doGenericServer_preserves_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + eauto using doGenericServer_preserves_candidateEntries.
      + do_in_map.
        find_copy_apply_lem_hyp doGenericServer_spec. break_and.
        subst. simpl in *.
        find_apply_hyp_hyp.
        exfalso.
        find_rewrite. eauto 20.
  Qed.

  Lemma candidate_entries_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros.
      repeat find_reverse_higher_order_rewrite.
      apply candidateEntries_ext with (sigma := nwState net); eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      find_apply_hyp_hyp.
      eapply_prop_hyp In In; eauto.
      apply candidateEntries_ext with (sigma := nwState net); eauto.
  Qed.

  Lemma reboot_log_same :
    forall d,
      log (reboot d) = log d.
  Proof using.
    unfold reboot.
    auto.
  Qed.

  Lemma reboot_preservers_candidateEntries :
    forall net h d gd e,
      nwState net h = (gd, d) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (gd, reboot d)).
  Proof using.
    unfold reboot, candidateEntries.
    intros.
    break_exists.
    exists x.
    break_and.
    rewrite update_fun_comm. simpl in *.
    update_destruct; subst; rewrite_update; auto.
    repeat find_rewrite. simpl in *. intuition. discriminate.
  Qed.

  Lemma candidate_entries_reboot :
    refined_raft_net_invariant_reboot CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros.
      repeat find_higher_order_rewrite.
      eapply candidateEntries_ext; eauto.
      subst.
      find_rewrite_lem update_fun_comm. simpl in *.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update.
      + repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        find_apply_hyp_hyp.
        eauto using reboot_preservers_candidateEntries.
      + eauto using reboot_preservers_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      repeat find_reverse_rewrite.
      eapply_prop_hyp In In; eauto.
      eapply candidateEntries_ext; eauto.
      eauto using reboot_preservers_candidateEntries.
  Qed.

  Lemma candidate_entries_init :
    refined_raft_net_invariant_init CandidateEntries.
  Proof using.
    red.
    unfold CandidateEntries.
    unfold candidateEntries_host_invariant, candidateEntries_nw_invariant.
    intuition;
     repeat match goal with
            | [ H : In _ _ |- _ ] => compute in H
            end;
    intuition.
  Qed.

  Theorem candidate_entries_invariant :
    forall (net : network),
      refined_raft_intermediate_reachable net ->
      CandidateEntries net.
  Proof using cci cti rri.
    intros.
    eapply refined_raft_net_invariant; eauto.
    - apply candidate_entries_init.
    - apply candidate_entries_client_request.
    - apply candidate_entries_timeout.
    - apply candidate_entries_append_entries.
    - apply candidate_entries_append_entries_reply.
    - apply candidate_entries_request_vote.
    - apply candidate_entries_request_vote_reply.
    - apply candidate_entries_do_leader.
    - apply candidate_entries_do_generic_server.
    - apply candidate_entries_state_same_packet_subset.
    - apply candidate_entries_reboot.
  Qed.

  Instance cei : candidate_entries_interface.
  Proof.
    split.
    auto using candidate_entries_invariant.
  Qed.
End CandidateEntriesProof.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Rel.Compat_weaken_X.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Set Implicit Arguments.

Local Hint Rewrite in_singleton in_union in_inter dom_single.
Local Hint Resolve subset_union_r subset_empty_l.
Local Hint Resolve 𝓥_monotone 𝓗_monotone.
Local Hint Constructors wf_XEnv.
Local Hint Constructors postfix.

Local Fact fsetfact3 (A : Type) (E : fset A) a :
a ∉ E → disjoint E \{a}.
Proof.
intro H ; apply fset_extens ; [ intros_all ; crush | auto ].
Qed.

Local Hint Resolve fsetfact3.

Section section_ccompat_tm_down.
Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (X : var).
Context (T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅).

Lemma ccompat_tm_down_aux n
(FrX :
  n ⊨ ∀ᵢ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂,
      𝓤⟦ Ξ & (X ~ (T,E)) ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇒ (X ∉ L₁ ∧ X ∉ L₂)ᵢ
) :
n ⊨ ∀ᵢ ζ₁ ζ₂ ξ₁ ξ₂ t₁ t₂,
    𝓣⟦ Ξ & (X ~ (T,E)) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
      δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂) t₁ t₂ ⇒
    𝓣⟦ Ξ & (X ~ (T,E)) ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂)
      (ktx_plug (ktx_down ktx_hole X) t₁)
      (ktx_plug (ktx_down ktx_hole X) t₂).
Proof.
loeb_induction LöbIH.
iintro ζ₁ ; iintro ζ₂ ; iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂ ; iintro Ht.
apply plug1 with
  (ε := ef_lbl (lbl_id (lid_f X))) (Ta := T) (ξ₁ := ζ₁ ++ X :: ξ₁) (ξ₂ := ζ₂ ++ X :: ξ₂).
+ exact FrX.
+ iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
  iintro v₁ ; iintro v₂ ; iintro Hv.
  eapply 𝓣_step_r.
  { simpl ; apply step_down_val ; eauto. }
  eapply 𝓣_step_l.
  { simpl ; apply step_down_val ; eauto. }
  iintro_later.
  apply 𝓥_in_𝓣 ; apply Hv.
+ clear - LöbIH.
  iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
  iintro K₁ ; iintro K₂ ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂.
  iintro H.
  iintro Xs_K₁K₂.
  iintro Hw.
  ielim_prop Xs_K₁K₂.

  simpl in H.
  idestruct H as X₁ H ; idestruct H as X₂ H ;
  idestruct H as r₁ H ; idestruct H as r₂ H ;
  idestruct H as HX₁X₂ H ; idestruct H as HXs₁Xs₂ H ;
  idestruct H as Hs₁s₂ H ; idestruct H as HX Hr.

  ielim_prop HX₁X₂ ; destruct HX₁X₂ as [HX₁ HX₂].
  ielim_prop Hs₁s₂ ; destruct Hs₁s₂ as [Hs₁ Hs₂].
  ielim_prop HXs₁Xs₂ ; destruct HXs₁Xs₂ as [HXs₁ HXs₂].
  simpl in HX₁, HX₂ ; inversion HX₁ ; inversion HX₂ ; clear HX₁ HX₂.
  subst s₁ s₂ Xs₁ Xs₂ X₁ X₂.

  rewrite get_concat in Hr.
  rewrite binds_single_eq in Hr.

  simpl.
  specialize (Xs_K₁K₂ X).
  assert (tunnels X K₁) ; [ crush | ].
  assert (tunnels X K₂) ; [ crush | ].
  eapply 𝓣_step_r.
  { apply step_down_up ; eauto. }
  eapply 𝓣_step_l.
  { apply step_down_up ; eauto. }

  unfold 𝓗_Fun in Hr.
  apply I_later_forall_down in Hr ; iespecialize Hr.
  apply I_later_forall_down in Hr ; iespecialize Hr.
  apply I_later_forall_down in Hr ; eapply I_forall_elim in Hr ; [ | apply postfix_refl ].
  apply I_later_forall_down in Hr ; eapply I_forall_elim in Hr ; [ | apply postfix_refl ].
  repeat (apply I_later_forall_down in Hr ; iespecialize Hr).
  apply I_later_arrow_down in Hr.
  erewrite I_iff_elim_M ; [ |
      eapply I_later_iff_down ; iintro_later ; apply fold_𝓥𝓤_in_𝓣
  ].
  iapply Hr.

  clear - LöbIH Hw Hξ₁' Hξ₂'.
  apply I_later_forall_up ; iintro ξ₁''.
  apply I_later_forall_up ; iintro ξ₂''.
  apply I_later_forall_up ; iintro Hξ₁''.
  apply I_later_forall_up ; iintro Hξ₂''.
  apply I_later_forall_up ; iintro t₁.
  apply I_later_forall_up ; iintro t₂.
  apply I_later_arrow_up ; iintro Ht.
  ielim_vars Hw ; [ | apply Hξ₂'' | apply Hξ₁'' ].
  iespecialize Hw.
  ispecialize Hw ; [ apply Ht | ].

  later_shift.
  erewrite <- I_iff_elim_M ; [ | apply fold_𝓥𝓤_in_𝓣 ].

  simpl ktx_plug in LöbIH.
  apply postfix_inv_app in Hξ₁'' ; destruct Hξ₁'' as [ ζ₁'' Hξ₁'' ].
  apply postfix_inv_app in Hξ₂'' ; destruct Hξ₂'' as [ ζ₂'' Hξ₂'' ].
  apply postfix_inv_app in Hξ₁' ; destruct Hξ₁' as [ ζ₁' Hξ₁' ].
  apply postfix_inv_app in Hξ₂' ; destruct Hξ₂' as [ ζ₂' Hξ₂' ].
  ispecialize LöbIH (ζ₁'' ++ ζ₁' ++ ζ₁) ;
  ispecialize LöbIH (ζ₂'' ++ ζ₂' ++ ζ₂) ;
  ispecialize LöbIH ξ₁ ;
  ispecialize LöbIH ξ₂.
  repeat rewrite <- app_assoc in LöbIH.
  rewrite <- Hξ₁', <- Hξ₂', <- Hξ₁'', <- Hξ₂'' in LöbIH.
  iespecialize LöbIH.
  ispecialize LöbIH ; [ apply Hw | ].
  apply LöbIH.
+ apply postfix_refl.
+ apply postfix_refl.
+ assumption.
Qed.

Context (FrX_Ξ : X # Ξ).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_E : wf_eff Ξ E).

Lemma ccompat_tm_down n ξ₁ ξ₂ t₁ t₂ :
n ⊨ ( ∀ᵢ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂,
      𝓤⟦ (Ξ & X ~ (T, E)) ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂ ⇒
      (X ∉ Xs₁ ∧ X ∉ Xs₂)ᵢ
    ) →
X ∉ from_list ξ₁ → X ∉ from_list ξ₂ →
n ⊨ 𝓣⟦ (Ξ & (X ~ (T, E))) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
    δ₁ δ₂ δ ρ₁ ρ₂ ρ
    (X :: ξ₁) (X :: ξ₂)
    (L_subst_tm (lid_f X) t₁) (L_subst_tm (lid_f X) t₂) →
n ⊨ 𝓣⟦ Ξ ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (⬇ t₁) (⬇ t₂).
Proof.
intros FrX_E FrX_ξ₁ FrX_ξ₂ Ht.
specialize (ccompat_tm_down_aux FrX_E) as H.
ispecialize H ([] : list var).
ispecialize H ([] : list var).
iespecialize H.
repeat rewrite app_nil_l in H.
simpl ktx_plug in H.

eapply 𝓣_step_r.
{ apply step_Down with (X := X) ; assumption. }
eapply 𝓣_step_l.
{ apply step_Down with (X := X) ; assumption. }

iintro_later.
iespecialize H ; ispecialize H ; [ apply Ht | ].
erewrite I_iff_elim_M ; [ apply H | apply X_weaken_𝓣 ] ; crush.
Qed.

End section_ccompat_tm_down.

Section section_compat_tm_down.
Context (n : nat).
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (Wf_Γ : wf_Γ Ξ Γ).
Context (t₁ t₂ : tm EV LV V (inc ∅)).
Context (T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_E : wf_eff Ξ E).

Lemma compat_tm_down (B : vars) :
( ∀ X, X \notin B →
  n ⊨ ⟦ (Ξ & (X ~ (T, E))) Γ ⊢
        (L_subst_tm (lid_f X) t₁) ≼ˡᵒᵍ (L_subst_tm (lid_f X) t₂) :
        T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
) →
n ⊨ ⟦ Ξ Γ ⊢ (⬇ t₁) ≼ˡᵒᵍ (⬇ t₂) : T # E ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
pick_fresh_gen (from_list ξ₁ \u from_list ξ₂ \u B) X.
assert (X ∉ B) as FrB ; [ crush | ].
specialize (Ht X FrB).
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hγ.
ielim_prop Hξ ; specialize Hξ as Hξ_copy ; destruct Hξ_copy as [Hξ₁ Hξ₂].
ielim_prop cl_ρ₁ρ₂.

assert (X ∉ from_list ξ₁) as Frξ₁ ; [ crush | ].
assert (X ∉ from_list ξ₂) as Frξ₂ ; [ crush | ].
assert (X ∉ dom Ξ) as FrΞ ; [ intro ; crush | ].

ispecialize Ht (X :: ξ₁) ; ispecialize Ht (X :: ξ₂).
ispecialize Ht δ₁ ; ispecialize Ht δ₂ ; ispecialize Ht δ.
ispecialize Ht ρ₁ ; ispecialize Ht ρ₂ ; ispecialize Ht ρ.
ispecialize Ht γ₁ ; ispecialize Ht γ₂.
ispecialize Ht.
{ iintro_prop ; split ; [ clear - Hξ₁ | clear - Hξ₂ ] ;
  rewrite dom_concat, from_list_cons, dom_single, union_comm ;
  apply subset_union_2 ; crush.
}
ispecialize Ht.
{ repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
  repeat rewrite from_list_cons ; ielim_prop cl_δ ; crush.
}
ispecialize Ht.
{ iintro_prop ; intros α Y ; specialize (cl_ρ₁ρ₂ α Y) ;
  clear - cl_ρ₁ρ₂ ; repeat rewrite from_list_cons ; crush.
}
ispecialize Ht.
{ iintro x ; ispecialize Hγ x ; clear - Wf_Ξ Wf_Γ Wf_T Wf_E FrΞ Hγ.
  erewrite <- I_iff_elim_M ; [ | apply X_weaken_𝓥 ; crush ].
  eauto.
}

simpl.
apply ccompat_tm_down with (X := X) ; try assumption.
+ iintro ξ₁' ; iintro ξ₂' ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂ ; iintro Hs.
  erewrite <- I_iff_elim_M in Hs ; [ | apply X_weaken_𝓤 ; crush ].
  iintro_prop.
  assert (Xs₁ \c from_list ξ₁ ∧ Xs₂ \c from_list ξ₂) as HXs₁Xs₂.
  { eapply 𝓤_is_closed ; eassumption. }
  clear - HXs₁Xs₂ Frξ₁ Frξ₂.
  destruct HXs₁Xs₂.
  split ; intro ; auto.
+ clear - Ht.
  repeat erewrite <- V_L_bind_tm, <- EV_L_bind_tm, <- LV_L_bind_tm.
  { apply Ht. }
  { intro ; unfold compose.
    erewrite L_bind_map_lbl, L_bind_lbl_id, L_map_lbl_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_lbl, L_bind_lbl_id, L_map_lbl_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }
Qed.

End section_compat_tm_down.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import PSCIAux.Spec.
Require Import PSCIAux2.Specs.psci_cpu_on_target.
Require Import PSCIAux2.LowSpecs.psci_cpu_on_target.
Require Import PSCIAux2.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       get_rec_runnable_spec
       buffer_unmap_spec
       granule_unlock_spec
       set_psci_result_x0_spec
       psci_reset_rec_spec
       set_rec_pc_spec
       set_rec_runnable_spec
       set_psci_result_forward_psci_call_spec
       set_psci_result_forward_x1_spec
    .

  Lemma psci_cpu_on_target_spec_exists:
    forall habd habd'  labd g_target_rec target_rec rec entry_point_address target_cpu
           (Hspec: psci_cpu_on_target_spec g_target_rec target_rec rec entry_point_address target_cpu habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', psci_cpu_on_target_spec0 g_target_rec target_rec rec entry_point_address target_cpu labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct g_target_rec, target_rec, rec.
    unfold psci_cpu_on_target_spec, psci_cpu_on_target_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    unfold ref_accessible in *; simpl.
    repeat (simpl_htarget; srewrite; simpl in * ).
    eexists; split. reflexivity. constructor; simpl.
    repeat simpl_update_reg.
    repeat (repeat simpl_field; repeat swap_fields).
    rewrite <- C12. reflexivity.
    eexists; split. reflexivity. constructor. rewrite <- C12. reflexivity.
  Qed.

End Refine.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsIntro.Layer.
Require Import TableDataOpsRef1.Code.table_unmap1.

Require Import TableDataOpsRef1.LowSpecs.table_unmap1.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_unmap ↦ gensem table_unmap_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_unmap: block.
    Hypothesis h_table_unmap_s : Genv.find_symbol ge _table_unmap = Some b_table_unmap.
    Hypothesis h_table_unmap_p : Genv.find_funct_ptr ge b_table_unmap
                                 = Some (External (EF_external _table_unmap
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap_spec.

    Lemma table_unmap1_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_unmap1_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_unmap1_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_unmap1_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.