Require Import FcEtt.sigs.

Require Export FcEtt.tactics.
Require Export FcEtt.imports.
Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ott.
Require Export FcEtt.ett_ind.
Require Export FcEtt.ext_wf.
Require Export FcEtt.ett_par.
Require Export FcEtt.ett_inf_cs.

Require Import FcEtt.erase_syntax.
Require Import FcEtt.fc_invert.
Require Import FcEtt.ext_consist.
Require Import FcEtt.erase.
Require Import FcEtt.fc_head_reduction.

(* Needed for annotation lemma at end. *)
Require Import FcEtt.fc_preservation.
Require Import FcEtt.ext_subst.

Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Module fc_consist (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig)
                  (e_invert : ext_invert_sig)(e_subst : ext_subst_sig).

Import wf weak.

Export subst.

Module invert := fc_invert wf weak subst.
Export invert.

Module consist := ext_consist e_invert wf.
Export consist.

Module erase' := erase wf weak subst e_invert.
Export erase'.

Module head := fc_head_reduction  e_invert weak wf subst.
Export head.

Module pres := fc_preservation wf weak subst e_subst.
Import pres.
(* Why does this cause so many messages? *)

Lemma erased_tm_erase_mutual :
  (forall G0 a B (H : AnnTyping G0 a B),
     erased_tm (erase a) /\ erased_tm (erase B)) /\
  (forall G0 phi (H : AnnPropWff G0 phi),
      forall a b A, phi = (Eq a b A) ->
                                         erased_tm (erase a) /\ erased_tm (erase b)
                                         /\ erased_tm (erase A)) /\
  (forall G0 D g p1 p2 (H : AnnIso G0 D g p1 p2),
     True) /\
  (forall  G0 D g A B (H : AnnDefEq G0 D g A B),
      True) /\
  (forall G0 (H : AnnCtx G0),
     forall x A, binds x (Tm A) G0 -> erased_tm (erase_tm A)
  ).
Proof.
 apply ann_typing_wff_iso_defeq_mutual; intros; simpl; repeat split; eauto.
 all: try solve [inversion H; eauto].
 all: try solve [inversion H1; eauto].
 all: try solve [inversion H0; eauto].
   (* all: try solve [ try (destruct rho); simpl; eauto]. *)
  - (* a_Pi rho *)
    erased_pick_fresh y. inversion H0. eauto using lc_erase.
    move: (H y) => h0. assert (W: y `notin` L). eauto.
    apply h0 in W. inversion W. rewrite <- open_tm_erase_tm in H1. eauto.
  - (* a_UAbs rho *)
    destruct rho; eauto.
    (* rel *)
    pick fresh x and apply erased_a_Abs.
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm. assert (W: x `notin` L). auto. apply H0 in W.
    inversion W. auto. auto.
    (*irrel*)
    pick fresh x and apply erased_a_Abs.
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm. assert (W: x `notin` L). auto. apply H0 in W.
    inversion W. auto.
    econstructor.
    assert (W: x `notin` L). auto.
    apply r in W. inversion W. simpl.
    rewrite Rew.r_erase_tm.
    rewrite Rew.r_erase_tm in H1. rewrite -open_tm_erase_tm in H1.
    simpl in H1. auto.
  - (* a_Pi type *)
    erased_pick_fresh y. inversion H. eauto using lc_erase.
    move: (H0 y) => h0. assert (W: y `notin` L). eauto.
    apply h0 in W. inversion W. clear h0 W.
    rewrite <- open_tm_erase_tm in H2. eauto.
  - inversion H. inversion H0. destruct rho; simpl; eauto.
  - rewrite <- open_tm_erase_tm.
    set M := erase_tm B.
    inversion H. inversion H2; subst.
    pick fresh x.
    unfold M in Fr.
    rewrite (tm_subst_tm_tm_intro x); eauto.
    eapply subst_tm_erased. inversion H0. auto.
    eapply H7. fsetdec.
  - (* a_CPi erase constraint *)
    destruct phi. destruct (H _ _ _ eq_refl) as (h0 & h1 & h2). simpl.
    eauto. erased_pick_fresh y; eauto using lc_erase.
    assert (W: y `notin` L). auto. apply H0 in W.
    rewrite Rew.r_erase_tm.
    erewrite open_co_erase_tm2. inversion W. apply H1.
  - (* a_UCAbs *)
    pick fresh y and apply erased_a_CAbs.
    assert (W: y `notin` L). auto. apply H0 in W.
    rewrite Rew.r_erase_tm.
    erewrite open_co_erase_tm2. inversion W. apply H1.
  - (* a_CPi type *)
    destruct phi. destruct (H _ _ _ eq_refl) as (h0 & h1 & h2). simpl.
    eauto. erased_pick_fresh y; eauto using lc_erase.
    assert (W: y `notin` L). auto. apply H0 in W.
    rewrite Rew.r_erase_tm.
    erewrite open_co_erase_tm2. inversion W. apply H2.
  - rewrite <- open_co_erase_tm.
    set M := erase_tm B.
    inversion H. inversion H2; subst.
    pick fresh x.
    unfold M in Fr.
    assert (W: x `notin` L). fsetdec. apply H10 in W.
    erewrite open_co_erase_tm with (a := (g_Var_f x)).
    erewrite open_co_erase_tm2 in W. apply W.
  - inversion H1. subst. inversion H. auto.
  - inversion H1. subst. inversion H0. auto.
  - inversion H1. subst. inversion H. auto.
  - simpl in H1.
    apply binds_cons_iff in H1.
    inversion H1. inversion H2.
    + inversion H4; subst; auto.
      inversion H0; auto.
    + apply H in H2; auto.
  - simpl in H1.
    apply binds_cons_iff in H1.
    inversion H1. destruct phi.
    inversion H2. inversion H4.
    apply H in H2; auto.
Qed.

Lemma erased_tm_erase : forall G0 a B, AnnTyping G0 a B -> erased_tm (erase a).
Proof.
  intros.
  destruct erased_tm_erase_mutual.
  apply H0 in H. inversion H. auto.
Qed.

Lemma erased_tm_erase_type : forall G0 a B, AnnTyping G0 a B -> erased_tm (erase B).
Proof.
  intros.
  destruct erased_tm_erase_mutual.
  apply H0 in H. inversion H. auto.
Qed.

Hint Resolve erased_tm_erase : erased.

Definition AnnGood G D := Good (erase_context G) D.

Lemma AnnGoodIsGood : forall G D, AnnGood G D -> Good (erase_context G) D.
Proof. intros. auto.
Qed.

Lemma AnnGoodnil : AnnGood nil AtomSetImpl.empty.
  unfold AnnGood. simpl. unfold Good. unfold erased_context.
  split. auto.
  intros.
  unfold binds in H. inversion H.
Qed.

Lemma AnnDefEq_consistent : forall S D g A B, AnnDefEq S D g A B -> AnnGood S D -> consistent (erase A) (erase B).
Proof.
  intros S D g A B H H0.
  pose S' := AnnGoodIsGood H0.
  destruct (AnnDefEq_regularity H) as (S1 & S2 & gs & TS1 & TS2 & ES).
  assert (DefEq (erase_context S) D (erase A) (erase B) (erase S1)).
  { apply (AnnDefEq_erase H).
    auto.
  }
  assert (C : consistent (erase A) (erase B)).
  eapply join_consistent.
  eapply consistent_defeq. eauto. eauto.
  inversion C; subst; auto.
Qed.

Lemma Paths_are_DataTy : forall T a,
    Path T a -> Value a -> forall G A, AnnTyping G a A -> DataTy A a_Star.
Proof.
  induction 1; intros.
  - inversion H0. subst.
    eapply (binds_to_type _ _ AnnSig_an_toplevel); eauto.
  - inversion H1. inversion H2. subst.
    move: (IHPath H8 _ _ H14) => h0.
    inversion h0. subst.
    pick fresh x.
    rewrite (tm_subst_tm_tm_intro x); eauto with lngen.
  - inversion H1. inversion H2. subst.
    move: (IHPath H7 _ _ H11) => h0.
    inversion h0. subst.
    pick fresh x.
    rewrite (co_subst_co_tm_intro x); eauto with lngen.
  - inversion H1.
Qed.

Lemma Paths_have_value_types : forall T a,
    Path T a -> Value a -> forall G A, AnnTyping G a A -> value_type A.
Proof. intros.
       eapply DataTy_value_type; eauto.
       eapply Paths_are_DataTy; eauto.
Qed.

Lemma values_have_value_types :
  forall G D a A, AnnGood G D ->  AnnTyping G a A -> Value a -> value_type A.
Proof.
  intros G D a A AN H V.
  move: (AnnTyping_regularity H) => h0.
  inversion H; subst; auto.
  all: try solve [inversion V; inversion H2].
  all: match goal with
  | [H : AnnTyping ?G ?b ?A |- value_type ?b] =>
    apply AnnTyping_lc in H; split_hyp; lc_inversion c;  eauto
       end.
  + inversion V.
    eapply (@Paths_have_value_types T (a_App b rho a0)); eauto.
  + inversion V.
    eapply (@Paths_have_value_types T (a_CApp a1 g)); eauto.
  + eapply DataTy_value_type.
    eapply (binds_to_type _ _ AnnSig_an_toplevel); eauto.
Qed.

(* --------- Paths infect the cannonical forms lemmas for functions --------- *)

Lemma canonical_forms_a_Pi :
  forall G D a rho A B, AnnGood G D ->
                   AnnTyping G a (a_Pi rho A B) -> Value a ->
                   (exists a', a = a_Abs rho A a') \/ (exists T, Path T a).
Proof.
  intros G D a rho A B AN H V.
  inversion V; subst; inversion H; subst; try solve [inversion H0].
  all: try solve [left; exists a0; auto].
  all: try solve [right; exists T; auto].
Qed.

Lemma canonical_forms_a_CPi :
  forall G D a phi B, AnnGood G D ->
                 AnnTyping G a (a_CPi phi B) -> Value a ->
                 (exists a', a = a_CAbs phi a') \/ (exists T, Path T a).
Proof.
  intros G D a phi B AN H V.
  inversion V; subst; inversion H; subst; try solve [inversion H0].
  all: try solve [left; exists a0; auto].
  all: try solve [right; exists T; auto].
Qed.

Lemma consistent_a_Pi :
  forall G A B C g rho,
    AnnGood G (dom G) -> value_type C ->
    AnnDefEq G (dom G) g C (a_Pi rho A B) -> exists A' B', C = a_Pi rho A' B'.
Proof.
  intros G A B C g rho AN VT DE.
  move: (AnnDefEq_consistent DE AN) => K;  simpl in K.
  inversion K.
  destruct C; destruct rho0; try destruct rho1; simpl in H; inversion H.
  - exists C1. exists C2. subst. auto.
  - subst. exists C1. exists C2. auto.
  - inversion VT.
  - inversion VT.
  - inversion H0.
  - assert False.
    apply AnnDefEq_lc in DE. split_hyp.
    match goal with
      [ H0 : ¬ value_type (a_Pi rho (erase_tm A) (erase_tm B)),
        H4 : lc_tm (a_Pi rho A B) |- _ ] =>
    apply H0; econstructor;
      pose M := H4; clearbody M; inversion M;
      eauto using lc_tm_erase;
      move: (lc_erase) => [h0 _]; apply h0 in H4; auto end.
    done.
  - subst.
    apply value_type_erase in VT. done.
Qed.

Lemma consistent_a_CPi :
  forall G phi B C g,
    AnnGood G (dom G) -> value_type C -> AnnDefEq G (dom G) g C (a_CPi phi B) -> exists phi' B', C = a_CPi phi' B'.
Proof.
  intros G phi B C g AN VT DE.
  move: (AnnDefEq_consistent DE AN) => K;  simpl in K.
  inversion K.
  destruct C; try destruct rho; simpl in H; inversion H;
  try solve [inversion VT; inversion H1].
  - subst. exists phi0. exists C.  auto.
  - inversion H0.
  - assert False.
    apply AnnDefEq_lc in DE. split_hyp.
    apply H0. econstructor.
    pose M := H4. inversion M.
    apply lc_erase. auto.
    move: (lc_erase) => [h0 _]. apply h0 in H4. apply H4.
    done.
  - subst.
    apply value_type_erase in VT. done.
Qed.

Definition irrelevant G D (a : tm) :=
  (forall x A, binds x (Tm A) G -> x `notin` fv_tm (erase a)) /\ AnnGood G D.

