Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Export preservation.

Lemma TypedReduce_progress: forall v A,
    value v -> typing nil v Chk A -> exists v', typ_reduce v A v'.
Proof with auto.
  intros.
  apply typing_chk2inf in H0.
  destruct_hypos.
  generalize dependent x.
  generalize dependent v.
  dependent induction A;intros v val...
  - (* top *)
    exists exp_top...
    constructor...
    apply value_lc_expr...
  - (* bot *)
    dependent induction val;intros;try solve [dependent destruction H0;dependent destruction H1;solve_not_toplike]...
    +
      dependent destruction H0...
      dependent destruction H2...
      inversion H3.
    +
      dependent destruction H0...
      *
        dependent destruction H1...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        solve_not_toplike.
      *
        dependent destruction H3...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        solve_not_toplike.
  - (* nat *)
    dependent induction val;intros;try solve [dependent destruction H0;dependent destruction H1;solve_not_toplike]...
    +
      exists exp_nat...
    +
      dependent destruction H0...
      dependent destruction H2...
      solve_not_toplike.
    +
      dependent destruction H0...
      *
        dependent destruction H1...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        solve_not_toplike.
      *
        dependent destruction H3...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        solve_not_toplike.
  - (* bvar *)
    intros.
    get_well_form.
    dependent destruction H2...
  - (* fvar *)
    intros.
    dependent induction H0;try solve [dependent destruction val|dependent destruction H1;solve_not_toplike]...
    +
      dependent destruction val.
      dependent destruction H1.
      destruct IHtyping1...
      exists x...
      apply tred_mergeL...
      get_well_form...
      destruct IHtyping2...
      exists x...
      apply tred_mergeR...
      get_well_form...
      solve_not_toplike.
    +
      dependent destruction val.
      dependent destruction H3.
      destruct IHtyping1...
      exists x...
      apply tred_mergeL...
      get_well_form...
      destruct IHtyping2...
      exists x...
      apply tred_mergeR...
      get_well_form...
      solve_not_toplike.
  - (* and *)
    assert (Hv:=val).
    dependent induction val;intros;assert (Hq:=H0)...
    +
      dependent destruction H0...
      destruct (and_inv H1)...
      destruct IHA1 with (v:=(exp_abs A t1 B)) (x:=(typ_arrow A B))...
      destruct IHA2 with (v:=(exp_abs A t1 B)) (x:=(typ_arrow A B))...
      exists (exp_merge x x0)...
    +
      dependent destruction H0...
      destruct (and_inv H1)...
      destruct IHA1 with (v:=exp_nat) (x:=typ_nat)...
      destruct IHA2 with (v:=exp_nat) (x:=typ_nat)...
      exists (exp_merge x x0)...
    +
      dependent destruction H0...
      destruct (and_inv H1)...
      destruct IHA1 with (v:=exp_top) (x:=typ_top)...
      destruct IHA2 with (v:=exp_top) (x:=typ_top)...
      exists (exp_merge x x0)...
    +
      dependent destruction H0...
      destruct (and_inv H2)...
      destruct IHA1 with (v:=(exp_fold (typ_mu A) e)) (x:=(typ_mu A) )...
      destruct IHA2 with (v:=(exp_fold (typ_mu A) e)) (x:=(typ_mu A) )...
      exists (exp_merge x x0)...
    +
      dependent destruction H0...
      *
        apply and_inv in H1.
        destruct_hypos.
        destruct IHA1 with (v:=exp_merge e1 e2) (x:=typ_and A B)...
        destruct IHA2 with (v:=exp_merge e1 e2) (x:=typ_and A B)...
        exists (exp_merge x x0)...
      *
        apply and_inv in H3.
        destruct_hypos.
        destruct IHA1 with (v:=exp_merge e1 e2) (x:=typ_and A B)...
        destruct IHA2 with (v:=exp_merge e1 e2) (x:=typ_and A B)...
        exists (exp_merge x x0)...
    +
      dependent destruction H0...
      destruct (and_inv H1)...
      destruct IHA1 with (v:=exp_rcd l e) (x:=typ_rcd l A )...
      destruct IHA2 with (v:=exp_rcd l e) (x:=typ_rcd l A )...
      exists (exp_merge x x0)...
  - (* mu *)
    dependent induction val;intros;try solve [dependent destruction H0;dependent destruction H1;exists exp_top;auto]...
    + (* mu *)
      assert (Hq:=H0).
      dependent destruction H0...
      pose toplike_dec.
      destruct s with (E:=empty) (A:=typ_mu A).
      *
        exists exp_top...
        constructor...
        constructor...
        apply value_lc_expr...
      *
        exists (exp_fold (typ_mu A) e).
        constructor...
        get_well_form...
    + (* merge *)
      dependent destruction H0...
      *
        dependent destruction H1...
        destruct IHval1 with (x:=A0)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
      *
        dependent destruction H3...
        destruct IHval1 with (x:=A0)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
    + (* rcd *)
      dependent destruction H0...
      dependent destruction H1...
      exists exp_top...
      constructor...
      get_well_form...
  - (* arrow *)
    assert (Hv:=val).
    dependent induction val;intros;try solve [dependent destruction H0;dependent destruction H1;exists exp_top;auto]...
    +  (* arrow *)
      dependent destruction H0...
      pose toplike_dec.
      destruct s with (E:=empty) (A:=A2).
      *
        exists exp_top...
        constructor...
        constructor...
        get_well_form...
        inversion H3...
      *
        exists (exp_abs A t1 A2).
        dependent destruction H1...
        assert (False) as q.
        apply n...
        dependent destruction H2...
        destruct q.
    + (* fold *)
      dependent destruction H0...
      dependent destruction H2...
      exists exp_top...
      constructor...
      constructor...
      get_well_form...
    + (* merge *)
      dependent destruction H0...
      *
        dependent destruction H1...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
      *
        dependent destruction H3...
        destruct IHval1 with (x:=A)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
    + (* rcd *)
      dependent destruction H0...
      dependent destruction H1...
      exists exp_top...
      constructor...
      get_well_form...
  - (* rcd *)
    dependent induction val;intros;try solve [dependent destruction H0;dependent destruction H1;exists exp_top;auto]...
    +
      dependent destruction H0...
      dependent destruction H2...
      exists exp_top...
      constructor...
      constructor...
      get_well_form...
    +
      dependent destruction H0...
      *
        dependent destruction H1...
        destruct IHval1 with (x:=A0)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
      *
        dependent destruction H3...
        destruct IHval1 with (x:=A0)...
        exists x...
        apply tred_mergeL...
        get_well_form...
        destruct IHval2 with (x:=B)...
        exists x...
        apply tred_mergeR...
        get_well_form...
        exists exp_top...
        constructor...
        constructor;get_well_form...
    +
      dependent destruction H0...
      pose toplike_dec.
      destruct s with (E:=empty) (A:=typ_rcd a A).
      *
        exists exp_top...
        constructor...
        get_well_form...
      *
        dependent destruction H1...
        --
          destruct IHA with (v:=e) (x:=A0)...
          exists (exp_rcd a x)...
        --
          assert (False) as q.
          apply n...
          destruct q.
Qed.

Lemma canonical_form_fold : forall e U ,
  value e ->
  typing empty e Chk (typ_mu U) ->
  ~ toplike empty (typ_mu U) ->
  (exists V, exists e1, Sub empty (typ_mu V) (typ_mu U) /\
                        value e1 /\ e = (exp_fold (typ_mu V) e1)) \/ (exists e1 e2, e = exp_merge e1 e2) .
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H;intros...
  - (* abs *)
    dependent destruction H0...
    dependent destruction H0...
    dependent destruction H1...
    assert (False) as Q.
    apply H3...
    destruct Q.
  -
    dependent destruction H0...
    dependent destruction H0...
    dependent destruction H0...
    assert (False) as Q.
    apply H2...
    destruct Q.
  -
    dependent destruction H0...
    dependent destruction H0...
    assert (False) as Q.
    apply H1...
    apply topCorrectR...
    destruct Q.
  -
    dependent destruction H1...
    dependent destruction H1...
    left.
    exists A.
    exists e...
  -
    right.
    exists e1.
    exists e2...
  -
    dependent destruction H0...
    dependent destruction H0...
    dependent destruction H1...
    assert (False) as Q.
    apply H3...
    destruct Q.
Qed.

Theorem progress : forall e dir A,
    typing nil e dir A ->
    value e \/ exists e', step e e' .
Proof with auto.
  intros.
  assert (Ht:=H).
  dependent induction Ht;try solve [left;get_well_form;constructor;auto]...
  - (* var *)
    analyze_binds H1...
  - (* anno *)
    right.
    dependent destruction H...
    destruct IHHt...
    +
      assert (Hq:=H0).
      apply TypedReduce_progress with (A:=A) in H0...
      destruct H0.
      exists x...
    +
      destruct H0.
      exists (exp_anno x A)...
      constructor...
      get_well_form...
      get_type...
  - (* app *)
    destruct IHHt1;destruct IHHt2...
    +
      dependent destruction Ht1;try solve [inversion H1|inversion H0|inversion H2|inversion H4]...
      *
        dependent destruction H1...
        right.
        exists exp_top...
      *
        right.
        dependent destruction H1...
        apply TypedReduce_progress in Ht2...
        destruct Ht2.
        exists (exp_anno (open_ee e x) T2)...
        constructor...
        apply value_lc_expr...
        apply TypedReduce_prv_value in H1...
    +
      destruct H2.
      right.
      exists (exp_app e1 x)...
    +
      destruct H1.
      right.
      exists (exp_app  x e2)...
      constructor...
      apply value_lc_expr...
    +
      destruct H1.
      right.
      exists (exp_app x e2)...
      constructor...
      get_well_form...
  - (* fix *)
    right.
    exists (exp_anno (open_ee e (exp_fix A e)) A)...
    constructor...
    get_well_form...
  - (* fold *)
    destruct IHHt...
    +
      left.
      constructor...
      get_type...
    +
      right.
      destruct H1.
      exists (exp_fold (typ_mu A) x)...
      constructor...
      get_type...
  - (* merge *)
    destruct IHHt1;destruct IHHt2...
    +
      right.
      destruct H2.
      exists (exp_merge e1 x)...
    +
      right.
      destruct H1.
      exists (exp_merge x e2)...
      constructor...
      apply value_lc_expr...
    +
      right.
      destruct_hypos.
      exists (exp_merge x0 e2)...
      constructor...
      get_well_form...
  - (* unfold *)
    right.
    destruct IHHt...
    +
      pose toplike_dec.
      destruct s with (E:=empty) (A:=typ_mu T).
      *
        exists exp_top.
        apply step_fldt...
        constructor...
        apply value_lc_expr...
      *
        apply canonical_form_fold in Ht...
        destruct Ht.
        --
          destruct_hypos.
          subst.
          dependent destruction H.
          dependent destruction H.
          dependent destruction H.
          assert (typing empty x0 Chk (open_tt T (typ_mu T))).
          apply typing_chk_sub with (A:=open_tt x (typ_mu x))...
          apply unfolding_lemma...
          apply TypedReduce_progress in H5...
          destruct_hypos.
          exists x1...
          constructor...
          get_type...
        --
          destruct_hypos.
          subst.
          dependent destruction H.
          apply TypedReduce_progress in H...
          destruct_hypos.
          dependent destruction H0.
          exists (exp_unfold (typ_mu T) x1)...
    +
      destruct_hypos.
      exists (exp_unfold (typ_mu T) x)...
      apply step_unfold...
      get_well_form...
      get_type...
  - (* rcd *)
    dependent destruction H...
    destruct IHHt...
    right.
    destruct_hypos.
    exists (exp_rcd l x)...
  - (* proj *)
    right.
    dependent destruction H...
    apply inference_unique with (A2:=A) in Ht...
    subst.
    destruct IHHt...
    +
      dependent destruction H;try solve [inversion H0|inversion H1|inversion H2|inversion H3|inversion H4|inversion H5|inversion H6]...
      *
        dependent destruction H0...
        exists exp_top...
      *
        dependent destruction H1.
        dependent destruction H2...
        exists e...
    +
      destruct_hypos.
      exists (exp_proj x l)...
