Require Stlc.SpecSyntax.
Require Utlc.SpecSyntax.
Require Import Stlc.SpecTyping.
Require Import Stlc.LemmasTyping.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.StlcOmega.
Require Import Utlc.SpecScoping.
Require Import Utlc.LemmasScoping.
Require Import Utlc.LemmasEvaluation.
Require Import Utlc.DecideEval.
Require Import LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.
Require Import LogRel.LemmasIntro.
Require Import LogRel.LemmasInversion.
Require Import Omega.
Require Import Db.Lemmas.

Require Import LogRel.LR.
Require Import Compiler.ProtectConfine.

Require Import BackTrans.UValHelpers.
Require Import BackTrans.UValHelpers2.

Require Import UVal.UVal.

Local Ltac crush :=
  cbn in * |-;
  repeat
    (repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushRepEmulEmbed;
     repeat crushUtlcSyntaxMatchH;
     repeat crushUtlcScopingMatchH;
     repeat crushUtlcScopingMatchH;
     repeat crushUtlcEvaluationMatchH2;
     split;
     trivial;
     crushTyping;
     try crushOfType;
     subst*);
  try discriminate; try Omega.omega;
  eauto with eval;
  repeat crushStlcSyntaxMatchH; (* remove apTm's again *)
  repeat crushUtlcSyntaxMatchH. (* same for apUTm's *)

Fixpoint inject (n : nat) (τ : Ty) :=
  S.abs τ
      (match τ with
         | tarr τ₁ τ₂ => inArrDwn n (S.abs (UVal n) (S.app (inject n τ₂) (S.app (S.var 1) (S.app (extract n τ₁) (S.var 0)))))
         | tunit => inUnitDwn n (S.var 0)
         | tbool => inBoolDwn n (S.var 0)
         | tprod τ₁ τ₂ => inProdDwn n (S.pair (S.app (inject n τ₁) (S.proj₁ (S.var 0)))
                                         (S.app (inject n τ₂) (S.proj₂ (S.var 0))))
         | tsum τ₁ τ₂ => inSumDwn n (S.caseof (S.var 0) (S.inl (S.app (inject n τ₁) (S.var 0)))
                                         (S.inr (S.app (inject n τ₂) (S.var 0))))
       end)
with extract (n : nat) (τ : Ty) :=
       S.abs (UVal n) (match τ with
                       | tarr τ₁ τ₂ => S.abs τ₁ (S.app (extract n τ₂) (uvalApp n (S.var 1) (S.app (inject n τ₁) (S.var 0))))
                       | tunit => caseUnitUp n (S.var 0)
                       | tbool => caseBoolUp n (S.var 0)
                       | tprod τ₁ τ₂ => S.pair (S.app (extract n τ₁) (S.proj₁ (caseProdUp n (S.var 0))))
                                             (S.app (extract n τ₂) (S.proj₂ (caseProdUp n (S.var 0))))
                       | tsum τ₁ τ₂ => S.caseof (caseSumUp n (S.var 0))
                                              (S.inl (S.app (extract n τ₁) (S.var 0)))
                                              (S.inr (S.app (extract n τ₂) (S.var 0)))
                     end).

Lemma inject_value {n τ} : S.Value (inject n τ).
Proof.
  (* exact I. *)
  (* Should be doable without the induction, but I don't see how *)
  induction τ; simpl; eauto with eval.
Qed.

Lemma injectT {n τ Γ} : ⟪ Γ ⊢ inject n τ : τ ⇒ UVal n ⟫
with extractT {n τ Γ} : ⟪ Γ ⊢ extract n τ : UVal n ⇒ τ ⟫.
Proof.
  - induction τ; unfold inject; eauto with typing uval_typing.
  - induction τ; unfold extract; eauto with typing uval_typing.
Qed.

Lemma inject_closed {n τ} :
  ⟨ 0 ⊢ inject n τ ⟩.
Proof.
  eapply (wt_implies_ws (Γ := empty)).
  eapply injectT.
Qed.

Lemma extract_value {n τ} : S.Value (extract n τ).
Proof.
  (* exact I. *)
  (* Should be doable without the induction, but I don't see how *)
  induction τ; simpl; eauto with eval.
Qed.

Lemma extract_closed {n τ} :
  ⟨ 0 ⊢ extract n τ ⟩.
Proof.
  eapply (wt_implies_ws (Γ := empty)).
  eapply extractT.
Qed.

Lemma inject_sub {n τ γ} : (inject n τ)[γ] = inject n τ.
Proof.
  apply wsClosed_invariant.
  eapply inject_closed.
Qed.

Lemma extract_sub {n τ γ} : (extract n τ)[γ] = extract n τ.
Proof.
  apply wsClosed_invariant.
  eapply extract_closed.
Qed.

Lemma termrel₀_extract_unit {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  termrel₀ d w ptunit (caseUnitUp n vs) (U.seq vu U.unit).
Proof.
  intros dwp vr.
  unfold caseUnitUp.

  (* do the upgrade *)
  unfold caseUnitUp_pctx; rewrite S.pctx_cat_app; cbn.
  assert (trupg : termrel₀ d w (pEmulDV (n + 1) p) (S.app (upgrade n 1) vs) vu)
    by eauto using upgrade_works''.
  replace (n + 1) with (S n) in trupg by Omega.omega.
  eapply (termrel₀_ectx' trupg); S.inferContext; U.inferContext; cbn; crush.

  (* continuation bureaucracy *)
  intros vs' vu' vr'.

  exact (termrel₀_caseUValUnit dwp vr').
Qed.

Lemma termrel₀_extract_bool {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  termrel₀ d w ptbool (caseBoolUp n vs) (U.ite vu U.true U.false).
Proof.
  intros dwp vr.
  unfold caseBoolUp.

  (* do the upgrade *)
  unfold caseBoolUp_pctx; rewrite S.pctx_cat_app; cbn.
  assert (trupg : termrel₀ d w (pEmulDV (n + 1) p) (S.app (upgrade n 1) vs) vu)
    by eauto using upgrade_works''.
  replace (n + 1) with (S n) in trupg by Omega.omega.
  eapply (termrel₀_ectx' trupg); S.inferContext; U.inferContext; cbn; crush.

  (* continuation bureaucracy *)
  intros vs' vu' vr'.

  exact (termrel₀_caseUValBool dwp vr').
Qed.

Lemma termrel₀_extract_proj₁ {n w d p vs vu} :
  dir_world_prec n (S w) d p →
  valrel d (S w) (pEmulDV n p) vs vu →
  termrel₀ d w (pEmulDV n p) (S.proj₁ (caseProdUp n vs)) (U.proj₁ vu).
Proof.
  intros dwp tr.
  unfold caseProdUp.
  unfold caseProdUp_pctx; rewrite S.pctx_cat_app; cbn.

  (* execute the upgrade *)
  assert (trupg : termrel₀ d (S w) (pEmulDV (n + 1) p) (S.app (upgrade n 1) vs) vu)
    by eauto using upgrade_works''.
  replace (n + 1) with (S n) in trupg by Omega.omega.
  eapply (termrel₀_ectx''' trupg); S.inferContext; U.inferContext; crush.

  (* continuation bureaucracy *)
  intros vs' vu' vr'.
  destruct (valrel_implies_Value vr').
  eapply invert_valrel_pEmulDV_for_caseUValProd in vr'.
  fold (caseProd n vs').
  destruct vr' as [(vs'' & ? & es & vr'')|
                   [(? & div)|(? & div)]].
  - eapply termrel₀_antired_star_left.
    eapply (evalstar_ctx' es); S.inferContext; crush.
    simpl.
    eauto using termrel₀_proj₁, valrel_in_termrel₀.
  - subst; eapply dwp_invert_imprecise in dwp; subst.
    eapply termreli₀_div_lt.
    eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
  - eapply termreli₀_div_wrong.
    + eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
    + right.
      simpl.
      eapply evalToStar.
      eapply eval₀_to_eval.
      eauto with eval.
Qed.

Lemma termrel₀_extract_proj₂ {n w d p vs vu} :
  dir_world_prec n (S w) d p →
  valrel d (S w) (pEmulDV n p) vs vu →
  termrel₀ d w (pEmulDV n p) (S.proj₂ (caseProdUp n vs)) (U.proj₂ vu).
Proof.
  intros dwp tr.
  unfold caseProdUp.
  unfold caseProdUp_pctx; rewrite S.pctx_cat_app; cbn.

  (* execute the upgrade *)
  assert (trupg : termrel₀ d (S w) (pEmulDV (n + 1) p) (S.app (upgrade n 1) vs) vu)
    by eauto using upgrade_works''.
  replace (n + 1) with (S n) in trupg by Omega.omega.
  eapply (termrel₀_ectx''' trupg); S.inferContext; U.inferContext; crush.

  (* continuation bureaucracy *)
  intros vs' vu' vr'.
  destruct (valrel_implies_Value vr').
  eapply invert_valrel_pEmulDV_for_caseUValProd in vr'.
  fold (caseProd n vs').
  destruct vr' as [(vs'' & ? & es & vr'')|
                   [(? & div)|(? & div)]].
  - eapply termrel₀_antired_star_left.
    eapply (evalstar_ctx' es); S.inferContext; crush.
    simpl.
    eauto using termrel₀_proj₂, valrel_in_termrel₀.
  - subst; eapply dwp_invert_imprecise in dwp; subst.
    eapply termreli₀_div_lt.
    eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
  - eapply termreli₀_div_wrong.
    + eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
    + right.
      simpl.
      eapply evalToStar.
      eapply eval₀_to_eval.
      eauto with eval.
Qed.

Lemma termreli₀_extract_ptsum {n w d dfc p τ' vs₁ vu₁ ts₂ tu₂ ts₃ tu₃} :
  dir_world_prec n (S w) d p →
  valrel d (S w) (pEmulDV n p) vs₁ vu₁ →
  (forall vs₂ vu₂,
                      valrel d w (pEmulDV n p) vs₂ vu₂ →
                      termreli₀ d dfc (S w) τ' (ts₂ [beta1 vs₂]) (tu₂ [beta1 vu₂])) →
  (forall vs₃ vu₃,
                      valrel d w (pEmulDV n p) vs₃ vu₃ →
                      termreli₀ d dfc (S w) τ' (ts₃ [beta1 vs₃]) (tu₃ [beta1 vu₃])) →
  termreli₀ d dfc (S w) τ' (S.caseof (caseSumUp n vs₁) ts₂ ts₃) (U.caseof vu₁ tu₂ tu₃).
Proof.
  intros dwp vr₁ tr₂ tr₃.
  unfold caseSumUp.
  unfold caseSumUp_pctx.
  rewrite S.pctx_cat_app; crush; cbn.

  (* evaluate upgrade *)
  assert (trupg : termrel₀ d (S w) (pEmulDV (n + 1) p) (S.app (upgrade n 1) vs₁) vu₁)
    by eauto using upgrade_works''.
  replace (n + 1) with (S n) in trupg by Omega.omega.
  eapply termreli₀_dfc_mono in trupg; try omega.
  eapply (termrel₀_ectx' trupg); S.inferContext; U.inferContext; crush.

  (* continuation bureaucracy *)
  intros vs' vu' vr'.
  fold (caseSum n vs'); cbn.

  (* case analysis *)
  destruct (valrel_implies_Value vr').
  eapply invert_valrel_pEmulDV_for_caseUValSum in vr'.
  destruct vr' as [(vs₁' & ? & es & vr₁')|
                   [(? & div)| (neql & neqr & div)]]; subst.

  - (* successful caseUValBool *)
    eapply termreli₀_antired_star.
    + eapply (evalstar_ctx' es); S.inferContext; crush.
    + eapply rt1n_refl.
    + cbn.

      eapply termreli₀_caseof; eauto using valrel_in_termreli₀.
  - (* unk case *)
    eapply dwp_invert_imprecise in dwp; subst.
    eapply termreli₀_div_lt.
    eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
  - (* other cases *)
    eapply termreli₀_div_wrong.
    + eapply (divergence_closed_under_evalcontext' div); S.inferContext; crush.
    + right.
      eapply evalToStar.
      eapply eval₀_to_eval.
      eauto with eval.
Qed.

Lemma inject_unit_works {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w ptunit vs vu →
  termrel₀ d w (pEmulDV n p) (S.app (inject n tunit) vs) (U.app (protect tunit) vu).
Proof.
  intros dwp vr.
  destruct (valrel_implies_Value vr).
  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - rewrite inUnitDwn_sub; cbn.

    eapply termrel₀_inUnitDwn; now assumption.
Qed.

Lemma inject_bool_works {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w ptbool vs vu →
  termrel₀ d w (pEmulDV n p) (S.app (inject n tbool) vs) (U.app (protect tbool) vu).
Proof.
  intros dwp vr.
  destruct (valrel_implies_Value vr).
  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - rewrite inBoolDwn_sub; cbn.
    eapply termrel₀_inBoolDwn; now assumption.
Qed.

Lemma inject_tarr_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (embed (τ₁ ⇒ τ₂)) vs vu →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (pEmulDV n p) vs' vu' →
              termrel₀ d w' (embed τ₁) (S.app (extract n τ₁) vs') (U.app (confine τ₁) vu')) →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (embed τ₂) vs' vu' →
              termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₂) vs') (U.app (protect τ₂) vu')) →
  termrel₀ d w (pEmulDV n p) (S.app (inject n (τ₁ ⇒ τ₂)) vs) (U.app (protect (τ₁ ⇒ τ₂)) vu).
Proof.
  intros dwp vr extr₁ inj₂.
  destruct (valrel_implies_Value vr) as [? ?].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].
  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - cbn.
    rewrite inArrDwn_sub, protect_sub, confine_sub.
    crushTyping.
    rewrite inject_sub, extract_sub; cbn.
    crushUtlcScoping.
    rewrite ?protect_sub, ?confine_sub.

    eapply termrel₀_inArrDwn; try assumption.

    change (UVal n) with (repEmul (pEmulDV n p)).
    eapply valrel_lambda.
    + eapply OfType_lambda; auto.
      * crushUtlcScoping; eauto using protect_closed, confine_closed.
      * crushTyping; rewrite repEmul_embed_leftinv; eauto using injectT, extractT.
    + intros w' vs' vu' fw' vr'.
      cbn.
      crushUtlcScoping.
      crushTyping.
      rewrite ?protect_sub, ?confine_sub.
      rewrite ?inject_sub, ?extract_sub.
      rewrite ?(wsClosed_invariant (wt_implies_ws tvs)).
      rewrite ?(wsClosed_invariant closed_vu).

      (* execute the extract/confine *)
      assert (dir_world_prec n w' d p) as dwp' by eauto using dwp_mono.
      pose proof (extr₁ _ _ _ fw' vr') as extr_tr.
      eapply termrel₀_in_termrel in extr_tr.
      eapply (termrel_ectx' extr_tr); S.inferContext; U.inferContext;
      crush; eauto using inject_value, protect_Value with eval.

      (* execute the applications *)
      intros w'' fw'' vs'' vu'' vr''.
      cbn.
      assert (w'' ≤ w) as fw2 by eauto with arith.
      pose proof (valrel_app (valrel_mono fw2 vr) vr'') as app_tr.
      eapply (termrel_ectx' app_tr); S.inferContext; U.inferContext;
      crush; eauto using inject_value, protect_Value with eval.

      intros w''' fw''' vs''' vu''' vr'''.
      cbn.
      (* execute the inject/protect *)
      eapply termrel₀_in_termrel.
      eapply inj₂; eauto using dwp_mono with arith.
Qed.

Lemma inject_tprod_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (embed (tprod τ₁ τ₂)) vs vu →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (embed τ₁) vs' vu' →
              termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₁) vs') (U.app (protect τ₁) vu')) →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (embed τ₂) vs' vu' →
              termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₂) vs') (U.app (protect τ₂) vu')) →
  termrel₀ d w (pEmulDV n p) (S.app (inject n (tprod τ₁ τ₂)) vs) (U.app (protect (tprod τ₁ τ₂)) vu).
Proof.
  intros dwp vr inj₁ inj₂.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  destruct (valrel_ptprod_inversion vr) as (vs₁ & vs₂ & vu₁ & vu₂ & ? & ? & ot₁ & ot₂ & vrs).
  subst.
  destruct ((fun x => x) vvs) as (vvs₁ & vvs₂).
  destruct ((fun x => x) vvu) as (vvu₁ & vvu₂).

  assert (0 + Nat.min 2 2 ≥ 1) as ineq by eauto with arith.

  eapply (termreli₀_antired 0 ineq).
  - (* beta-reduce *)
    eapply stepRel_step.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
    rewrite inProdDwn_sub. cbn. repeat crushStlcSyntaxMatchH.
    rewrite ?inject_sub; cbn.

    (* project *)
    eapply stepRel_step.
    assert (S.eval₀ (S.proj₁ (S.pair vs₁ vs₂)) vs₁) as proj_eval₀ by crush.
    unfold inProdDwn.
    eapply (S.eval_from_eval₀ proj_eval₀); S.inferContext; crush;
    eauto using downgrade_value, inject_value.

    eapply stepRel_zero.

  - (* beta-reduce *)
    eapply stepRel_step.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
    cbn. repeat crushUtlcSyntaxMatchH. rewrite ?protect_sub.

    (* project *)
    eapply stepRel_step.
    assert (U.eval₀ (U.proj₁ (U.pair vu₁ vu₂)) vu₁) as proj_eval₀ by crush.
    eapply (U.ctxeval_from_eval₀ proj_eval₀); U.inferContext; crush;
    eauto using protect_Value.

    eapply stepRel_zero.
  - rewrite ?S.pctx_cat_app.
    cbn.
    destruct w.
    + eapply termrel₀_zero.
    + assert (w < S w) as fw by eauto with arith.
      specialize (vrs w fw).
      destruct vrs as (vr₁ & vr₂).

      (* execute first inject/protects *)
      assert (dir_world_prec n w d p) as dwp' by eauto using dwp_mono.
      pose proof (inj₁ _ _ _ fw vr₁) as inj₁_tr.

      change w with (lateri 1 (S w)) in inj₁_tr.
      assert (lev (S w) ≥ 1) by (unfold lev; omega).
      eapply (termreli₀_ectx' inj₁_tr); S.inferContext; U.inferContext;
      crush; eauto using downgrade_value.

      (* execute second projection *)
      intros vs₁' vu₁' vr₁'.
      destruct (valrel_implies_Value vr₁') as (? & ?).
      rewrite S.pctx_cat_app; cbn.
      eapply termreli₀_antired_star.
      * eapply evalToStar.
        assert (S.eval₀ (S.proj₂ (S.pair vs₁ vs₂)) vs₂) as proj_eval₀ by crush.
        unfold inProdDwn.
        eapply (S.eval_from_eval₀ proj_eval₀); S.inferContext; crush;
        eauto using downgrade_value, inject_value.
      * eapply evalToStar.
        assert (U.eval₀ (U.proj₂ (U.pair vu₁ vu₂)) vu₂) as proj_eval₀ by crush.
        eapply (U.ctxeval_from_eval₀ proj_eval₀); U.inferContext; crush;
        eauto using protect_Value.
      * rewrite ?S.pctx_cat_app, ?U.pctx_cat_app; cbn.

        (* execute second inject/protect *)
        pose proof (inj₂ _ _ _ fw vr₂) as inj₂_tr.

        change w with (lateri 1 (S w)) in inj₂_tr.
        assert (lev (S w) ≥ 1) by (unfold lev; omega).
        eapply (termreli₀_ectx' inj₂_tr); S.inferContext; U.inferContext;
        crush; eauto using downgrade_value.

        intros vs₂' vu₂' vr₂'.
        rewrite ?S.pctx_cat_app; cbn.

        pose proof (valrel_pair' vr₁' vr₂') as vrp.
        eapply termrel₀_inProdDwn in vrp.
        eapply (termreli₀_dfc_mono vrp); eauto with arith.
        exact dwp.
Qed.

Lemma inject_tsum_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (embed (tsum τ₁ τ₂)) vs vu →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (embed τ₁) vs' vu' →
              termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₁) vs') (U.app (protect τ₁) vu')) →
  (forall {w' vs' vu'}, w' < w →
              valrel d w' (embed τ₂) vs' vu' →
              termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₂) vs') (U.app (protect τ₂) vu')) →
  termrel₀ d w (pEmulDV n p) (S.app (inject n (tsum τ₁ τ₂)) vs) (U.app (protect (tsum τ₁ τ₂)) vu).
Proof.
  intros dwp vr inj₁ inj₂.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  rewrite ?protect_sub.

  destruct w; try eapply termrel₀_zero.
  assert (w < S w) as fw by eauto with arith.
  assert (dir_world_prec n w d p) as dwp' by eauto using dwp_mono.

  destruct (valrel_ptsum_inversion vr) as (vs' & vu' & [(? & ? & ot' & vrs)|(? & ? & ot' & vrs) ]);
    specialize (vrs w fw);
    subst; cbn in vvs;
    assert (0 + Nat.min 2 2 ≥ 1) as ineq by eauto with arith.
  - eapply (termreli₀_antired 0 ineq).
    + (* beta-reduce *)
      eapply stepRel_step.
      eapply (S.eval_ctx₀ S.phole); simpl;
      eauto using S.eval_beta.
      rewrite inSumDwn_sub. cbn. repeat crushStlcSyntaxMatchH.
      rewrite ?inject_sub; cbn.

      (* execute the pattern match *)
      eapply stepRel_step.
      assert (S.eval₀ (S.caseof (S.inl vs') (S.inl (S.app (inject n τ₁) (S.var 0))) (S.inr (S.app (inject n τ₂) (S.var 0)))) (S.inl (S.app (inject n τ₁) (S.var 0)))[beta1 vs']) as caseof_eval₀ by crush.
      unfold inSumDwn.
      eapply (S.eval_from_eval₀ caseof_eval₀); S.inferContext; crush;
      eauto using downgrade_value, inject_value.

      eapply stepRel_zero.
    + (* beta-reduce *)
      eapply stepRel_step.
      eapply U.eval₀_ctxeval.
      eapply U.eval_beta; eauto.
      cbn. repeat crushUtlcSyntaxMatchH. rewrite ?protect_sub.

      (* execute the pattern match *)
      eapply stepRel_step.
      assert (U.eval₀ (U.caseof (U.inl vu') (U.inl (U.app (protect τ₁) (U.var 0)))
                                (U.inr (U.app (protect τ₂) (U.var 0)))) (U.inl (U.app (protect τ₁) (U.var 0))) [beta1 vu']) as proj_eval₀ by crush.
      eapply (U.ctxeval_from_eval₀ proj_eval₀); U.inferContext; crush;
      eauto using protect_Value.

      eapply stepRel_zero.
    + crush.
      rewrite ?inject_sub, ?protect_sub; cbn.

      (* execute inject/protect *)
      pose proof (inj₁ _ _ _ fw vrs) as inj_tr.
      change w with (lateri 1 (S w)) in inj_tr.
      assert (lev (S w) ≥ 1) by (unfold lev; omega).
      eapply (termreli₀_ectx' inj_tr); S.inferContext; U.inferContext;
      crush; eauto using downgrade_value.

      (* and finish up *)
      intros vs'' vu'' vr''.
      destruct (valrel_implies_OfType vr'') as ((? & ?) & (? & ?)).
      rewrite S.pctx_cat_app; cbn.

      eapply valrel_inl' in vr''.
      eapply termrel₀_inSumDwn in vr''; try assumption.
      refine (termreli₀_dfc_mono vr'' _); eauto with arith.
  - eapply (termreli₀_antired 0 ineq).
    + (* beta-reduce *)
      eapply stepRel_step.
      eapply (S.eval_ctx₀ S.phole); simpl;
      eauto using S.eval_beta.
      rewrite inSumDwn_sub. cbn. repeat crushStlcSyntaxMatchH.
      rewrite ?inject_sub; cbn.

      (* execute the pattern match *)
      eapply stepRel_step.
      assert (S.eval₀ (S.caseof (S.inr vs') (S.inl (S.app (inject n τ₁) (S.var 0))) (S.inr (S.app (inject n τ₂) (S.var 0)))) (S.inr (S.app (inject n τ₂) (S.var 0)))[beta1 vs']) as caseof_eval₀ by crush.
      unfold inSumDwn.
      eapply (S.eval_from_eval₀ caseof_eval₀); S.inferContext; crush;
      eauto using downgrade_value, inject_value.

      eapply stepRel_zero.
    + (* beta-reduce *)
      eapply stepRel_step.
      eapply U.eval₀_ctxeval.
      eapply U.eval_beta; eauto.
      cbn. repeat crushUtlcSyntaxMatchH. rewrite ?protect_sub.

      (* execute the pattern match *)
      eapply stepRel_step.
      assert (U.eval₀ (U.caseof (U.inr vu') (U.inl (U.app (protect τ₁) (U.var 0)))
                                (U.inr (U.app (protect τ₂) (U.var 0)))) (U.inr (U.app (protect τ₂) (U.var 0))) [beta1 vu']) as proj_eval₀ by crush.
      eapply (U.ctxeval_from_eval₀ proj_eval₀); U.inferContext; crush;
      eauto using protect_Value.

      eapply stepRel_zero.
    + crush.
      rewrite ?inject_sub, ?protect_sub; cbn.

      (* execute inject/protect *)
      pose proof (inj₂ _ _ _ fw vrs) as inj_tr.
      change w with (lateri 1 (S w)) in inj_tr.
      assert (lev (S w) ≥ 1) by (unfold lev; omega).
      eapply (termreli₀_ectx' inj_tr); S.inferContext; U.inferContext;
      crush; eauto using downgrade_value.

      (* and finish up *)
      intros vs'' vu'' vr''.
      destruct (valrel_implies_OfType vr'') as ((? & ?) & (? & ?)).
      rewrite S.pctx_cat_app; cbn.

      eapply valrel_inr' in vr''.
      eapply termrel₀_inSumDwn in vr''; try assumption.
      refine (termreli₀_dfc_mono vr'' _); eauto with arith.
Qed.

Lemma extract_tunit_works {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  termrel₀ d w (embed tunit) (S.app (extract n tunit) vs) (U.app (confine tunit) vu).
Proof.
  intros dwp vr.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - rewrite caseUnitUp_sub; cbn.
    eapply termrel₀_extract_unit; try eassumption.
Qed.

Lemma extract_tbool_works {n w d p vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  termrel₀ d w (embed tbool) (S.app (extract n tbool) vs) (U.app (confine tbool) vu).
Proof.
  intros dwp vr.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - rewrite caseBoolUp_sub; cbn.
    eapply termrel₀_extract_bool; try eassumption.
Qed.

Lemma extract_tarr_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  (forall w' vs' vu', w' < w →
                      valrel d w' (embed τ₁) vs' vu' →
                      termrel₀ d w' (pEmulDV n p) (S.app (inject n τ₁) vs') (U.app (protect τ₁) vu')) →
  (forall w' vs' vu', w' < w →
                      valrel d w' (pEmulDV n p) vs' vu' →
                      termrel₀ d w' (embed τ₂) (S.app (extract n τ₂) vs') (U.app (confine τ₂) vu')) →
  termrel₀ d w (embed (tarr τ₁ τ₂)) (S.app (extract n (tarr τ₁ τ₂)) vs) (U.app (confine (tarr τ₁ τ₂)) vu).
Proof.
  intros dwp vr inj₁ extr₂.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].
  eapply termrel₀_antired_star.
  - eapply evalToStar.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
  - eapply evalToStar.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
  - cbn.
    rewrite protect_sub, confine_sub.
    crushTyping.
    rewrite uvalApp_sub; crushTyping.
    rewrite inject_sub, extract_sub; cbn.
    crushUtlcScoping.
    rewrite ?protect_sub, ?confine_sub.

    eapply valrel_in_termrel₀.
    replace τ₁ with (repEmul (embed τ₁)) at 2 by eapply repEmul_embed_leftinv.
    eapply valrel_lambda.
    + eapply OfType_lambda; crushUtlcScoping;
      rewrite ?repEmul_embed_leftinv;
      eauto using protect_closed, confine_closed, extractT, injectT, uvalApp_T with typing.
    + intros w' vs' vu' fw vr'.
      cbn.
      crushUtlcScoping.
      crushTyping.
      rewrite uvalApp_sub.
      cbn; crushUtlcScoping; crushTyping.
      rewrite ?protect_sub, ?confine_sub.
      rewrite ?inject_sub, ?extract_sub.
      rewrite ?(wsClosed_invariant (wt_implies_ws tvs)).
      rewrite ?(wsClosed_invariant closed_vu).

      assert (dir_world_prec n w' d p) as dwp' by eauto using dwp_mono.
      assert (termrel d w' (pEmulDV n p) (uvalApp n vs (S.app (inject n τ₁) vs')) (U.app vu (U.app (protect τ₁) vu'))) as uvalApp_tr.
      * eapply termrel_uvalApp; eauto using valrel_mono, valrel_in_termrel.
        intros w'' fw'.
        (* execute the inject/protect *)
        eapply termrel₀_in_termrel.
        eapply inj₁; eauto using valrel_mono, dwp_mono with arith.
      * eapply (termrel_ectx' uvalApp_tr); S.inferContext; U.inferContext;
        crush; eauto using extract_value, confine_Value with eval.

        intros w'' fw'' vs'' vu'' vr''.
        cbn.

        eapply termrel₀_in_termrel.
        eapply extr₂; eauto using valrel_mono, dwp_mono with arith.
Qed.

Lemma extract_tprod_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  (forall w' vs' vu', w' < w →
                      valrel d w' (pEmulDV n p) vs' vu' →
                      termrel₀ d w' (embed τ₁) (S.app (extract n τ₁) vs') (U.app (confine τ₁) vu')) →
  (forall w' vs' vu', w' < w →
                      valrel d w' (pEmulDV n p) vs' vu' →
                      termrel₀ d w' (embed τ₂) (S.app (extract n τ₂) vs') (U.app (confine τ₂) vu')) →
  termrel₀ d w (embed (tprod τ₁ τ₂)) (S.app (extract n (tprod τ₁ τ₂)) vs) (U.app (confine (tprod τ₁ τ₂)) vu).
Proof.
  intros dwp vr extr₁ extr₂.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  assert (0 + Nat.min 1 1 ≥ 1) as ineq by eauto with arith.

  eapply (termreli₀_antired 0 ineq).
  * (* beta-reduce *)
    eapply stepRel_step.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
    cbn. crushTyping. rewrite caseProdUp_sub. cbn. repeat crushStlcSyntaxMatchH.
    rewrite ?extract_sub; cbn.

    eapply stepRel_zero.

  * (* beta-reduce *)
    eapply stepRel_step.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
    cbn. repeat crushUtlcSyntaxMatchH. rewrite ?confine_sub.

    eapply stepRel_zero.
  * destruct w; try eapply termrel₀_zero.
    assert (w < S w) as fw by eauto with arith.

    (* execute proj₁s *)
    pose proof (termrel₀_extract_proj₁ dwp vr) as proj₁_tr.
    change w with (lateri 1 (S w)) in proj₁_tr.
    eapply (termreli₀_ectx' proj₁_tr); S.inferContext; U.inferContext; crush; unfold lev in *; eauto using extract_value, confine_Value with arith.

    (* continuation boilerplate *)
    intros vs₁' vu₁' vr₁'.
    rewrite U.pctx_cat_app; cbn.

    (* execute first extract/confine *)
    assert (dir_world_prec n w d p) as dwp' by eauto using dwp_mono.
    pose proof (extr₁ _ _ _ fw vr₁') as extract₁_tr.
    change w with (lateri 1 (S w)) in extract₁_tr.
    eapply (termreli₀_ectx' extract₁_tr); S.inferContext; U.inferContext; crush; unfold lev; eauto with arith.

    (* continuation boilerplate *)
    intros vs₁'' vu₁'' vr₁''.
    rewrite U.pctx_cat_app; cbn.
    destruct (valrel_implies_Value vr₁'').

    (* execute proj₂s *)
    pose proof (termrel₀_extract_proj₂ dwp vr) as proj₂_tr.
    change w with (lateri 1 (S w)) in proj₂_tr.
    eapply (termreli₀_ectx' proj₂_tr); S.inferContext; U.inferContext; crush; unfold lev in *; eauto using extract_value, confine_Value with arith.

    (* continuation boilerplate *)
    intros vs₂' vu₂' vr₂'.
    rewrite U.pctx_cat_app; cbn.

    (* execute first extract/confine *)
    pose proof (extr₂ _ _ _ fw vr₂') as extract₂_tr.
    change w with (lateri 1 (S w)) in extract₂_tr.
    eapply (termreli₀_ectx' extract₂_tr); S.inferContext; U.inferContext; crush; unfold lev; eauto with arith.

    (* continuation boilerplate *)
    intros vs₂'' vu₂'' vr₂''.
    rewrite U.pctx_cat_app; cbn.

    eapply valrel_in_termreli₀.
    eapply valrel_pair'; assumption.
Qed.

Lemma extract_tsum_works {n w d p τ₁ τ₂ vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  (forall w' vs' vu', w' < w →
                      valrel d w' (pEmulDV n p) vs' vu' →
                      termrel₀ d w' (embed τ₁) (S.app (extract n τ₁) vs') (U.app (confine τ₁) vu')) →
  (forall w' vs' vu', w' < w →
                      valrel d w' (pEmulDV n p) vs' vu' →
                      termrel₀ d w' (embed τ₂) (S.app (extract n τ₂) vs') (U.app (confine τ₂) vu')) →
  termrel₀ d w (embed (tsum τ₁ τ₂)) (S.app (extract n (tsum τ₁ τ₂)) vs) (U.app (confine (tsum τ₁ τ₂)) vu).
Proof.
  intros dwp vr extr₁ extr₂.
  destruct (valrel_implies_Value vr) as [vvs vvu].
  destruct (valrel_implies_OfType vr) as [[? tvs] [closed_vu ?]].

  rewrite ?confine_sub.

  assert (0 + Nat.min 1 1 ≥ 1) as ineq by eauto with arith.

  eapply (termreli₀_antired 0 ineq).
  - (* beta-reduce *)
    eapply stepRel_step.
    eapply (S.eval_ctx₀ S.phole); simpl;
    eauto using S.eval_beta.
    cbn. crushTyping. rewrite caseSumUp_sub. cbn. repeat crushStlcSyntaxMatchH.
    rewrite ?extract_sub; cbn.

    eapply stepRel_zero.

  - (* beta-reduce *)
    eapply stepRel_step.
    eapply U.eval₀_ctxeval.
    eapply U.eval_beta; eauto.
    cbn. repeat crushUtlcSyntaxMatchH. rewrite ?confine_sub.

    eapply stepRel_zero.
  - destruct w; try eapply termrel₀_zero.
    assert (w < S w) as fw by eauto with arith.
    eapply termreli₀_extract_ptsum; try eassumption.
    + intros vs₂ vu₂ vr₂.
      cbn. crush. rewrite confine_sub, extract_sub.

      assert (dir_world_prec n w d p) as dwp' by eauto using dwp_mono.
      pose proof (extr₁ _ _ _ fw vr₂) as extract_tr.
      change w with (lateri 1 (S w)) in extract_tr.
      eapply (termreli₀_ectx' extract_tr); S.inferContext; U.inferContext; crush; unfold lev; eauto with arith.

      intros vs₂' vu₂' vr₂'.
      cbn.
      eauto using valrel_in_termreli₀, valrel_inl'.
    + intros vs₃ vu₃ vr₃.
      cbn. crush. rewrite confine_sub, extract_sub.

      assert (dir_world_prec n w d p) as dwp' by eauto using dwp_mono.
      pose proof (extr₂ _ _ _ fw vr₃) as extract_tr.
      change w with (lateri 1 (S w)) in extract_tr.
      eapply (termreli₀_ectx' extract_tr); S.inferContext; U.inferContext; crush; unfold lev; eauto with arith.

      intros vs₃' vu₃' vr₃'.
      cbn.
      eauto using valrel_in_termreli₀, valrel_inr'.
Qed.

Lemma inject_and_protect_work {n w d p τ vs vu} :
  dir_world_prec n w d p →
  valrel d w (embed τ) vs vu →
  termrel₀ d w (pEmulDV n p) (S.app (inject n τ) vs) (U.app (protect τ) vu)
with extract_and_confine_work {n w d p τ vs vu} :
  dir_world_prec n w d p →
  valrel d w (pEmulDV n p) vs vu →
  termrel₀ d w (embed τ) (S.app (extract n τ) vs) (U.app (confine τ) vu).
Proof.
  - revert n w vs vu.
    induction τ;
      intros n w vs vu dwp vr;
      destruct (valrel_implies_OfType vr) as ((_ & tvs) & (closed_vu & _));
      destruct (valrel_implies_Value vr) as (vvs & vvu);
      simpl.
    + (* τ₁ ⇒ τ₂ *)
      eapply inject_tarr_works;
      eauto using dwp_mono.
    + (* tunit *)
      eapply inject_unit_works; now assumption.
    + (* tbool *)
      eapply inject_bool_works; now assumption.
    + (* tprod τ₁ τ₂ *)
      eapply inject_tprod_works;
      eauto using dwp_mono.
    + (* τ₁ ⊎ τ₂ *)
      eapply inject_tsum_works;
      eauto using dwp_mono.
  - (* extract *)
    revert n w vs vu.
    induction τ;
      intros n w vs vu dwp vr;
      destruct (valrel_implies_OfType vr) as ((_ & tvs) & (closed_vu & _));
      destruct (valrel_implies_Value vr) as (vvs & vvu);
      simpl.
    + (* τ₁ ⇒ τ₂ *)
      eapply extract_tarr_works;
      eauto using dwp_mono.
    + (* tunit *)
      eapply extract_tunit_works;
      eauto using dwp_mono.
    + (* tbool *)
      eapply extract_tbool_works;
      eauto using dwp_mono.
    + (* tprod τ₁ τ₂ *)
      eapply extract_tprod_works;
      eauto using dwp_mono.

    + (* τ₁ ⊎ τ₂ *)
      eapply extract_tsum_works;
      eauto using dwp_mono.
Qed.

Lemma inject_works_open {d n m τ ts tu Γ p} :
  dir_world_prec n m d p →
  ⟪ Γ ⊩ ts ⟦ d , m ⟧ tu : embed τ ⟫ →
  ⟪ Γ ⊩ S.app (inject n τ) ts ⟦ d , m ⟧ U.app (protect τ) tu : pEmulDV n p ⟫.
Proof.
  intros dwp lr.
  destruct lr as (? & ? & lr).
  unfold OpenLRCtxN; split; [|split].
  - crushTyping.
    rewrite repEmul_embed_leftinv.
    eauto using injectT.
  - crushUtlcScoping; eauto using protect_closed.
  - intros w wm γs γu envrel.
    specialize (lr w wm γs γu envrel).

    cbn; crushTyping; crushUtlcScoping.
    rewrite inject_sub, protect_sub.

    eapply (termrel_ectx' lr); S.inferContext; U.inferContext;
    crush; eauto using inject_value, protect_Value.

    intros w' fw vs vu vr.
    cbn.
    eapply termrel₀_in_termrel.
    eapply inject_and_protect_work; eauto using dwp_mono.
Qed.

Lemma extract_works_open {d n m τ ts tu Γ p} :
  dir_world_prec n m d p →
  ⟪ Γ ⊩ ts ⟦ d , m ⟧ tu : pEmulDV n p ⟫ →
  ⟪ Γ ⊩ S.app (extract n τ) ts ⟦ d , m ⟧ U.app (confine τ) tu : embed τ ⟫.
Proof.
  intros dwp lr.
  destruct lr as (? & ? & lr).
  unfold OpenLRCtxN; split; [|split].
  - crushTyping.
    rewrite repEmul_embed_leftinv.
    eauto using extractT.
  - crushUtlcScoping; eauto using confine_closed.
  - intros w wm γs γu envrel.
    specialize (lr w wm γs γu envrel).

    cbn; crushTyping; crushUtlcScoping.
    rewrite extract_sub, confine_sub.

    eapply (termrel_ectx' lr); S.inferContext; U.inferContext;
    crush; eauto using extract_value, confine_Value.

    intros w' fw vs vu vr.
    cbn.
    eapply termrel₀_in_termrel.
    eapply extract_and_confine_work.
    eauto using dwp_mono.
    assumption.
Qed.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
(*
 * The following code contains code derived from code original to the
 * stdpp project. That original code is
 *
 *	Copyright stdpp developers and contributors
 *
 * and used according to the following license.
 *
 *	SPDX-License-Identifier: BSD-3-Clause
 *
 * Original stdpp License:
 * https://gitlab.mpi-sws.org/iris/stdpp/-/blob/5415ad3003fd4b587a2189ddc2cc29c1bd9a9999/LICENSE
 *)

From elpi Require Import locker.
From bedrock.prelude Require Import base.

(** * Theory for [is_Some_proj]

[@stdpp.option.is_Some_proj A mx P] extracts the element of type [A]
from [mx] knowing that [mx] is not a [None].

The theory for [is_Some_proj] is simply [is_Some_proj_eq], which can
be used in combination with [Some_inj] to switch between [A] and [option A].
*)
Lemma is_Some_proj_eq {A : Type} {mx : option A} (P : is_Some mx) :
  mx = Some (is_Some_proj P).
Proof. rewrite /is_Some_proj. case_match; [done|by destruct P]. Qed.

(**
Haskell's [Data.Function.on]
(https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-Function.html#v:on).

Examples:
- Lift relation [R] by precomposing with function [f] (with [C := Prop].
  We provide theory specialized to this use-case.
*)
(* TODO: namespace, and move from [option]. This is only _used_ here.*)
Definition on {A B C} (R : B -> B -> C) (f : A -> B) (x y : A) : C :=
  R (f x) (f y).

(** Preorder properties lift through [on].
Only import locally when declaring specialized instances!
These instances can lead to divergence of setoid rewriting, so they're only
available when importing [on_props]. *)
Module on_props.
Section on_props.
  Context {A B : Type} {f : A -> B}.
  (* We use both [R] and [strict R] *)
  Implicit Type (R : relation B).

  (* We can safely make this global. *)
  #[global] Instance on_decidable `{!RelDecision R} : RelDecision (on R f).
  Proof. GUARD_TC. rewrite /on => ??. apply _. Defined.

  (** * Lift basic relation typeclasses from [RelationClasses] *)
  #[export] Instance on_reflexive `{!Reflexive R} : Reflexive (on R f).
  Proof. GUARD_TC. rewrite /on. by intros ?. Qed.
  #[export] Instance on_irreflexive `{!Irreflexive R} : Irreflexive (on R f).
  Proof. GUARD_TC. rewrite /on. by intros ??%irreflexivity. Qed.

  #[export] Instance on_symmetric `{!Symmetric R} : Symmetric (on R f).
  Proof. GUARD_TC. rewrite /on. by intros ?. Qed.
  #[export] Instance on_asymmetric `{!Asymmetric R} : Asymmetric (on R f).
  Proof. GUARD_TC. rewrite /on. intros ??. apply: asymmetry. Qed.

  #[export] Instance on_transitive `{!Transitive R} : Transitive (on R f).
  Proof. GUARD_TC. rewrite /on. by intros ???; etrans. Qed.

  (** * Lift bundled relation typeclasses from [RelationClasses] *)
  #[export] Instance on_equivalence `{!Equivalence R} : Equivalence (on R f).
  Proof. GUARD_TC. split; apply _. Qed.
  #[export] Instance on_preorder `{!PreOrder R} : PreOrder (on R f).
  Proof. GUARD_TC. split; apply _. Qed.
  #[export] Instance on_per `{!RelationClasses.PER R} : RelationClasses.PER (on R f).
  Proof. GUARD_TC. split; apply _. Qed.
  #[export] Instance on_strict_order `{!StrictOrder R} : StrictOrder (on R f).
  Proof. GUARD_TC. split; apply _. Qed.

  (** * Lift basic relation typeclasses from [stdpp.base] *)
  #[export] Instance on_antisymm
      (S : relation B) `{!AntiSymm S R} :
    AntiSymm (on S f) (on R f) | 100.
  Proof. GUARD_TC. rewrite /on. intros ??. apply: anti_symm. Qed.

  (** Needed to lift [PartialOrder] *)
  #[export] Instance on_antisymm_eq_inj
      `{!AntiSymm (=) R} `{!Inj eq eq f} :
    AntiSymm (=) (on R f).
  Proof. GUARD_TC. rewrite /on. intros ????. apply (inj f). exact: anti_symm. Qed.

  (** Needed to lift [TotalOrder] *)
  #[export] Instance on_trichotomy
      `{!Trichotomy R} `{!Inj eq eq f} :
    Trichotomy (on R f).
  Proof. GUARD_TC. rewrite /on. intros ??. rewrite -(inj_iff f). apply: trichotomy. Qed.

  #[export, refine] Instance on_trichotomyT
      `{!TrichotomyT R} `{!Inj eq eq f} :
    TrichotomyT (on R f) := fun x y =>
      match trichotomyT R (f x) (f y) with
      | inleft (left H) => inleft (left H)
      | inleft (right H) => inleft (right _)
      | inright H => inright H
      end.
  Proof. abstract (apply (inj f _ _ H)). Defined.

  (** * Lift bundled relation typeclasses from [stdpp.base] *)
  #[export] Instance on_partial_order `{!PartialOrder R} `{!Inj eq eq f} : PartialOrder (on R f).
  Proof. GUARD_TC. split; apply _. Qed.

  #[export] Instance on_total_order `{!TotalOrder R} `{!Inj eq eq f} : TotalOrder (on R f).
  Proof. GUARD_TC. split; rewrite -?[strict (on R f)]/(on (strict R) f); apply _. Qed.
End on_props.
End on_props.
#[global] Typeclasses Opaque on.

mlock Definition some_Forall2 {A} (R : relation A) (oa1 oa2 : option A) :=
  is_Some oa1 ∧ is_Some oa2 ∧ option_Forall2 R oa1 oa2.
#[global] Arguments some_Forall2 {A} _ _ _ : assert.
(* ^^ Necessary to workaround [mlock] bugs. *)

Section some_Forall2.
  Context `{R : relation A}.

  (* #[global] Instance some_Forall2_reflexive `{!Reflexive R}: Reflexive (some_Forall2 R).
  Proof. rewrite some_Forall2.unlock. intros ?. Qed. *)
  #[global] Instance some_Forall2_symmetric `{!Symmetric R}: Symmetric (some_Forall2 R).
  Proof. GUARD_TC. rewrite some_Forall2.unlock. intros ?; naive_solver. Qed.
  #[global] Instance some_Forall2_transitive `{!Transitive R}: Transitive (some_Forall2 R).
  Proof. GUARD_TC. rewrite some_Forall2.unlock. intros ?; intuition idtac. by etrans. Qed.
  #[global] Instance some_Forall2_per `{!RelationClasses.PER R} : RelationClasses.PER (some_Forall2 R).
  Proof. GUARD_TC. split; apply _. Qed.

  Lemma some_Forall2_iff oa1 oa2 :
    some_Forall2 R oa1 oa2 ↔
    ∃ (a1 a2 : A), oa1 = Some a1 ∧ oa2 = Some a2 ∧ R a1 a2.
  Proof.
    rewrite some_Forall2.unlock; split.
    { destruct 1 as ([??] & [??] & Hop); inversion Hop; naive_solver. }
    destruct 1 as (? & ? & -> & -> & ?); split_and!; by econstructor.
  Qed.

  #[global, refine] Instance option_Forall2_decision
      `{EqDecision A} `{!RelDecision R} :
    RelDecision (option_Forall2 R) :=
    fun oa1 oa2 =>
      match oa1, oa2 with
      | None, None => left _
      | Some a1, Some a2 => cast_if (decide (R a1 a2))
      | _, _ => right _
      end.
  Proof.
    all: abstract (intros; by [inversion_clear 1 | constructor]).
  Defined.

  #[global, refine] Instance some_Forall2_decision `{EqDecision A} `{!RelDecision R} :
    RelDecision (some_Forall2 R) :=
    λ oa1 oa2, cast_if (decide (is_Some oa1 ∧ is_Some oa2 ∧ option_Forall2 R oa1 oa2)).
  Proof. all: abstract (by rewrite some_Forall2.unlock). Defined.
End some_Forall2.

Section some_Forall2_eq.
  Context {A : Type}.

  Lemma some_Forall2_eq_iff (oa1 oa2 : option A) :
    some_Forall2 eq oa1 oa2 ↔
    ∃ (a : A), oa1 = Some a ∧ oa2 = Some a.
  Proof. rewrite some_Forall2_iff; naive_solver. Qed.
End some_Forall2_eq.

(** ** Define a partial equivalence relation from an observation *)
Definition same_property `(obs : A → option B) :=
  on (some_Forall2 eq) obs.
Section same_property.
  Context `{obs : A → option B}.

  (* Lift [#[global]] and [#[export]] instances from [on_props] before making it
  opaque. *)
  #[global] Instance same_property_decision `{EqDecision B} :
    RelDecision (same_property obs) := _.

  Section with_on_props.
    Import on_props.
    #[global] Instance same_property_per : RelationClasses.PER (same_property obs) := _.
  End with_on_props.

  #[global] Typeclasses Opaque same_property.

  #[global] Instance: RewriteRelation (same_property obs) := {}.

  Lemma same_property_iff a1 a2 :
    same_property obs a1 a2 ↔
    ∃ (b : B), obs a1 = Some b ∧ obs a2 = Some b.
  Proof. by rewrite /same_property /on some_Forall2_eq_iff. Qed.

  Lemma same_property_intro a1 a2 b :
    obs a1 = Some b -> obs a2 = Some b -> same_property obs a1 a2.
  Proof. rewrite same_property_iff. eauto. Qed.

  Lemma same_property_reflexive_equiv a :
    is_Some (obs a) ↔ same_property obs a a.
  Proof. rewrite same_property_iff /is_Some. naive_solver. Qed.

  Lemma same_property_partial_reflexive a b :
    obs a = Some b → same_property obs a a.
  Proof. rewrite -same_property_reflexive_equiv. naive_solver. Qed.
End same_property.

Section add_opt.
  Definition add_opt (oz1 oz2 : option Z) : option Z := liftM2 Z.add oz1 oz2.
  #[global] Instance add_opt_inj a : Inj eq eq (add_opt (Some a)).
  Proof.
    rewrite /add_opt => -[b1|] [b2|] // [?]. f_equal. lia.
  Qed.
End add_opt.

Lemma option_list_nil {A} (x : option A) : option_list x = [] -> x = None.
Proof. case: x => //=. Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal49.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_theorem0_155_mem_insort/goal49_lfind_orig.ml"  adtind.goal49.insort adtind.goal49.sort Coq.Init.Datatypes.orb adtind.goal49.eqb adtind.goal49.mem.
Success.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** * Canonical Forms *)
(** This module proves the Canonical Forms Lemmas, which allow us
    to retrieve the shape of a value given its type. *)

Set Implicit Arguments.

Require Import Coq.Program.Equality List String.
Require Import Binding Definitions GeneralToTight InvertibleTyping Lookup Narrowing
        PreciseTyping Replacement ReplacementTyping RecordAndInertTypes Substitution
        Subenvironments TightTyping Weakening.
Require Import Sequences.

(** Converting a stable term to a general term *)
Definition deftrm t : trm :=
  match t with
  | defp p => trm_path p
  | defv v => trm_val v
  end.

(** ** Type preservation for path lookup *)

(** If the record [{a = t}] has type [{a: V}] then [t] is either
    - a function that has type [V],
    - an object [ν(U)ds] that has type [μ(U)], and [V=μ(U)], or
    - a well-typed path [q], and [V=q.type] *)
Lemma object_typing G x bs ds T a t V :
  inert G ->
  x; bs; G ⊢ ds :: T ->
  defs_has ds {a := t} ->
  record_has T {a ⦂ V} ->
  (exists U u, t = defv (λ(U) u) /\ G ⊢ deftrm t : V) \/
  (exists U ds', t = defv (ν(U) ds') /\
            x; (a :: bs); G ⊢ open_defs_p (p_sel (avar_f x) (a :: bs)) ds' ::
                                 open_typ_p (p_sel (avar_f x) (a :: bs)) U /\
            V = μ U) \/
  (exists q S, t = defp q /\ V = {{ q }} /\ G ⊢ trm_path q : S).
Proof.
  intros Hi Hds Hdh Hr.
  destruct (record_has_ty_defs Hds Hr) as [? [Hdh' Hdt]].
  destruct (defs_invert_trm Hdt) as [t' ->].
  pose proof (defs_has_inv Hdh Hdh') as <-. destruct t as [q | v]; simpl in *.
  - inversion* Hdt.
  - destruct v.
    * right. left. inversions Hdt.
      simpl in *. repeat eexists; auto.
    * left. inversions Hdt. eauto.
Qed.

(** If [p] looks up to [t] in a value environment, [p]'s environment type
    is [T] and [p]'s precise type is [U], then either [t] is
    - a function that has type [T],
    - an object [ν(S)ds] that has type [μ(S)], and [T] and [μ(s)] are equivalent, or
    - a well-typed path [q], and [T] is equivalent to [q.type] *)
Lemma lookup_step_preservation_prec1: forall G γ p px pbs t T U,
    inert G ->
    wf G ->
    γ ⫶ G ->
    γ ⟦ p ⤳ t ⟧ ->
    G ⊢! p : T ⪼ U ->
    p = p_sel (avar_f px) pbs ->
    (exists S u, t = defv (λ(S) u) /\ G ⊢ deftrm t : T) \/
    (exists S ds W T' G1 G2 pT,
        t = defv (ν(S) ds) /\
        T = μ T' /\
        G = G1 & px ~ pT & G2 /\
        px ; pbs; G ⊢ open_defs_p p ds :: open_typ_p p S /\
        G1 ⊩ S ⟿ W ⬳ T') \/
    (exists q r r' G1 G2 pT,
        t = defp q /\
        T = {{ r }} /\
        G = G1 & px ~ pT & G2 /\
        (r = r' \/ G1 ⊢!!! r : {{ r' }}) /\ (q = r' \/ G1 ⊢!!! q : {{ r' }})).
Proof.
  introv Hi Hwf Hwt. gen p px pbs t T U.
  (* induction on well-formedness **)
  induction Hwt; introv Hs Hp Heq.
  - Case "G is empty"%string.
    false* lookup_empty.
  - Case "G is not empty"%string.
    pose proof (typed_paths_named (precise_to_general Hp)) as [px' [bs ->]].
    destruct (classicT (x = px')) as [-> | Hn].
    * SCase "x = px"%string.
      (* induction on ⟦⤳⟧ **)
      gen T U T0 px pbs.
      dependent induction Hs; introv Hwf Hi Hv; introv Hp; introv [= -> <-];
        try simpl_dot; try rewrite proj_rewrite in *.
      + SSCase "lookup_var"%string.
        apply binds_push_eq_inv in H1 as ->.
        lets Hb: (pf_binds Hi Hp). pose proof (binds_push_eq_inv Hb) as ->.
        apply binds_inert in Hb; auto.
        destruct v as [S ds | S u].
        ++ (* v is an object *)
           right. left.
           lets Hi': (inert_prefix Hi). lets Hwf': (wf_prefix Hwf).
           inversions Hb; proof_recipe. { inversion Hvpr. }
           inversions Hv. pick_fresh z. assert (z \notin L) as Hz by auto.
           apply H4 in Hz. repeat eexists.
           +++ rewrite concat_empty_r. eauto.
           +++ apply open_env_last_defs; auto.
               apply narrow_defs with (G:=G & px ~ open_typ px S). {
                 assert (open_defs_p (p_sel (avar_f px) nil) ds = open_defs px ds) as -> by rewrite* open_var_defs_eq.
                 assert (open_typ_p (p_sel (avar_f px) nil) S = open_typ px S) as -> by rewrite* open_var_typ_eq.
                 apply rename_defs with (x := z); auto.
               }
               apply subenv_last; auto. apply (repl_composition_open (pvar px)) in Hrc.
               eapply (repl_composition_open (pvar px)) in Hrc'.
               apply subtyp_trans with (T:=open_typ px U');
                 apply repl_composition_sub in Hrc'; apply repl_composition_sub in Hrc; destruct_all;
                   repeat rewrite open_var_typ_eq in *; auto. all: auto.
           +++ eauto.
           +++ eauto.
        ++ (* v is a function *) left. repeat eexists. apply* weaken_ty_trm.
      + SSCase "lookup_sel_p"%string.
        destruct (pf_path_sel _ _ Hi Hp) as [V Hp'].
        specialize (IHHs _ _ _ Hwt IHHwt _ H0 H JMeq_refl eq_refl _ Hwf Hi Hv _ _ Hp' _ _ eq_refl)
          as [[? [? [[=] ?]]] |
              [[? [? [? [? [? [? [? [[=]]]]]]]]] |
               [? [? [? [? [? [? [[= ->] [[=] ?]]]]]]]]]].
      + SSCase "lookup_sel_v"%string.
        destruct (pf_path_sel _ _ Hi Hp) as [V Hp'].
        specialize (IHHs _ _ _ Hwt IHHwt _ H0 H JMeq_refl eq_refl _ Hwf Hi Hv _ _ Hp' _ _ eq_refl)
          as [[? [? [[=] ?]]] |
              [[S [ds' [W [T'' [G1 [G2 [pT [[= -> ->] [[= ->] [Heq [Hds Hrc]]]]]]]]]]] |
               [? [? [? [? [? [? [[= ->] [-> [[= ->] ?]]]]]]]]]]].
        lets H': (defs_has_open (p_sel (avar_f px) f) H1). simpl in *.
        lets Hr: (pf_record_has_U Hi Hp').
        rewrite Heq in Hi, Hwf.
        pose proof (repl_comp_trans_open (p_sel (avar_f px) f)
                                         (inert_prefix (inert_prefix Hi))
                                         Hrc) as Hrc_op.
        pose proof (repl_comp_trans_record_has Hrc_op Hr) as [V [W' [Hrh [Hrc1' Hrc2']]]].
        rewrite <- concat_empty_r in Heq at 1.
        assert (G2 = empty) as ->. {
          eapply env_ok_inv. eauto. rewrite concat_empty_r. rewrite <- Heq, concat_empty_r in Hi. auto.
        }
        repeat rewrite concat_empty_r in *. apply eq_push_inv in Heq as [_ [<- <-]].
        assert (G & px ~ T0 ⊢ V <: T1 /\ G & px ~ T0 ⊢ T1 <: V) as [HVT HTV]. {
          apply repl_composition_sub in Hrc2'. apply repl_composition_sub in Hrc1'.
          destruct_all.
          split; apply weaken_subtyp; eauto.
        }
        destruct (object_typing Hi Hds H' Hrh) as [[U' [u [Heq Ht']]] |
                                                   [[U' [ds'' [Heq [Hds'' ->]]]] | [q [V' [Heq1 [-> Hq]]]]]].
        ++ destruct t; inversions Heq. destruct v0; inversions H3.
           left. repeat eexists. eauto.
        ++ destruct t as [|]; inversions Heq. destruct v0 as [X ds |]; inversions H3. fold open_rec_defs_p in Hds''.
           right. left.
           pose proof (repl_comp_bnd_inv1 Hrc1') as [Y ->]. pose proof (repl_comp_bnd_inv2 Hrc2') as [Z ->].
           repeat eexists; eauto.
           +++ apply repl_comp_bnd' in Hrc1'. rewrite concat_empty_r. eauto.
           +++ apply repl_comp_bnd' in Hrc1'. apply Hrc1'.
           +++ apply* repl_comp_bnd'.
        ++ destruct t; inversions Heq1. right. right.
           pose proof (repl_comp_sngl_inv1 Hrc1') as [r ->]. pose proof (repl_comp_sngl_inv2 Hrc2') as [r' ->].
           pose proof (pf_sngl_U Hp) as ->.
           pose proof (sngl_typed Hi Hwf Hp) as [V Hr'%pt3].
           pose proof (pt3_exists Hi Hq) as [V'' Hp3].
           pose proof (repl_comp_to_prec' Hi Hwf Hrc2' Hr')
             as [-> | Hpr];
             pose proof (repl_comp_to_prec' Hi Hwf Hrc1' Hp3)
             as [<- | Hpr']; clear Hrc1' Hrc2';
               repeat eexists; try rewrite concat_empty_r; eauto.
    * SCase "x <> x0"%string.
      apply pf_strengthen in Hp; auto. apply lookup_strengthen_one in Hs; auto.
      inversions Heq.
      specialize (IHHwt (inert_prefix Hi) (wf_prefix Hwf) _ _ _ _ _ _ Hs Hp eq_refl)
        as [[? [? [[= ->]]]] |
              [[? [? [? [? [? [? [? [-> [-> [-> [Hds [? ?]]]]]]]]]]]] |
               [? [? [? [? [? [? [[= ->] [[= ->] [-> [? ?]]]]]]]]]]]].
      + left. repeat eexists. apply* weaken_ty_trm.
      + right. left. repeat eexists. rewrite concat_assoc. eauto.
        apply* weaken_ty_defs. all: eauto.
      + right. right. repeat eexists. rewrite concat_assoc. all: eauto.
  Unshelve. all: solve_ex_typ_L.
Qed.

(** If [p] looks up to [t] in a value environment and [p]'s II-level precise type
    is [T], then either [t] is
    - a function that has type [T], and [T] is [p]'s precise type,
    - an object [ν(S)ds] that has type [μ(S)], and [T] and [μ(s)] are equivalent, or
    - a well-typed path [q], and [T] is equivalent to [q.type] *)
Lemma lookup_step_preservation_prec2 G γ p px pbs t T :
    inert G ->
    wf G ->
    γ ⫶ G ->
    γ ⟦ p ⤳ t ⟧ ->
    G ⊢!! p : T ->
    p = p_sel (avar_f px) pbs ->
    (exists S U u, t = defv (λ(S) u) /\ G ⊢ deftrm t : U /\ G ⊢! p : U ⪼ T) \/
    (exists S ds W U G1 G2 pT,
        t = defv (ν(S) ds) /\
        G ⊢! p : μ U ⪼ T /\
        G = G1 & px ~ pT & G2 /\
        px ; pbs; G ⊢ open_defs_p p ds :: open_typ_p p S /\
        G1 ⊩ S ⟿ W ⬳ U) \/
    (exists q r r' G1 G2 pT,
        t = defp q /\
        T = {{ r }} /\
        G = G1 & px ~ pT & G2 /\
        (r = r' \/ G1 ⊢!!! r : {{ r' }}) /\ (r' = q \/ G1 ⊢!!! q : {{ r' }})).
Proof.
  introv Hi Hwf Hwt Hs Hp Heq. gen γ t px pbs. induction Hp; introv Hwt; introv Hs; introv Heq.
  - destruct (lookup_step_preservation_prec1 Hi Hwf Hwt Hs H Heq)
      as [[? [? [[= ->]]]] |
          [[S [ds' [W [T'' [G1 [G2 [pT [-> [-> [-> [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
           [? [? [? [? [? [? [-> [-> [-> [? ?]]]]]]]]]]]].
    * left. repeat eexists; eauto.
    * right. left. repeat eexists; eauto.
    * pose proof (pf_sngl_U H) as ->. right. right. repeat eexists; eauto.
      destruct_all; eauto.
  - clear IHHp2. simpl_dot. specialize (IHHp1 Hi Hwf _ Hwt).
    gen q U. dependent induction Hs; simpl_dot; introv Hp IHHp1 Hv.
    * specialize (IHHp1 _ Hs _ _ eq_refl) as [[? [? [? [[=] ?]]]] |
                                  [[? [? [? [? [? [? [? [[=] ?]]]]]]]] |
                                   [q' [r [r' [G1 [G2 [pT [[= <-] [[= ->] [-> [Hrc1 Hrc2]]]]]]]]]]]].
      right. right. exists (q • a) (r • a).
      pose proof (inert_prefix (inert_prefix Hi)) as Hi'.
      pose proof (wf_prefix (wf_prefix Hwf)) as Hwf'.
      destruct Hrc1 as [-> | Hr1]; destruct Hrc2 as [-> | Hr2].
      ** repeat eexists; eauto.
      ** repeat eexists; eauto. right. apply* pt3_field_elim_p.
         apply* pt3_trans2.
         pose proof (sngl_typed3 Hi' Hwf' Hr2) as [_ [T Ht]%pt2_exists].
         constructor. rewrite <- concat_assoc in *. apply* pt2_fld_strengthen.
      ** repeat eexists. right. apply* pt3_field_elim_p.
         rewrite <- concat_assoc in *. apply* pt3_fld_strengthen.
         left*.
      ** pose proof (field_elim_q3) as Hf.
         rewrite <- concat_assoc in *.
         pose proof (pt3_weaken (inert_ok Hi) Hr1).
         specialize (Hf _ _ _ _ _ Hi H (pt3 Hv)) as [S Ht].
         repeat eexists. rewrite* concat_assoc.
         right. apply* pt3_field_elim_p.
         apply* pt3_fld_strengthen.
         right. apply* pt3_field_elim_p. apply* pt3_fld_strengthen.
         eapply pt3_trans2. eapply pt3_weaken. apply* inert_ok. apply Hr2.
         eapply pt3_weaken in Hr1. apply Ht. apply* inert_ok.
    * specialize (IHHp1 _ Hs) as [[? [? [? [[= ->] ?]]]] |
                                  [[? [? [? [? [? [? [? [? [[=]%pf_sngl_T [[=] [HH [HHH ?]]]]]]]]]]]] |
                                   [? [? [? [? [? [? [[=] ?]]]]]]]]]; auto.
Qed.

(** If [p] looks up to [t] in a value environment and [p]'s III-level precise type
    is an _inert_ type [T], then either [t] is
    - a function that has type [T],
    - an object [ν(S)ds] that has type [μ(S)], and [T] and [μ(s)] are equivalent, or
    - a well-typed path [q], and [q]'s type is [T] *)
Lemma lookup_step_preservation_inert_prec3: forall G γ p T t,
    inert G ->
    wf G ->
    γ ⫶ G ->
    γ ⟦ p ⤳ t ⟧ ->
    G ⊢!!! p : T ->
    inert_typ T ->
    (exists S U, T = ∀(S) U /\ G ⊢ deftrm t : ∀(S) U) \/
    (exists U, T = μ U /\
          ((exists S ds px pbs W, t = defv (ν(S) ds) /\
                               p = p_sel (avar_f px) pbs /\
                               px; pbs; G ⊢ open_defs_p p ds :: open_typ_p p S /\
                               G ⊩ S ⟿ W ⬳ U) \/
           (exists q, t = defp q /\ G ⊢!!! q : T))).
Proof.
  introv Hi Hwf Hwt Hs Hp. gen t.
  pose proof (typed_paths_named (precise_to_general3 Hp)) as [px [pbs Heq]].
  dependent induction Hp; introv Hs Hit;
    destruct (lookup_step_preservation_prec2 Hi Hwf Hwt Hs H Heq)
                                as [[S' [U [u [[= ->] [Hv Hp']]]]] |
                                    [[S' [ds [W [U [G1 [G2 [pT [[= ->] [Hp' [-> [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
                                     [q' [r [r' [G1 [G2 [pT [[= ->] [[= ->] [Heq' [Hrc1 Hrc2]]]]]]]]]]]]; simpl.
  - left. simpl in *. inversions Hit.
    * apply (pf_forall_T Hi) in Hp' as ->. repeat eexists; eauto.
    * apply (pf_bnd_T Hi) in Hp' as ->. proof_recipe. inversion Hv.
  - right. inversions Hit.
    * apply (pf_forall_T Hi) in Hp' as [=].
    * apply (pf_bnd_T Hi) in Hp' as [= ->]. eexists. split*. left. repeat eexists; eauto;
      repeat apply* repl_composition_weaken; apply* inert_ok; apply* inert_prefix.
  - inversion Hit.
  - apply pf_sngl_T in Hp' as ->; auto. proof_recipe. inversions Hv. inversions H0. inversion H1.
  - apply (pf_sngl_T Hi) in Hp' as [=].
  - clear IHHp.
    assert (exists V, G ⊢!!! q' : V) as [V Hq']. {
      destruct Hrc1 as [-> | Hr]; destruct Hrc2 as [-> | Hr']; subst; rewrite <- concat_assoc in *; eauto.
      - eexists. apply* pt3_weaken.
      - apply sngl_typed3 in Hr as [S Ht]. eexists. apply* pt3_weaken. apply* inert_prefix. apply* wf_prefix.
      - eexists. apply* pt3_weaken.
    }
    lets Hok: (inert_ok Hi). rewrite Heq' in Hok.
    destruct Hrc1 as [-> | Hr]; destruct Hrc2 as [-> | Hr']; inversions Hit.
    + left; repeat eexists; apply* precise_to_general3.
    + right. eexists. split*.
    + left. repeat eexists. apply* precise_to_general3. apply* pt3_sngl_trans3.
      repeat apply* pt3_weaken.
    + right. eexists. split*. right. eexists. split*.
      apply* pt3_sngl_trans3. repeat apply* pt3_weaken.
    + left. repeat eexists.
      do 2 eapply pt3_weaken in Hr.
      pose proof (pt3_inert_sngl_invert Hi Hp Hr (inert_typ_all _ _)) as Hr'.
      apply* precise_to_general3. all: eauto; apply* inert_ok. apply* inert_prefix.
    + right. eexists. split*. right. eexists. split*.
      do 2 eapply pt3_weaken in Hr.
      apply* (pt3_inert_sngl_invert Hi Hp Hr).
      all: eauto; apply* inert_ok. apply* inert_prefix.
    + left. repeat eexists. apply precise_to_general3.
      eapply pt3_sngl_trans3. repeat apply* pt3_weaken.
      apply* pt3_inert_sngl_invert. repeat apply* pt3_weaken.
    + right. eexists. split*. right. eexists. split*.
      eapply pt3_sngl_trans3. repeat apply* pt3_weaken.
      apply* pt3_inert_sngl_invert. repeat apply* pt3_weaken.
Qed.

(** If [p] looks up to [t] in a value environment and [p]'s III-level precise type
    is a function type, then [t] has the same function type *)
Lemma lookup_step_preservation_prec3_fun G γ p T S t :
  inert G ->
  wf G ->
  γ ⫶ G ->
  γ ⟦ p ⤳ t ⟧ ->
  G ⊢!!! p : ∀(T) S ->
  G ⊢ deftrm t : ∀(T) S.
Proof.
  intros Hi Hwf Hwt Hs Hp.
  destruct (lookup_step_preservation_inert_prec3 Hi Hwf Hwt Hs Hp) as
      [[? [? [-> Ht]]] | [? [[=] ?]]]; auto.
Qed.

(** The following two lemmas are needed only for path safety (not for term safety) *)

(** If a well-typed path [p] looks up to a path [q] then [q] is also well-typed. *)
Lemma lookup_step_pres G p T q γ :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!! p : T ->
  γ ⟦ p ⤳ defp q ⟧ ->
  exists U, G ⊢!!! q : U.
Proof.
  intros Hi Hwf Hwt Hp Hl.
  apply pt2_exists in Hp as [U Hp].
  pose proof (named_lookup_step Hl) as [x [bs Heq]].
  pose proof (lookup_step_preservation_prec2 Hi Hwf Hwt Hl Hp Heq)
    as [[? [? [? [[=] ?]]]] |
        [[? [? [? [? [? [? [? [[=] ?]]]]]]]] |
         [r' [r [G1 [G2 [pT [S [[= ->] [-> [-> [[-> | Hr] [-> | Hr']]]]]]]]]]]]].
  - apply sngl_typed2 in Hp as [U Hr]; eauto.
  - eexists. do 2 apply* pt3_weaken. apply inert_ok in Hi.
    apply* ok_concat_inv_l.
  - apply sngl_typed3 in Hr as [U Hr]; eauto.
    eexists. do 2 apply* pt3_weaken. apply inert_ok in Hi.
    apply* ok_concat_inv_l. do 2 apply* inert_prefix.
  - eexists. do 2 apply* pt3_weaken. apply inert_ok in Hi.
    apply* ok_concat_inv_l.
Qed.

(** If a well-typed path [p] looks up to a path [q] in a finite number
    of steps then [q] is also well-typed.*)
Lemma lookup_pres G p T q γ :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!! p : T ->
  γ ⟦ defp p ⤳* defp q ⟧ ->
  exists U, G ⊢!!! q : U.
Proof.
  intros Hi Hwf Hwt Hp Hl. gen T. dependent induction Hl; introv Hp; eauto.
  destruct b.
  - pose proof (lookup_step_pres Hi Hwf Hwt Hp H) as [U Hq]. eauto.
  - apply lookup_val_inv in Hl as [=].
Qed.

(** If a stable term [t] has a function type and [t] can be looked
    up to [u] in a finite number of steps in the value environment,
    then [u] has the same function type. *)
Lemma lookup_preservation_forall : forall G γ t u T S,
    inert G ->
    wf G ->
    γ ⫶ G ->
    γ ⟦ t ⤳* u ⟧ ->
    G ⊢ deftrm t : ∀(S) T ->
    G ⊢ deftrm u: ∀(S) T.
Proof.
  introv Hi Hwf Hwt Hl Hp. dependent induction Hl; auto.
  assert (exists q, a = defp q) as [q ->] by (inversions H; eauto).
  proof_recipe.
  pose proof (lookup_step_preservation_prec3_fun Hi Hwf Hwt H Hpr) as Hb.
  apply IHHl.
  apply ty_sub with (T:=∀(Spr) Tpr); auto; fresh_constructor; apply* tight_to_general.
Qed.

(** ** Looking up well-typed paths *)
(** If a path has a precise type then it can be looked up in the value environment *)
Lemma typ_to_lookup1 G γ p T U :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢! p : T ⪼ U ->
  exists t, γ ⟦ p ⤳ t ⟧.
Proof.
  intros Hi Hwf Hwt Hp. gen p T U. induction Hwt; introv Hp.
  (* induction on ⟦~⟧ **)
  - false. dependent induction Hp; eauto. apply* binds_empty_inv.
  - pose proof (typed_paths_named (precise_to_general Hp)) as [y [bs ->]].
    (* later when we figure out how to make env closed *)
    destruct (classicT (x = y)) as [-> | Hn].
    * SCase "x = y"%string.
      (* induction on ⟦⊢!⟧ **)
      dependent induction Hp; try simpl_dot.
      + eexists. apply* lookup_var.
      + specialize (IHHp _ _ H0 _ _ Hwf Hi Hwt H H1 IHHwt JMeq_refl eq_refl) as [t Hs].
        pose proof (pf_bnd_T2 Hi Hp) as [V ->].
        destruct (lookup_step_preservation_prec1 Hi Hwf (well_typed_push Hwt H H0 H1) Hs Hp eq_refl)
          as [[S [u [-> Ht]]] |
              [[S [ds' [W [T'' [G1 [G2 [pT [-> [[= ->] [Heq [Hds Hrc]]]]]]]]]]] |
               [? [? [? [? [? [? [? [[=] [? ?]]]]]]]]]]].
        ++ proof_recipe. inversion Ht.
        ++ assert (exists u, defs_has ds' {a := u}) as [u Hu]. {
             apply pf_record_has_U in Hp; auto.
             eapply repl_comp_trans_open in Hrc.
             eapply repl_comp_trans_record_has in Hrc as [V [X [Hr _]]]; try apply Hp.
             eapply record_has_ty_defs in Hds as [d [Hdh Hds]]; eauto.
             eapply defs_invert_trm in Hds as [t ->]. unfold defs_has in *.
             simpl in *. apply* defs_has_open'. rewrite  Heq in Hi, Hwf.
             repeat apply* inert_prefix.
           }
           eexists. rewrite proj_rewrite. eauto.
      + eauto.
      + eauto.
      + eauto.
    * SCase "x <> y"%string.
      apply pf_strengthen in Hp; auto. specialize (IHHwt (inert_prefix Hi) (wf_prefix Hwf) _ _ _ Hp) as [t Hs].
      eexists. apply* lookup_step_weaken_one.
Qed.

(** If a path has a II-level precise type then it can be looked up in the value environment *)
Lemma typ_to_lookup2 G γ p T :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!! p : T ->
  exists t, γ ⟦ p ⤳ t ⟧.
Proof.
  intros Hi Hwf Hwt Hp. induction Hp.
  - apply* typ_to_lookup1.
  - specialize (IHHp1 Hi Hwf Hwt) as [u1 Hs1]. specialize (IHHp2 Hi Hwf Hwt) as [u2 Hs2].
    pose proof (typed_paths_named (precise_to_general2 Hp1)) as [px [pbs ->]].
    destruct (lookup_step_preservation_prec2 Hi Hwf Hwt Hs1 Hp1 eq_refl)
                                as [[S' [U' [u [[= ->] [Hv Hp']]]]] |
                                    [[S' [ds [W [U' [G1 [G2 [pT [-> [Hp' [Heq [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
                                     [? [? [? [? [? [? [-> [[= ->] ?]]]]]]]]]].
    + pose proof (pf_sngl_T Hi Hp') as ->. proof_recipe. inversions Hv. inversions H. inversions H0.
    + pose proof (pf_sngl_T Hi Hp') as [=].
    + eauto.
Qed.

(** If a path has a III-level precise type then it can be looked up
    in the value environment *)
Lemma typ_to_lookup3 G γ p T :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!!p : T ->
  exists t, γ ⟦ p ⤳ t ⟧.
Proof.
  intros Hi Hwf Hwt Hp. induction Hp; apply* typ_to_lookup2.
Qed.

(** If a path [p]'s environment type is a singleton type [q.type]
    then [p] can be looked up to a path [r] in the value environment,
    and either [q=r], or there exists a path [r'] such that
    both [r'] is the III-level precise type of both [q] and [r].
    In other words, [q] and [r] are aliases of the same path [r']. *)
Lemma sngl_path_lookup G γ p q U :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢! p : {{ q }} ⪼ U ->
           exists r r', γ ⟦ p ⤳ defp r ⟧ /\
                   (r = r' \/ G ⊢!!! r : {{ r' }}) /\
                   (q = r' \/ G ⊢!!! q : {{ r' }}).
Proof.
  intros Hi Hwf Hwt Hp. destruct (typ_to_lookup1 Hi Hwf Hwt Hp) as [t Hs].
  pose proof (typed_paths_named (precise_to_general Hp)) as [px [pbs ->]].
  destruct (lookup_step_preservation_prec1 Hi Hwf Hwt Hs Hp eq_refl)
           as [[S [u [-> Ht]]] |
              [[S [ds' [W [T'' [G1 [G2 [pT [-> [[= ->] ?]]]]]]]]] |
               [? [? [? [G1 [G2 [pT [-> [[= -> ] [-> [Hrc1 Hrc2]]]]]]]]]]]].
  - proof_recipe. inversions Ht. inversions H. inversion H0.
  - pose proof (inert_ok Hi) as Hok%ok_concat_inv_l.
    destruct Hrc1 as [-> | Hx0]; destruct Hrc2 as [-> | Hrx1]; do 2 eexists; eauto.
    + split*. split. right.
      repeat apply* pt3_weaken. eauto.
    + split*. split. left*. right. repeat apply* pt3_weaken.
    + split*. split; right; repeat apply* pt3_weaken.
Qed.

(** If [p] looks up to [t] in a value environment and [p]'s III-level precise type
    is [q.type], where [q]'s environment type is a function type, then
    [t] is a path [r], and [q] and [r] are aliases. *)
Lemma lookup_step_preservation_sngl_prec3: forall G γ p q t Q1 Q2 Q3,
    inert G ->
    wf G ->
    γ ⫶ G ->
    γ ⟦ p ⤳ t ⟧ ->
    G ⊢!!! p : {{ q }} ->
    G ⊢! q : ∀(Q1) Q2 ⪼ Q3 ->
    exists r r', t = defp r /\
            (q = r' \/ G ⊢!!! q : {{ r' }}) /\
            (r = r' \/ G ⊢!!! r : {{ r' }}).
Proof.
  introv Hi Hwf Hwt Hs Hp. gen t.
  pose proof (typed_paths_named (precise_to_general3 Hp)) as [px [pbs Heq]].
  dependent induction Hp; introv Hs Hq;
    destruct (lookup_step_preservation_prec2 Hi Hwf Hwt Hs H Heq)
    as [[S' [U' [u [[= ->] [Hv Hp']]]]] |
        [[S' [ds [W [U [G1 [G2 [pT [-> [Hp' [Heq' [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
         [q' [r [r' [G1 [G2 [pT [-> [[= ->] [-> [Hrc1 Hrc2]]]]]]]]]]]].
  - pose proof (pf_sngl_T Hi Hp') as ->. pose proof (sngl_path_lookup Hi Hwf Hwt Hp') as [? [? [Hl ?]]].
    pose proof (lookup_step_func Hl Hs) as [=].
  - pose proof (pf_sngl_T Hi Hp') as [=].
  - destruct Hrc1 as [-> | Hrc1]; destruct Hrc2 as [-> | Hrc2]; do 2 eexists; eauto; split*; split;
      [ left* | right | right | left* | right | right ]; repeat apply* pt3_weaken.
    all: apply* inert_ok; apply* inert_prefix.
  - pose proof (pf_sngl_T Hi Hp') as ->. pose proof (sngl_path_lookup Hi Hwf Hwt Hp') as [? [? [Hl ?]]].
    pose proof (lookup_step_func Hl Hs) as [=].
  - pose proof (pf_sngl_T Hi Hp') as [=].
  - pose proof (typ_to_lookup3 Hi Hwf Hwt Hp) as [t Hl].
    pose proof (typed_paths_named (precise_to_general3 Hp)) as [rx [rbs Heqr]].
    specialize (IHHp _ Hi Hwf Hwt eq_refl _ _ Heqr _ Hl Hq) as [r1 [r2 [-> [[-> | Hq'] [-> | Hq'']]]]].
      * destruct Hrc1 as [-> | Hp']; destruct Hrc2 as [-> | Hp'']; do 2 eexists; split*.
        ** split. left*. right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken.
           apply inert_ok. apply* inert_prefix.
        ** split. left*. do 2 eapply pt3_weaken in Hp'. pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1 [[= ->] [-> | ?]]]]; eauto.
           false* pf_inert_pt3_sngl_false. all: apply* inert_ok; apply* inert_prefix.
        ** split. left*. do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1 [[= ->] [-> | ?]]]].
           *** right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken. eapply inert_ok, inert_prefix; eauto.
           *** right. repeat apply* pt3_weaken. eapply inert_ok, inert_prefix; eauto.
           *** false* pf_inert_pt3_sngl_false.
      * destruct Hrc1 as [-> | Hp']; destruct Hrc2 as [-> | Hp'']; do 2 eexists; split*.
        ** split. left*. right. eapply pt3_sngl_trans3. repeat apply* pt3_weaken.
           apply* inert_ok. apply* inert_prefix. auto.
        ** split. left*. do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1' [[= ->] [-> | ?]]]]; eauto. false* pf_inert_pt3_sngl_false.
        ** split. left*.
           do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp') as [? | [r1' [[= ->] [-> | HHH]]]].
           *** right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken. apply* inert_ok. apply* inert_prefix.
           *** right. repeat apply* pt3_weaken. apply* inert_ok. apply* inert_prefix.
           *** false* pf_inert_pt3_sngl_false.
      * destruct Hrc1 as [-> | Hp']; destruct Hrc2 as [-> | Hp'']; do 2 eexists; split*.
        ** split. left*. right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken.
           apply* inert_ok. apply* inert_prefix.
        ** split. left*.
           do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1 [[= ->] [-> | ?]]]]; eauto.
           false* pf_inert_pt3_sngl_false.
        ** split. left*.
            do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1 [[= ->] [-> | ?]]]].
           *** right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken. apply* inert_ok; apply* inert_prefix.
           *** right. repeat apply* pt3_weaken. apply* inert_ok; apply* inert_prefix.
           *** false* pf_inert_pt3_sngl_false.
      * destruct Hrc1 as [-> | Hp']; destruct Hrc2 as [-> | Hp'']; do 2 eexists; split*.
        ** split. left*. right. eapply pt3_sngl_trans3. repeat apply* pt3_weaken.
           apply inert_ok; apply* inert_prefix. auto.
        ** split. left*.
            do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp')
             as [? | [r1' [[= ->] [-> | ?]]]]; eauto. false* pf_inert_pt3_sngl_false.
        ** split. left*.
           do 2 eapply pt3_weaken in Hp'; try solve [apply* inert_ok; apply* inert_prefix].
           pose proof (pt3_invert Hi Hp Hp') as [? | [r1' [[= ->] [-> | HHH]]]].
           *** right. apply* pt3_sngl_trans3. repeat apply* pt3_weaken. apply* inert_ok. apply* inert_prefix.
           *** right. repeat apply* pt3_weaken. apply* inert_ok. apply* inert_prefix.
           *** false* pf_inert_pt3_sngl_false.
Qed.

(** If a [x.bs] looks up to a path [x.cs] in the value environment,
    and [x.bs]'s environment type is [T] then [T = x.cs.type]. *)
Lemma lookup_same_var_same_type G γ x bs cs T:
  inert G ->
  wf G ->
  γ ⫶ G ->
  γ ⟦ p_sel (avar_f x) bs ⤳ defp (p_sel (avar_f x) cs) ⟧ ->
  G ⊢!! p_sel (avar_f x) bs : T ->
  T = {{ p_sel (avar_f x) cs }}.
Proof.
  intros Hi Hwf Hwt. gen x bs cs T. induction Hwt; introv Hs Ht.
  - Case "s is empty"%string.
    false* lookup_empty.
  - Case "G is not empty"%string.
    destruct (classicT (x = x0)) as [<- | Hn].
    + SCase "x = x0"%string.
      pose proof (lookup_step_preservation_prec2 Hi Hwf (well_typed_push Hwt H H0 H1) Hs Ht eq_refl)
        as [[S' [U' [u [[= ->] [Hv Hp']]]]] |
            [[S' [ds [W [U' [G1 [G2 [pT [[=] [Hp' [Heq [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
             [q [r [r' [G1 [G2 [pT [[= <-] [-> [Heq [Hrc1 Hrc2]]]]]]]]]]]].
      rewrite <- concat_empty_r in Heq at 1.
      apply eq_sym in Heq. apply env_ok_inv in Heq as [<- [<- ->]]; try rewrite concat_empty_r in *; auto.
      pose proof (sngl_typed2 Hi Hwf Ht) as [T [rx [rbs ->]]%precise_to_general2%typed_paths_named].
      destruct Hrc1 as [-> | Hrc1];
        destruct Hrc2 as [-> | [U Hu]%precise_to_general3%typing_implies_bound];
        eauto.
      * false binds_fresh_inv; eauto.
      * apply sngl_typed3 in Hrc1 as
            [? [S Hb]%precise_to_general3%typing_implies_bound].
        false binds_fresh_inv; eauto. apply* inert_prefix. apply* wf_prefix.
      * false binds_fresh_inv; eauto.
    + SCase "x <> x0"%string.
      apply pt2_strengthen_one in Ht; auto.
      apply lookup_strengthen_one in Hs; eauto. apply* IHHwt. apply* inert_prefix. apply* wf_prefix.
Qed.

(** If the path [y.bs] has II-level precise type [y.cs.type] then
    [y.bs] looks up to [y.cs] in the value environment. *)
Lemma typed_path_lookup_same_var2 G γ y bs cs :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!! p_sel (avar_f y) bs : {{ p_sel (avar_f y) cs }} ->
  γ ⟦ p_sel (avar_f y) bs ⤳ defp (p_sel (avar_f y) cs) ⟧.
Proof.
  intros Hi Hwf Hwt Hp. pose proof (typ_to_lookup2 Hi Hwf Hwt Hp) as [t Hs].
  pose proof (lookup_step_preservation_prec2 Hi Hwf Hwt Hs Hp eq_refl)
        as [[? [? [? [[= ->] [Hv ->%pf_sngl_T]]]]] |
            [[? [? [? [? [? [? [? [[= ->] [[=]%pf_sngl_T ?]]]]]]]]] |
             [q' [r [r' [G1 [G2 [pT [-> [[= <-] [-> [Hrc1 Hrc2]]]]]]]]]]]]; auto.
  - proof_recipe. inversions Hv. inversions H. inversion H0.
  - apply (pt2_strengthen eq_refl Hi Hwf) in Hp.
    pose proof (wt_prefix Hwt) as [v [s1 [s2 [-> Hwt']]]].
    pose proof (wt_to_ok_γ Hwt) as Hoks.
    apply (lookup_strengthen Hoks eq_refl) in Hs.
    pose proof (inert_ok Hi) as Hok%ok_middle_inv_l.
    destruct Hrc1 as [<- | Hrc1]; destruct Hrc2 as [-> | Hrc2]; eauto.
    + apply* lookup_step_weaken.
    + apply (sngl_typed3 (inert_prefix (inert_prefix Hi))) in Hrc2
        as [T [U Hb]%precise_to_general3%typing_implies_bound].
      false binds_fresh_inv; eauto. repeat apply* wf_prefix.
    + pose proof (typing_implies_bound (precise_to_general3 Hrc1)) as [S Hb].
      false binds_fresh_inv; eauto.
    + pose proof (typing_implies_bound (precise_to_general3 Hrc1)) as [S Hb].
      false binds_fresh_inv; eauto.
Qed.

(** If the path [y.bs] has III-level precise type [y.cs.type] then
    [y.bs] looks up to [y.cs] in the value environment in a finite number of steps. *)
Lemma typed_path_lookup_same_var3 G γ y bs cs :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!! p_sel (avar_f y) bs : {{ p_sel (avar_f y) cs }} ->
  γ ⟦ defp (p_sel (avar_f y) bs) ⤳* defp (p_sel (avar_f y) cs) ⟧.
Proof.
  intros Hi Hwf Hwt Hp. dependent induction Hp.
  - apply star_one. apply* typed_path_lookup_same_var2.
  - pose proof (typed_paths_named (precise_to_general3 Hp)) as [qx [qbs ->]].
    destruct (classicT (qx = y)) as [-> | Hn].
    + specialize (IHHp _ _ _ Hi Hwf Hwt eq_refl eq_refl).
      pose proof (typed_path_lookup_same_var2 Hi Hwf Hwt H) as Hs.
      eapply star_trans. apply* star_one. auto.
    + clear IHHp.
      pose proof (typing_implies_bound (precise_to_general2 H)) as [S [G1 [G2 ->]]%binds_destruct].
      pose proof (inert_ok Hi) as Hok%ok_middle_inv_l.
      eapply pt2_strengthen in H; eauto.
      pose proof (sngl_typed2 (inert_prefix Hi) (wf_prefix Hwf) H)
        as [T [U [[-> ->] |
                  [Hn' [G1' [G2' ->]]%binds_destruct]]%binds_push_inv]%precise_to_general2%typing_implies_bound].
      * false*.
      * do 2 rewrite <- concat_assoc in Hp, Hi, Hwf. apply (pt3_strengthen eq_refl Hi Hwf) in Hp.
        apply (sngl_typed3 (inert_prefix Hi) (wf_prefix Hwf)) in Hp
          as [V [W Hb]%precise_to_general3%typing_implies_bound].
        simpl_dom. apply notin_union in Hok as [Hnu _]. false binds_fresh_inv; eauto.
Qed.

(** If [px.pbs] has III-level precise type [qx.qbs.type], and [px ≠ qx]
    then there exists a type [q'] that is [px.pbs]'s II-level precise type,
    [qx.qbs.type] is [q']'s III-level precise type, and [q']'s receiver is
    not equal to [px]. *)
Lemma prev_var_exists G p q px pbs qx qbs:
  inert G ->
  wf G ->
  p = p_sel (avar_f px) pbs ->
  q = p_sel (avar_f qx) qbs ->
  G ⊢!!! p : {{ q }} ->
  px <> qx ->
  exists p' cs q' ds rx,
    rx <> px /\
    p' = p_sel (avar_f px) cs /\
    q' = p_sel (avar_f rx) ds /\
    (p = p' \/ G ⊢!!! p : {{ p' }}) /\
    G ⊢!! p' : {{ q' }} /\
    (q' = q \/ G ⊢!!! q' : {{ q }}).
Proof.
  intros Hi Hwf -> -> Hp Hn. dependent induction Hp.
  - repeat eexists; eauto.
  - pose proof (sngl_typed2 Hi Hwf H) as [? [rx [rbs ->]]%precise_to_general2%typed_paths_named].
    destruct (classicT (rx = qx)) as [-> | Hn'].
    + do 5 eexists. split. eauto. split*.
    + specialize (IHHp _ _ _ _ Hi Hwf eq_refl eq_refl Hn')
        as [p' [cs [q' [ds [sx [Hn'' [-> [-> [Hp' [Hpq Hq]]]]]]]]]].
      destruct (classicT (px = rx)) as [-> | Hnpr].
      * eexists. exists cs. eexists. exists ds sx. repeat split*. right.
        destruct Hp' as [<- | Hnr]; eauto.
      * eexists. exists pbs. eexists. exists rbs rx. split*.
Qed.

(** If [p]'s III-level precise type is [r.type] and [r]'s environment type is
    a function type then [p] can be looked up to [r] in the value environment
    in a finite number of steps. *)
Lemma typed_path_lookup_helper G γ p r S T V :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!! p : {{ r }} ->
  G ⊢! r : ∀(S) T ⪼ V->
  γ ⟦ defp p ⤳* defp r ⟧.
Proof.
  intros Hi Hwf Hwt. gen p r S T V. induction Hwt; introv Hp Hr.
  - Case "G is empty"%string.
    apply precise_to_general in Hr. false* typing_empty_false.
  - Case "G is not empty"%string.
    destruct p as [x' bs].
    pose proof (typed_paths_named (precise_to_general3 Hp)) as [px [pbs [= -> ->]]].
    destruct (classicT (x = px)) as [-> | Hn].
    + SCase "x = px"%string.
      lets Hwt': (well_typed_push Hwt H H0 H1).
      pose proof (typ_to_lookup3 Hi Hwf Hwt' Hp) as [t Hlt].
      pose proof (lookup_step_preservation_sngl_prec3 Hi Hwf Hwt' Hlt Hp Hr)
        as [r1 [r2 [-> [Hrc Hrc']]]].
      pose proof (sngl_typed3 Hi Hwf Hp) as [? [rx [rbs ->]]%precise_to_general3%typed_paths_named].
      destruct (classicT (px = rx)) as [-> | Hn].
      { apply* typed_path_lookup_same_var3. }
      pose proof (prev_var_exists Hi Hwf eq_refl eq_refl Hp Hn) as
          [p' [cs' [q' [ds [sx [Hn' [-> [-> [Hpp' [Hp'q' Hq'q]]]]]]]]]].
      pose proof (typ_to_lookup2 Hi Hwf Hwt' Hp'q') as [t Hst].
      pose proof (lookup_step_preservation_prec2 Hi Hwf Hwt' Hst Hp'q' eq_refl)
        as [[S' [U' [u [[= ->] [Hv ->%pf_sngl_T]]]]] |
            [[S' [ds' [W [U' [G1 [G2 [pT [-> [[=]%pf_sngl_T [Heq [Hds [Hrc1 Hrc2]]]]]]]]]]]] |
             [q' [r [r' [G1 [G2 [pT [[= ->] [[= <-] [Heq' [Hrc1 Hrc2]]]]]]]]]]]]; auto.
      { simpl in *. proof_recipe. inversions Hv. inversions H2. inversion H3. }
      pose proof (inert_prefix Hi) as Hi'.
      rewrite <- concat_empty_r in Heq' at 1. apply env_ok_inv'  in Heq' as [-> [-> <-]];
                                               try rewrite concat_empty_r in *; auto.
      assert (exists q'x q'bs, q' = p_sel (avar_f q'x) q'bs) as [q'x [q'bs ->]]. {
        destruct Hrc2 as [-> | Hq'%precise_to_general3].
        - destruct Hrc1 as [<- | Hq']; eauto.
          pose proof (sngl_typed3 (inert_prefix Hi) (wf_prefix Hwf) Hq') as [? Hq''%precise_to_general3].
          apply* typed_paths_named.
        - apply* typed_paths_named.
      }
      apply star_trans with (b:=defp (p_sel (avar_f px) cs')). {
        destruct Hpp' as [[= ->] | Hpp'].
        - apply* star_refl.
        - eapply (typed_path_lookup_same_var3 Hi); auto.
      }
      clear Hpp'.
      assert (p_sel (avar_f rx) rbs = r2) as <-. {
        destruct Hrc as [<- | Ht]; auto. false (pf_inert_pt3_sngl_false Hi Hr Ht); auto.
      }
      clear Hrc.
      apply star_trans with (b:=defp (p_sel (avar_f q'x) q'bs)).
      { apply* star_one. }
      apply* lookup_weaken.
      { apply* wt_to_ok_γ. }
      pose proof (wf_prefix Hwf) as Hwf'.
      apply pf_strengthen in Hr; auto. clear Hrc' Hst Hp'q' Hp.
      destruct Hq'q as [[= -> ->] | Hq'q%pt3_strengthen_one]; destruct Hrc1 as [<- | Hrc1]; destruct Hrc2 as [[= ->] | Hrc2]; subst; auto;
        try solve [apply* IHHwt; try solve [false (pf_inert_pt3_sngl_false Hi' Hr Hrc1); auto]].
        * apply* IHHwt. apply* pt3_sngl_trans3.
        * pose proof (pt3_invert Hi' Hrc1 Hq'q) as [Contra | [q' [[= ->] [[= <-] | Hqt]]]].
          ** false (pf_inert_pt3_sngl_false Hi' Hr Contra); auto.
          ** subst. apply* star_refl.
          ** apply* IHHwt.
        * pose proof (pt3_invert Hi' Hrc1 Hq'q) as [Contra | [q' [[= ->] [[= <-] | Hqt]]]].
          ** false (pf_inert_pt3_sngl_false Hi' Hr Contra); auto.
          ** apply* IHHwt.
          ** apply (pt3_sngl_trans3 Hrc2) in Hqt. apply* IHHwt.
    + SCase "x <> px"%string.
      apply pt3_strengthen_one in Hp; auto. apply lookup_weaken.
      { apply* ok_push. apply* wt_to_ok_γ. }
      pose proof (inert_prefix Hi) as Hi'. pose proof (wf_prefix Hwf) as Hwf'.
      apply* IHHwt.
      apply (sngl_typed3 Hi' Hwf') in Hp as [U Ht]. apply* pf_strengthen_from_pt3.
Qed.

(** If [p]'s III-level precise type is a function type then [p] can be looked
    up to a value in the value environment. *)
Lemma typed_path_lookup3 G γ p T U :
  inert G ->
  wf G ->
  γ ⫶ G ->
  G ⊢!!! p: ∀(T) U ->
  exists v, γ ⟦ defp p ⤳* defv v ⟧.
Proof.
  intros Hi Hwf Hwt Hp.
  pose proof (typed_paths_named (precise_to_general3 Hp)) as [px [pbs ->]].
  apply (last_path Hi) in Hp as [Hp | [q [Hpq Hq]]].
  - inversions Hp. pose proof (typ_to_lookup1 Hi Hwf Hwt H) as [t Hs].
    destruct (lookup_step_preservation_prec1 Hi Hwf Hwt Hs H eq_refl)
          as [[S [u [-> Ht]]] |
              [[S [ds' [W [T'' [G1 [G2 [pT [-> [[= ->] [? ?]]]]]]]]]] |
               [? [? [? [? [? [? [? [[= ->] [-> ?]]]]]]]]]]]; eauto.
    apply pf_sngl_U in H as [=].
  - inversions Hq. pose proof (pf_forall_T Hi H) as ->.
    pose proof (typed_path_lookup_helper Hi Hwf Hwt Hpq H) as Hs.
    pose proof (typ_to_lookup1 Hi Hwf Hwt H) as [t Hs'].
    pose proof (typed_paths_named (precise_to_general H)) as [qx [qbs ->]].
    destruct (lookup_step_preservation_prec1 Hi Hwf Hwt Hs' H eq_refl)
          as [[S [u [-> Ht]]] |
              [[S [ds' [W [T'' [G1 [G2 [pT [-> [[= ->] [? ?]]]]]]]]]] |
               [? [? [? [? [? [? [? [[= ->] [-> ?]]]]]]]]]]].
    eexists. eapply star_trans. apply Hs. apply* star_one.
Qed.

(** If a path has a III-level function type then the path can be
    looked up in the value environment in a finite number of steps
    to a value of the same type. *)
Lemma corresponding_types_fun: forall G γ p S T,
    inert G ->
    wf G ->
    γ ⫶ G ->
    G ⊢!!! p: ∀(S) T ->
    (exists v, γ ⟦ defp p ⤳* defv v ⟧ /\
            G ⊢ trm_val v : ∀(S) T).
Proof.
  introv Hi Hwf Hwt Hp.
  destruct (typed_path_lookup3 Hi Hwf Hwt Hp) as [v Hs].
  lets Ht: (lookup_preservation_forall Hi Hwf Hwt Hs (precise_to_general3 Hp)). eauto.
Qed.

(** ** Canonical Forms for Functions (Lemma 5.5) *)
(** If a path has a function type then it can be looked up in the value environment
    in a finite number of steps to a function that has the same function type. *)
Lemma canonical_forms_fun: forall G γ p T U,
    inert G ->
    wf G ->
    γ ⫶ G ->
    G ⊢ trm_path p : ∀(T) U ->
                   (exists L T' t, γ ⟦ defp p ⤳* defv (λ(T') t) ⟧ /\
                    G ⊢ T <: T' /\
                    (forall y, y \notin L -> G & y ~ T ⊢ open_trm y t : open_typ y U)).
Proof.
  introv Hin Hwf Hwt Hty.
  destruct (path_typ_all_to_precise Hin Hty) as [L [S [T' [Hp [Hs1 Hs2]]]]].
  destruct (corresponding_types_fun Hin Hwf Hwt Hp) as [v [P Hv]].
  destruct (val_typ_all_to_lambda Hin Hv) as [L' [S' [t [Heq [Hs1' Hs2']]]]].
  subst.
  exists (L \u L' \u (dom G)) S' t. repeat split~.
  - eapply subtyp_trans; eauto.
  - intros.
    assert (HL: y \notin L) by auto.
    assert (HL': y \notin L') by auto.
    specialize (Hs2 y HL).
    specialize (Hs2' y HL').
    apply narrow_typing with (G':=G & y ~ T) in Hs2'; auto.
    eapply ty_sub; eauto.
Qed.


Module option.

(* Define the option type, which will be used in the list hd! *)

Inductive option (X:Type) : Type :=
| Some: X -> option X
| None : option X.

End option.


From iris.base_logic.lib Require Export invariants.
From iris.algebra Require Export auth.
From iris.algebra Require Import gmap.
From iris.base_logic Require Import big_op.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

(* The CMRA we need. *)
Class authG Σ (A : ucmraT) := AuthG {
  auth_inG :> inG Σ (authR A);
  auth_cmra_discrete :> CmraDiscrete A;
}.
Definition authΣ (A : ucmraT) : gFunctors := #[ GFunctor (authR A) ].

Instance subG_authΣ Σ A : subG (authΣ A) Σ → CmraDiscrete A → authG Σ A.
Proof. solve_inG. Qed.

Section definitions.
  Context `{invG Σ, authG Σ A} {T : Type} (γ : gname).

  Definition auth_own (a : A) : iProp Σ :=
    own γ (◯ a).
  Definition auth_inv (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    (∃ t, own γ (● f t) ∗ φ t)%I.
  Definition auth_ctx (N : namespace) (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    inv N (auth_inv f φ).

  Global Instance auth_own_ne : NonExpansive auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_proper : Proper ((≡) ==> (⊣⊢)) auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_timeless a : Timeless (auth_own a).
  Proof. apply _. Qed.
  Global Instance auth_own_core_id a : CoreId a → Persistent (auth_own a).
  Proof. apply _. Qed.

  Global Instance auth_inv_ne n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_inv_proper :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_ne N n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_proper N :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_persistent N f φ : Persistent (auth_ctx N f φ).
  Proof. apply _. Qed.
End definitions.

Typeclasses Opaque auth_own auth_inv auth_ctx.
Instance: Params (@auth_own) 4.
Instance: Params (@auth_inv) 5.
Instance: Params (@auth_ctx) 7.

Section auth.
  Context `{invG Σ, authG Σ A}.
  Context {T : Type} `{!Inhabited T}.
  Context (f : T → A) (φ : T → iProp Σ).
  Implicit Types N : namespace.
  Implicit Types P Q R : iProp Σ.
  Implicit Types a b : A.
  Implicit Types t u : T.
  Implicit Types γ : gname.

  Lemma auth_own_op γ a b : auth_own γ (a ⋅ b) ⊣⊢ auth_own γ a ∗ auth_own γ b.
  Proof. by rewrite /auth_own -own_op auth_frag_op. Qed.

  Global Instance from_and_auth_own γ a b1 b2 :
    IsOp a b1 b2 →
    FromAnd false (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. rewrite /IsOp /FromAnd=> ->. by rewrite auth_own_op. Qed.
  Global Instance from_and_auth_own_persistent γ a b1 b2 :
    IsOp a b1 b2 → Or (CoreId b1) (CoreId b2) →
    FromAnd true (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 91.
  Proof.
    intros ? Hper; apply mk_from_and_persistent; [destruct Hper; apply _|].
    by rewrite -auth_own_op -is_op.
  Qed.

  Global Instance into_and_auth_own p γ a b1 b2 :
    IsOp a b1 b2 →
    IntoAnd p (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. intros. apply mk_into_and_sep. by rewrite (is_op a) auth_own_op. Qed.

  Lemma auth_own_mono γ a b : a ≼ b → auth_own γ b ⊢ auth_own γ a.
  Proof. intros [? ->]. by rewrite auth_own_op sep_elim_l. Qed.
  Lemma auth_own_valid γ a : auth_own γ a ⊢ ✓ a.
  Proof. by rewrite /auth_own own_valid auth_validI. Qed.
  Global Instance auth_own_sep_homomorphism γ :
    WeakMonoidHomomorphism op uPred_sep (≡) (auth_own γ).
  Proof. split; try apply _. apply auth_own_op. Qed.

  Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (auth_own γ).
  Proof. intros a1 a2. apply auth_own_mono. Qed.

  Lemma auth_alloc_strong N E t (G : gset gname) :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜γ ∉ G⌝ ∧ auth_ctx γ N f φ ∧ auth_own γ (f t).
  Proof.
    iIntros (?) "Hφ". rewrite /auth_own /auth_ctx.
    iMod (own_alloc_strong (Auth (Excl' (f t)) (f t)) G) as (γ) "[% Hγ]"; first done.
    iRevert "Hγ"; rewrite auth_both_op; iIntros "[Hγ Hγ']".
    iMod (inv_alloc N _ (auth_inv γ f φ) with "[-Hγ']") as "#?".
    { iNext. rewrite /auth_inv. iExists t. by iFrame. }
    eauto.
  Qed.

  Lemma auth_alloc N E t :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, auth_ctx γ N f φ ∧ auth_own γ (f t).
  Proof.
    iIntros (?) "Hφ".
    iMod (auth_alloc_strong N E t ∅ with "Hφ") as (γ) "[_ ?]"; eauto.
  Qed.

  Lemma auth_empty γ : (|==> auth_own γ ε)%I.
  Proof. by rewrite /auth_own -own_unit. Qed.

  Lemma auth_acc E γ a :
    ▷ auth_inv γ f φ ∗ auth_own γ a ={E}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E}=∗ ▷ auth_inv γ f φ ∗ auth_own γ b.
  Proof using Type*.
    iIntros "[Hinv Hγf]". rewrite /auth_inv /auth_own.
    iDestruct "Hinv" as (t) "[>Hγa Hφ]".
    iModIntro. iExists t.
    iDestruct (own_valid_2 with "Hγa Hγf") as % [? ?]%auth_valid_discrete_2.
    iSplit; first done. iFrame. iIntros (u b) "[% Hφ]".
    iMod (own_update_2 with "Hγa Hγf") as "[Hγa Hγf]".
    { eapply auth_update; eassumption. }
    iModIntro. iFrame. iExists u. iFrame.
  Qed.

  Lemma auth_open E N γ a :
    ↑N ⊆ E →
    auth_ctx γ N f φ ∗ auth_own γ a ={E,E∖↑N}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E∖↑N,E}=∗ auth_own γ b.
  Proof using Type*.
    iIntros (?) "[#? Hγf]". rewrite /auth_ctx. iInv N as "Hinv" "Hclose".
    (* The following is essentially a very trivial composition of the accessors
       [auth_acc] and [inv_open] -- but since we don't have any good support
       for that currently, this gets more tedious than it should, with us having
       to unpack and repack various proofs.
       TODO: Make this mostly automatic, by supporting "opening accessors
       around accessors". *)
    iMod (auth_acc with "[$Hinv $Hγf]") as (t) "(?&?&HclAuth)".
    iModIntro. iExists t. iFrame. iIntros (u b) "H".
    iMod ("HclAuth" $! u b with "H") as "(Hinv & ?)". by iMod ("Hclose" with "Hinv").
  Qed.
End auth.

Arguments auth_open {_ _ _} [_] {_} [_] _ _ _ _ _ _ _.


Require Import Coq.Structures.Orders.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.Strings.Ascii Coq.Strings.String.
Require Import Coq.Arith.Arith.
Require Import Coq.NArith.NArith.
Require Export Crypto.Util.FixCoqMistakes.

(** This should disappear whenever we bump the minimum version to a version where https://github.com/coq/coq/pull/14096 has been merged *)

Module Ascii_as_OT <: UsualOrderedType.
  Definition t := ascii.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := Ascii.eqb.
  Definition eqb_eq := Ascii.eqb_eq.
  Include HasEqBool2Dec.

  Definition compare (a b : ascii) := N_as_OT.compare (N_of_ascii a) (N_of_ascii b).
  Definition lt (a b : ascii) := N_as_OT.lt (N_of_ascii a) (N_of_ascii b).

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
    intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; unfold lt; [ intro | intros ??? ]; eapply N_as_OT.lt_strorder.
  Qed.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
    intros x y; unfold eq, lt, compare.
    destruct (N_as_OT.compare_spec (N_of_ascii x) (N_of_ascii y)) as [H|H|H]; constructor; try assumption.
    now rewrite <- (ascii_N_embedding x), <- (ascii_N_embedding y), H.
  Qed.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedType.
  Definition t := string.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := String.eqb.
  Definition eqb_eq := String.eqb_eq.
  Include HasEqBool2Dec.

  Fixpoint compare (a b : string)
    := match a, b with
       | EmptyString, EmptyString => Eq
       | EmptyString, _ => Lt
       | String _ _, EmptyString => Gt
       | String a_head a_tail, String b_head b_tail =>
         match Ascii_as_OT.compare a_head b_head with
         | Lt => Lt
         | Gt => Gt
         | Eq => compare a_tail b_tail
         end
       end.

  Definition lt (a b : string) := compare a b = Lt.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
    intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
  Qed.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
    unfold eq, lt.
    induction x as [|x xs IHxs], y as [|y ys]; cbn [compare]; try constructor; cbn [compare]; try reflexivity.
    specialize (IHxs ys).
    destruct (Ascii_as_OT.compare x y) eqn:H; [ destruct IHxs; constructor | constructor | constructor ]; cbn [compare].
    all: destruct (Ascii_as_OT.compare_spec y x), (Ascii_as_OT.compare_spec x y); cbv [Ascii_as_OT.eq] in *; try congruence; subst.
    all: exfalso; eapply irreflexivity; (idtac + etransitivity); eassumption.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; unfold lt; [ intro x | intros x y z ]; unfold complement.
    { induction x as [|x xs IHxs]; cbn [compare]; [ congruence | ].
      destruct (Ascii_as_OT.compare x x) eqn:H; try congruence.
      exfalso; eapply irreflexivity; eassumption. }
    { revert x y z.
      induction x as [|x xs IHxs], y as [|y ys], z as [|z zs]; cbn [compare]; try congruence.
      specialize (IHxs ys zs).
      destruct (Ascii_as_OT.compare x y) eqn:Hxy, (Ascii_as_OT.compare y z) eqn:Hyz, (Ascii_as_OT.compare x z) eqn:Hxz;
        try intuition (congruence || eauto).
      all: destruct (Ascii_as_OT.compare_spec x y), (Ascii_as_OT.compare_spec y z), (Ascii_as_OT.compare_spec x z);
        try discriminate.
      all: unfold Ascii_as_OT.eq in *; subst.
      all: exfalso; eapply irreflexivity; (idtac + etransitivity); (idtac + etransitivity); eassumption. }
  Qed.
End String_as_OT.