(* Other statement?
Lemma progress : forall a A G D, AnnGood G D -> AnnTyping G a A -> CoercedValue a \/ exists a', head_reduction G a a'.
*)
Lemma progress : forall G a A, irrelevant G (dom G) a -> AnnTyping G a A -> CoercedValue a \/ exists a', head_reduction G a a'.
Proof.
  intros G a A AN H.
  destruct AN as [IR AN].
  assert (M : AnnTyping G a A); auto.
  dependent induction H; destruct (AnnTyping_lc M) as [LCa LCA]; inversion LCa.
  - left; auto.
  - apply IR in H0. simpl in H0. fsetdec.
  - left; eauto.
  - destruct rho; try solve [left; eauto].
    pick fresh x.
    have: x `notin` L; auto => h0.
    move: (H2 x h0) => h1.
    inversion h1. subst. clear H2.
    destruct (H1 x h0) as [V | [a' R]].
    { move: (H0 x h0) => h2.
      have ctx: (AnnCtx ([(x, Tm A)] ++ G)) by eauto with ctx_wff.
      move: (AnnCtx_uniq ctx) => u. inversion u. subst.
      intros x0 A0 b0.
      apply binds_cons_uniq_1 in b0. destruct b0; split_hyp.
      ++ subst. auto.
      ++ move: (IR _ _ H2) => fr. simpl in fr.
         rewrite <- open_tm_erase_tm.
         eapply notin_sub; [idtac| eapply fv_tm_tm_tm_open_tm_wrt_tm_upper].
         simpl.
         fsetdec.
      ++ eauto. }
    { unfold AnnGood. simpl. eapply Good_add_tm_2; eauto.
      rewrite <- erase_dom. auto.
      eapply Typing_erased. eapply (AnnTyping_erase). eauto. }
    { eauto. }
    -- inversion V. subst.
       ++ left.
       econstructor.
       eapply Value_AbsIrrel_exists with (x := x); eauto.
       ++ resolve_open a.
       left. eapply CV.
       eapply Value_AbsIrrel_exists with (x:=x); eauto.
    -- right. exists (a_Abs Irrel A (close_tm_wrt_tm x a')).
       eapply An_AbsTerm_exists with (x := x).
         { eapply notin_union; auto.
           simpl. rewrite fv_tm_tm_tm_close_tm_wrt_tm. auto. }
         auto.
         rewrite open_tm_wrt_tm_close_tm_wrt_tm. auto.
  - destruct IHAnnTyping1; auto.
    + intros. move: (IR x A0 H6) => h0. destruct rho; simpl in h0. fsetdec. fsetdec.
    + inversion M. subst.
      match goal with
        H: CoercedValue b |- _ => inversion H
      end.
      -- (* application of a value *)
        edestruct canonical_forms_a_Pi as [[ a1 EQ] | [T P]] ; eauto; subst.
        (* path case solved automatically *)
        ++ right. (* a lambda, do a beta reduction *)
           exists (open_tm_wrt_tm a1 a). eapply An_AppAbs; eauto.
      -- right. (* push/pull rule *)
         subst.
         inversion H.
         subst.
         have VT: value_type A1. eapply values_have_value_types; eauto.
         edestruct consistent_a_Pi as (A' & B' & EQ); eauto. subst.
         edestruct canonical_forms_a_Pi as [[ a0' EQ] | [T P]]; eauto; subst.
    + subst.
      match goal with H : exists a' : tm, head_reduction G b a' |- _ => destruct H end.
      right. eexists. eapply An_AppLeft; eauto.
  - (* cast *)
    subst. destruct IHAnnTyping1; auto.
    inversion H2.
    + subst. left; auto.
    + subst. right. inversion H4.
      eexists.  eapply An_Combine; eauto.
    + destruct H2. right. eexists. eapply An_ConvTerm; eauto.
  - left; auto.
  - left; auto.
  - destruct IHAnnTyping; auto.
    + intros. move: (IR x A H5) => h0. simpl in h0. fsetdec.
    + inversion M. subst.
      match goal with
        H : CoercedValue ?a1 |- _ => inversion H
      end.
      -- edestruct canonical_forms_a_CPi as [[a2 EQ]|[T p]]; eauto; subst.
         right. exists (open_tm_wrt_co a2 g). eapply An_CAppCAbs; eauto.
         destruct (AnnTyping_lc H) as [h0 h1]. inversion h0; auto.
      -- subst.  inversion H. subst.
         have VT: value_type A. eapply values_have_value_types; eauto.
        edestruct consistent_a_CPi as (A' & a2 & EQ); eauto. subst.
        edestruct canonical_forms_a_CPi as [[a0' EQ]|[T p]]; eauto; subst.
    + destruct H5. right. eexists. eapply An_CAppLeft. eauto. eauto.
  - left. eauto.
  - right. exists a. eauto.
Qed.

(* ------------------------------------- *)

(* This is proved in the preservation file.
Lemma reduction_erasure : forall G a a',
    head_reduction G a a' ->
    reduction_in_one (erase a) (erase a') \/ erase a = erase a'. *)

(* ------------------------------------- *)
Inductive multi (rel : tm -> tm -> Prop) : tm -> tm -> Prop :=
| multi_refl : forall a, lc_tm a -> multi rel a a
| multi_step : forall a b c, rel a b -> multi rel b c -> multi rel a c.

Lemma multi_trans : forall r a b, multi r a b -> forall c, multi r b c -> multi r a c.
Proof.
  intros.
  dependent induction H. auto.
  eapply multi_step. eauto. auto.
Qed.

(* ------------------------------------- *)

Lemma multi_An_AbsTerm_exists : ∀ (G : list (atom * sort)) (x : atom) (A a a' : tm),
       x `notin` union (fv_tm a) (union (fv_tm a') (dom G))
       → AnnTyping G A a_Star
         → multi (head_reduction ([(x, Tm A)] ++ G)) (open_tm_wrt_tm a (a_Var_f x))
             (open_tm_wrt_tm a' (a_Var_f x))
           → multi (head_reduction G) (a_Abs Irrel A a) (a_Abs Irrel A a').
Proof.
  intros.
  dependent induction H1.
  + apply open_tm_wrt_tm_inj in x; auto.
    subst.
    eapply multi_refl; eauto using AnnTyping_lc1.
  + eapply multi_step with (b := a_Abs Irrel A (close_tm_wrt_tm x b)); eauto.
    eapply An_AbsTerm_exists with (x:=x); auto.
    autorewrite with lngen. auto.
    autorewrite with lngen. auto.
    eapply IHmulti with (x0:=x); auto.
    autorewrite with lngen. auto.
    autorewrite with lngen. auto.
Qed.

Lemma multi_An_ConvTerm : ∀ (G : context) (a : tm) (g : co) (a' : tm),
    lc_co g → multi (head_reduction G) a a'
    → multi (head_reduction G) (a_Conv a g) (a_Conv a' g).
Proof.
  intros.
  dependent induction H0.
  - eapply multi_refl; eauto.
  - eapply multi_step with (b:= (a_Conv b g)); auto.
Qed.

Lemma multi_An_AppLeft : ∀ (G : context) (a b: tm) rho (a' : tm),
    lc_tm b → multi (head_reduction G) a a'
    → multi (head_reduction G) (a_App a rho b) (a_App a' rho b).
Proof.
  intros.
  dependent induction H0.
  - eapply multi_refl; eauto.
  - eapply multi_step with (b:= (a_App b0 rho b)); auto.
Qed.

Lemma multi_An_CAppLeft : ∀ (G : context) (a: tm) (g:co) (a' : tm),
    lc_co g → multi (head_reduction G) a a'
    → multi (head_reduction G) (a_CApp a g) (a_CApp a' g).
Proof.
  intros.
  dependent induction H0.
  - eapply multi_refl; eauto.
  - eapply multi_step with (b:= (a_CApp b g)); auto.
Qed.

(* ------------------------------------- *)

Lemma multi_preservation : forall G a b A, multi (head_reduction G) a b ->
                                      AnnTyping G a A ->
                                      AnnTyping G b A.
Proof.
  induction 1.
  intros. auto.
  intros.
  eapply IHmulti.
  eapply preservation; eauto.
Qed.

(* ------------------------------------- *)

(* TODO: move elsewhere?  ext_consist for the first two? *)

Lemma erased_constraint_erase :
  forall G a b A, AnnPropWff G (Eq a b A) -> erased_tm (erase a) /\ erased_tm (erase b)
                                      /\ erased_tm (erase A).
Proof.
  move: erased_tm_erase_mutual => [_ [h [_ _]]].
  eauto.
Qed.

Lemma erased_context_erase :
  forall G, AnnCtx G -> erased_context (erase_context G).
       Proof.
         induction 1; simpl; unfold erased_context; rewrite Forall_forall.
         - intros. inversion H.
         - intros. destruct x0. inversion H2.
           -- inversion H3. destruct s. inversion H6. subst.
              econstructor. eapply erased_tm_erase. eauto.
              inversion H6.
           -- unfold erased_context in IHAnnCtx.
              move: (Forall_forall (λ p : atom * sort, let (_, s) := p in erased_sort s) (erase_context G)) => [h0 h1].
              move: (h0 IHAnnCtx) => h2.
              eapply (h2 (a,s)). auto.
         - intros. destruct x. inversion H2.
           -- inversion H3. destruct s. inversion H6.
              inversion H6. subst.
              destruct phi.
              inversion H0.
              econstructor.
              + eapply erased_tm_erase. eauto using AnnTyping_lc1.
              + eapply erased_tm_erase. eauto using AnnTyping_lc2.
              + eapply erased_tm_erase_type. eauto.
           -- unfold erased_context in IHAnnCtx.
              move: (Forall_forall (λ p : atom * sort, let (_, s) := p in erased_sort s) (erase_context G)) => [h0 h1].
              move: (h0 IHAnnCtx) => h2.
              eapply (h2 (a,s)). auto.
       Qed.

Lemma AnnGood_add_tm :
  forall G x A,  x `notin` dom G -> AnnTyping G A a_Star -> AnnGood G (dom G) -> AnnGood (x ~ Tm A ++ G) (dom (x ~ Tm A ++ G)).
Proof.
  intros G x A Fr AT GG.
  inversion GG.  econstructor. eapply erased_context_erase; eauto using AnnTyping_AnnCtx.
  intros.
  simpl in H1.
  apply binds_cons_1 in H1.
  destruct H1 as [[_ EQ] | BI1]. inversion EQ.
  edestruct (H0 c1) as (C & P1 & P2); eauto.
  move: (binds_In _ c1 _ _ BI1) => b0.
  unfold erase_context in b0. move: (dom_map _ _ erase_sort G) => DM. fsetdec.
  exists C. repeat split;
         eapply context_Par_irrelevance; eauto.
Qed.

(* ------------------------------------- *)

(* A specialized version of eauto that only uses the most common
   lc lemmas to cut down the search space. *)
Ltac eauto_lc := simpl; eauto using AnnTyping_lc1, Value_lc,
                        AnnDefEq_lc3, AnnPropWff_lc.

(* If an annotated term erases to a value, then it evaluates to a coerced value. *)
Lemma erased_Value_reduces_to_CoercedValue :
  forall G a0 A,
    AnnTyping G a0 A
    -> AnnGood G (dom G) -> forall a, erase a0 = a -> Value a
           -> exists av, multi (head_reduction G) a0 av /\ CoercedValue av /\ erase av = a.
Proof.
  intros G a0 A H. induction H.
  all: intros GG aa E V; simpl in E; inversion E; subst.
  all: try solve [inversion V].
  all: try solve [eexists; repeat split;
                  try eapply multi_refl; eauto_lc].
  + exists (a_Pi rho A B).
    have ?: lc_tm (a_Pi rho A B) by eauto_lc.
    repeat split; try eapply multi_refl; eauto_lc.

  + have ?: lc_tm (a_Abs rho A a) by eauto_lc.
    destruct rho.
    ++ exists (a_Abs Rel A a).
       repeat split; try eapply multi_refl; eauto_lc.
    ++ (* irrelevant abstraction case *)
      inversion V. subst.
      match goal with
        [H5 : forall x, x `notin` ?L -> Value _ |- _ ] =>
        pick_fresh y; move: (H5 y ltac:(auto)) => Va; clear H5 end.

      have EE: erase (open_tm_wrt_tm a (a_Var_f y)) = open_tm_wrt_tm (erase_tm a) (a_Var_f y)
        by simpl_erase; auto.

       have G1 : AnnGood (y ~ Tm A ++ G) (dom (y ~ Tm A ++ G)) by  eapply AnnGood_add_tm; eauto.

       match goal with
         [ H1 : ∀ x : atom, x `notin` ?L → AnnGood _ _ -> _ |- _ ] =>
         move: (H1 y ltac:(auto) G1 _ EE Va) => [av [MS [VV EV]]] end.

       exists (a_Abs Irrel A (close_tm_wrt_tm y av)).
       repeat split.
       +++ eapply multi_An_AbsTerm_exists with (x:=y);
            autorewrite with lngen; eauto.
       +++ econstructor.
           eapply Value_AbsIrrel_exists with (x:=y); autorewrite with lngen; eauto_lc.
       +++ simpl_erase. rewrite EV.
           simpl. rewrite close_tm_wrt_tm_open_tm_wrt_tm; eauto using fv_tm_erase_tm.

  + destruct rho; simpl in V; inversion V; subst;
    move: (IHAnnTyping1 GG (erase b) eq_refl ltac:(auto)) => [av [MS [CV EE]]];
    inversion CV; subst.
    ++ exists (a_App av Rel a).
       repeat split. eapply multi_An_AppLeft; eauto_lc.
       repeat econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl. autorewcs. congruence.
    ++ move: (multi_preservation MS H) => TC. inversion TC.
       move: (values_have_value_types GG H9 H3) => VT.
       move: (consistent_a_Pi GG VT H11) => [A' [B' EQ]]. subst.
       pose VV := H3. clearbody VV.
       eapply An_Push with (b:=a) in H3; try eapply H11; try reflexivity.
       eexists.
       split. eapply multi_trans.
       eapply multi_An_AppLeft; eauto_lc.
       eapply multi_step; eauto_lc.
       eapply multi_refl; eauto_lc.
       repeat econstructor; eauto_lc.
       split.
       eapply CC; econstructor; eauto_lc.
       econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl in EE. simpl. congruence.
    ++ exists (a_App av Irrel a).
       repeat split. eapply multi_An_AppLeft; eauto_lc.
       repeat econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl. autorewcs. congruence.
    ++ move: (multi_preservation MS H) => TC. inversion TC.
       move: (values_have_value_types GG H9 H3) => VT.
       move: (consistent_a_Pi GG VT H11) => [A' [B' EQ]]. subst.
       pose VV := H3. clearbody VV.
       eapply An_Push with (b:=a) in H3; try eapply H11; try reflexivity.
       eexists.
       split. eapply multi_trans.
       eapply multi_An_AppLeft; eauto_lc.
       eapply multi_step; eauto_lc.
       eapply multi_refl; eauto_lc.
       repeat econstructor; eauto_lc.
       split.
       eapply CC; econstructor; eauto_lc.
       econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl in EE. simpl. congruence.

  + move: (IHAnnTyping1 GG _ eq_refl V) => [av [MS [CV EE]]].
    inversion CV.
    ++ subst.
      exists (a_Conv av g).
      repeat split.
      eapply multi_An_ConvTerm; eauto using AnnDefEq_lc3.
      eapply CC; eauto using AnnDefEq_lc3.
      simpl. autorewcs. auto.
    ++ subst.
      have ?: lc_tm a0 by eauto using Value_lc.
      have ?: lc_co g by eauto using AnnDefEq_lc3.
      exists (a_Conv a0 (g_Trans g0 g)).
      split.
      eapply multi_trans.
      eapply multi_An_ConvTerm; eauto.
      eapply multi_step.
      eapply An_Combine; eauto.
      eapply multi_refl; eauto.
      split. eapply CC; eauto.
      simpl. simpl in EE. auto.
  + exists (a_CPi phi B).
    have ?: lc_tm (a_CPi phi B) by eapply AnnTyping_lc1; eauto.
    repeat split; try eapply multi_refl; eauto using Value_lc;
      simpl; auto.
    econstructor; eauto using AnnTyping_lc1, AnnPropWff_lc.
  + exists (a_CAbs phi a).
    have ?: lc_tm (a_CAbs phi a). eapply AnnTyping_lc1; eauto.
    repeat split; try eapply multi_refl; eauto using Value_lc;
      simpl; auto.
    econstructor; eauto using AnnTyping_lc1, AnnPropWff_lc.
  + (* CApp case (for paths) *)
    simpl in V; inversion V; subst;
    move: (IHAnnTyping GG (erase a1) eq_refl ltac:(auto)) => [av [MS [CV EE]]];
    inversion CV; subst.
    ++ exists (a_CApp av g).
       repeat split.
       eapply multi_An_CAppLeft; eauto_lc.
       repeat econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl. autorewcs. congruence.
    ++ move: (multi_preservation MS H) => TC. inversion TC.
       move: (values_have_value_types GG H9 H3) => VT.
       move: (consistent_a_CPi GG VT H11) => [A' [B' EQ]]. subst.
       pose VV := H3. clearbody VV.
       eapply An_CPush with (g:=g0) in H3; try eapply H11; try reflexivity.
       eexists.
       split.
       eapply multi_trans.
       eapply multi_An_CAppLeft; eauto_lc.
       eapply multi_step; eauto_lc.
       eapply multi_refl; eauto_lc.
       repeat econstructor; eauto_lc.
       split.
       eapply CC; econstructor; eauto_lc.
       eapply Path_to_Path; eauto_lc.
       simpl in EE. simpl. congruence.
Qed.

(* simple solver for irrelevant goals *)
(* TODO replace args y AA b0 h0 with "fresh" *)
Ltac solve_irrelevant y AA b0 h0 :=
  match goal with
    [ H1 : irrelevant _ _ _ |- _ ] => inversion H1 end;
  match goal with
    [ H4 : forall x A, binds x _ _ -> x `notin` _ |- _ ] =>
    simpl in H4; econstructor; eauto;
    try (intros y AA b0; move: (H4 y AA b0) => h0; fsetdec) end.

(* paths are not (erased) abstractions. *)
Lemma paths_arent_abs :
  forall a T, Path T a -> forall rho b, a = a_UAbs rho b -> False.
Proof.
  intros a T P.
  induction P; intros r b0 EQ;
    try  destruct rho; simpl in *; inversion EQ.
Qed.

Ltac no_paths:=
  match goal with
    [ EE : erase (a_App ?b0 ?rho ?a) = a_UAbs _ ?b, H : Path ?T ?b0 |- _ ] =>
    destruct rho; simpl in EE;
    match goal with
      [ FF : ?a = a_UAbs _ ?b |- _ ] =>
      have P: (Path T a); by eauto using lc_tm_erase end end.

(* Each of the subcases are by induction on a0 to account for top-level coercions on the term.
   This tactic handles all of the inductive cases. *)
Ltac induction_a0 :=
  let IR := fresh  in
  let a0' := fresh in
  let y := fresh in
  let AA := fresh in
  let b0 := fresh in
  let h0 := fresh in
  match goal with
    [ IHa0 : ∀ A0 : tm, irrelevant ?G (dom ?G) ?a0 → _,
        H1 : irrelevant ?G _ (a_Conv ?a0 ?g),
        H2 : AnnTyping ?G (a_Conv ?a0 ?g) ?A0 |- _ ] =>
    inversion H2; subst;
    (have IR: irrelevant G (dom G) a0 by solve_irrelevant y AA b0 h0);
    move: (IHa0 _ IR ltac:(eauto) ltac:(auto)) =>
    [a0' [? ?]];
    exists (a_Conv a0' g);
    split; [ eapply multi_An_ConvTerm; eauto with lc | simpl; auto ]
  end.

Lemma reduction_annotation : forall a a',
    reduction_in_one a a' ->
    forall G a0 A0, irrelevant G (dom G) a0 -> AnnTyping G a0 A0 -> erase a0 = a ->
    exists a0', multi (head_reduction G) a0 a0' /\ erase a0' = a'.
Proof.
  intros a a' H.
  induction H.
  - (* E_AbsTerm. Body of irrelevant abs takes a step. *)
    intros.
    dependent induction a0; try destruct rho; simpl in H3; inversion H3; subst.
    + inversion H2. subst.
      pick fresh x for (L \u L0 \u (fv_tm a0_2) \u dom G \u fv_tm a').
      move: (H11 x ltac:(auto)) => RC. inversion RC. subst. clear H11.
      move: (H10 x ltac:(auto)) => T2. clear H10.
      inversion H1.
      have IR: irrelevant ((x ~ Tm a0_1) ++ G) (dom (x ~ Tm a0_1 ++ G))
                       (open_tm_wrt_tm a0_2 (a_Var_f x)).
      econstructor; eauto.
      { intros x0 A0 b0.
        destruct (binds_cons_1 _ x0 x _ _ _ b0).
        + split_hyp.
          inversion H9. subst.
          autorewcshyp H4.  auto.
        + move: (binds_In _ _ _ _ H7) => h0.
          have NE: x0 <> x. fsetdec.
          move: (H5 _ _ H7) => NI. simpl in NI.
          simpl_erase.
          move: (fv_tm_tm_tm_open_tm_wrt_tm_upper (erase a0_2) (a_Var_f x)) => h1.
          simpl in h1. fsetdec.
      }
      { eapply AnnGood_add_tm; eauto. }
      have h1: erase (open_tm_wrt_tm a0_2 (a_Var_f x)) =
               open_tm_wrt_tm (erase_tm a0_2) (a_Var_f x).
      simpl_erase. auto.
      move: (H0 x ltac:(auto) _ _ _ IR T2 h1) => [a0' [ms ee]].
      exists (a_Abs Irrel a0_1 (close_tm_wrt_tm x a0')).
      split.
      eapply multi_An_AbsTerm_exists with (x:=x);
        autorewrite with lngen; auto.
      simpl_erase. rewrite ee.
      simpl. autorewrite with lngen. auto.
    + inversion H2.
    + induction_a0.
  - (* E_AppRel *)
    intros.
    dependent induction a0; try destruct rho; simpl in H3; inversion H3; subst.
    + inversion H1. simpl in H4.
      inversion H2. subst.
      have I1: irrelevant G (dom G) a0_1.
      solve_irrelevant y AA b0 h0.
      move: (IHreduction_in_one _ _ _ I1 H11 eq_refl) => [a0_1' [MS E']].
      exists (a_App a0_1' Rel a0_2).
      split.
      eapply multi_An_AppLeft; eauto using AnnTyping_lc1.
      simpl. autorewcs. congruence.
    + induction_a0.
  - (* E_AppIrrel *)
    intros.
    dependent induction a0; try destruct rho; simpl in H2; inversion H2; subst.
    + inversion H1. simpl in H4.
      inversion H2. subst.
      have I1: irrelevant G (dom G) a0_1.
      solve_irrelevant y AA b0 h0.
      move: (IHreduction_in_one _ _ _ I1 H8 eq_refl) => [a0_1' [MS E']].
      exists (a_App a0_1' Irrel a0_2).
      split.
      eapply multi_An_AppLeft; eauto using AnnTyping_lc1.
      simpl. autorewcs. congruence.
    + induction_a0.
  - (* E_CAppLeft. *)
    intros.
    match goal with
      [ H2 : erase ?a0 = _ |- _ ] =>
      dependent induction a0; try destruct rho; simpl in H2; inversion H2; subst
    end.
    + induction_a0.
    + ann_invert_clear.
      have I: irrelevant G (dom G) a0. solve_irrelevant y AA b0 h0.
      match goal with
        [ H7 : AnnTyping ?G a0 ?A |- _ ] =>
        move: (IHreduction_in_one _ _ _ I H7 eq_refl) => [a0_1' [MS E']]
      end.
      exists (a_CApp a0_1' g).
      split. eapply multi_An_CAppLeft; eauto with lc.
      simpl. autorewcs. congruence.
  - (* E_AppAbs *)
    intros.
    (* Need induction on a0 for the coercions around the application. *)
    dependent induction a0; try destruct rho; simpl in H3; inversion H3; subst.
    + (* No coercions. a0 is a direct (Rel) application of
      a0_1, which erases to an abstraction. *)
      ann_invert_clear.
      inversion H1.
      have ?: Value (a_UAbs Rel v) by eauto.
      move: (erased_Value_reduces_to_CoercedValue H10 H4 H5 ltac:(auto)) =>
      [av ?]. split_hyp.
      move: (multi_preservation H6 H10) => Tav.
      (* Check if there is a coercion at the top of av *)
      match goal with [ H : CoercedValue av |- _ ] => inversion H; subst end.
      ++ (* Value av *)
         match goal with [ H10 : Value av , H9 : erase av = _ |- _ ] =>
            inversion Tav; subst; inversion H10; subst; simpl in H9; inversion H9 end.
         exists (open_tm_wrt_tm a a0_2).
         split.
         eapply multi_trans with (b:= a_App (a_Abs Rel A a) Rel a0_2).
         eapply multi_An_AppLeft; eauto_lc.
         eapply multi_step; eauto_lc.
         eapply multi_refl; eauto.
         { lc_inversion c. subst.
           pick fresh y.
           rewrite (tm_subst_tm_tm_intro y); auto.
           eapply tm_subst_tm_tm_lc_tm; eauto using AnnTyping_lc1. }
         rewrite open_tm_erase_tm. auto.
         (* prove that paths don't erase to abstractions. *)
         no_paths.
      ++ (* av = (a |> g) *)
         have LC: lc_tm a0_1 by eauto using AnnTyping_lc1.
         (* Push rule *)
         inversion H1.
         ann_invert_clear.
         match goal with
           [ H4 : AnnGood _ _,  H20 : AnnDefEq G (dom G) g A0 (a_Pi Rel A B),
             H18 : AnnTyping G a A0, H11: Value a |- _ ] =>
         move: (values_have_value_types H4 H18 H11) => VT;
         move: (consistent_a_Pi H4 VT H20) => [A' [B' EQ]]; subst;
         move: (An_Push _ _ _ _ a0_2 _ _ _ _ _ _ H11 H20 eq_refl eq_refl)=> RED end.
         have TA': AnnTyping G A' a_Star.
           { move: (AnnTyping_regularity H17) => T1. inversion T1. auto. }
         have Tb': AnnTyping G (a_Conv a0_2 (g_Sym (g_PiFst g))) A'.
           { eapply An_Conv; eauto.
             eapply An_Sym.  eauto. eauto using AnnTyping_regularity.
             eapply An_Refl; eauto. eauto with ctx_wff.
             eapply An_PiFst; eauto. }

         (* Now Beta *)
         simpl in *.
         match goal with
           [ H10: Value ?a, H9 : erase_tm ?a = _ , Ta : AnnTyping G ?a _ |- _ ] =>
           inversion Ta; subst; inversion H10; subst; simpl in H9; inversion H9 end.

         eexists.
         split.
         (* evaluate to application of coerced value *)
         eapply multi_trans with (b:= a_App (a_Conv (a_Abs Rel A' a0) g) Rel a0_2).
         eapply multi_An_AppLeft; eauto_lc.

         (* do push rule, lifting coercion to outside. *)
         eapply (multi_step _ RED).

         (* do beta reduction inside coercion *)
         eapply multi_step.
         eapply An_ConvTerm. eauto using AnnTyping_lc1, AnnDefEq_lc3.
         eapply An_AppAbs; eauto using AnnTyping_lc1.

         (* stop *)
         eapply multi_refl.
         { lc_inversion c. repeat econstructor; eauto_lc. }

         (* erasure property *)
         simpl_erase. auto.

         destruct rho.
         +++ have P: Path T (a_App (erase v) Rel (erase a0)); by eauto
                                                                    using lc_tm_erase.
         +++ have P: Path T (a_App (erase v) Irrel a_Bullet); by eauto using lc_tm_erase.
    + (* induction step for top-level coercions (Rel) *)
      induction_a0.
  - (* E_AppAbs Irrel*)
    intros.
    dependent induction a0; try destruct rho; simpl in H2; inversion H2; subst.
    + (* No coercions. a0 is a direct (Irrel) application of
        a0_1, which erases to an abstraction. *)
      ann_invert_clear.
      inversion H0.
      match goal with [H12 : AnnTyping G a0_1 (a_Pi Irrel A B),
                       H4  : AnnGood G (dom G),
                       H6  : erase_tm a0_1 = a_UAbs Irrel v |- _ ] =>
      move: H12 => Ta01;
      move: (erased_Value_reduces_to_CoercedValue Ta01 H4 H6
             ltac:(auto)) => [av [RE ?]];
      split_hyp end.
      move: (multi_preservation RE Ta01) => Tav.
      (* Check if there is a coercion at the top of av *)
      match goal with [ H : CoercedValue av |- _ ] => inversion H; subst end.
      ++ (* Value av *)
         match goal with [ H10 : Value av , H9 : erase av = _ |- _ ] =>
            inversion Tav; subst; inversion H10; subst; simpl in H9; inversion H9 end.
         exists (open_tm_wrt_tm a a0_2).
         split.
         eapply multi_trans with (b:= a_App (a_Abs Irrel A a) Irrel a0_2).
         eapply multi_An_AppLeft; eauto_lc.
         eapply multi_step; eauto_lc.
         eapply multi_refl; eauto.
         { lc_inversion c. subst.
           pick fresh y.
           rewrite (tm_subst_tm_tm_intro y); auto.
           eapply tm_subst_tm_tm_lc_tm; eauto using AnnTyping_lc1. }
         {
         (* argument really is irelevant. *)
           simpl_erase.
           pick fresh x.
           move: (H16 x ltac:(auto)) => RC. inversion RC.
           rewrite (tm_subst_tm_tm_intro x (erase a)).
           replace (a_Var_f x) with (erase (a_Var_f x)); auto.
           rewrite open_tm_erase_tm.
           rewrite tm_subst_tm_tm_fresh_eq; auto.
           rewrite (tm_subst_tm_tm_intro x (erase a)).
           replace (a_Var_f x) with (erase (a_Var_f x)); auto.
           rewrite open_tm_erase_tm.
           rewrite tm_subst_tm_tm_fresh_eq; auto.
           apply fv_tm_erase_tm; auto.
           apply fv_tm_erase_tm; auto.
         }

         no_paths.
      ++ (* av = (a |> g) *)
         have LC: lc_tm a0_1 by eauto using AnnTyping_lc1.
         (* Push rule *)
         inversion H0.
         ann_invert_clear.
         match goal with
           [ H4 : AnnGood _ _,  H20 : AnnDefEq G (dom G) g A0 (a_Pi Irrel A B),
             H18 : AnnTyping G a A0, H11: Value a |- _ ] =>
         move: (values_have_value_types H4 H18 H11) => VT;
         move: (consistent_a_Pi H4 VT H20) => [A' [B' EQ]]; subst;
         move: (An_Push _ _ _ _ a0_2 _ _ _ _ _ _ H11 H20 eq_refl eq_refl)=> RED;
         have TA': AnnTyping G A' a_Star by
           (move: (AnnTyping_regularity H18) => T1; inversion T1; auto)
         end.
         have Tb': AnnTyping G (a_Conv a0_2 (g_Sym (g_PiFst g))) A'.
           { eapply An_Conv; eauto.
             eapply An_Sym.  eauto. eauto using AnnTyping_regularity.
             eapply An_Refl; eauto. eauto with ctx_wff.
             eapply An_PiFst; eauto. }

         (* Now Beta *)
         simpl in *.
         match goal with
           [ H10: Value ?a, H9 : erase_tm ?a = _ , Ta : AnnTyping G ?a _ |- _ ] =>
           inversion Ta; subst; inversion H10; subst; simpl in H9; inversion H9 end.

         eexists.
         split.
         (* evaluate to application of coerced value *)
         eapply multi_trans with (b:= a_App (a_Conv (a_Abs Irrel A' a0) g) Irrel a0_2).
         eapply multi_An_AppLeft; eauto_lc.

         (* do push rule, lifting coercion to outside. *)
         eapply (multi_step _ RED).

         (* do beta reduction inside coercion *)
         eapply multi_step.
         eapply An_ConvTerm. eauto using AnnTyping_lc1, AnnDefEq_lc3.
         eapply An_AppAbs; eauto using AnnTyping_lc1.

         (* stop *)
         eapply multi_refl.

         { lc_inversion c. repeat econstructor; eauto_lc.
           pick fresh y.
           move: (H22 y ltac:(auto)) => h0.
           rewrite (tm_subst_tm_tm_intro y); auto.
           apply tm_subst_tm_tm_lc_tm; eauto_lc.
         }

         (* erasure property *)
         {
           simpl_erase.
           pick fresh x.
           move: (H22 x ltac:(auto)) => RC. inversion RC.
           rewrite (tm_subst_tm_tm_intro x (erase a0)).
           replace (a_Var_f x) with (erase (a_Var_f x)); auto.
           rewrite open_tm_erase_tm.
           rewrite tm_subst_tm_tm_fresh_eq; auto.
           rewrite (tm_subst_tm_tm_intro x (erase a0)).
           replace (a_Var_f x) with (erase (a_Var_f x)); auto.
           rewrite open_tm_erase_tm.
           rewrite tm_subst_tm_tm_fresh_eq; auto.
           apply fv_tm_erase_tm; auto.
           apply fv_tm_erase_tm; auto.
         }

         destruct rho.
         +++ have P: Path T (a_App (erase v) Rel (erase a0)); by eauto
                                                                    using lc_tm_erase.
         +++ have P: Path T (a_App (erase v) Irrel a_Bullet); by eauto using lc_tm_erase.
    + (* induction step for top-level coercions (irrel) *)
      induction_a0.
  - (* E_CAbsCApp *)
    intros.
    match goal with
      [ H3 : erase a0 = _ |- _ ] =>
    dependent induction a0; try destruct rho; simpl in H3; inversion H3; subst
    end.
    +  (* induction step *)
      induction_a0.

    + (* no coercion on top. *)
      clear IHa0.
      ann_invert_clear.
      match goal with
        [ H0 : irrelevant _ _ _ |- _ ] => inversion H0
      end.
      have ?: Value (a_UCAbs b) by eauto.
      match goal with
        [ H8 : AnnTyping G a0 _,
          H4 : AnnGood G (dom G),
          H5 : erase_tm a0 = _ |- _ ] =>
        move: (erased_Value_reduces_to_CoercedValue H8 H4 H5 ltac:(auto)) =>
        [av ?] ;  split_hyp end.
      match goal with
        [ H6 : multi (head_reduction G) a0 ?av,
          H8 : AnnTyping G a0 _ |- _ ] =>
        move: (multi_preservation H6 H8) => Tav
      end.
      (* Check if there is a coercion at the top of av *)
      match goal with [ H : CoercedValue av |- _ ] => inversion H; subst end.
      ++ (* Value av *)
        match goal with [ H10 : Value av , H9 : erase av = _ |- _ ] =>
        inversion Tav; subst; inversion H10; subst; try destruct rho;
        simpl in H9; inversion H9 end.
        subst.

        exists (open_tm_wrt_co a1 g).
        split.
        eapply multi_trans with (b := a_CApp (a_CAbs (Eq a b0 A1) a1) g).
        eapply multi_An_CAppLeft; eauto_lc.
        eapply multi_step.
        eapply An_CAppCAbs; eauto_lc.
        eapply multi_refl; eauto_lc.

        { invert_lc.
          eapply lc_body_tm_wrt_co; eauto_lc. }

        rewrite <- open_co_erase_tm2 with (g := g_Triv).
        auto.

      ++ (* av = (a |> g0) *)
         have LC: lc_tm a1 by eauto using Value_lc.
         (* Push rule *)
         match goal with
           [ H0 : irrelevant _ _ _ |- _ ] => inversion H0
         end.
         ann_invert_clear.
         match goal with
           [ H4 : AnnGood _ _,  H20 : AnnDefEq G (dom G) ?g0 A (a_CPi _ _),
             H18 : AnnTyping G a1 A, H11: Value a1 |- _ ] =>
         move: (values_have_value_types H4 H18 H11) => VT;
         move: (consistent_a_CPi H4 VT H20) => [phi' [B' EQ]]; subst;
         move : (An_CPush G a1 g0 g _ _ _ _ _ _ H11 H20 eq_refl eq_refl) => RED
         end.
         destruct phi' as [a' b' A'].
         have Tb':
           AnnDefEq G (dom G) (g_Cast g (g_Sym (g_CPiFst g0))) a' b'.
           { eapply An_Cast; eauto. }

         (* Now CBeta *)
         simpl in *.
         match goal with
           [ H10: Value ?a, H9 : erase_tm ?a = _ , Ta : AnnTyping G ?a _ |- _ ] =>
           inversion Ta; subst; inversion H10; subst; try destruct rho;
           simpl in H9; inversion H9 end.

         eexists.
         split.
         (* evaluate to application of coerced value *)
         eapply multi_trans.

         eapply multi_An_CAppLeft; eauto_lc.

         (* do push rule, lifting coercion to outside. *)
         eapply (multi_step _ RED).

         (* do beta reduction inside coercion *)
         eapply multi_step.
         eapply An_ConvTerm. eauto using AnnTyping_lc1, AnnDefEq_lc3.
         eapply An_CAppCAbs; eauto_lc.

         (* stop *)
         eapply multi_refl.

         { lc_inversion c. repeat econstructor; eauto_lc. }

         simpl_erase.
         rewrite <- open_co_erase_tm2 with (g := g_Triv).
         auto.

  - (* E_Axiom *)
    intros.
    dependent induction a0; try destruct rho; simpl in H2; inversion H2; subst.

    + unfold toplevel in H. unfold erase_sig in H.
      destruct (@binds_map_3 _ _ erase_csort F (Ax a A) an_toplevel H).
      split_hyp. destruct x; inversion H3. subst.

      exists a0. repeat split.
      eapply multi_step. eauto.
      eapply multi_refl.
      eauto using AnnTyping_lc1, an_toplevel_closed.

    + (* induction step *)
      induction_a0.

Unshelve. all: auto.
Qed.

End fc_consist.


Require Import List.
Import ListNotations.
(*Require Import Coq.Lists.ListSet.*)
Require Import Extraction.

Require Import Unify.
Require Import MiniKanrenSyntax.
Require Import Stream.
Require Import DenotationalSem.
Require Import OperationalSem.
Require Import OpSemSoundness.
Require Import OpSemCompleteness.

Module ObviousConstraintStore <: ConstraintStoreSig.

Definition constraint_store (s : subst) : Set := list (term * term).

Definition init_cs : constraint_store empty_subst := [].

Inductive add_constraint_ind_def : forall (s : subst), constraint_store s -> term -> term -> option (constraint_store s) -> Set :=
| acC : forall s cs t1 t2, add_constraint_ind_def s cs t1 t2 (Some ((t1, t2) :: cs)).

Definition add_constraint := add_constraint_ind_def.

Lemma add_constraint_exists :
  forall (s : subst) (cs : constraint_store s) (t1 t2 : term),
    {r : option (constraint_store s) & add_constraint s cs t1 t2 r}.
Proof. intros. eexists. econstructor. Qed.

Lemma add_constraint_unique :
  forall (s : subst) (cs : constraint_store s) (t1 t2 : term) (r r' : option (constraint_store s)),
    add_constraint s cs t1 t2 r -> add_constraint s cs t1 t2 r' -> r = r'.
Proof. intros. good_inversion H. good_inversion H0. simpl_existT_cs_same. reflexivity. Qed.

Inductive upd_cs_ind_def : forall (s : subst), constraint_store s -> forall (d : subst), option (constraint_store (compose s d)) -> Set :=
| uC : forall s cs d, upd_cs_ind_def s cs d (Some cs).

Definition upd_cs := upd_cs_ind_def.

Lemma upd_cs_exists :
  forall (s : subst) (cs : constraint_store s) (d : subst),
    {r : option (constraint_store (compose s d)) & upd_cs s cs d r}.
Proof. intros. eexists. econstructor. Qed.

Lemma upd_cs_unique :
  forall (s : subst) (cs : constraint_store s) (d : subst) (r r' : option (constraint_store (compose s d))),
    upd_cs s cs d r -> upd_cs s cs d r' -> r = r'.
Proof. intros. good_inversion H. good_inversion H0. simpl_existT_cs_same. reflexivity. Qed.

Definition in_denotational_sem_cs (s : subst) (cs : constraint_store s) (f : repr_fun) :=
  forall (t1 t2 : term), In (t1, t2) cs -> ~ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2).

Notation "[| s , cs , f |]" := (in_denotational_sem_cs s cs f) (at level 0).

Lemma init_condition : forall f, [| empty_subst , init_cs , f |].
Proof. unfold in_denotational_sem_cs. contradiction. Qed.

Lemma add_constraint_fail_condition :
  forall (s : subst) (cs : constraint_store s) (t1 t2 : term),
    add_constraint s cs t1 t2 None ->
    forall f, ~ ([| s , cs  , f |] /\ [ s , f ] /\ [| Disunify t1 t2 , f |]).
Proof. intros. inversion H. Qed.

Lemma add_constraint_success_condition :
  forall (s : subst) (cs cs' : constraint_store s) (t1 t2 : term),
    add_constraint s cs t1 t2 (Some cs') ->
    forall f, [| s , cs' , f |] /\ [ s , f ] <->
              [| s , cs  , f |] /\ [ s , f ] /\ [| Disunify t1 t2 , f |].
Proof.
  unfold in_denotational_sem_cs. intros.
  good_inversion H. simpl_existT_cs_same. good_inversion H4. split.
  { intros [DSCS DSS]. split; try split; intros; auto.
    { apply DSCS. right. auto. }
    { constructor. apply DSCS. left. auto. }  }
  { intros [DSCS [DSS DSG]]. good_inversion DSG. split; auto. intros.
    destruct H; auto. good_inversion H; auto. }
Qed.

Lemma upd_cs_fail_condition :
  forall (s : subst) (cs : constraint_store s) (d : subst),
    upd_cs s cs d None -> forall f, ~ ([| s , cs , f |] /\ [ compose s d , f ]).
Proof. intros. inversion H. Qed.

Lemma upd_cs_success_condition :
  forall (s : subst) (cs : constraint_store s) (d : subst) (cs' : constraint_store (compose s d)),
    upd_cs s cs d (Some cs') ->
    forall f, [| compose s d , cs' , f |] /\ [ compose s d , f ] <->
              [| s           , cs  , f |] /\ [ compose s d , f ].
Proof.
  unfold in_denotational_sem_cs. intros. good_inversion H. simpl_existT_cs_same.
  good_inversion H3. reflexivity.
Qed.

End ObviousConstraintStore.

Module OperationalSemObviousCS := OperationalSemAbstr ObviousConstraintStore.

Module OperationalSemObviousCSSoundness := OperationalSemSoundnessAbstr ObviousConstraintStore.

Module OperationalSemObviousCSCompleteness := OperationalSemCompletenessAbstr ObviousConstraintStore.

Import OperationalSemObviousCS.

Extraction Language Haskell.

Extraction "extracted/obvious_diseq_interpreter.hs" op_sem_exists.


From iris.algebra Require Import auth agree excl csum.
From iris.proofmode Require Import tactics.
From Perennial.base_logic.lib Require Export own.
From iris.prelude Require Import options.

Definition crashR := csumR fracR (agreeR unitO).
Definition NC_tok q : crashR := Cinl q.
Definition C_tok : crashR := Cinr (to_agree ()).

Class crashGS Σ := { crash_inG :> inG Σ crashR; crash_name : gname }.
Class crashGpreS Σ := { crash_inPreG :> inG Σ crashR }.

Definition crashΣ : gFunctors :=
    #[GFunctor (csumR fracR (agreeR unitO))].

Global Instance subG_crashGS {Σ} : subG crashΣ Σ → crashGpreS Σ.
Proof. solve_inG. Qed.

Global Instance crashGpreS_fromGS Σ :
  crashGS Σ → crashGpreS Σ.
Proof. intros ?. constructor. apply _. Defined.

Definition NC_def `{crashGS Σ} q := own crash_name (NC_tok q).
Definition NC_aux `{crashGS Σ} : seal NC_def. by eexists. Qed.
Definition NC `{crashGS Σ} := NC_aux.(unseal).
Global Arguments NC {_ _} _%Qp.
Definition C_def `{crashGS Σ} := own crash_name C_tok.
Definition C_aux `{crashGS Σ} : seal C_def. by eexists. Qed.
Definition C `{crashGS Σ} := C_aux.(unseal).

Lemma NC_alloc `{!crashGpreS Σ} : ⊢ |==> ∃ _ : crashGS Σ, NC 1.
Proof.
  iIntros.
  iMod (own_alloc (Cinl 1%Qp)) as (γ) "H".
  { rewrite //=. }
  iExists {| crash_name := γ |}.
  rewrite /NC NC_aux.(seal_eq). by iFrame.
Qed.

Lemma NC_alloc_strong `{!crashGpreS Σ} :
  ⊢ |==> ∃ γn : gname, let Hc := {| crash_name := γn |} in NC 1.
Proof.
  iIntros.
  iMod (own_alloc (Cinl 1%Qp)) as (γ) "H".
  { rewrite //=. }
  iExists γ.
  rewrite /NC NC_aux.(seal_eq). by iFrame.
Qed.

Section crash_tok_props.
Context `{!crashGS Σ}.
Implicit Types i : positive.
Implicit Types P Q R : iProp Σ.

Global Instance C_timeless : Timeless C.
Proof. rewrite /C C_aux.(seal_eq). apply _. Qed.

Global Instance C_persistent : Persistent C.
Proof. rewrite /C C_aux.(seal_eq). apply _. Qed.

Global Instance NC_timeless q : Timeless (NC q).
Proof. rewrite /NC NC_aux.(seal_eq). apply _. Qed.

Lemma NC_split q:
  NC q ⊢ NC (q/2) ∗ NC (q/2).
Proof. by rewrite /NC NC_aux.(seal_eq) -own_op -Cinl_op frac_op Qp.div_2. Qed.

Lemma NC_join q:
  NC (q/2) ∗ NC (q/2) ⊢ NC q.
Proof. by rewrite /NC NC_aux.(seal_eq) -own_op -Cinl_op frac_op Qp.div_2. Qed.

Lemma NC_C q: NC q -∗ C -∗ False.
Proof.
 rewrite /C C_aux.(seal_eq).
 rewrite /NC NC_aux.(seal_eq).
  iIntros "H H'".
  { by iDestruct (own_valid_2 with "H H'") as %?. }
Qed.

Lemma NC_upd_C: NC 1 ==∗ C.
Proof.
 rewrite /C C_aux.(seal_eq).
 rewrite /NC NC_aux.(seal_eq).
 iIntros "H". iMod (own_update with "H") as "$".
 { by apply cmra_update_exclusive. }
 done.
Qed.
End crash_tok_props.


(** * Functoriality of the construction of adjunctions *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Identity Functor.Composition.Core.
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import NaturalTransformation.Identity.
Require Import NaturalTransformation.Paths.
Require Import Functor.Dual NaturalTransformation.Dual.
Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.Dual.
Require Import Adjoint.Functorial.Parts.
Require Import HoTT.Tactics.
Require Import Basics.Tactics.

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

Local Open Scope natural_transformation_scope.
Local Open Scope morphism_scope.

Section laws.
  (** Some tactics to handle all the proofs.  The tactics deal with
      the "obvious" commutativity requirements by writing back and
      forth with associativity and respectfulness of composition,
      trying to find applications of the adjunction laws. *)
  Local Ltac try_various_ways tac :=
    progress repeat first [ progress tac
                          | rewrite <- ?Functor.Core.composition_of;
                            progress try_associativity_quick tac
                          | rewrite -> ?Functor.Core.composition_of;
                            progress try_associativity_quick tac ].

  (** This is suboptimal, because we keep rewriting back and forth
      with associativity and [composition_of].  But it only takes 0.74
      seconds total, so it's probably not worth optimizing. *)
  Local Ltac handle_laws' :=
    idtac;
    match goal with
      | _ => reflexivity
      | _ => progress rewrite ?identity_of, ?Category.Core.left_identity, ?Category.Core.right_identity
      | _ => try_various_ways ltac:(f_ap)
      | [ |- context[components_of ?T ?x] ]
        => try_various_ways ltac:(simpl rewrite <- (commutes T))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_1 A))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_2 A))
    end.

  Local Ltac t :=
    apply path_natural_transformation; intro;
    cbn;
    repeat handle_laws'.

  Section left.
    Local Arguments unit : simpl never.
    Local Arguments counit : simpl never.

    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.

      Definition left_identity_of
      : @left_morphism_of C C 1 D D 1 G F A G F A 1
        = ((left_identity_natural_transformation_2 _)
             o (right_identity_natural_transformation_1 _))%natural_transformation.
      Proof. t. Qed.

      Definition left_identity_of_nondep
      : @left_morphism_of_nondep C D G F A G F A 1 = 1%natural_transformation.
      Proof. t. Qed.
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D' C'.
      Variable F' : Functor C' D'.
      Variable A' : F' -| G'.
      Variable G'' : Functor D'' C''.
      Variable F'' : Functor C'' D''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (CF o G) (G' o DF).
      Variable T' : NaturalTransformation (CF' o G') (G'' o DF').

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of
      : (@left_morphism_of
           _ _ _ _ _ _ _ _
           A _ _ A''
           ((associator_1 _ _ _)
              o (T' oR DF)
              o (associator_2 _ _ _)
              o (CF' oL T)
              o (associator_1 _ _ _)))
        = (associator_2 _ _ _)
            o (DF' oL left_morphism_of A A' T)
            o (associator_1 _ _ _)
            o (left_morphism_of A' A'' T' oR CF)
            o (associator_2 _ _ _).
      Proof. t. Qed.
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D C.
      Variable F' : Functor C D.
      Variable A' : F' -| G'.
      Variable G'' : Functor D C.
      Variable F'' : Functor C D.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation G G'.
      Variable T' : NaturalTransformation G' G''.

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of_nondep
      : (@left_morphism_of_nondep _ _ _ _ A _ _ A'' (T' o T))
        = ((left_morphism_of_nondep A A' T)
             o (left_morphism_of_nondep A' A'' T')).
      Proof. t. Qed.
    End composition_of.
  End left.

  Section right.
    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.

      Definition right_identity_of
      : @right_morphism_of C C 1 D D 1 F G A F G A 1
        = ((right_identity_natural_transformation_2 _)
             o (left_identity_natural_transformation_1 _))%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of _ _ _ F^op G^op A^op).

      Definition right_identity_of_nondep
      : @right_morphism_of_nondep C D F G A F G A 1 = 1%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of_nondep _ _ _ F^op G^op A^op).
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C' D'.
      Variable G' : Functor D' C'.
      Variable A' : F' -| G'.
      Variable F'' : Functor C'' D''.
      Variable G'' : Functor D'' C''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (F' o CF) (DF o F).
      Variable T' : NaturalTransformation (F'' o CF') (DF' o F').

      Local Open Scope natural_transformation_scope.

      (** This is slow, at about 3.8 s.  It also requires the opposite
          association to unify. *)
      Definition right_composition_of
      : right_morphism_of
          A A''
          ((associator_2 DF' DF F)
             o ((DF' oL T)
                  o ((associator_1 DF' F' CF)
                       o ((T' oR CF)
                            o (associator_2 F'' CF' CF)))))
        = (associator_1 G'' DF' DF)
            o ((right_morphism_of A' A'' T' oR DF)
                 o ((associator_2 CF' G' DF)
                      o ((CF' oL right_morphism_of A A' T)
                           o (associator_1 CF' CF G))))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of
                 _ _ _ _ (DF^op) (DF'^op) _ _ _ (CF^op) (CF'^op)
                 _ _ A^op _ _ A'^op _ _ A''^op T^op T'^op).
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C D.
      Variable G' : Functor D C.
      Variable A' : F' -| G'.
      Variable F'' : Functor C D.
      Variable G'' : Functor D C.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation F F'.
      Variable T' : NaturalTransformation F' F''.

      Local Open Scope natural_transformation_scope.

      Definition right_composition_of_nondep
      : (@right_morphism_of_nondep _ _ _ _ A'' _ _ A (T' o T))
        = ((right_morphism_of_nondep A' A T)
             o (right_morphism_of_nondep A'' A' T'))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of_nondep _ _ _ _ _ A''^op _ _ A'^op _ _ A^op T'^op T^op).
    End composition_of.
  End right.
End laws.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import pile.
Require Import spec_stdlib.
Require Import spec_pile.
Require Import spec_pile_private.
Require Import PileModel.

Section Pile_VSU.
Variable M: MallocFreeAPD.

Lemma listrep_local_facts:
  forall sigma p,
   listrep M sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil) /\ Forall (Z.le 0) sigma).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros.
  entailer!; intuition.
Intros y. entailer!.
split.
split; intro. subst p. destruct H0; contradiction. discriminate.
constructor; auto. lia.
Qed.

Local Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep M sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; entailer!; auto with valid_pointer.
Qed.

Local Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma prep_local_facts:
  forall sigma p,
   prep M sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold prep.
Intros q.
entailer!.
Qed.
Local Hint Resolve prep_local_facts : saturate_local.

Lemma prep_valid_pointer:
  forall sigma p,
   prep M sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold prep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Local Hint Resolve prep_valid_pointer : valid_pointer.

Definition pilefreeable (p: val) : mpred :=
            malloc_token M Ews tpile p.

Definition PILE: PileAPD := Build_PileAPD (prep M) prep_local_facts prep_valid_pointer pilefreeable.

Definition PILEPRIV: PilePrivateAPD M := Build_PilePrivateAPD M PILE (eq_refl _).

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ size_t ]
       PROP (0 <= sizeof t <= Ptrofs.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vptrofs (Ptrofs.repr (sizeof t))) GLOBALS (gv)
       SEP (mem_mgr M gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr M gv; malloc_token M Ews t p * data_at_ Ews t p).

  Definition Pile_ASI: funspecs := PileASI M PILE.

  Definition pile_imported_specs:funspecs := MallocFreeASI M.

  Definition pile_internal_specs: funspecs := surely_malloc_spec::Pile_ASI.

  Definition PileVprog: varspecs. mk_varspecs prog. Defined.
  Definition PileGprog: funspecs := pile_imported_specs ++ pile_internal_specs.

Lemma body_surely_malloc: semax_body PileVprog PileGprog f_surely_malloc surely_malloc_spec.
Proof.
start_function.
forward_call (malloc_spec_sub M t) gv.
Intros p.
if_tac.
{ subst.
  forward_if False.
  - forward_call 1. contradiction.
  - congruence. }
forward_if True.
+ contradiction.
+ forward. entailer!.
+ forward. Exists p. entailer!.
Qed.

Lemma body_Pile_new: semax_body PileVprog PileGprog f_Pile_new (Pile_new_spec M PILE).
Proof.
start_function.
forward_call (tpile, gv).
split3; simpl; auto; computable.
Intros p.
repeat step!.
simpl spec_pile.pilerep.
unfold prep, listrep, pile_freeable.
repeat step!.
Qed.

Lemma body_Pile_add: semax_body PileVprog PileGprog f_Pile_add (Pile_add_spec M PILE).
Proof.
start_function.
forward_call (tlist, gv).
split3; simpl; auto; computable.
Intros q.
simpl spec_pile.pilerep; unfold prep.
Intros head.
forward.
forward.
forward.
forward.
simpl pilerep; unfold prep.
Exists q.
unfold listrep at 2; fold listrep.
Exists head.
entailer!; try apply derives_refl.
Qed.

Lemma body_Pile_count: semax_body PileVprog PileGprog f_Pile_count (Pile_count_spec PILE).
Proof.
start_function.
simpl pilerep; unfold prep. Intros head.
forward.
unfold Sfor.
forward.
forward_loop (EX r:val, EX s2: list Z,
   PROP(0 <= sumlist s2 <= sumlist sigma)
   LOCAL(temp _c (Vint (Int.repr (sumlist sigma - sumlist s2)));
              temp _p p; temp _q r)
   SEP (data_at Ews tpile head p;
          listrep M s2 r -* listrep M sigma head;
          listrep M s2 r))%assert
   break:
  (PROP()
   LOCAL(temp _c (Vint (Int.repr (sumlist sigma))); temp _p p)
   SEP (data_at Ews tpile head p;
          listrep M sigma head))%assert.
-
Exists head sigma.
entailer!. rewrite Z.sub_diag. auto.
apply wand_sepcon_adjoint. cancel.
-
Intros r s2.
forward_if (r<>nullval).
forward.
entailer!.
subst r.
forward.
entailer!.
assert (s2=nil) by intuition; subst s2.
simpl. rewrite Z.sub_0_r; auto.
sep_apply (modus_ponens_wand (listrep M s2 nullval)).
cancel.
Intros.
destruct s2.
assert_PROP False; [ | contradiction]. {
 entailer!. assert (r=nullval) by intuition; subst r. congruence.
}
unfold listrep at 3; fold (listrep M).
Intros r'.
forward.
forward. {
 entailer!.
 simpl in H0.
 clear - H0 H H2 H9.
 rewrite (Int.signed_repr z) by rep_lia.
 rewrite (Int.signed_repr) by rep_lia.
 assert (0 <= sumlist s2). {
 clear - H9. induction s2; simpl; auto. lia.
 inv H9. apply IHs2 in H2. lia.
 }
 rep_lia.
}
forward.
Exists r' s2.
entailer!.
simpl. split.
simpl in H0.
 assert (0 <= sumlist s2). {
 clear - H9. induction s2; simpl; auto. lia.
 inv H9. apply IHs2 in H2. lia.
 }
 rep_lia.
 f_equal; f_equal; lia.
apply -> wand_sepcon_adjoint.
match goal with |- (_ * ?A * ?B * ?C)%logic |-- _ =>
 assert ((A * B * C)%logic |-- listrep M (z::s2) r) end.
unfold listrep at 2; fold (listrep M). Exists r'. entailer!.
sep_apply H10.
sep_apply modus_ponens_wand.
auto.
 -
forward.
simpl pilerep; unfold prep.
Exists head.
cancel.
Qed.

Lemma body_Pile_free: semax_body PileVprog PileGprog f_Pile_free (Pile_free_spec M PILE).
Proof.
start_function.
simpl pilerep; unfold prep.
simpl pile_freeable. unfold pilefreeable. Intros head.
forward.
forward_while (EX q:val, EX s2: list Z,
   PROP ( )
   LOCAL (temp _q q; temp _p p; gvars gv)
   SEP (data_at Ews tpile head p;
       listrep M s2 q; malloc_token M Ews tpile p;
   mem_mgr M gv))%assert.
{ Exists head sigma; entailer!. }
{ entailer!. }
{ destruct s2.
   assert_PROP False; [|contradiction]. unfold listrep. entailer!.
  unfold listrep; fold (listrep M).
  Intros y.
  forward.
  forward_call (free_spec_sub M (Tstruct _list noattr)) (q, gv).
  rewrite if_false by (intro; subst; contradiction).
  cancel.
  forward.
  Exists (y, s2).
  entailer!. cancel. }
subst.
assert_PROP (p<>nullval). entailer!.
forward_call (free_spec_sub M (Tstruct _pile noattr))  (p, gv).
rewrite if_false by auto.
cancel.
forward.
rewrite (proj1 H0) by auto.
unfold listrep.
entailer!.
Qed.

Definition PileVSU: @VSU NullExtension.Espec
           nil pile_imported_specs ltac:(QPprog prog) Pile_ASI emp.
 Proof.
    mkVSU prog pile_internal_specs.
    + solve_SF_internal body_surely_malloc.
    + solve_SF_internal body_Pile_new.
    + solve_SF_internal body_Pile_add.
    + solve_SF_internal body_Pile_count.
    + solve_SF_internal body_Pile_free.
  Qed.

Definition PilePrivateVSU: @VSU NullExtension.Espec
      nil pile_imported_specs ltac:(QPprog prog) (PilePrivateASI M PILEPRIV) emp.
 Proof.
    mkVSU prog pile_internal_specs.
    + solve_SF_internal body_surely_malloc.
    + solve_SF_internal body_Pile_new.
    + solve_SF_internal body_Pile_add.
    + solve_SF_internal body_Pile_count.
    + solve_SF_internal body_Pile_free.
  Qed.

End Pile_VSU.


Add LoadPath "../from_compcert".
Require Import Libs.
(*Require Import Floats.*)
Require Import AST.
Require Import Setoid.
Require Import ArithClasses.

(* we define the type of memories for Loops *)

(* memory is splitted in arrays. Each array is recognised through it's
   ident.

   each cell of the array is then accessed through a list of indexes
   of type int *)

Record Array_Id := mk_Array_Id {
  open_Array_Id : ident}.

Global Instance singletonInd_Array_Id : singletonInd Array_Id ident :=
{ open := open_Array_Id;
  mk := mk_Array_Id}.
Proof.
  destruct i; auto.
  auto.
Qed.

Record Cell_Id `(Numerical Num) := mkCellIdent
  { array : Array_Id;
    cell : list Num}.

Implicit Arguments Cell_Id [[H]].
Implicit Arguments array [[Num] [H]].
Implicit Arguments cell [[Num] [H]].

Definition z2icell (ci: Cell_Id Z) : option (Cell_Id int) :=
  do c <- z2ilist (ci.(cell));
  Some {| array := ci.(array);
     cell := c|}.

Definition i2zcell (ci: Cell_Id int) : Cell_Id Z :=
  {| array := ci.(array);
     cell := i2zlist ci.(cell)|}.

Lemma z2i2zcell zci ici: z2icell zci = Some ici -> i2zcell ici = zci.
Proof.
  unfold z2icell, i2zcell.
  destruct zci, ici. simpl. intro SOME.
  monadInv SOME.
  inv SOME.
  f_equal.
  apply z2i2zlist. auto.
Qed.

Global Instance EqDec_t `{Numerical Num}: EqDec (Cell_Id Num).
Proof.
  constructor. intros.
  dec_eq.
Qed.

Module Type BASEMEM(N:NUMERICAL).
  Import N.
  Existing Instance Numerical_Num.

  (* values of the language *)
  Parameter Value: Type.

  (* memories *)
  Parameter Memory: Type.

  (* memories can be of "same layout", and it's an equivalence
     relation. One can see two memories with the same layout as memories
     with the same arrays, containing the same layout of values. *)

  Parameter same_memory_layout: relation Memory.

  Declare Instance Equiv_smt: Equivalence same_memory_layout.

  Parameter read: Memory -> Cell_Id Num -> option Value.

  (* two memories with same layout are readable at the same locations *)

  Parameter read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
    is_some (read mem1 ci) -> is_some (read mem2 ci).

  Parameter write: Memory -> Cell_Id Num -> Value -> option Memory.

  (* you don't change the layout of a memory by writing in it *)

  Parameter write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.

  (* two memories with the same layout are accessible at the same locations *)
  Parameter write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 ->
    (is_some (write mem1 ci v) -> is_some (write mem2 ci v)).

  (* write followed by a read *)
  Definition read_write mem ci v : option Value :=
    do mem' <- write mem ci v;
    read mem' ci.

  (* at the same location for two memories with the same layout, we read
     the new value *)
  (* one might have espect something like:

     read_write mem1 ci v = Some mem2 ->
     read mem2 ci = Some v

     This would not take into account the fact that writing at some
     location can lead to lose information. Say you have a char[] and
     you write a large value in it. The compiler will automatically
     downgrade the large value to a char before writing it. So reading
     it will lead to a value in the range of char, not the initial one.

     For the correctness of the reordering of write, it is in fact
     useless to know exactly what would be read, but just that it is
     the same, whatever the order of the writes are*)

  Parameter rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.

  (* at an other location, we read the old value *)
  Parameter rwo: forall mem1 mem2 ci1 ci2 v,
    write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.

End BASEMEM.

(* This is a very simplist instance of the module type. A more
   credible one can be found in OtherMemory. It is to show it is
   instanciable and to "explain" better some prerequisites*)

Module BMem(N:NUMERICAL) <: BASEMEM(N).
  Import N.
  Existing Instance Numerical_Num.

  Definition Value := Z.

  (*
  Inductive has_type: value -> typ -> Prop :=
  | HT_int: forall i, has_type (Vint i) Tint
  | HT_float: forall f, has_type (Vfloat f) Tfloat.

  Definition typ_of (v:val) :=
    match v with
      | Vint _ => Tint
      | Vfloat _ => Tfloat
    end.
  *)
  Module ValEqDec <: EQUALITY_TYPE.
    Definition t := Value.
    Global Instance EqDec_t: EqDec Value.
    Proof.
      constructor. unfold Value.
      apply ZEqDec.EqDec_t.
    Qed.
  End ValEqDec.

  Definition valid_cell:= Cell_Id Num -> bool.

  Definition eqA_valid_cell (mt1 mt2: valid_cell) := forall ci, mt1 ci = mt2 ci.

  Lemma valid_cell_equiv: Equivalence eqA_valid_cell.
  Proof.
    prove_equiv; dintuition congruence.
  Qed.

  Instance EqA_mt : EqA valid_cell:=
  { eqA := eqA_valid_cell;
    eqAequiv := valid_cell_equiv}.

  (* a memory is a mapping between Cell_Ids and Values *)
  Definition Memory := Cell_Id Num -> option Value.

  Implicit Type m: Memory.

  Definition valid_cell_of (mem: Memory) ci :=
    match mem ci with
      | None => false
      | Some _ => true
    end.

  Definition same_memory_layout mem1 mem2 := valid_cell_of mem1 ≡ valid_cell_of mem2.

  Global Instance Equiv_smt: Equivalence same_memory_layout.
  Proof.
    prove_equiv; unfold same_memory_layout.
    reflexivity. symmetry; auto.
    intros * H H0. eapply transitivity; eauto.
  Defined.

  Definition read m ci:= m ci.

  (* two memories with same layout are readable at the same locations *)

(*  Lemma same_typ_of: forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
    typ_of <$> mem1 ci = typ_of <$> mem2 ci.
  Proof.
    intros * H.
    unfold same_memory_layout, mem_type_of in H.
    simpl in *. auto.
  Qed.*)

  Lemma read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 -> is_some (read mem1 ci) ->
      is_some (read mem2 ci).
  Proof.
    unfold same_memory_layout, read, valid_cell_of.
    intros * H. compute in H. specialize (H ci).
    destruct (mem1 ci), (mem2 ci); intro; simpl in *;  auto.
  Qed.

  Definition write m ci v :=
    if valid_cell_of m ci then
      Some (fun ci' => if ci' == ci then Some v else m ci')
    else
      None.

  (* you don't change the layout of a memory by writing in it *)

  Lemma write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.
  Proof.
    unfold write, same_memory_layout.
    intros mem1 mem2 ci v H.
    simpl. intro ci'.
    dest_if; simpl; clean.
    unfold valid_cell_of in *; simpl in *.
    dest==; subst; auto.
  Qed.

  Lemma write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 -> (is_some (write mem1 ci v) -> is_some (write mem2 ci v)).
  Proof.
    unfold same_memory_layout, write, valid_cell_of. compute.
    intros mem1 mem2 ci v H.
    specialize (H ci).
    destruct (mem1 ci); destruct (mem2 ci); clean.
  Qed.

  Definition read_write m ci v : option Value :=
    do m' <- write m ci v;
    read m' ci.

  Lemma rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.
  Proof.
    unfold same_memory_layout, write, read, valid_cell_of. compute.
    intros mem1 mem2 ci v H.
    specialize (H ci).
    destruct (mem1 ci); destruct (mem2 ci); clean.
  Qed.

  Lemma rwo: forall mem1 mem2 ci1 ci2 v, write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
  Proof.
    unfold same_memory_layout, write, read, valid_cell_of. compute.
    intros mem1 mem2 ci1 ci2 v H H0.
    destruct (mem1 ci1); clean.
  Qed.

End BMem.

(* build a complete memory from a base memory *)
Module MEMORY (N:NUMERICAL) (BM: BASEMEM(N)).
  Export BM.

  (* two memories are equivalent if the map the same cells to the same values
     and they have the same layout *)
  Definition eqA_memory mem1 mem2 :=
    same_memory_layout mem1 mem2 /\
    forall ci, read mem1 ci = read mem2 ci.

  Lemma eqA_mem_equiv : Equivalence eqA_memory.
  Proof.
    prove_equiv; unfold eqA_memory; intros; split'.
    Case "Reflexivity"; SCase "left".
      reflexivity.
    Case "Reflexivity"; SCase "right".
      reflexivity.
    Case "Symmetry"; SCase "left".
      inv H. symmetry; auto.
    Case "Symmetry"; SCase "right".
      inv H; symmetry; auto.
    Case "Transitivity"; SCase "left".
      inv H; inv H0; etransitivity; eauto.
      inv H; inv H0; etransitivity; eauto.
  Qed.

  (* this gives us the notation ≡ *)
  Global Instance EqA_memory : EqA Memory :=
  { eqA := eqA_memory;
    eqAequiv := eqA_mem_equiv}.

  Lemma EqA_memory_unfold: forall mem1 mem2,
    mem1 ≡ mem2 = (same_memory_layout mem1 mem2 /\
    forall ci, read mem1 ci = read mem2 ci).
  Proof.
    reflexivity.
  Qed.

  Lemma use_EqA_memory_1: forall mem1 mem2,
    mem1 ≡ mem2 -> forall ci, read mem1 ci = read mem2 ci.
  Proof.
    intros * [? ?]; auto.
  Qed.

  Lemma use_EqA_memory_2: forall mem1 mem2,
    mem1 ≡ mem2 -> same_memory_layout mem1 mem2.
  Proof.
    intros * [? ?]; auto.
  Qed.

  (* we don't want EqA_memory to be unfold in general *)
  Global Opaque EqA_memory.

  Global Hint Resolve use_EqA_memory_1 use_EqA_memory_2 read_same_layout
    write_keep_layout write_same_layout rws rwo: memory.

  Lemma smt_refl: forall m, same_memory_layout m m.
  Proof. reflexivity. Qed.

  Lemma smt_sym: forall mem1 mem2, same_memory_layout mem1 mem2 -> same_memory_layout mem2 mem1.
  Proof. symmetry. auto. Qed.

  Lemma smt_trans: forall mem1 mem2 m3, same_memory_layout mem1 mem2 -> same_memory_layout mem2 m3 -> same_memory_layout mem1 m3.
  Proof. etransitivity; eauto. Qed.

  Global Hint Immediate smt_sym: memory.
  Global Hint Resolve 5 smt_trans: memory.
  Hint Extern 1 (same_memory_layout ?X ?X) => reflexivity: memory.

  Ltac get_all_mem_layouts :=
  option_on_right;
  repeat
  match goal with
    | H: ?mem1 ≡ ?mem2 |- _ =>
      match goal with
        | H' : same_memory_layout mem1 mem2 |- _ => fail 1
        | H' : same_memory_layout mem2 mem1 |- _ => fail 1
        | |- _ =>
          pose proof (use_EqA_memory_2 _ _ H)
      end
  end;
  repeat
  match goal with
    | H: write ?mem1 _ _ = Some ?mem2 |- _ =>
      match goal with
        | H' : same_memory_layout mem1 mem2 |- _ => fail 1
        | H' : same_memory_layout mem2 mem1 |- _ => fail 1
        | |- _ =>
          pose proof (write_keep_layout _ _ _ _ H)
      end
  end.

  Definition owrite omem ci v: option Memory :=
    do mem <- omem;
    write mem ci v.

  Lemma rws': forall mem1 mem2 mem1' mem2' ci v, same_memory_layout mem1 mem2 ->
    write mem1 ci v = Some mem1' -> write mem2 ci v = Some mem2' ->
    read mem1' ci = read mem2' ci.
  Proof.
    intros mem1 mem2 mem1' mem2' ci v H H0 H1.
    pose proof (rws mem1 mem2 ci v H). compute in H2.
    rewrite H0, H1 in H2. auto.
  Qed.
  Hint Resolve rws': memory.

  Ltac check_diff x y :=
    match goal with
      | H : x <> y |- _ => idtac
      | H : y <> x |- _  => idtac
    end.

  Ltac push_read_up :=
  repeat
  match goal with
    | H: write ?mem1 ?ci1 ?v = Some ?mem2 |- context[read ?mem2 ?ci2] =>
      check_diff ci1 ci2;
      replace (read mem2 ci2) with (read mem1 ci2) by (symmetry; eapply rwo; eauto)
  end.

  Ltac solve_same_memory :=
    repeat match goal with
             | H : _ ≡ _ |- _ => apply use_EqA_memory_2 in H
           end;
    repeat match goal with
             | H: write _ _ _ = Some _ |- _ =>
               apply write_keep_layout in H; revert H
             | H : same_memory_layout _ _ |- _ => revert H
           end;
    clear'; intros;
    let rec aux := (* aux is used to backtrack *)
    match goal with
    | H: same_memory_layout ?m1 ?m2 |- same_memory_layout ?m1 ?m2
      => apply H
    | H: same_memory_layout ?m1 ?m2 |- same_memory_layout ?m1 ?m2
      => symmetry; apply H
    | H: same_memory_layout ?m1 _ |- same_memory_layout ?m1 _ =>
      etransitivity; [eapply H| clear H; solve [aux]]
    | H: same_memory_layout _ ?m1 |- same_memory_layout ?m1 _ =>
      etransitivity; [symmetry; eapply H| clear H; solve [aux]]
    end in solve [aux].

  (* if two cells are differents, we can permut the write *)
  Lemma permut_write: forall mem1 mem2 ci1 ci2 v1 v2, ci1 <> ci2 ->
    mem1 ≡ mem2 ->
    owrite (write mem1 ci1 v1) ci2 v2 ≡ owrite (write mem2 ci2 v2) ci1 v1.
  Proof.
    intros * DIFF EQUIV.
    remember (write mem1 ci1 v1) as omem1.
    remember (write mem2 ci2 v2) as omem2.
    destruct' omem1 as [mem1'|]; destruct' omem2 as [mem2'|];
    unfold owrite; prog_dos; prog_dos; clean; try reflexivity.

    Case "Some mem1'"; SCase "Some mem2'".

    repeat match goal with
        | H: write ?M1 ?CI ?V = Some _|- context[write ?M2 ?CI ?V] =>
          let HSOME := fresh in
          let HSAME := fresh in
            assert (is_some (write M2 CI V)) as HSOME by
            (assert (same_memory_layout M1 M2) as HSAME by solve_same_memory;
             eapply write_same_layout;[ eapply HSAME| instantiate; eauto]);
            inv HSOME
      end.
    simpl; rewrite EqA_memory_unfold.
    get_all_mem_layouts.

    split'.
    SSCase "left".
      eauto with memory.
    SSCase "right".
      intro ci.
      dest ci == ci1; dest ci == ci2; repeat (progress subst); auto;
        push_read_up; eauto with memory.

    Case "Some mem1'"; SCase "None".
    simpl.
    get_all_mem_layouts.
    prog_match_option; auto.

    assert (is_some (write mem ci2 v2)) by auto. symmetry in H0.
    eapply (write_same_layout mem mem2) in H1.
    rewrite Heqomem2 in H1. auto. etransitivity; eauto.

    Case "None"; SCase "Some mem2'".
    simpl.
    get_all_mem_layouts.
    case_eq (write mem2' ci1 v1); intros; auto.

    assert (is_some (write mem2' ci1 v1)) by auto.
    symmetry in H0. eapply (write_same_layout mem2' mem1) in H2.
    rewrite Heqomem1 in H2. auto.
    symmetry in H0. symmetry. etransitivity; eauto.
  Qed.

End MEMORY.

Module ZBMem := BMem(ZNum).
Module IntBMem := BMem(IntNum).

Module Zmem := MEMORY(ZNum)(ZBMem).
Module Intmem := MEMORY(IntNum)(IntBMem).

Module BmemI2Z(BMI: BASEMEM(IntNum)) <: BASEMEM(ZNum).

  (* values of the language *)
  Definition Value:= BMI.Value.

  (* memories *)
  Definition Memory := BMI.Memory.
  Implicit Type m: Memory.
  Implicit Type ci: Cell_Id Z.

  (* memories can be of "same layout", and it's an equivalence relation *)

  Definition same_memory_layout : relation Memory := BMI.same_memory_layout.

  Global Instance Equiv_smt: Equivalence same_memory_layout.
  Proof.
    unfold same_memory_layout.
    apply BMI.Equiv_smt.
  Qed.

  Definition read m ci : option Value :=
    do ci' <- z2icell ci;
    BMI.read m ci'.

  (* two memories with same layout are readable at the same locations *)

  Lemma read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
      is_some (read mem1 ci) -> is_some (read mem2 ci).
  Proof.
    intros * SMT SOME.
    unfold read in *.
    monadInv SOME. simpl_do.
    eapply BMI.read_same_layout; eauto.
  Qed.

  Definition write m ci v: option Memory :=
    do ci' <- z2icell ci;
    BMI.write m ci' v.

  (* you don't change the layout of a memory by writing in it *)

  Lemma write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.
  Proof.
    unfold write. intros * SOME.
    monadInv SOME. eapply BMI.write_keep_layout; eauto.
  Qed.

  Lemma write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 -> (is_some (write mem1 ci v)
      -> is_some (write mem2 ci v)).
  Proof.
    unfold write. intros * SMT SOME.
    monadInv SOME. simpl_do. eapply BMI.write_same_layout; eauto.
  Qed.

  Definition read_write m ci v : option Value :=
    do m' <- write m ci v;
    read m' ci.

  Lemma rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.
  Proof.
    intros * SMT.
    destruct (z2icell ci) as [ci'|] _eqn.
    pose proof (BMI.rws mem1 mem2 ci' v SMT).
    unfold BMI.read_write in H.
    unfold read_write, read, write.
    rewrite Heqo.
    compute in H. compute. auto.

    unfold read_write, read, write.
    rewrite Heqo. simpl_do. reflexivity.
  Qed.
  Lemma inv_cons: forall A (a1 a2 :A) l1 l2,
    tag_to_inv (a1 :: l1 = a2 :: l2).
  Proof. auto. Qed.
  Hint Rewrite inv_cons: opt_inv.

  Lemma rwo: forall mem1 mem2 ci1 ci2 v, write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
  Proof.
    unfold write, read.

    intros * SOME DIFF.
    monadInv SOME.
    prog_dos.
    eapply BMI.rwo; eauto.
    intro. apply DIFF. subst.
    erewrite <- z2i2zcell; eauto.
    erewrite <- (z2i2zcell ci1); eauto.
  Qed.

End BmemI2Z.


(* begin hide *)
From ITree Require Import
     ITree
     Basics.Monad
     Events.StateFacts
     Eq.Eqit.

From Vellvm Require Import
     Utilities
     Syntax
     Semantics.LLVMEvents
     Semantics.Denotation
     Handlers.Handlers.
(* end hide *)

Section InterpreterMCFG.

  (**
   Partial interpretations of the trees produced by the denotation of _VIR_ programs.
   The intent is to allow us to only interpret as many layers as needed
   to perform the required semantic reasoning, and lift for free the
   equivalence down the pipe.
   This gives us a _vertical_ notion of compositionality.
   *)

  Definition interp_mcfg1 {R} (t: itree L0 R) g :=
    let uvalue_trace       := interp_intrinsics t in
    let L1_trace           := interp_global uvalue_trace g in
    L1_trace.

  Definition interp_mcfg2 {R} (t: itree L0 R) g l :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    L2_trace.

  Definition interp_mcfg3 {R} (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    L3_trace.

  Definition interp_mcfg4 {R} RR (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := model_undef RR L3_trace in
    L4_trace.

  (* The interpreter stray away from the model starting from the fourth layer: we pick an arbitrary valid path of execution *)
  Definition interp_mcfg4_exec {R} (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := exec_undef L3_trace in
    L4_trace.

End InterpreterMCFG.

Section InterpreterCFG.

  (**
   Partial interpretations of the trees produced by the
   denotation of cfg. They differ from the ones of Vellvm programs by
   their event signature, as well as by the lack of a stack of local event.
   The intent is to allow us to only interpret as many layers as needed
   to perform the required semantic reasoning, and lift for free the
   equivalence down the pipe.
   This gives us a _vertical_ notion of compositionality.
   *)

  (**
   NOTE: Can we avoid this duplication w.r.t. [interpi]?
   *)

  Definition interp_cfg1 {R} (t: itree instr_E R) (g: global_env) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    L1_trace.

  Definition interp_cfg2 {R} (t: itree instr_E R) (g: global_env) (l: local_env) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    L2_trace.

  Definition interp_cfg3 {R} (t: itree instr_E R) (g: global_env) (l: local_env) (m: memory_stack) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    L3_trace.

  Definition interp_cfg4 {R} RR (t: itree instr_E R) (g: global_env) (l: local_env) (m: memory_stack) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := model_undef RR L3_trace in
    L4_trace.

End InterpreterCFG.

Module D := Denotation Addr LLVMEvents.
Export D.

Module SemNotations.

  Notation ℑ1 := interp_cfg1.
  Notation ℑ2 := interp_cfg2.
  Notation ℑ3 := interp_cfg3.
  Notation ℑ4 := interp_cfg4.
  Notation ℑ  := interp_cfg4.

  Notation ℑs1 := interp_mcfg1.
  Notation ℑs2 := interp_mcfg2.
  Notation ℑs3 := interp_mcfg3.
  Notation ℑs4 := interp_mcfg4.
  Notation ℑs  := interp_mcfg4.

  Notation Ret1 g x     := (Ret (g,x)).
  Notation Ret2 g l x   := (Ret (l,(g,x))).
  Notation Ret3 g l m x := (Ret (m,(l,(g,x)))).

  Notation "⟦ e 'at?' t '⟧e'" :=  (denote_exp t e).
  Notation "⟦ e 'at' t '⟧e'" :=   (denote_exp (Some t) e).
  Notation "⟦ e '⟧e'" :=          (denote_exp None e).
  Notation "⟦ e 'at?' t '⟧e3'" := (ℑ3 (translate exp_to_instr ⟦ e at? t ⟧e)).
  Notation "⟦ e 'at' t '⟧e3'" :=  (ℑ3 (translate exp_to_instr ⟦ e at t ⟧e)).
  Notation "⟦ e '⟧e3'" :=         (ℑ3 (translate exp_to_instr ⟦ e ⟧e )).

  Notation "⟦ i '⟧i'" :=        (denote_instr i).
  Notation "⟦ i '⟧i3'" :=       (ℑ3 ⟦ i ⟧i).

  Notation "⟦ c '⟧c'" :=          (denote_code c).
  Notation "⟦ c '⟧c3'" :=         (ℑ3 ⟦ c ⟧c).

  Notation "⟦ t '⟧t'" :=        (denote_terminator t).
  Notation "⟦ t '⟧t3'" :=       (ℑ3 (translate exp_to_instr ⟦ t ⟧t)).

  Notation "⟦ phi '⟧Φ' from"  := (denote_phi from phi) (at level 0, from at next level).
  Notation "⟦ phi '⟧Φ3' from" := (ℑ3 (denote_phi from phi)) (at level 0, from at next level).

  Notation "⟦ phis '⟧Φs' from"  := (denote_phis from phis) (at level 0, from at next level).
  Notation "⟦ phis '⟧Φs3' from" := (ℑ3 (denote_phis from phis)) (at level 0, from at next level).

  Notation "⟦ bk '⟧b'" :=  (denote_block bk).
  Notation "⟦ bk '⟧b3' id" := (ℑ3 (⟦ bk ⟧b id)) (at level 0, id at next level).

  Notation "⟦ bks '⟧bs'"  := (denote_ocfg bks).
  Notation "⟦ bks '⟧bs3' ids" := (ℑ3 (denote_ocfg bks ids)) (at level 0, ids at next level).

  Notation "⟦ f '⟧cfg'"  := (denote_cfg f).
  Notation "⟦ f '⟧cfg3'" := (ℑ3 (denote_cfg f)).

  Notation "⟦ f '⟧f'"  := (denote_function f).

  Ltac intros3 := intros (? & ? & ? & ?).

End SemNotations.


Add Search Blacklist "Private_" "_subproof".
Set Printing Depth 50.
Remove Search Blacklist "Private_" "_subproof".
Add Search Blacklist "Private_" "_subproof".
Add LoadPath "../..".
Require Import BetaJulia.BasicPLDefs.Identifier.
Require Import BetaJulia.Sub0280a.BaseDefs.
Require Import BetaJulia.Sub0280a.BaseMatchProps.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Open Scope btjm.
Lemma cname_eq__decidable : forall n1 n2 : cname, Decidable.decidable (n1 = n2).
Proof.
(intros n1 n2; destruct n1; destruct n2; (left; reflexivity) || (right; intros H; inversion H)).
Qed.
Definition sem_sub (t1 t2 : ty) := forall k : nat, ||-[ k][t1]<= [t2].
Notation "'||-' '[' t1 ']' '<=' '[' t2 ']'" := (sem_sub t1 t2) (at level 50) : btjm_scope.
Lemma sem_sub__refint_eXrefX : ||- [TRef tint]<= [TExist vX (TRef tX)].
Proof.
(intros k).
(destruct k; intros w1; exists 1; intros v Hm).
-
(apply match_ty_ref__weak_inv in Hm).
(destruct Hm as [t' Heq]; subst).
(simpl).
exists tint.
constructor.
-
(apply match_ty_ref__inv in Hm).
(destruct Hm as [t' [Heq Href]]; subst).
(simpl).
exists t'.
(split; intros w; exists w; tauto).
Qed.
Lemma sem_sub__eXrefX_eYrefY : ||- [TExist vX (TRef tX)]<= [TExist vY (TRef tY)].
Proof.
(intros k; intros w1; exists w1; intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm; contradiction).
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(apply match_ty_exist).
exists tx.
assumption.
Qed.
Lemma sem_sub_refeXrefX_eYrefY : ||- [TRef (TExist vX (TRef tX))]<= [TExist vY (TRef tY)].
Proof.
(intros k w1).
exists (S w1).
(intros v Hm).
(apply match_ty_exist).
exists (TExist vX (TRef tX)).
assumption.
Qed.
Lemma not_sem_sub__refint_refflt : ~ ||- [TRef tint]<= [TRef tflt].
Proof.
(intros Hcontra).
specialize (Hcontra 1 0).
(destruct Hcontra as [w2 Hcontra]).
(assert (Hm : |-[ 1, 0] TRef tint <$ TRef tint) by (apply match_ty_value_type__reflexive; constructor)).
specialize (Hcontra _ Hm).
clear Hm.
(apply match_ty_ref__inv in Hcontra).
(destruct Hcontra as [t' [Heq Hcontra]]).
(inversion Heq; subst).
clear Heq.
(destruct Hcontra as [Hcontra _]).
(assert (Hm : |-[ 0, 0] tint <$ tint) by (apply match_ty_value_type__reflexive; constructor)).
specialize (Hcontra 0).
(destruct Hcontra as [w2' Hcontra]).
specialize (Hcontra _ Hm).
(apply match_ty_cname__inv in Hcontra).
(inversion Hcontra).
Qed.
Lemma sem_sub__eunion__unione : forall (X : id) (t1 t2 : ty), ||- [TExist X (TUnion t1 t2)]<= [TUnion (TExist X t1) (TExist X t2)].
Proof.
(intros X t1 t2 k).
(intros w1).
exists w1.
(intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm).
contradiction.
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_union__inv in Hmx).
(destruct Hmx as [Hmx| Hmx]; [ apply match_ty_union_1 | apply match_ty_union_2 ]; apply match_ty_exist; exists tx; assumption).
Qed.
Lemma sem_sub__unione__eunion : forall (X : id) (t1 t2 : ty), ||- [TUnion (TExist X t1) (TExist X t2)]<= [TExist X (TUnion t1 t2)].
Proof.
(intros X t1 t2 k).
(intros w1).
exists w1.
(intros v Hm).
(apply match_ty_union__inv in Hm).
(destruct Hm as [Hm| Hm]).
-
(destruct w1).
+
(apply match_ty_exist__0_inv in Hm).
contradiction.
+
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_exist).
exists tx.
(apply match_ty_union_1).
assumption.
-
(destruct w1).
+
(apply match_ty_exist__0_inv in Hm).
contradiction.
+
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_exist).
exists tx.
(apply match_ty_union_2).
assumption.
Qed.
Lemma sem_sub__pair_exist_distr_1 : forall (X : id) (t1 t2 : ty), ||- [TPair (TExist X t1) t2]<= [TExist X (TPair t1 t2)].
Proof.
(intros X t1 t2 k w1).
(* Auto-generated comment: Succeeded. *)


Class inhabited(A: Type): Type := mk_inhabited { default: A }.
Global Arguments mk_inhabited {_} _.
Global Hint Mode inhabited + : typeclass_instances.

Global Hint Extern 1 (inhabited _) =>
  simple refine (mk_inhabited _); constructor
  : typeclass_instances.

Module InhabitedTests.
  Goal inhabited nat. typeclasses eauto. Abort.
  Goal inhabited (list nat). typeclasses eauto. Abort.
  Goal forall A, inhabited (option A). typeclasses eauto. Abort.

  Inductive test_foo: Type :=
  | C1(x: False)
  | C2
  | C3(x: False).

  Goal inhabited test_foo. typeclasses eauto. Abort.
End InhabitedTests.

(* TODO move code below to specific files *)

Require Import coqutil.Word.Interface.
Global Instance word_inhabited{width: BinInt.Z}{word: word.word width}: inhabited word :=
  mk_inhabited (word.of_Z BinInt.Z0).

Require Import coqutil.Map.Interface.
Global Instance map_inhabited{key value: Type}{map: map.map key value}: inhabited map :=
  mk_inhabited map.empty.

Module Option.
  Definition force{A: Type}{i: inhabited A}(o: option A): A :=
    match o with
    | Some a => a
    | None => default
    end.
End Option.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     AdversaryUniverse
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation

     ModelCheck.UniverseEqAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
     ModelCheck.ProtocolAutomation.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations.
Import RealWorld.RealWorldNotations.

Set Implicit Arguments.

(* User ids *)
Definition A   := 0.
Definition B   := 1.

Notation owner  := {| IdealWorld.read := true; IdealWorld.write := true |}.
Notation reader := {| IdealWorld.read := true; IdealWorld.write := false |}.
Notation writer := {| IdealWorld.read := false; IdealWorld.write := true |}.

Section IdealWorldDefs.
  Import IdealWorld.

  Definition mkiU
             (cv : channels)
             (perms__a perms__b : permissions)
             (p__a p__b : cmd (Base Nat)) : universe Nat :=
    {| channel_vector := cv;
       users :=
         $0
          $+ (A,   {| perms := perms__a ; protocol := p__a |})
          $+ (B,   {| perms := perms__b ; protocol := p__b |})
    |}.
End IdealWorldDefs.

Section RealWorldDefs.
  Import RealWorld.

  Definition mkrUsr (ks : key_perms) (p : user_cmd (Base Nat)) :=
    {| key_heap  := ks ;
       protocol  := p ;
       msg_heap  := [] ;
       c_heap    := [] ;
       from_nons := [] ;
       sent_nons := [] ;
       cur_nonce := 0
    |}.

  Definition mkrU
             (gks : keys)
             (keys__a keys__b : key_perms)
             (p__a p__b : user_cmd (Base Nat)) (adv : user_data Unit) : universe Nat Unit :=
    {| users :=
         $0 $+ (A, mkrUsr keys__a p__a)
            $+ (B, mkrUsr keys__b p__b)
     ; adversary        := adv
     ; all_ciphers      := $0
     ; all_keys         := gks
    |}.
End RealWorldDefs.

#[export] Hint Unfold mkrU mkrUsr : user_build.

Module SignPingSendProtocol.

  Section IW.
    Import IdealWorld.

    Notation CH__A2B := (Single 0).
    Notation perms_CH__A2B := 0.

    Definition PERMS__a := $0 $+ (perms_CH__A2B, {| read := true; write := true |}). (* writer *)
    Definition PERMS__b := $0 $+ (perms_CH__A2B, {| read := true; write := false |}). (* reader *)

    Definition ideal_univ_start :=
      mkiU (#0 #+ (CH__A2B, [])) PERMS__a PERMS__b
           (* user A *)
           ( n <- Gen
           ; _ <- Send (Content n) CH__A2B
           ; Return n)

           (* user B *)
           ( m <- @Recv Nat CH__A2B
           ; ret (extractContent m)).

  End IW.

  Section RW.
    Import RealWorld.

    Definition KID1 : key_identifier := 0.

    Definition KEY1  := MkCryptoKey KID1 Signing AsymKey.
    Definition KEYS  := $0 $+ (KID1, KEY1).

    Definition A__keys := $0 $+ (KID1, true).
    Definition B__keys := $0 $+ (KID1, false).

    Definition real_univ_start :=
      mkrU KEYS A__keys B__keys
           (* user A *)
           ( n  <- Gen
           ; c  <- Sign KID1 B (message.Content n)
           ; _  <- Send B c
           ; Return n)

           (* user B *)
           ( c  <- @Recv Nat (Signed KID1 true)
           ; v  <- Verify KID1 c
           ; ret (if fst v
                  then match snd v with
                       | message.Content p => p
                       | _                 => 0
                       end
                  else 1)).

  End RW.

  #[export] Hint Unfold
       A B KID1 KEY1 KEYS A__keys B__keys
       PERMS__a PERMS__b
       real_univ_start mkrU mkrUsr
       ideal_univ_start mkiU : constants.

  Import SimulationAutomation.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with constants; simpl) : core.

  #[export] Hint Extern 1 (PERMS__a $? _ = _) => unfold PERMS__a : core.
  #[export] Hint Extern 1 (PERMS__b $? _ = _) => unfold PERMS__b : core.

  #[export] Hint Extern 1 (istepSilent ^* _ _) =>
  autounfold with constants; simpl;
    repeat (ideal_single_silent_multistep A);
    repeat (ideal_single_silent_multistep B); solve_refl : core.

End SignPingSendProtocol.

Module EncPingSendProtocol.

  Section IW.
    Import IdealWorld.

    Definition CH__A2B : channel_id := Single 0.
    Definition perms_CH__A2B := 0.

    Definition PERMS__a := $0 $+ (perms_CH__A2B, {| read := false; write := true |}). (* writer *)
    Definition PERMS__b := $0 $+ (perms_CH__A2B, {| read := true; write := false |}). (* reader *)

    Definition ideal_univ_start :=
      mkiU (#0 #+ (CH__A2B, [])) PERMS__a PERMS__b
           (* user A *)
           ( n <- Gen
           ; _ <- Send (Content n) CH__A2B
           ; Return n)

           (* user B *)
           ( m <- @Recv Nat CH__A2B
           ; ret (extractContent m)).

  End IW.

  Section RW.
    Import RealWorld.

    Definition KID__A : key_identifier := 0.
    Definition KID__B : key_identifier := 1.

    Definition KEY__A  := MkCryptoKey KID__A Signing AsymKey.
    Definition KEY__B := MkCryptoKey KID__B Encryption AsymKey.
    Definition KEYS  := $0 $+ (KID__A, KEY__A) $+ (KID__B, KEY__B).

    Definition A__keys := $0 $+ (KID__A, true) $+ (KID__B, false).
    Definition B__keys := $0 $+ (KID__A, false) $+ (KID__B, true).

    Definition real_univ_start :=
      mkrU KEYS A__keys B__keys
           (* user A *)
           ( n  <- Gen
           ; c  <- SignEncrypt KID__A KID__B B (message.Content n)
           ; _  <- Send B c
           ; Return n)

           (* user B *)
           ( c  <- @Recv Nat (SignedEncrypted KID__A KID__B true)
           ; v  <- Decrypt c
           ; ret (extractContent v)).

  End RW.

  #[export] Hint Unfold
       A B KID__A KID__B KEY__A KEY__B KEYS A__keys B__keys
       PERMS__a PERMS__b
       real_univ_start mkrU mkrUsr
       ideal_univ_start mkiU : constants.

  Import SimulationAutomation.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with constants; simpl) : core.

  #[export] Hint Extern 1 (PERMS__a $? _ = _) => unfold PERMS__a : core.
  #[export] Hint Extern 1 (PERMS__b $? _ = _) => unfold PERMS__b : core.

  #[export] Hint Extern 1 (istepSilent ^* _ _) =>
  autounfold with constants; simpl;
    repeat (ideal_single_silent_multistep A);
    repeat (ideal_single_silent_multistep B); solve_refl : core.

End EncPingSendProtocol.