Qed.

Theorem step_unique: forall A e e1 e2 dir,
    typing nil e dir A -> step e e1 -> step e e2 -> e1 = e2.
Proof with auto.
  intros.
  generalize dependent A.
  generalize dependent dir.
  generalize dependent e2.
  assert (HG:=H0).
  dependent induction H0;intros...
  - (* top *)
    dependent destruction H1...
    +
      dependent destruction H1...
    +
      apply step_not_value in H1...
      destruct H1.
  - (* abs *)
    dependent destruction H3...
    +
      f_equal...
      f_equal...
      apply TypedReduce_unique with (A:=A) (v:=e1)...
      dependent induction H7...
      *
        dependent destruction H7...
        dependent destruction H7_...
        apply typing_chk2inf in H7_0...
        destruct_hypos.
        exists x...
        apply typing_chk2inf in H7_0...
        destruct_hypos.
        exists x...
      *
        destruct IHtyping with (A0:=A) (B0:=B) (e0:=e) (e3:=e1)...
        exists x...
    +
      dependent destruction H4...
    +
      apply step_not_value in H4...
      destruct H4.
  - (* appl *)
    dependent destruction H1...
    +
      apply step_not_value in H0...
      destruct H0.
    +
      dependent destruction H0.
    +
      f_equal...
      dependent induction H3...
      *
        dependent destruction H3...
        apply IHstep with (A:=typ_arrow T1 T2) (dir:=Inf)...
        apply IHstep with (A:=typ_top) (dir:=Inf)...
      *
        apply IHtyping with (e3:=e2) (e4:=e1)...
    +
      apply step_not_value in H0...
      destruct H0.
  - (* appr *)
    dependent destruction H1...
    +
      apply step_not_value in H0...
      destruct H0.
    +
      apply step_not_value in H0...
      destruct H0.
    +
      apply step_not_value in H2...
      destruct H2.
    +
      f_equal...
      dependent induction H3...
      *
        dependent destruction H3.
        apply IHstep with (A:=T1) (dir:=Chk)...
        apply IHstep with (A:=typ_top) (dir:=Chk)...
      *
        apply IHtyping with (e3:=e2) (v2:=v1)...
  - (* mergel *)
    dependent destruction H1...
    +
      f_equal.
      dependent induction H3...
      *
        apply IHstep with (A:=A) (dir:=Inf)...
      *
        apply IHstep with (A:=A) (dir:=Inf)...
      *
        apply IHtyping with (e3:=e2) (e4:=e1)...
    +
      apply step_not_value in H0...
      destruct H0.
  - (* merger *)
    dependent destruction H1...
    +
      apply step_not_value in H2...
      destruct H2.
    +
      f_equal...
      dependent induction H3.
      *
        apply IHstep with (A:=B) (dir:=Inf)...
      *
        apply IHstep with (A:=B) (dir:=Inf)...
      *
        apply IHtyping with (e3:=e2) (e4:=e1)...
  - (* anno *)
    dependent destruction H1...
    +
      f_equal...
      dependent induction H3...
      apply IHstep with (A:=A) (dir:=Chk)...
      apply IHtyping with (A0:=A) (e0:=e)...
    +
      apply step_not_value in H0...
      destruct H0.
  - (* annov *)
    dependent destruction H1...
    +
      apply step_not_value in H1...
      destruct H1.
    +
      apply TypedReduce_unique with (A:=A) (v:=e)...
      dependent induction H3.
      *
        apply typing_chk2inf in H3...
        destruct_hypos.
        exists x...
      *
        dependent destruction H3...
        apply typing_chk2inf in H3...
        destruct_hypos.
        exists x...
  - (* fix *)
    dependent destruction H1...
  - (* unfold *)
    dependent destruction H3...
    +
      apply TypedReduce_unique with (A:=(open_tt A (typ_mu A))) (v:=e1)...
      dependent induction H7...
      *
        dependent destruction H7.
        dependent destruction H7.
        dependent destruction H7.
        exists A0...
      *
        destruct IHtyping with (e4:=e1) (B0:=B) (A0:=A)...
        exists x...
    +
      assert (False).
      apply H2...
      destruct H7.
    +
      dependent destruction H3...
      apply step_not_value in H3...
      destruct H3.
  - (* unfold merge *)
    dependent destruction H3...
    +
      f_equal.
      apply TypedReduce_unique with (A:=typ_mu A) (v:=exp_merge e1 e2)...
      dependent induction H7.
      *
        dependent destruction H7.
        exists A0...
      *
        destruct IHtyping with (e3:=e2) (e5:=e1) (A0:=A)...
        exists x...
    +
      assert (False).
      apply H2...
      destruct H7.
    +
      apply step_not_value in H3...
      destruct H3.
  - (* unfold top *)
    dependent destruction H2...
    +
      assert (False).
      apply H5...
      destruct H7.
    +
      assert (False).
      apply H5...
      destruct H7.
    +
      apply step_not_value in H2...
      destruct H2.
  - (* fold *)
    dependent destruction H1...
    f_equal...
    dependent induction H3...
    *
      dependent destruction H3...
      apply IHstep with (A:=A0) (dir:=Inf)...
    *
      apply IHtyping with (T0:=T) (e0:=e)...
  - (* unfold *)
    dependent destruction H1...
    +
      apply step_not_value in H0...
      destruct H0.
    +
      apply step_not_value in H0...
      destruct H0.
    +
      apply step_not_value in H0...
      destruct H0.
    +
      f_equal...
      dependent induction H3...
      *
        apply IHstep with (A:=typ_mu T0) (dir:=Chk)...
      *
        apply IHtyping with (T0:=T) (e0:=e)...
  - (* rcd *)
    dependent destruction H1...
    f_equal...
    dependent induction H...
    *
      apply IHstep with (A:=A) (dir:=Inf)...
    *
      apply IHtyping with (e0:=e) (l0:=l)...
  - (* proj *)
    dependent destruction H1...
    +
      f_equal.
      dependent induction H...
      *
        apply IHstep with (A:=A) (dir:=Inf)...
      *
        apply IHtyping with (e0:=e) (l0:=l)...
    +
      dependent destruction HG...
      dependent destruction HG...
    +
      dependent destruction HG...
      dependent destruction HG...
      apply step_not_value in HG...
      destruct HG.
  - (* projtop *)
    dependent destruction H1...
    dependent destruction H1...
  - (* projrcd *)
    dependent destruction H1...
    dependent destruction H1...
    apply step_not_value in H1...
    destruct H1.
Qed.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class SepconMonoAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  __sepcon_mono: forall x1 x2 y1 y2 : expr, |-- x1 --> x2 -> |-- y1 --> y2 -> |-- x1 * y1 --> x2 * y2
}.

Class SepconAxiomatization_weak
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  __sepcon_comm_impp: forall x y, |-- x * y --> y * x;
  __sepcon_assoc1: forall x y z, |-- x * (y * z) --> (x * y) * z;
}.

Class SepconAxiomatization_weak_iffp
        (L: Language)
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  __sepcon_comm: forall x y, |-- x * y <--> y * x;
  __sepcon_assoc: forall x y z, |-- x * (y * z) <--> (x * y) * z;
}.

Class EmpAxiomatization_iffp
        (L: Language)
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  __sepcon_emp: forall x, |-- x * emp <--> x
}.

Lemma SepconAxiomatizationWeak2SepconAxiomatization
      {L: Language}
      {minL: MinimumLanguage L}
      {sepconL: SepconLanguage L}
      {Gamma: Provable L}
      {minAX: MinimumAxiomatization L Gamma}
      {sepconAX: SepconAxiomatization_weak L Gamma}
      {sepcon_mono_AX: SepconMonoAxiomatization L Gamma}:
  SepconAxiomatization L Gamma.
Proof.
  intros.
  constructor.
  + apply __sepcon_comm_impp.
  + apply __sepcon_assoc1.
  + apply __sepcon_mono.
Qed.

Section FromAdjPlusSepconWeakToSepcon.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {wandX: WandAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization_weak L Gamma}.

Let sepcon_Comm: Commutativity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply __sepcon_comm_impp.
Qed.

Let sepcon_Mono: Monotonicity L Gamma sepcon.
Proof.
  apply @Adjoint2Mono with (funcp := wand).
  + auto.
  + apply wand_sepcon_Adj.
  + apply sepcon_Comm.
Qed.

Lemma Adj2SepconMono: SepconMonoAxiomatization L Gamma.
Proof.
  constructor.
  intros.
  apply (@prodp_mono _ _ _ _ sepcon_Mono); auto.
Qed.

End FromAdjPlusSepconWeakToSepcon.

Section FromSepconWeakIffToSepconWeak.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {sepconAX: SepconAxiomatization_weak_iffp L Gamma}.

Lemma SepconAxiomatizationWeakIff2SepconAxiomatizationWeak:
  SepconAxiomatization_weak L Gamma.
Proof.
  constructor.
  + pose proof __sepcon_comm.
    intros.
    eapply solve_andp_elim1.
    apply H.
  + pose proof __sepcon_assoc.
    intros.
    eapply solve_andp_elim1.
    apply H.
Qed.

End FromSepconWeakIffToSepconWeak.

Section FromAdjToPropositionalCombination.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}
        {wandX: WandAxiomatization L Gamma}.

Let RDistr: RightDistr L Gamma sepcon orp.
Proof.
  apply (@Adjoint2RDistr _ _ _ _ _ _ _ wand).
  apply wand_sepcon_Adj.
Qed.

Let LDistr: LeftDistr L Gamma sepcon orp.
Proof.
  apply @RightDistr2LeftDistr; auto.
  + apply sepcon_Comm.
  + apply orp_Mono.
Qed.

Lemma Adj2SepconOr: SepconOrAxiomatization L Gamma.
Proof.
  intros.
  constructor.
  intros.
  pose proof @prodp_sump_distr_r _ _ _ _ _ _ _ _ RDistr.
  rewrite H.
  apply provable_impp_refl.
Qed.

Lemma Adj2SepconFalse: SepconFalseAxiomatization L Gamma.
Proof.
  intros.
  constructor.
  intros.
  rewrite (@falsep_prodp _ _ _ _ _ _ _ _ wand_sepcon_Adj).
  apply provable_impp_refl.
Qed.

End FromAdjToPropositionalCombination.

Section FromEmpIffToEmp.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}
        {empAX: EmpAxiomatization_iffp L Gamma}.

Lemma EmpAxiomatizationIff2EmpAxiomatization:
  EmpAxiomatization L Gamma.
Proof.
  constructor.
  + pose proof __sepcon_emp.
    intros.
    eapply solve_andp_elim1.
    apply H.
  + pose proof __sepcon_emp.
    intros.
    eapply solve_andp_elim2.
    apply H.
Qed.

End FromEmpIffToEmp.


Require Import Setoid PArith.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import TView View Time Event Cell Thread Memory Configuration.
Require Import MemoryAux.

Definition closedness_preserved memory memory' :=
  forall view,
    Memory.closed_timemap view memory ->
    Memory.closed_timemap view memory'.

Lemma closedness_preserved_id memory :
  closedness_preserved memory memory.
Proof using. by intros view. Qed.

Lemma closedness_preserved_add memory memory'
      loc from to msg
      (ADD : Memory.add memory loc from to msg memory'):
  closedness_preserved memory memory'.
Proof using.
  intros view CP. red.
  intros loc'.
  erewrite Memory.add_o; eauto.
  destruct (loc_ts_eq_dec (loc', view loc') (loc, to)) as [[A B]|NEQ]; simpls.
  subst.
  exfalso.
  apply Memory.add_get0 in ADD. desf.
  specialize (CP loc). desf. rewrite ADD in CP. inv CP.
Qed.

Lemma closedness_preserved_split memory memory'
      loc from to to' msg msg'
      (SPLIT : Memory.split memory loc from to to' msg msg' memory'):
  closedness_preserved memory memory'.
Proof using.
  intros view CP. red.
  intros loc'.
  set (MM:=SPLIT).
  apply Memory.split_get0 in MM. desf.
  erewrite Memory.split_o; eauto.
  destruct (loc_ts_eq_dec (loc', view loc') (loc, to)) as [[A B]|NEQ]; simpls; subst.
  { specialize (CP loc). desf. rewrite MM in CP. inv CP. }
  destruct (loc_ts_eq_dec (loc', view loc') (loc, to')) as [[A B]|NEQ']; simpls; desf.
  specialize (CP loc). desf. rewrite MM0 in CP. inv CP.
  eauto.
Qed.

Lemma closedness_preserved_cancel memory memory' loc from to
      (CANCEL : Memory.remove memory loc from to Message.reserve memory'):
  closedness_preserved memory memory'.
Proof using.
  intros view CP. red.
  intros loc'.
  erewrite Memory.remove_o; eauto.
  destruct (loc_ts_eq_dec (loc', view loc') (loc, to)) as [[A B]|NEQ]; simpls.
  subst.
  exfalso.
  apply Memory.remove_get0 in CANCEL. desf.
  specialize (CP loc). desf. rewrite CANCEL in CP. inv CP.
Qed.

Lemma closedness_preserved_trans memory memory' memory''
      (CP  : closedness_preserved memory  memory')
      (CP' : closedness_preserved memory' memory'') :
  closedness_preserved memory memory''.
Proof using. red. ins. apply CP'. by apply CP. Qed.

Lemma tview_closedness_preserved_add tview memory memory'
      loc from to msg
      (ADD : Memory.add memory loc from to msg memory')
      (MEM_CLOSE : memory_close tview memory) :
  memory_close tview memory'.
Proof using.
  red; splits; ins.
  all: eapply closedness_preserved_add; eauto.
  all: by apply MEM_CLOSE.
Qed.

Lemma tview_closedness_preserved_split tview memory memory'
      loc from to to' msg msg'
      (SPLIT : Memory.split memory loc from to to' msg msg' memory')
      (MEM_CLOSE : memory_close tview memory) :
  memory_close tview memory'.
Proof using.
  red; splits; ins.
  all: eapply closedness_preserved_split; eauto.
  all: by apply MEM_CLOSE.
Qed.

Lemma tview_closedness_preserved_cancel tview memory memory'
      loc from to
      (ADD : Memory.remove memory loc from to Message.reserve memory')
      (MEM_CLOSE : memory_close tview memory) :
  memory_close tview memory'.
Proof using.
  red; splits; ins.
  all: eapply closedness_preserved_cancel; eauto.
  all: by apply MEM_CLOSE.
Qed.


(** Type Checker for TAL-0: Control-Flow-Safety *)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import TAL.Maps.
Require Import TAL.TAL0.Eval.
Require Import TAL.TAL0.Syntax.
Require Import TAL.TAL0.TypeSyntax.
Import ListNotations.

(** * The TAL-0 Type System *)
(*--------------------------*)

(** Definition of a context for the typing rules: *)

Inductive ctx :=
  | EmptyCtx    : ctx
  | PsiCtx      : ty_map -> ctx
  | PsiGammaCtx : ty_map -> ty_map -> ctx.

(** Typing rules for values: *)

Inductive value_has_type : ctx -> val -> ty -> Prop :=
  | S_Int : forall Ψ n,
    value_has_type (PsiCtx Ψ) (VNum n) int
  | S_Lab : forall Ψ l τ,
    ty_lookup Ψ l = Some τ -> value_has_type (PsiCtx Ψ) (VLbl l) τ.

(** Typing rules for operands: *)

Inductive val_has_type : ctx -> val -> ty -> Prop :=
  | S_Reg  : forall Ψ Γ r τ,
    ty_lookup_int Γ r = τ -> val_has_type (PsiGammaCtx Ψ Γ) (VReg r) τ
  | S_Val  : forall Ψ Γ v τ,
    value_has_type (PsiCtx Ψ) v τ -> val_has_type (PsiGammaCtx Ψ Γ) v τ
  | S_Inst : forall Ψ Γ v τ τ' τ'' α,
    val_has_type (PsiGammaCtx Ψ Γ) v (∀α.>τ)
      -> replace_ty τ α τ' = τ''
      -> val_has_type (PsiGammaCtx Ψ Γ) v τ''.

(** Typing rules for instructions: *)

Inductive instr_has_type : ctx -> instr -> ty_map * ty_map -> Prop :=
  | S_Mov : forall Ψ Γ Γ' d v τ,
    val_has_type (PsiGammaCtx Ψ Γ) v τ
      -> ty_update Γ d τ = Γ'
      -> instr_has_type (PsiCtx Ψ) (IMov d v) (Γ, Γ')
  | S_Add : forall Ψ Γ Γ' d s v,
    val_has_type (PsiGammaCtx Ψ Γ) (VReg s) int
      -> val_has_type (PsiGammaCtx Ψ Γ) v int
      -> ty_update Γ d int = Γ'
      -> instr_has_type (PsiCtx Ψ) (IAdd d s v) (Γ, Γ')
  | S_If  : forall Ψ Γ r v,
    val_has_type (PsiGammaCtx Ψ Γ) (VReg r) int
      -> val_has_type (PsiGammaCtx Ψ Γ) v code(Γ)
      -> instr_has_type (PsiCtx Ψ) (IJIf r v) (Γ, Γ).

(** Typing rules for instruction sequences: *)

Inductive instr_seq_has_type : ctx -> instr_seq -> ty -> Prop :=
  | S_Jump : forall Ψ Γ v,
    val_has_type (PsiGammaCtx Ψ Γ) v code(Γ)
      -> instr_seq_has_type (PsiCtx Ψ) (IJmp v) code(Γ)
  | S_Seq  : forall Ψ Γ Γ2 ι I,
    instr_has_type (PsiCtx Ψ) ι (Γ, Γ2)
      -> instr_seq_has_type (PsiCtx Ψ) I code(Γ2)
      -> instr_seq_has_type (PsiCtx Ψ) (ι ;; I) code(Γ)
  | S_Gen  : forall Ψ I α τ,
    instr_seq_has_type (PsiCtx Ψ) I τ
      -> instr_seq_has_type (PsiCtx Ψ) I (∀α.>τ).

(** Typing rules for register files: *)

Inductive regs_has_type : ctx -> regs -> ty_map -> Prop :=
  | S_Regfile : forall Ψ Γ R,
    (forall r, exists v τ, to_val (R (Id r)) = v
                             /\ ty_lookup_int Γ r = τ
                             /\ value_has_type (PsiCtx Ψ) v τ)
      -> regs_has_type (PsiCtx Ψ) R Γ.

(** Typing rules for heaps: *)

Inductive heap_has_type : ctx -> heap -> ty_map -> Prop :=
  | S_Heap : forall Ψ H,
    (forall l, ty_lookup Ψ l = None
                 \/ (exists I τ, H (Id l) = Some I
                                   /\ ty_lookup Ψ l = Some τ
                                   /\ instr_seq_has_type (PsiCtx Ψ) I τ
                                   /\ ftv_null τ))
      -> heap_has_type EmptyCtx H Ψ.

(** Typing rules for machine states: *)

Inductive mstate_ok : ctx -> mstate -> Prop :=
  | S_Mach : forall Ψ Γ H R I,
    heap_has_type EmptyCtx H Ψ
      -> regs_has_type (PsiCtx Ψ) R Γ
      -> instr_seq_has_type (PsiCtx Ψ) I code(Γ)
      -> mstate_ok EmptyCtx (MSt H R I).

(** In addition to the relations from above we now provide functions for
    type-checking of operands, instructions and so on.
*)

(** Returns the type of the given value by using the given context.
    If no type can be found, [None] is returned.
*)

Definition value_type (c : ctx) (v : val) : option ty :=
  match c, v with
    | PsiCtx _, VNum _ => Some int
    | PsiCtx Ψ, VLbl l => ty_lookup Ψ l
    | _,        _      => None
  end.

(** Returns the type of the given operand by using the given context.
    If no type can be found, [None] is returned.
*)

Definition val_type (c : ctx) (v : val) : option ty :=
  match c, v with
    | PsiGammaCtx _ Γ, VReg r => ty_lookup Γ r
    | PsiGammaCtx Ψ _, _      => value_type (PsiCtx Ψ) v
    | _,               _      => None
  end.

(** Returns a substitution type for the given type variable in the first type
    by unifying the first type with the second type.
    If no type can be found, [None] is returned.
*)

Fixpoint ty_var_subst (τ : ty) (τ' : ty) (α : nat) : option ty :=
  match τ, τ' with
    | int,      _        => None
    | code(Γ),  code(Γ') =>
      (fix ty_map_var_subst (xs : ty_map) (ys : ty_map) : option ty :=
         match xs, ys with
           | (_, t) :: tm1, (_, t') :: tm2 =>
             match ty_var_subst t t' α with
               | None   => ty_map_var_subst tm1 tm2
               | x      => x
             end
           | _,             _              => None
         end) Γ Γ'
    | code(_),  _        => None
    | TAlpha β, _        => if beq_nat α β then Some τ' else None
    | ∀β.>t,    ∀_.>t'   => if beq_nat α β then None else ty_var_subst t t' α
    | ∀β.>t,    _        => if beq_nat α β then None else ty_var_subst t τ' α
  end.

(** Removes the first quantifier in the beginning of the given type. *)

Definition ty_remove_quantifier (τ : ty) : ty :=
  match τ with
    | ∀_.>τ' => τ'
    | _      => τ
  end.

(** Instantiates the type variables, that are quantified in the beginning of the
    first type, with a concrete type by unifying the first type with the second
    type. This function implements the typing rule [S_Inst].
*)

Definition ty_inst (τ : ty) (τ' : ty) : ty :=
  (fix ty_inst' (τ1 : ty) (τ2 : ty) : ty :=
     if beq_ty τ2 τ'
       then τ2
       else match τ1 with
              | ∀α.>t => match ty_var_subst t τ' α with
                           | None    => τ2
                           | Some t' => let τ2' := ty_remove_quantifier τ2
                                         in ty_inst' t (replace_ty τ2' α t')
                         end
              | _     => τ2
            end) τ τ.

(** Returns the type of the given instruction by using the given context and
    the given register file type.
    If no type can be found, [None] is returned.
*)

Definition instr_type (c : ctx) (Γ : ty_map) (ι : instr)
  : option (ty_map * ty_map) :=
  match c, ι with
    | PsiCtx Ψ, IMov d v   => match val_type (PsiGammaCtx Ψ Γ) v with
                                | None   => None
                                | Some τ => Some (Γ, ty_update Γ d τ)
                              end
    | PsiCtx Ψ, IAdd d s v =>
      let ctx := PsiGammaCtx Ψ Γ
       in match val_type ctx (VReg s), val_type ctx v with
            | Some τ, Some τ' => if beq_ty int (ty_inst τ int)
                                      && beq_ty int (ty_inst τ' int)
                                   then Some (Γ, ty_update Γ d int)
                                   else None
            | _,      _       => None
          end
    | PsiCtx Ψ, IJIf r v   =>
      let ctx := PsiGammaCtx Ψ Γ
       in match val_type ctx (VReg r), val_type ctx v with
            | Some τ, Some τ' => if beq_ty int (ty_inst τ int)
                                      && beq_ty code(Γ) (ty_inst τ' code(Γ))
                                   then Some (Γ, Γ)
                                   else None
            | _,      _       => None
          end
    | _,        _          => None
  end.

(** Returns the type of the given instruction sequence by using the given
    context and the given register file type.
    If no type can be found, [None] is returned.
*)

Fixpoint instr_seq_type (c : ctx) (Γ : ty_map) (I : instr_seq) : option ty :=
  match c, I with
    | PsiCtx Ψ, IJmp v  =>
      match val_type (PsiGammaCtx Ψ Γ) v with
        | None   => None
        | Some τ => if beq_ty code(Γ) (ty_inst τ code(Γ))
                      then Some code(Γ)
                      else None
      end
    | PsiCtx Ψ, ι ;; I' =>
      match instr_type (PsiCtx Ψ) Γ ι, instr_seq_type (PsiCtx Ψ) Γ I' with
        | Some (Γ1, Γ2), Some code(Γ3) => if beq_ty_map Γ2 Γ3
                                            then Some code(Γ1)
                                            else None
        | _,             _             => None
      end
    | _,        _       => None
  end.

(** Checks whether the given register file is typed with the given register file
    type by using the given context.
*)

Definition regs_typed (c : ctx) (Γ : ty_map) (R : regs) : bool :=
  match c with
    | PsiCtx Ψ =>
      forallb (fun p => match value_type c (to_val (R (Id (fst p)))) with
                          | None   => false
                          | Some τ => beq_ty τ (snd p)
                        end) Γ
    | _        => false
  end.

(** Checks whether the first type can be generalized with new quantified type
    variables so that the resulting type is equal to the second type.
    This function implements the typing rule [S_Gen].
*)

Fixpoint ty_gen (τ : ty) (τ' : ty) : bool :=
  beq_ty τ τ' || match τ' with
                   | ∀_.>τ'' => ty_gen τ τ''
                   | _       => false
                 end.

(** Checks whether the given heap is typed with the given heap type by using the
    given register file type.
*)

Definition heap_typed (Ψ : ty_map) (Γ : ty_map) (H : heap) : bool :=
  forallb (fun p => match H (Id (fst p)) with
                      | None    => true
                      | Some Is => match instr_seq_type (PsiCtx Ψ) Γ Is with
                                     | None   => false
                                     | Some τ => ty_gen τ (snd p)
                                                   && ftv_null_b (snd p)
                                   end
                    end) Ψ.

(** Checks whether the given machine state is well-typed. *)

Definition mstate_ok_b (Ψ : ty_map) (Γ : ty_map) (ms : mstate) : bool :=
  match ms with
    | MSt H R Is => match heap_typed Ψ Γ H,
                          regs_typed (PsiCtx Ψ) Γ R,
                          instr_seq_type (PsiCtx Ψ) Γ Is with
                      | true, true, Some code(Γ') => beq_ty_map Γ Γ'
                      | _,    _,    _             => false
                    end
  end.

(** We prove some useful type substitution lemmas: *)

Lemma ty_subst_val : forall (Ψ Ψ' Γ Γ' : ty_map) (α : nat) (v : val)
                            (τ τ' τ'' : ty),
  val_has_type (PsiGammaCtx Ψ Γ) v τ
    -> replace_ty τ α τ' = τ''
    -> replace_ty_map Ψ α τ' = Ψ'
    -> replace_ty_map Γ α τ' = Γ'
    -> val_has_type (PsiGammaCtx Ψ' Γ') v τ''.
Proof.
Admitted.

Lemma ty_subst_instr : forall (Ψ Γ1 Γ1' Γ2 Γ2' : ty_map) (α : nat) (ι : instr)
                              (τ : ty),
  instr_has_type (PsiCtx Ψ) ι (Γ1, Γ2)
    -> replace_ty_map Γ1 α τ = Γ1'
    -> replace_ty_map Γ2 α τ = Γ2'
    -> instr_has_type (PsiCtx Ψ) ι (Γ1', Γ2').
Proof.
Admitted.

Lemma ty_subst_instr_seq : forall (Ψ : ty_map) (I : instr_seq) (α : nat)
                                  (τ τ' τ'' : ty),
  instr_seq_has_type (PsiCtx Ψ) I τ
    -> replace_ty τ α τ' = τ''
    -> instr_seq_has_type (PsiCtx Ψ) I τ''.
Proof.
Admitted.

Lemma ty_subst_regs : forall (Ψ Γ Γ' : ty_map) (R : regs) (α : nat) (τ : ty),
  regs_has_type (PsiCtx Ψ) R Γ
    -> replace_ty_map Γ α τ = Γ'
    -> regs_has_type (PsiCtx Ψ) R Γ'.
Proof.
Admitted.

(** The register substitution lemma ensures that typing is preserved when we
    look up a value in the register file.
*)

Lemma regs_subst : forall (Ψ Γ : ty_map) (H : heap) (R : regs) (v v' : val)
                          (τ : ty),
  heap_has_type EmptyCtx H Ψ
    -> regs_has_type (PsiCtx Ψ) R Γ
    -> val_has_type (PsiGammaCtx Ψ Γ) v τ
    -> to_val (reval v R) = v'
    -> value_has_type (PsiCtx Ψ) v' τ.
Proof.
Admitted.

(** We prove some canonical values and canonical operands lemmas: *)

Lemma cc_values_int : forall (Ψ : ty_map) (H : heap) (v : val),
  heap_has_type EmptyCtx H Ψ
    -> value_has_type (PsiCtx Ψ) v int
    -> exists n, v = VNum n.
Proof.
  intros Ψ H v H0 H1.
  inversion H1; subst.
  - exists n.
    reflexivity.
  - inversion H0.
    subst.
    specialize H4 with (l := l).
    destruct H4 as [H2|H4].
    + rewrite H2 in H3.
      inversion H3.
    + destruct H4 as [I [τ [H4 [H5 [H6 H7]]]]].
      inversion H6; subst; rewrite H3 in H5; inversion H5.
Qed.

Lemma cc_values_lbl : forall (Ψ Γ : ty_map) (H : heap) (v : val),
  heap_has_type EmptyCtx H Ψ
    -> value_has_type (PsiCtx Ψ) v code(Γ)
    -> exists l I, v = VLbl l /\ H (Id l) = Some I
                              /\ instr_seq_has_type (PsiCtx Ψ) I code(Γ).
Proof.
  intros Ψ Γ H v H0 H1.
  inversion H1.
  subst.
  exists l.
  inversion H0.
  subst.
  specialize H4 with (l := l).
  destruct H4 as [H2|H4].
  - rewrite H2 in H3.
    inversion H3.
  - destruct H4 as [I [τ [H4 [H5 [H6 H7]]]]].
    exists I.
    split.
    + reflexivity.
    + split.
      * assumption.
      * rewrite H5 in H3.
        inversion H3.
        subst.
        assumption.
Qed.

Lemma cc_operands_int : forall (Ψ Γ : ty_map) (H : heap) (R : regs) (v : val),
  heap_has_type EmptyCtx H Ψ
    -> regs_has_type (PsiCtx Ψ) R Γ
    -> val_has_type (PsiGammaCtx Ψ Γ) v int
    -> exists n, reval v R = RNum n.
Proof.
Admitted.

Lemma cc_operands_lbl : forall (Ψ Γ : ty_map) (H : heap) (R : regs) (v : val),
  heap_has_type EmptyCtx H Ψ
    -> regs_has_type (PsiCtx Ψ) R Γ
    -> val_has_type (PsiGammaCtx Ψ Γ) v code(Γ)
    -> exists l I, reval v R = RLbl l
                     /\ H (Id l) = Some I
                     /\ instr_seq_has_type (PsiCtx Ψ) I code(Γ).
Proof.
Admitted.

(** Finally the proof of Soundness for TAL-0: *)

Theorem soundness : forall (ms : mstate),
  mstate_ok EmptyCtx ms
    -> exists ms', mseval_prop ms ms' /\ mstate_ok EmptyCtx ms'.
Proof.
  intros [H R I] H0.
  inversion H0.
  subst.
  destruct I.
  - inversion H7.
    subst.
    pose proof (cc_operands_lbl Ψ Γ H R v H5 H6 H4).
    destruct H1 as [l [I [H8 [H9 H10]]]].
    exists (MSt H R I).
    split.
    + eapply R_Jump; eassumption.
    + eapply S_Mach; eassumption.
  - destruct i.
    + inversion H7.
      subst.
      inversion H8.
      subst.
      pose proof (regs_subst Ψ Γ H R v _ τ H5 H6 H10 eq_refl).
      exists (MSt H (t_update R (Id n) (reval v R)) I).
      split.
      * eapply R_Mov; reflexivity.
      * eapply S_Mach.
        -- eassumption.
        -- apply S_Regfile with (Γ := ty_update Γ n τ).
           intros r.
           compare r n.
           ++ intros H13.
              exists (to_val (reval v R)).
              exists τ.
              split.
              ** rewrite H13.
                 rewrite t_update_eq.
                 reflexivity.
              ** split.
                 --- rewrite H13.
                     unfold ty_lookup_int.
                     rewrite ty_update_eq.
                     reflexivity.
                 --- assumption.
           ++ intros H13.
              exists (to_val (R (Id r))).
              exists (ty_lookup_int Γ r).
              split.
              ** rewrite t_update_neq.
                 --- reflexivity.
                 --- congruence.
              ** split.
                 --- unfold ty_lookup_int.
                     rewrite (ty_update_neq _ _ _ _ H13).
                     reflexivity.
                 --- inversion H6.
                     subst.
                     specialize H3 with (r := r).
                     destruct H3 as [v2 [τ2 [H3 [H14 H15]]]].
                     subst.
                     assumption.
        -- assumption.
    + inversion H7.
      subst.
      inversion H8.
      subst.
      pose proof (cc_operands_int Ψ Γ H R v H5 H6 H13).
      destruct H1 as [n2 H14].
      inversion H6.
      subst.
      specialize H2 with (r := n0).
      destruct H2 as [v2 [τ [H2 [H15 H16]]]].
      apply (cc_operands_int _ _ H R _ H5 H6) in H11.
      destruct H11 as [n1 H11].
      simpl in H11.
      exists (MSt H (t_update R (Id n) (RNum (Z.add n1 n2))) I).
      split.
      * eapply R_Add; try eassumption. reflexivity.
      * eapply S_Mach.
        -- eassumption.
        -- apply S_Regfile with (Γ := ty_update Γ n int).
           intros r.
           compare r n.
           ++ intros H17.
              exists (VNum (Z.add n1 n2)).
              exists int.
              rewrite H17.
              split.
              ** rewrite t_update_eq.
                 simpl.
                 reflexivity.
              ** split.
                 --- unfold ty_lookup_int.
                     rewrite ty_update_eq.
                     reflexivity.
                 --- apply S_Int.
           ++ intros H17.
              exists (to_val (R (Id r))).
              exists (ty_lookup_int Γ r).
              split.
              ** rewrite t_update_neq.
                 --- reflexivity.
                 --- congruence.
              ** split.
                 --- unfold ty_lookup_int.
                     rewrite (ty_update_neq _ _ _ _ H17).
                     reflexivity.
                 --- inversion H6.
                     subst.
                     specialize H3 with (r := r).
                     destruct H3 as [v2 [τ [H3 [H18 H19]]]].
                     subst.
                     assumption.
        -- assumption.
    + inversion H7.
      subst.
      inversion H8.
      subst.
      pose proof (cc_operands_lbl Ψ Γ2 H R v H5 H6 H12).
      destruct H1 as [l [I2 [H13 [H14 H15]]]].
      pose proof (cc_operands_int Ψ Γ2 H R (VReg n) H5 H6 H10).
      destruct H1 as [m H16].
      destruct m.
      * exists (MSt H R I2).
        split.
        -- simpl in H16.
           eapply R_If_Eq; eassumption.
        -- eapply S_Mach; eassumption.
      * exists (MSt H R I).
        split.
        -- simpl in H16.
           eapply R_If_Neq.
           ++ eassumption.
           ++ congruence.
        -- eapply S_Mach; eassumption.
      * exists (MSt H R I).
        split.
        -- simpl in H16.
           eapply R_If_Neq.
           ++ eassumption.
           ++ congruence.
        -- eapply S_Mach; eassumption.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e512m569_16limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import AggregateType.demo1.expr.

Fixpoint reptype (t: type): Type :=
  match t with
  | Tint => val
  | Tstruct _ fs => reptype_fieldlist fs
  end
with reptype_fieldlist (fs: fieldlist) : Type :=
  match fs with
  | Fnil => unit
  | Fcons (_, t) fs_tl => prod (reptype t) (reptype_fieldlist fs_tl)
  end.

Fixpoint default_val (t: type): reptype t :=
  match t as t_PAT return reptype t_PAT with
  | Tint => Vundef
  | Tstruct _ fs => default_val_fieldlist fs
  end
with default_val_fieldlist (fs: fieldlist) : reptype_fieldlist fs :=
  match fs as fs_PAT return reptype_fieldlist fs_PAT with
  | Fnil => tt
  | Fcons (_, t) fs_tl => (default_val t, default_val_fieldlist fs_tl)
  end.

Open Scope logic.

Fixpoint data_at_rec (t: type)
  (v: reptype t) : val -> Pred :=
  match t as t_PAT
  return reptype t_PAT -> val -> Pred with
  | Tint => fun v p =>
      mapsto p v
  | Tstruct _ fs => fun v p =>
      data_at_rec_fieldlist fs v fs p
  end v
with data_at_rec_fieldlist (fs: fieldlist)
 (v: reptype_fieldlist fs) (full_fs: fieldlist): val -> Pred :=
  match fs as fs_PAT
  return reptype_fieldlist fs_PAT -> val -> Pred with
  | Fnil => fun v p =>
      emp
  | Fcons (id, t) fs_tl => fun v p=>
      data_at_rec t (fst v)
        (offset_val (field_offset id full_fs) p)*
      data_at_rec_fieldlist fs_tl (snd v) full_fs p
  end v.

Fixpoint nested_pred (atom_pred: type -> Prop) (t: type): Prop :=
  match t with
  | Tint => atom_pred t
  | Tstruct _ fs => atom_pred t /\ nested_pred_fieldlist atom_pred fs
  end
with nested_pred_fieldlist (atom_pred: type -> Prop) (fs: fieldlist): Prop :=
  match fs with
  | Fnil => True
  | Fcons (i0, t0) fs0 => nested_pred atom_pred t0 /\ nested_pred_fieldlist atom_pred fs0
  end.

Lemma nested_pred_atom_pred: forall atom_pred t, nested_pred atom_pred t -> atom_pred t.
Proof.
  intros.
  destruct t; simpl in H; tauto.
Qed.

Definition legal_type: type -> Prop :=
  nested_pred
   (fun t => match t with
             | Tint => True
             | Tstruct _ fs => members_no_replicate fs
             end).


From iris.program_logic Require Export language ectx_language ectxi_language.
From Autosubst Require Export Autosubst.
From iris.prelude Require Import options.

Module stlc.
  Inductive expr :=
    | Var (x : var)
    | Lam (e : {bind 1 of expr})
    | App (e1 e2 : expr)
    (* Unit *)
    | Unit
    (* Products *)
    | Pair (e1 e2 : expr)
    | Fst (e : expr)
    | Snd (e : expr)
    (* Sums *)
    | InjL (e : expr)
    | InjR (e : expr)
    | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr}).

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

  Inductive val :=
    | LamV (e : {bind 1 of expr})
    | UnitV
    | PairV (v1 v2 : val)
    | InjLV (v : val)
    | InjRV (v : val).

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr}).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    end.

  Definition state : Type := ().

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Global Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Global Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κ e2 σ2 ef :
    head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.
End stlc.

(** Language *)
Canonical Structure stlc_ectxi_lang := EctxiLanguage stlc.lang_mixin.
Canonical Structure stlc_ectx_lang := EctxLanguageOfEctxi stlc_ectxi_lang.
Canonical Structure stlc_lang := LanguageOfEctx stlc_ectx_lang.

Export stlc.

Global Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Global Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Global Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Global Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Global Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.


Set Implicit Arguments.

Require Import LNameless_Meta.
Require Import LNameless_Meta_Env.
Require Import LNameless_Isomorphism.
Require Import LNameless_STLC_Iso.
Require Export LN_Template.

(* Module Export M_tt := LNTemplate Iso_trm Iso_trm. *)

Module Export M_tt := FWellformed Iso_trm Iso_trm.
Module Export M_yt := PWellformed Iso_typ Iso_trm.

Module MT := Iso_trm.
Module MY := Iso_typ.

  (**************************************************************)
  (** * Tactics I *)
  (**************************************************************)

  (** A tactic unfolding everything *)

  Ltac gunfold :=
    unfold Twf, Twf_basic in *;
    unfold gTwf, gTwf_basic, wf_basic in *;
    unfold Tfsubst, Tbsubst, Tfv, TwfT, TenvT, TSize in *;
    intros;
    repeat rewrite MT.To_From in *;
    repeat rewrite MT.From_To in *;
    repeat rewrite MY.To_From in *;
    simpl in *;
    simpl_env in *.

  (** Substitution Lemma *)

  Lemma Tfsubst_Lemma : forall (T U V:MT.TT)(a b : nat),
    a <> b ->
    a `notin` (Tfv V) ->
    Tfsubst (Tfsubst T a U) b V =
    Tfsubst (Tfsubst T b V) a (Tfsubst U b V).
  Proof.
    gunfold; f_equal; auto using fsubstitution.
  Qed.

  (**************************************************************)
  (** * Permutation of substitutions *)
  (**************************************************************)

  (** Swapping of substitutions for (bound) variables. *)

  (* Tbsubst_homo_1 => Tbsubst_homo_wf *)
  Lemma Tbsubst_homo_wf : forall (T:MT.TT) k l (U V:MT.TT),
    k <> l ->
    Twf U ->
    Twf V ->
    Tbsubst (Tbsubst T k U) l V = Tbsubst (Tbsubst T l V) k U.
  Proof.
    introv Hneq Hu Hv.
    puts (Twf_gTwf Hu); clear Hu.
    puts (Twf_gTwf Hv); clear Hv.
    gunfold; f_equal; apply* bsubstitution_homo_wf.
  Qed.

  (* Tbsubst_var_twice_1 => Tbsubst_var_twice_wf *)
  Lemma Tbsubst_var_twice_wf : forall (T:MT.TT) k (U V:MT.TT),
    Twf V ->
    Tbsubst T k V = Tbsubst (Tbsubst T k V) k U.
  Proof.
    introv Hwf.
    puts (Twf_gTwf Hwf); clear Hwf.
    gunfold; f_equal; apply* bsubstitution_var_twice_wf.
  Qed.

  Lemma Tbfsubst_permutation_core : forall (T U V:MT.TT) (a:nat),
    TwfT U ->
    forall (k:nat),
      Tbsubst (Tfsubst T a U) k (Tfsubst V a U)
      = Tfsubst (Tbsubst T k V) a U.
  Proof.
    gunfold; rewrite bfsubst_permutation_core; auto.
  Qed.

  Lemma Tbfsubst_permutation_core_wf : forall (T U V:MT.TT) (a:nat),
    Twf U ->
    forall (k:nat),
      Tbsubst (Tfsubst T a U) k (Tfsubst V a U)
      = Tfsubst (Tbsubst T k V) a U.
  Proof.
    introv H.
    cut (gTwf U); auto 2.
    gunfold; rewrite bfsubst_permutation_core_wf; auto.
  Qed.

  Lemma Tbfsubst_permutation_ind : forall (T U V:MT.TT) (a:nat),
    TwfT U ->
    a `notin` (Tfv V) ->
    forall (k:nat),
      Tbsubst (Tfsubst T a U) k V = Tfsubst (Tbsubst T k V) a U.
  Proof.
    gunfold; rewrite bfsubst_permutation_ind; auto.
  Qed.

  Lemma Tbfsubst_permutation_ind_wf : forall (T U V:MT.TT) (a:nat),
    Twf U ->
    a `notin` (Tfv V) ->
    forall (k:nat),
      Tbsubst (Tfsubst T a U) k V = Tfsubst (Tbsubst T k V) a U.
  Proof.
    introv H.
    cut (gTwf U); auto 2.
    gunfold; rewrite bfsubst_permutation_ind_wf; auto.
  Qed.

  Lemma Tbfsubst_permutation_wfT : forall (T U V:MT.TT) (a:nat),
    TwfT U ->
    a `notin` (Tfv V) ->
    Tbsubst (Tfsubst T a U) 0 V = Tfsubst (Tbsubst T 0 V) a U.
  Proof.
    gunfold; f_equal; auto using bfsubst_permutation_wfT.
  Qed.

  Lemma Tbfsubst_permutation_wf : forall (T U V:MT.TT) (a:nat),
    Twf U ->
    a `notin` (Tfv V) ->
    Tbsubst (Tfsubst T a U) 0 V = Tfsubst (Tbsubst T 0 V) a U.
  Proof.
    introv H.
    cut (gTwf U); auto 2.
    gunfold; f_equal; auto using bfsubst_permutation_wf.
  Qed.

  Lemma Tbfsubst_permutation_var_wfT : forall (T U:MT.TT) (a b:nat),
    a <> b ->
    TwfT U ->
    Tbsubst (Tfsubst T a U) 0 (MT.To (Var MT.RR (inl b))) =
    Tfsubst (Tbsubst T 0 (MT.To (Var MT.RR (inl b)))) a U.
  Proof.
    gunfold; f_equal; auto using bfsubst_permutation_var_wfT.
  Qed.

  Lemma Tbfsubst_permutation_var_wf : forall (T U:MT.TT) (a b:nat),
    a <> b ->
    Twf U ->
    Tbsubst (Tfsubst T a U) 0 (MT.To (Var MT.RR (inl b))) =
    Tfsubst (Tbsubst T 0 (MT.To (Var MT.RR (inl b)))) a U.
  Proof.
    introv H H0.
    cut (gTwf U); auto 2.
    gunfold; f_equal; auto using bfsubst_permutation_var_wf.
  Qed.

  (**************************************************************)
  (** * Preservation of well-formedness *)
  (**************************************************************)

  (** Substitutions preserve well-formedness. *)

  (* wfT_Tfsubst => TwfT_Tfsubst *)
  Lemma TwfT_Tfsubst : forall (T U:MT.TT) (a:nat),
    TwfT T ->
    TwfT U ->
    TwfT (Tfsubst T a U).
  Proof.
    gunfold; auto using wfT_fsubst.
  Qed.

  (* wf_Tfsubst => Twf_Tfsubst *)
  Lemma Twf_Tfsubst : forall (T U:MT.TT) (a:nat),
    Twf T ->
    Twf U ->
    Twf (Tfsubst T a U).
  Proof.
    introv H H0.
    cut (gTwf T); auto 2.
    cut (gTwf U); auto 2; intros.
    cut (gTwf (Tfsubst T a U)); auto 2.
    gunfold; auto using wf_fsubst.
  Qed.

  (**************************************************************)
  (** * Well-formedness in an environment *)
  (**************************************************************)

  (** Well-formed terms/types in an environment are well-formed. *)

  Lemma TenvT_TwfT : forall (E:env MY.TT)(T:MT.TT),
    TenvT E T ->
    TwfT T.
  Proof.
    gunfold; eauto using envT_wfT.
  Qed.

  Hint Resolve TenvT_TwfT.

  (* Tbsubst_on_env => TenvT_Twf *)
  Lemma TenvT_Twf : forall (E:env MY.TT)(T:MT.TT),
    TenvT E T -> forall (k:nat) (U:MT.TT), T = Tbsubst T k U.
  Proof.
    intros; eauto using TenvT_TwfT, M.TwfT_Twf.
  Qed.

  (** Environments capture all the parameters in terms/types *)
  Lemma envT_Tfv : forall (E:env MY.TT) (T:MT.TT) (a:atom),
    a # E -> TenvT E T -> a `notin` Tfv T.
  Proof.
    gunfold;
    apply envT_fv with (r':= MY.RR)(E:= map MY.From E); auto.
  Qed.

  Lemma TenvT_dom_subset : forall (E:env MY.TT) (T:MT.TT),
    TenvT E T -> Tfv T [<=] dom E.
  Proof.
    gunfold; intros a H0; apply dom_map_2 with (f:=MY.From).
    generalize dependent a; apply envT_dom_subset; auto.
  Qed.

  (** Parameter substitution for a fresh parameter *)

  Lemma Tfsubst_fresh : forall (E:env MY.TT)(T U:MT.TT)(a:nat),
    a # E -> TenvT E T -> T = Tfsubst T a U.
  Proof.
    gunfold; erewrite <- fsubst_fresh; eauto; auto.
  Qed.

  (** Permutation of substitutions when [TenvT] holds *)

  Lemma Tbfsubst_permutation : forall (E:env MY.TT)(T U V:MT.TT)(a:nat),
    TenvT E U ->
    a `notin` (Tfv V) ->
    Tbsubst (Tfsubst T a U) 0 V = Tfsubst (Tbsubst T 0 V) a U.
  Proof.
    gunfold; f_equal; eauto using bfsubst_permutation.
  Qed.

  Lemma Tbfsubst_permutation_var : forall (E:env MY.TT)(T U:MT.TT)(a b:nat),
    a <> b ->
    TenvT E U ->
    Tbsubst (Tfsubst T a U) 0 (MT.To (Var MT.RR (inl b))) =
    Tfsubst (Tbsubst T 0 (MT.To (Var MT.RR (inl b)))) a U.
  Proof.
    gunfold; f_equal; eauto using bfsubst_permutation_var.
  Qed.

  (**************************************************************)
  (** * Tactics II *)
  (**************************************************************)

  (** The following tactics can be used in concrete formalizations.
     They help the end user of the DGP libraries in the way that
     the end user don't need to look into the generic library.
     - [auto_rewrite] rewrites all the basic equalities
       from the [isorew] autorewrite library.

     - [gsimpl] makes [Tfsubst], [Tbsubst], [Tsize], etc. in
       each patters behaves as if they are resursively defined
       in the object languages.

     - [gsimpl in H] simplifies the assumptions as expectied.

     - [gconstructor] is useful e.g. when proving the equivalence
       of the generic and concrete version of well-formedness.

     - The other tactics are auxiliary. *)

  (** [auto_rewrite]  *)

  Ltac auto_rewrite :=
    try case_var;
    intros;
    autorewrite with isorew in *;
    simpl in *;
    auto 1.

  (** [gsimpl] *)

  Ltac gsimpl_bsubst :=
    unfold Tbsubst;
    simpl bsubst.

  Ltac gsimpl_fsubst :=
    unfold Tfsubst;
    simpl fsubst.

  Ltac from_freevars :=
    match goal with
      | _ : context [ freevars MT.RR (MT.From ?T) ] |- _ =>
        replace (freevars MT.RR (MT.From T)) with
          (Tfv T) in *; [idtac | auto]
      | |- context [ freevars MT.RR (MT.From ?T) ] =>
        replace (freevars MT.RR (MT.From T)) with
          (Tfv T) in *; [idtac | auto]
    end.

  Ltac gsimpl_fv :=
    unfold Tfv in *; simpl in *;
      repeat from_freevars;
        destruct_notin; try solve_notin.

  Ltac gsimpl_size :=
    unfold TSize;
    simpl.

  Ltac from_subst :=
    match goal with
      | _ : context [MT.To (fsubst (MT.From ?T) ?k (MT.From ?U))] |- _ =>
        replace (MT.To (fsubst (MT.From T) k (MT.From U))) with
          (Tfsubst T k U) in * |-; [idtac | unfold Tfsubst; reflexivity]
      | _ : context [MT.To (bsubst (MT.From ?T) ?k (MT.From ?U))] |- _ =>
        replace (MT.To (bsubst (MT.From T) k (MT.From U))) with
          (Tbsubst T k U) in * |-; [idtac | unfold Tbsubst; reflexivity]
    end.

  Ltac from_size :=
    match goal with
      | _ : context [ size (MT.From ?T) ] |- _ =>
        replace (size (MT.From T)) with
          (TSize T) in *; [idtac | unfold TSize in *; reflexivity]
    end.

  Ltac gsimpl := repeat (
    gsimpl_bsubst;
    gsimpl_fsubst;
    auto_rewrite;
    try gsimpl_fv;
    simpl_alist in *;
    try gsimpl_size;
    repeat from_subst;
    repeat from_freevars;
    destruct_notin; try solve_notin;
    repeat from_size;
    auto_rewrite);
    simpl_alist in *.

  (** [gsimpl in]  *)

  Tactic Notation "gsimpl_bsubst" "in" constr(H) :=
    unfold Tbsubst in H;
    simpl bsubst in H.

  Tactic Notation "gsimpl_fsubst" "in" constr(H) :=
    unfold Tfsubst in H;
    simpl fsubst in H.

  Tactic Notation "gsimpl_fv" "in" constr(H) :=
    unfold Tfv in H;
    simpl freevars in H.

  Tactic Notation "gsimpl_size" "in" constr(H) :=
    unfold TSize in H;
    simpl size in H.

  Tactic Notation "gsimpl" "in" constr(H) := repeat (
    gsimpl_bsubst in H;
    gsimpl_fsubst in H;
    auto_rewrite;
    try gsimpl_fv in H;
    simpl_alist in *;
    try gsimpl_size in H;
    repeat from_subst;
    repeat from_freevars;
    destruct_notin; try solve_notin;
    from_size).

  (** [gconstructor] *)

  Ltac apply_wfT :=
    match goal with
      | |- wfTRep _ (Unit) => apply wf_Unit
      | |- wfTRep _ (Const _ _) => apply wf_Const
      | |- wfTRep _ (InL _ _) => apply wf_InL
      | |- wfTRep _ (InR _ _) => apply wf_InR
      | |- wfTRep _ (Pair _ _) => apply wf_Pair
      | |- wfTRep _ (Bind _ _ _) =>
        let L := fresh "L" in
          let L := gather_atoms in
            apply wf_Bind_REC_homo with L; auto; simpl; intros; destruct_notin
      | |- wfTRep _ (Rec _) => apply wf_Rec
      | |- wfT _ (Var _ _) => apply wf_fvar; auto
      | |- wfT _ (Term _) => apply wf_Term
    end.

  Ltac gsimpl_subst :=
    unfold Tbsubst; simpl;
    unfold Tfsubst; simpl;
    try case_var; intros;
    autorewrite with isorew;
    simpl in *; auto*.

  Ltac from_wfT :=
    match goal with
      | |- wfT MT.RR (MT.From ?T) =>
        change (wfT MT.RR (MT.From T)) with (TwfT T); auto
      | |- wf MT.RR (MT.From ?T) =>
        change (wf MT.RR (MT.From T)) with (Twf T); auto
    end.

  Ltac gconstructor :=
    intros;
    unfold TwfT;
    simpl;
    repeat apply_wfT;
    gsimpl_subst;
    from_wfT.

  (** [gconstructor with]   *)

  Tactic Notation "apply_wfT" "with" constr(L) :=
    match goal with
      | |- wfTRep _ (Unit) => apply wf_Unit
      | |- wfTRep _ (Const _ _) => apply wf_Const
      | |- wfTRep _ (InL _ _) => apply wf_InL
      | |- wfTRep _ (InR _ _) => apply wf_InR
      | |- wfTRep _ (Pair _ _) => apply wf_Pair
      | |- wfTRep _ (Bind _ _ _) =>
        apply wf_Bind_REC_homo with L; auto; simpl; intros; destruct_notin
      | |- wfTRep _ (Rec _) => apply wf_Rec
      | |- wfT _ (Var _ _) => apply wf_fvar; auto
      | |- wfT _ (Term _) => apply wf_Term
    end.

  Tactic Notation "gconstructor" "with" constr(L) :=
    intros;
    unfold TwfT;
    simpl;
    repeat (apply_wfT with L);
    gsimpl_subst; from_wfT.

  (** Customization of [gather_atoms] which originally defined
     in [MetatheoryAtom.v]
     - [gather_atoms] collects all parameter which have occurrs
       during proof.  *)

  Ltac gather_atoms :=
    let A := gather_atoms_with (fun x : atoms => x) in
    let B := gather_atoms_with (fun x : atom => {{ x }}) in
    let C := gather_atoms_with (fun x : MT.TT => Tfv x) in
    let D := gather_atoms_with (fun A : Type => fun x : env A => dom x) in
      constr:(A `union` B `union` C `union` D).

  Tactic Notation "pick" "fresh" ident(Y) :=
    let L := gather_atoms in
      pick fresh Y for L.

  Ltac pick_fresh y :=
    pick fresh y.


(** * Grothendieck Construction of a pseudofunctor to Cat *)
Require Import FunctorCategory.Morphisms.
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Pseudofunctor.Core Pseudofunctor.RewriteLaws.
Require Import Category.Morphisms Cat.Morphisms.
Require Import Functor.Composition.Core.
Require Import Functor.Identity.
Require Import FunctorCategory.Core.
Require Import Basics Types HoTT.Tactics.

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

Local Open Scope morphism_scope.

Section Grothendieck.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable F : Pseudofunctor C.

  Record Pair :=
    {
      c : C;
      x : object (F c)
    }.

  Local Notation morphism s d :=
    { f : morphism C s.(c) d.(c)
    | morphism _ (p_morphism_of F f s.(x)) d.(x) }.

  Definition compose s d d'
             (m1 : morphism d d')
             (m2 : morphism s d)
  : morphism s d'.
  Proof.
    exists (m1.1 o m2.1).
    refine (m1.2 o ((p_morphism_of F m1.1) _1 m2.2 o _)).
    apply (p_composition_of F).
  Defined.

  Definition identity s : morphism s s.
  Proof.
    exists 1.
    apply (p_identity_of F).
  Defined.

  Global Arguments identity _ / .
  Global Arguments compose _ _ _ _ _ / .

  Local Ltac try_associativity_f_ap :=
    first [ f_ap; []
          | repeat (etransitivity; [ apply Category.Core.associativity | ]);
            repeat (etransitivity; [ | symmetry; apply Category.Core.associativity ]);
            f_ap; []
          | repeat (etransitivity; [ symmetry; apply Category.Core.associativity | ]);
            repeat (etransitivity; [ | apply Category.Core.associativity ]);
            f_ap; [] ].

  Local Ltac assoc_before_commutes_tac :=
    rewrite !composition_of;
    rewrite <- !Category.Core.associativity;
    etransitivity; [ | symmetry; apply compose4associativity_helper ].

  Local Ltac assoc_fin_tac :=
    repeat match goal with
             | _ => reflexivity
             | _ => progress rewrite ?Category.Core.left_identity, ?Category.Core.right_identity
             | [ |- context[components_of ?T ?x o components_of ?T^-1 ?x] ]
               => let k := constr:(@iso_compose_pV _ _ _ (T x) _) in
                  simpl rewrite k (* https://coq.inria.fr/bugs/show_bug.cgi?id=3773 and https://coq.inria.fr/bugs/show_bug.cgi?id=3772 (probably) *)
             | _ => try_associativity_quick
                      first [ f_ap; []
                            | apply concat_left_identity
                            | apply concat_right_identity ]
             | _ => rewrite <- ?identity_of, <- ?composition_of;
                   progress repeat (f_ap; []);
                   rewrite ?identity_of, ?composition_of
             | _ => try_associativity_quick rewrite compose4associativity_helper
           end.

  Local Ltac helper_t before_commutes_tac :=
    repeat intro;
    symmetry;
    apply path_sigma_uncurried;
    simpl in *;
    let ex_hyp := match goal with
                    | [ H : ?A = ?B |- @sig (?B = ?A) _ ] => constr:(H)
                  end in
    (exists (inverse ex_hyp));
      simpl;
      rewrite ?transport_Fc_to_idtoiso, ?transport_cF_to_idtoiso;
      rewrite ?idtoiso_inv, ?ap_V, ?inv_V;
      simpl;
      let rew_hyp := match goal with
                       | [ H' : context[ex_hyp] |- _ ] => constr:(H')
                     end in
      rewrite rew_hyp;
        clear rew_hyp ex_hyp;
        before_commutes_tac;
        repeat first [ reflexivity
                     | progress rewrite ?Category.Core.left_identity, ?Category.Core.right_identity
                     | try_associativity_quick (f_ap; []) ];
        match goal with
          | _ => reflexivity
          | [ |- context[?F _1 ?m o components_of ?T ?x] ]
            => simpl rewrite <- (commutes T _ _ m);
              try reflexivity
          | [ |- context[components_of ?T ?x o ?F _1 ?m] ]
            => simpl rewrite (commutes T _ _ m);
              try reflexivity
        end.

  (* The goal for, e.g., the following associativity helper was made
  with the following code:
<<
intros a b c d [f f'] [g g'] [h h']; simpl.
    pose proof (apD10 (ap components_of (p_composition_ofCoherent_for_rewrite F _ _ _ _ f g h))) as rew_hyp.
    revert rew_hyp.
    generalize dependent (Category.Core.associativity C _ _ _ _ f g h). intros fst_hyp ?.

    simpl in *.
    hnf in rew_hyp.
    simpl in *.

    Local Ltac gen_x x :=
      generalize dependent (X x);
      generalize dependent (C x);
      repeat (let x1 := fresh "x" in intro x1).
    gen_x a.
    gen_x b.
    gen_x c.
    gen_x d.
    repeat match goal with
             | [ |- context[p_identity_of ?F ?x] ]
               => generalize dependent (p_identity_of F x)
             | [ |- context[p_composition_of ?F ?x ?y ?z ?f ?g] ]
               => generalize dependent (p_composition_of F x y z f g)
             | [ |- context[p_morphism_of ?F ?m] ]
               => generalize dependent (p_morphism_of F m)
             | [ |- context[p_object_of ?F ?x] ]
               => generalize dependent (p_object_of F x)
             | [ H : context[p_morphism_of ?F ?m] |- _ ]
               => generalize dependent (p_morphism_of F m)
             | [ |- context[@p_morphism_of _ _ ?F ?x ?y] ]
               => generalize dependent (@p_morphism_of _ _ F x y)
           end.
    simpl.

    intros.

    lazymatch goal with
      | [ H : context[ap ?f ?H'] |- _ ]
        => rename H' into fst_hyp;
          rename H into rew_hyp;
          move rew_hyp at top
    end.

    generalize dependent fst_hyp.
    clear.
    intros.
    move rew_hyp at top.

    move H at top.

    repeat match goal with
             | [ H : Isomorphic _ _ |- _ ]
               => let x := fresh "x" in
                  let H' := fresh "H" in
                  destruct H as [x H'];
                    simpl in *
           end.
    move rew_hyp at top.
    repeat match goal with
             | [ H : _ |- _ ] => revert H
           end.

    intro H.
    intro C.
>> *)

  Lemma pseudofunctor_to_cat_assoc_helper
  : forall {x x0 : C} {x2 : Category.Core.morphism C x x0} {x1 : C}
           {x5 : Category.Core.morphism C x0 x1} {x4 : C} {x7 : Category.Core.morphism C x1 x4}
           {p p0 : PreCategory} {f : Category.Core.morphism C x x4 -> Functor p0 p}
           {p1 p2 : PreCategory} {f0 : Functor p2 p} {f1 : Functor p1 p2}
           {f2 : Functor p0 p2} {f3 : Functor p0 p1} {f4 : Functor p1 p}
           {x16 : Category.Core.morphism (_ -> _) (f (x7 o x5 o x2)) (f4 o f3)%functor}
           {x15 : Category.Core.morphism (_ -> _) f2 (f1 o f3)%functor} {H2 : IsIsomorphism x15}
           {x11 : Category.Core.morphism (_ -> _) (f (x7 o (x5 o x2))) (f0 o f2)%functor}
           {H1 : IsIsomorphism x11} {x9 : Category.Core.morphism (_ -> _) f4 (f0 o f1)%functor}
           {fst_hyp : x7 o x5 o x2 = x7 o (x5 o x2)}
           (rew_hyp : forall x3 : p0,
                        (idtoiso (p0 -> p) (ap f fst_hyp) : Category.Core.morphism _ _ _) x3 =
                        x11^-1 x3 o (f0 _1 (x15^-1 x3) o (1 o (x9 (f3 x3) o x16 x3))))
           {H0' : IsIsomorphism x16}
           {H1' : IsIsomorphism x9}
           {x13 : p} {x3 : p0} {x6 : p1} {x10 : p2}
           {x14 : Category.Core.morphism p (f0 x10) x13} {x12 : Category.Core.morphism p2 (f1 x6) x10}
           {x8 : Category.Core.morphism p1 (f3 x3) x6},
      exist (fun f5 : Category.Core.morphism C x x4 => Category.Core.morphism p ((f f5) x3) x13)
             (x7 o x5 o x2)
             (x14 o (f0 _1 x12 o x9 x6) o (f4 _1 x8 o x16 x3)) =
      (x7 o (x5 o x2); x14 o (f0 _1 (x12 o (f1 _1 x8 o x15 x3)) o x11 x3)).
  Proof.
    helper_t assoc_before_commutes_tac.
    assoc_fin_tac.
  Qed.

  Lemma pseudofunctor_to_cat_left_identity_helper
  : forall {x1 x2 : C} {f : Category.Core.morphism C x2 x1} {p p0 : PreCategory}
           {f0 : Category.Core.morphism C x2 x1 -> Functor p0 p} {f1 : Functor p p}
           {x0 : Category.Core.morphism (_ -> _) (f0 (1 o f)) (f1 o f0 f)%functor}
           {x : Category.Core.morphism (_ -> _) f1 1%functor}
           {fst_hyp : 1 o f = f}
           (rewrite_hyp : forall x3 : p0,
                            (idtoiso (p0 -> p) (ap f0 fst_hyp) : Category.Core.morphism _ _ _) x3
                            = 1 o (x ((f0 f) x3) o x0 x3))
           {H0' : IsIsomorphism x0}
           {H1' : IsIsomorphism x}
           {x3 : p} {x4 : p0} {f' : Category.Core.morphism p ((f0 f) x4) x3},
      exist (fun f2 : Category.Core.morphism C x2 x1 => Category.Core.morphism p ((f0 f2) x4) x3)
             (1 o f)
             (x x3 o (f1 _1 f' o x0 x4))
      = (f; f').
  Proof.
    helper_t idtac.
  Qed.

  Lemma pseudofunctor_to_cat_right_identity_helper
  : forall {x1 x2 : C} {f : Category.Core.morphism C x2 x1} {p p0 : PreCategory}
           {f0 : Category.Core.morphism C x2 x1 -> Functor p0 p} {f1 : Functor p0 p0}
           {x0 : Category.Core.morphism (_ -> _) (f0 (f o 1)) (f0 f o f1)%functor}
           {H0' : IsIsomorphism x0}
           {x : Category.Core.morphism (_ -> _) f1 1%functor}
           {H1' : IsIsomorphism x}
           {fst_hyp : f o 1 = f}
           (rew_hyp : forall x3 : p0,
                        (idtoiso (p0 -> p) (ap f0 fst_hyp) : Category.Core.morphism _ _ _) x3
                        = 1 o ((f0 f) _1 (x x3) o x0 x3))
           {x3 : p} {x4 : p0} {f' : Category.Core.morphism p ((f0 f) x4) x3},
        exist (fun f2 : Category.Core.morphism C x2 x1 => Category.Core.morphism p ((f0 f2) x4) x3)
               (f o 1)
               (f' o ((f0 f) _1 (x x4) o x0 x4))
        = (f; f').
  Proof.
    helper_t idtac.
  Qed.

  (** ** Category of elements *)
  Definition category : PreCategory.
  Proof.
    refine (@Build_PreCategory
              Pair
              (fun s d => morphism s d)
              identity
              compose
              _
              _
              _
              _);
    [ abstract (
          intros ? ? ? ? [f ?] [g ?] [h ?];
          exact (pseudofunctor_to_cat_assoc_helper
                   (apD10
                      (ap components_of
                          (p_composition_of_coherent_for_rewrite F _ _ _ _ f g h))))
        )
    | abstract (
          intros ? ? [f ?];
          exact (pseudofunctor_to_cat_left_identity_helper
                   (apD10
                      (ap components_of
                          (p_left_identity_of_coherent_for_rewrite F _ _ f))))
        )
    | abstract (
          intros ? ? [f ?];
          exact (pseudofunctor_to_cat_right_identity_helper
                   (apD10
                      (ap components_of
                          (p_right_identity_of_coherent_for_rewrite F _ _ f))))
    ) ].
  Defined.

  (** ** First projection functor *)
  Definition pr1 : Functor category C
    := Build_Functor category C
                     c
                     (fun s d => @pr1 _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End Grothendieck.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus lv2 (plus lv1 lv0))).
Admitted.
QuickChick conj20eqsynthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (mult lv1 lv0) lv2)).
Admitted.
QuickChick conj19eqsynthconj4.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris_examples.logrel.F_mu_ref Require Export rules typing.
From iris.algebra Require Import list.
Import uPred.

Definition logN : namespace := nroot .@ "logN".

(** interp : is a unary logical relation. *)
Section logrel.
  Context `{heapG Σ}.
  Notation D := (valO -n> iPropO Σ).
  Implicit Types τi : D.
  Implicit Types Δ : listO D.
  Implicit Types interp : listO D → D.

  Program Definition ctx_lookup (x : var) : listO D -n> D := λne Δ,
    from_option id (cconst True)%I (Δ !! x).
  Solve Obligations with solve_proper.

  Definition interp_unit : listO D -n> D := λne Δ w, ⌜w = UnitV⌝%I.

  Program Definition interp_prod
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    (∃ w1 w2, ⌜w = PairV w1 w2⌝ ∧ interp1 Δ w1 ∧ interp2 Δ w2)%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_sum
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    ((∃ w1, ⌜w = InjLV w1⌝ ∧ interp1 Δ w1) ∨ (∃ w2, ⌜w = InjRV w2⌝ ∧ interp2 Δ w2))%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_arrow
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ w,
    (□ ∀ v, interp1 Δ v → WP App (# w) (# v) {{ interp2 Δ }})%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Program Definition interp_forall
      (interp : listO D -n> D) : listO D -n> D := λne Δ w,
    (□ ∀ τi : D,
      ⌜(∀ v, Persistent (τi v))⌝ → WP TApp (# w) {{ interp (τi :: Δ) }})%I.
  Solve Obligations with repeat intros ?; simpl; solve_proper.

  Definition interp_rec1
      (interp : listO D -n> D) (Δ : listO D) (τi : D) : D := λne w,
    (□ (∃ v, ⌜w = FoldV v⌝ ∧ ▷ interp (τi :: Δ) v))%I.

  Global Instance interp_rec1_contractive
    (interp : listO D -n> D) (Δ : listO D) : Contractive (interp_rec1 interp Δ).
  Proof. by solve_contractive. Qed.

  Lemma fixpoint_interp_rec1_eq (interp : listO D -n> D) Δ x :
    fixpoint (interp_rec1 interp Δ) x ≡ interp_rec1 interp Δ (fixpoint (interp_rec1 interp Δ)) x.
  Proof. exact: (fixpoint_unfold (interp_rec1 interp Δ) x). Qed.

  Program Definition interp_rec (interp : listO D -n> D) : listO D -n> D := λne Δ,
    fixpoint (interp_rec1 interp Δ).
  Next Obligation.
    intros interp n Δ1 Δ2 HΔ; apply fixpoint_ne => τi w. solve_proper.
  Qed.

  Program Definition interp_ref_inv (l : loc) : D -n> iPropO Σ := λne τi,
    (∃ v, l ↦ v ∗ τi v)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_ref
      (interp : listO D -n> D) : listO D -n> D := λne Δ w,
    (∃ l, ⌜w = LocV l⌝ ∧ inv (logN .@ l) (interp_ref_inv l (interp Δ)))%I.
  Solve Obligations with solve_proper.

  Fixpoint interp (τ : type) : listO D -n> D :=
    match τ return _ with
    | TUnit => interp_unit
    | TProd τ1 τ2 => interp_prod (interp τ1) (interp τ2)
    | TSum τ1 τ2 => interp_sum (interp τ1) (interp τ2)
    | TArrow τ1 τ2 => interp_arrow (interp τ1) (interp τ2)
    | TVar x => ctx_lookup x
    | TForall τ' => interp_forall (interp τ')
    | TRec τ' => interp_rec (interp τ')
    | Tref τ' => interp_ref (interp τ')
    end.
  Notation "⟦ τ ⟧" := (interp τ).

  Definition interp_env (Γ : list type)
      (Δ : listO D) (vs : list val) : iProp Σ :=
    (⌜length Γ = length vs⌝ ∗ [∗] zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs)%I.
  Notation "⟦ Γ ⟧*" := (interp_env Γ).

  Definition interp_expr (τ : type) (Δ : listO D) (e : expr) : iProp Σ :=
    WP e {{ ⟦ τ ⟧ Δ }}%I.

  Class env_Persistent Δ :=
    ctx_persistent : Forall (λ τi, ∀ v, Persistent (τi v)) Δ.
  Global Instance ctx_persistent_nil : env_Persistent [].
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_cons τi Δ :
    (∀ v, Persistent (τi v)) → env_Persistent Δ → env_Persistent (τi :: Δ).
  Proof. by constructor. Qed.
  Global Instance ctx_persistent_lookup Δ x v :
    env_Persistent Δ → Persistent (ctx_lookup x Δ v).
  Proof. intros HΔ; revert x; induction HΔ=>-[|?] /=; apply _. Qed.
  Global Instance interp_persistent τ Δ v :
    env_Persistent Δ → Persistent (⟦ τ ⟧ Δ v).
  Proof.
    revert v Δ; induction τ=> v Δ HΔ; simpl; try apply _.
    rewrite /Persistent fixpoint_interp_rec1_eq /interp_rec1 /= intuitionistically_into_persistently.
    by apply persistently_intro'.
  Qed.
  Global Instance interp_env_base_persistent Δ Γ vs :
  env_Persistent Δ → TCForall Persistent (zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs).
  Proof.
    intros HΔ. revert vs.
    induction Γ => vs; simpl; destruct vs; constructor; apply _.
  Qed.
  Global Instance interp_env_persistent Γ Δ vs :
    env_Persistent Δ → Persistent (⟦ Γ ⟧* Δ vs) := _.

  Lemma interp_weaken Δ1 Π Δ2 τ :
    ⟦ τ.[upn (length Δ1) (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2)
    ≡ ⟦ τ ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; auto.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi w /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - intros w; simpl; properness; auto. apply (IHτ (_ :: _)).
    - intros w; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst_up Δ1 Δ2 τ τ' :
    ⟦ τ ⟧ (Δ1 ++ interp τ' Δ2 :: Δ2)
    ≡ ⟦ τ.[upn (length Δ1) (τ' .: ids)] ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl.
    - done.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros w; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi w /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..].
      case EQ: (x - length Δ1) => [|n]; simpl.
      { symmetry. asimpl. apply (interp_weaken [] Δ1 Δ2 τ'). }
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - intros w; simpl; properness; auto. apply (IHτ (_ :: _)).
    - intros w; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst Δ2 τ τ' v : ⟦ τ ⟧ (⟦ τ' ⟧ Δ2 :: Δ2) v ≡ ⟦ τ.[τ'/] ⟧ Δ2 v.
  Proof. apply (interp_subst_up []). Qed.

  Lemma interp_env_length Δ Γ vs : ⟦ Γ ⟧* Δ vs ⊢ ⌜length Γ = length vs⌝.
  Proof. by iIntros "[% ?]". Qed.

  Lemma interp_env_Some_l Δ Γ vs x τ :
    Γ !! x = Some τ → ⟦ Γ ⟧* Δ vs ⊢ ∃ v, ⌜vs !! x = Some v⌝ ∧ ⟦ τ ⟧ Δ v.
  Proof.
    iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen.
    destruct (lookup_lt_is_Some_2 vs x) as [v Hv].
    { by rewrite -Hlen; apply lookup_lt_Some with τ. }
    iExists v; iSplit. done. iApply (big_sepL_elem_of with "HΓ").
    apply elem_of_list_lookup_2 with x.
    rewrite lookup_zip_with; by simplify_option_eq.
  Qed.

  Lemma interp_env_nil Δ : (⟦ [] ⟧* Δ [])%I.
  Proof. iSplit; simpl; auto. Qed.
  Lemma interp_env_cons Δ Γ vs τ v :
    ⟦ τ :: Γ ⟧* Δ (v :: vs) ⊣⊢ ⟦ τ ⟧ Δ v ∗ ⟦ Γ ⟧* Δ vs.
  Proof.
    rewrite /interp_env /= (assoc _ (⟦ _ ⟧ _ _)) -(comm _ ⌜(_ = _)⌝%I) -assoc.
    by apply sep_proper; [apply pure_proper; lia|].
  Qed.

  Lemma interp_env_ren Δ (Γ : list type) (vs : list val) τi :
    ⟦ subst (ren (+1)) <$> Γ ⟧* (τi :: Δ) vs ⊣⊢ ⟦ Γ ⟧* Δ vs.
  Proof.
    apply sep_proper; [apply pure_proper; by rewrite fmap_length|].
    revert Δ vs τi; induction Γ=> Δ [|v vs] τi; csimpl; auto.
    apply sep_proper; auto. apply (interp_weaken [] [τi] Δ).
  Qed.
End logrel.

Typeclasses Opaque interp_env.
Notation "⟦ τ ⟧" := (interp τ).
Notation "⟦ τ ⟧ₑ" := (interp_expr τ).
Notation "⟦ Γ ⟧*" := (interp_env Γ).