From iris.base_logic.lib Require Export fancy_updates wsat.
From iris.proofmode Require Import base tactics classes.
From mwp Require Import mwp mwp_adequacy mwp_lifting.
From mwp.mwp_modalities.ni_logrel Require Import mwp_right.
From iris.program_logic Require Export ectxi_language ectx_language language.

Section mwp_left.
  Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).
  Typeclasses Transparent mwpC_state_interp mwpC_modality.

  Definition mwpd_left : mwpData Λ Σ :=
    {| mwpD_state_interp := mwpD_SI;
       mwpD_Extra := [Prod val Λ; nat];
       mwpD_modality_index := [Prod expr Λ];
       mwpD_modality_bind_condition e1 e2 f g :=
         ∃ K (_: LanguageCtx K),
           e1 = K e2 ∧ g = (λ x y, (y.1, x.2 + y.2)) ∧
           ∀ v k, f (v, k) = K (of_val v);
      mwpD_modality idx E n Φ :=
        MWP@{mwpd_right mwpD_SI', n} idx @ E {{ w; k, Φ (w, k) }}%I;
    |}.

  Global Instance mwpC_left : mwpC mwpd_left.
  Proof.
    split.
    - intros idx E m n ? ? ?; simpl. apply mwp_ne.
      intros ? ? ?; auto.
    - intros idx E1 E2 n Φ Ψ HE; simpl.
      iIntros "HP Hic".
      iApply (mwp_strong_mono_wand _ _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      by iIntros (? ? ?) "?"; iApply "HP".
    - iIntros (idx E n Φ) "H";simpl.
      iApply mwp_right_intro; last eauto. simpl; lia.
    - intros e e' f g E n m Φ (K & HK & He & Hg & Hf); simplify_eq.
      iIntros "H"; simpl.
      iApply (mwp_right_bind _ _ _ _ _ _ n m); simpl; first done.
      iApply (mwp_strong_mono_wand _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      iIntros (v l _); rewrite Hf /=.
      iIntros "H".
      iApply (mwp_strong_mono_wand _ _ _ _ _ _ (λ v m _, _)); eauto; iFrame.
      by iIntros (? j _) "?".
  Qed.

  Global Instance mwpC_left_is_outer_fupd idx :
    mwpMIsOuterModal mwpd_left idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_left_is_outer_bupd idx :
    mwpMIsOuterModal mwpd_left idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_left_is_outer_except_0 idx :
    mwpMIsOuterModal mwpd_left idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsOuterModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H". by iMod "H".
  Qed.

  Global Instance mwpC_left_is_inner_fupd idx :
    mwpMIsInnerModal mwpd_left idx (λ E _ P, |={E}=> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_fupd _ _ _ _ (λ v m _, _)).
  Qed.

  Global Instance mwpC_left_is_inner_bupd idx :
    mwpMIsInnerModal mwpd_left idx (λ _ _ P, |==> P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_bupd _ _ _ _ (λ v m _, _)).
  Qed.

  Global Instance mwpC_left_is_inner_except_0 idx :
    mwpMIsInnerModal mwpd_left idx (λ _ _ P, ◇ P)%I.
  Proof.
    rewrite /mwpMIsInnerModal /mwpC_modality /mwpD_modality /=.
    iIntros (E n P) "H".
    by iApply (mwp_except_0 _ _ _ _ (λ v m _, _)).
  Qed.

  (* Global Instance mwpC_left_SupportsAtomicShift idx : *)
  (*   mwpMSupportsAtomicShift mwpd_left idx. *)
  (* Proof. *)
  (*   rewrite /mwpMSupportsAtomicShift /mwpC_modality /mwpD_modality /=. *)
  (*   iIntros (n E1 E2 Φ Hn) "H". *)
  (*   iApply (mwp_shift (mwpd_indexed_step_fupd mwpD_SI')); *)
  (*     eauto using mwp_indexed_step_fupd_AlwaysSupportsShift. *)
  (* Qed. *)

  Global Program Instance mwpC_left_SplitForStep idx :
    mwpMSplitForStep mwpd_left idx :=
    {|
      mwpM_split_for_step_M1 E P := |={E, ∅}=> ▷ P;
      mwpM_split_for_step_M2 E P := |={∅, E}=> P;
    |}%I.
  Next Obligation.
  Proof.
    iIntros (e n E P) "HP /=".
    rewrite /mwpC_modality /mwpD_modality /=.
    by iApply (mwp_indexed_step_fupd_index_step_fupd _ _ 1).
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    by iMod "HP"; iModIntro; iApply "HPQ".
  Qed.
  Next Obligation.
  Proof.
    iIntros (idx E P Q) "HPQ HP /=".
    iMod "HP"; iModIntro. by iApply "HPQ".
  Qed.

  Lemma mwp_left_strong_bind
        K `{!LanguageCtx K} K' `{!LanguageCtx K'} E e e' Φ :
    MWP@{mwpd_left, e'} e @ E {{ v; m | w ; k,
      MWP@{mwpd_left, K' (of_val w)}
        K (of_val v) @ E {{ w; n | u ; y, Φ w (m + n) (u, (k + y)) }} }}
    ⊢ MWP@{mwpd_left, K' e'} K e @ E {{ Φ }}.
  Proof.
    iIntros "H".
    iApply (@mwp_bind _ _ _ mwpC_left K _ _ e'
                     (λ '(v, k), K' (of_val v))
                     (λ x y, (y.1, x.2 + y.2))).
    { rewrite /mwpC_modality_bind_condition /=; eauto. }
    iApply mwp_mono; last eauto.
    intros ? ? []; auto.
  Qed.

Lemma mwp_left_change_of_index e1' e2' f E e Φ :
  (∀ Ψ n,
      MWP@{mwpd_right mwpD_SI', n}
        e1' @ E {{ v; n | [_], Ψ (f (v, n)) }} -∗
        MWP@{mwpd_right mwpD_SI', n}
        e2' @ E {{ v; n | [_], Ψ (v, n) }})
  -∗ MWP@{mwpd_left, e1'} e @ E {{ λ v n x, Φ v n (f x) }}
  -∗ MWP@{mwpd_left, e2'} e @ E {{ Φ }}.
Proof.
  iIntros "Hm H".
  iApply (mwp_change_of_index mwpd_left with "[Hm] H").
  iIntros (Ψ n) "H".
  by iApply "Hm".
Qed.

Lemma mwp_left_pure_step_index `{!Inhabited (state Λ)}  e1' e2' E e Φ φ n :
  PureExec φ n e2' e1' →
  φ →
  MWP@{mwpd_left, e1'} e @ E {{ v;k | w;m, Φ v k (w, n + m) }}
  ⊢ MWP@{mwpd_left, e2'} e @ E {{ v;m | [x], Φ v m x }}.
Proof.
  iIntros (Hexec Hφ) "Hic".
  iApply (mwp_left_change_of_index _ _ (λ '(v, m), (v, n + m))).
  - iIntros (??) "H".
    iApply mwp_right_pure_step; first done.
    iNext. iApply "H".
  - iApply mwp_wand_r; iSplitL; first iApply "Hic".
    by iIntros (??[]) "Hic".
Qed.

End mwp_left.

Section lifting.

Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI': state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → val Λ * nat → iProp Σ.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_fupd_lift_step idx E Φ e1 :
  to_val e1 = None →
    (∀ σ1, mwpD_SI σ1 -∗
      |={E, ∅}=>
     ▷ ∀ e2 σ2,
         ⌜prim_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
            (mwpD_SI σ2 ∗ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
                    e2 @ E {{ v; n| [x], Φ v (S n) x }}))
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (?) "?".
  iApply (mwp_lift_step (mwpd_left mwpD_SI mwpD_SI') idx E); simpl; auto.
Qed.

Lemma mwp_left_lift_pure_step idx E Φ e1 :
  to_val e1 = None →
  (∀ σ1 e2 σ2, prim_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
      ⌜prim_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e2 @ E
        {{ v; n | [x], Φ v (S n) x }})
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_step
            (mwpd_left mwpD_SI mwpD_SI') idx E);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_left_lift_atomic_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ ∀ v2 σ2,
            ⌜prim_step e1 σ1 [] (of_val v2) σ2 []⌝
             ={∅, E}=∗ (mwpD_SI σ2 ∗
                        MWP@{mwpd_right mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (??).
  by iApply (mwp_lift_atomic_step
               (mwpd_left mwpD_SI mwpD_SI') idx E).
Qed.

Lemma mwp_left_lift_atomic_det_step idx E Φ e1 :
  to_val e1 = None →
  Atomic StronglyAtomic e1 →
  (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     ▷ (∃ v2 σ2,
         ⌜∀ e2' σ2', prim_step e1 σ1 [] e2' σ2' [] →
                     σ2 = σ2' ∧ to_val e2' = Some v2⌝ ∧
                     |={∅, E}=> mwpD_SI σ2 ∗
                          MWP@{mwpd_right mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by iIntros (??);
    iApply (mwp_lift_atomic_det_step
              (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_left_lift_pure_det_step idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ σ1 e2' σ2, prim_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  ▷ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(??) "H".
  iApply (mwp_lift_pure_det_step
            (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_left_pure_step `{!Inhabited (state Λ)} idx E e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  ▷^n MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v ; m | [x], Φ v (n + m) x }}
  ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (Hexec Hφ) "Hic".
  iApply (mwp_pure_step (mwpd_left mwpD_SI mwpD_SI') idx); eauto.
  clear Hexec.
  iInduction n as [] "IH" forall (Φ); simpl; auto.
  iApply step_fupd_intro; first set_solver.
  iApply ("IH" $! (λ w k, Φ w (S k)) with "Hic").
Qed.

End lifting.

Section mwp_ectx_lifting.

Context {Λ : ectxLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → val Λ * nat → iProp Σ.

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_left_lift_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ ∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
                          e2 @ E {{ w; n | [x], Φ w (S n) x }}))
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by intros;
    iApply (mwp_lift_head_step
              (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_left_lift_pure_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
      ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
      MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
        e2 @ E {{ w; n| [x], Φ w (S n) x }})
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_head_step
            (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_left_lift_atomic_head_step idx E Φ e1 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
     ▷ ∀ v2 σ2,
       ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
          (mwpD_SI σ2 ∗ MWP@{mwpd_right mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }}))
     ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by intros;
    iApply (mwp_lift_atomic_head_step
              (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_left_lift_pure_det_head_step idx E Φ e1 e2 :
  to_val e1 = None →
  sub_redexes_are_values e1 →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2')→
  ▷ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros(???) "H".
  iApply (mwp_lift_pure_det_head_step
            (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1);
    simpl; eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

End mwp_ectx_lifting.

Section mwp_ectxi_lifting.

Context {Λ : ectxiLanguage}.
Context {Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).

Implicit Types P : iProp Σ.
Implicit Types Φ : (val Λ) → nat → val Λ * nat → iProp Σ.
Implicit Types v : (val Λ).
Implicit Types e : (expr Λ).

Typeclasses Transparent mwpC_state_interp mwpD_state_interp mwpC_modality.

Lemma mwp_left_lift_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
        ▷ (∀ e2 σ2,
            ⌜head_step e1 σ1 [] e2 σ2 []⌝ ={∅, E}=∗
             (mwpD_SI σ2 ∗ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
                            e2 @ E {{ w; n | [x], Φ w (S n) x }})))
     ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  by iIntros (??);
    iApply (mwp_lift_head_step'
              (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_left_lift_pure_head_step' idx E Φ e1 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2 σ2, head_step e1 σ1 [] e2 σ2 [] → σ1 = σ2) →
  ▷ (∀ σ1 e2 σ2,
       ⌜head_step e1 σ1 [] e2 σ2 []⌝ →
       MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
         e2 @ E {{ w; n | [x], Φ w (S n) x }})
     ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_head_step'
            (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1); eauto.
   by iApply step_fupd_intro; first set_solver.
Qed.

Lemma mwp_left_lift_atomic_head_step' idx E Φ e1:
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  Atomic StronglyAtomic e1 →
   (∀ σ1, mwpD_SI σ1 ={E, ∅}=∗
      ▷ (∀ v2 σ2,
          ⌜head_step e1 σ1 [] (of_val v2) σ2 []⌝ ={∅, E}=∗
           (mwpD_SI σ2 ∗ MWP@{mwpd_right mwpD_SI', 0}
                          idx @ E {{ v; n, Φ v2 1 (v, n) }})))
    ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???).
  by iApply (mwp_lift_atomic_head_step'
               (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1).
Qed.

Lemma mwp_left_lift_pure_det_head_step' idx E Φ e1 e2 :
  to_val e1 = None →
  (∀ Ki e', e1 = fill_item Ki e' → is_Some (to_val e')) →
  (∀ σ1 e2' σ2, head_step e1 σ1 [] e2' σ2 [] → σ1 = σ2 ∧ e2 = e2') →
  ▷ MWP@{mwpd_left mwpD_SI mwpD_SI', idx}
    e2 @ E {{ v; n | [x], Φ v (S n) x }}
  ⊢ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e1 @ E {{ Φ }}.
Proof.
  iIntros (???) "?".
  iApply (mwp_lift_pure_det_head_step'
            (mwpd_left mwpD_SI mwpD_SI') idx E Φ e1); eauto.
  by iApply step_fupd_intro; first set_solver.
Qed.

End mwp_ectxi_lifting.

Section basmwp_soundness.
Context {Λ Σ} `{!invG Σ} (mwpD_SI mwpD_SI' : state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Lemma mwp_left_adequacy_basic idx E e σ Φ :
  mwpD_SI σ ∗ MWP@{mwpd_left mwpD_SI mwpD_SI', idx} e @ E {{ λ v n x, Φ v n x.1 x.2 }} -∗
    ∀ (rd : Reds e σ),
      MWP@{mwpd_right mwpD_SI', nstps rd}
                          idx @ E {{ v; n, mwpD_SI (end_state rd) ∗
                                          Φ (end_val rd) (nstps rd) v n }}.
Proof.
  iApply (mwp_adequacy_basic
            (mwpd_left mwpD_SI mwpD_SI') idx E e σ (λ v n x, Φ v n x.1 x.2)).
Qed.

End basmwp_soundness.

Section soundness.
Context {Λ Σ} `{!invPreG Σ}
        {SI_data : Type} (mwpD_SI : SI_data → state Λ → iProp Σ)
          {SI_data' : Type} (mwpD_SI' : SI_data' → state Λ → iProp Σ).

Typeclasses Transparent mwpC_state_interp mwpC_modality.

Program Instance left_Initialization
        SSI SSI' `{!InitData SSI} `{!InitData SSI'} e' σ' :
  Initialization
    (val Λ * nat)
    (λ x : invG_pack Σ (SI_data * SI_data'),
           mwpd_left (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2))
    (λ x, @mwpC_left Λ Σ _ (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2))
    (λ _, e') :=
{|
  initialization_modality Hi P := |={⊤}=> P;
  initialization_seed_for_modality _ := wsat ∗ ownE ⊤;
  initialization_seed_for_state_interp x := SSI (PIG_cnt x).1 ∗ SSI' (PIG_cnt x).2;
  initialization_residue _ := ▷ wsat ∗ ▷ ownE ⊤;
  initialization_elim_laters := 1;
  initialization_mwpCM_soundness_arg := Reds e' σ';
  initialization_mwpCM_soundness_laters n rd' := S ((nstps rd') + S n);
  initialization_modality_initializer x _ := mwpD_SI' (PIG_cnt x).2 σ';
  initialization_mwpCM_soundness_fun rd := (end_val rd, nstps rd);
  initialization_Ex_conv _ x := x;
|}%I.
Next Obligation.
Proof.
  intros; simpl.
  iApply init_data.
  apply (init_invGpack (λ x, SSI x.1 ∗ SSI' x.2))%I.
Qed.
Next Obligation.
Proof.
  iIntros (???? e' σ' P Hi) "[Hs HE] HP".
  rewrite uPred_fupd_eq /uPred_fupd_def.
  iMod ("HP" with "[$]") as "(Hs & HE & HP)".
  iModIntro. rewrite -!bi.later_sep.
  iMod "Hs"; iMod "HE"; iMod "HP". iNext.
  iFrame.
Qed.
Next Obligation.
Proof.
  simpl.
  iIntros (???? e' σ' Hi P E n rd) "[[Hs HE] [Hσ' HP]]".
  iNext.
  rewrite /mwpC_modality /mwpD_modality /=.
  iDestruct (mwp_right_adequacy_basic with "[Hσ' $HP]")
    as "HP"; eauto.
  iSpecialize ("HP" $! rd).
  rewrite uPred_fupd_eq /uPred_fupd_def /=.
  replace ⊤ with ((⊤ ∖ E) ∪ E) by by rewrite difference_union_L; set_solver.
  iDestruct (ownE_op with "HE") as "[_ HE]"; first set_solver.
  rewrite (plus_comm _ (S n))  -Nat.add_1_r -plus_assoc (plus_comm 1)
          plus_assoc bi.laterN_plus (plus_comm n) /=.
  iInduction (nstps rd + n) as [] "IH".
  { iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & ? & HP)".
    by iMod "HP". }
  simpl.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  iMod "HP"; iMod "Hs"; iMod "HE".
  iNext.
  iMod ("HP" with "[$Hs $HE]") as "(Hs & HE & HP)".
  rewrite -bi.laterN_later /=.
  iMod "HP"; iMod "Hs"; iMod "HE".
  iApply ("IH" with "Hs HP HE").
Qed.

Lemma mwp_left_adequacy SSI SSI' `{!InitData SSI} `{!InitData SSI'}
      E e σ (e' : expr Λ) σ' (Ψ : val Λ → nat → val Λ → nat → Prop) :
  (∀ (x : invG_pack Σ (SI_data * SI_data')),
      SSI (PIG_cnt x).1 ∗ SSI' (PIG_cnt x).2
          ⊢ |={⊤}=> (mwpD_SI (PIG_cnt x).1 σ ∗ mwpD_SI' (PIG_cnt x).2 σ' ∗
                  MWP@{mwpd_left (mwpD_SI (PIG_cnt x).1) (mwpD_SI' (PIG_cnt x).2), e'}
                    e @ E {{ v ; n| w; k,  ⌜Ψ v n w k⌝ }}))
  → ∀ (rd : Reds e σ) (rd' : Reds e' σ'),
    Ψ (end_val rd) (@nstps Λ _ _ rd) (end_val rd') (@nstps Λ _ _ rd').
Proof.
  intros Hic rd rd'.
  by apply (mwp_adequacy
              _ _ _ _ (left_Initialization SSI SSI' e' σ') E e σ
              (λ v n x, Ψ v n x.1 x.2) rd').
Qed.

End soundness.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

Require Import Equality.

Require Import ComhCoq.Extras.LibTactics.

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
(*
Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.ProtAuxDefs.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.ModeStateLanguage.
Require Import ComhCoq.EntityLanguage.*)
Require Import ComhCoq.NetworkLanguage.
(*Require Import ComhCoq.EntAux.*)
Require Import ComhCoq.NetAuxBasics.
Require Import ComhCoq.NetAuxDefs.

(*If an entity is pending then it cannot delay.*)
Theorem pending_urgent (n n' : Network) (d : Delay) (i : nat) (p : reachableNet n) :
  pending i n p -> ~ n -ND- d -ND> n'. Admitted. (*1*)
(**Proof: *SPAWN SEPARATE URGENCY RESULTS FOR THIS DONE*
Induction on pending. We have 2 cases. Case 1 is that we are
ovWaitStateNet m t x 0 i n- the y parameter can be shown to be 0 (separate proof?).
In this case, the input on pos is enabled and so the process can't delay by
progress [salvaged?]. Case 2 is the ovReadyStateNet m t l i n', which is ready to
output on io. Again by progress this means a delay is not possible.*)

(* If an entity is pending, and the same entity is in the state
ovWaitState m u x y, then we can show that u is equal to tw(m0, m) + period m, for some m0.*)
Theorem pending_time1 (n : Network) (m : Mode) (i : nat)
  (u x y : Time) (p : reachableNet n) :
  pending i n p -> ovWaitStateNet m u x y i n -> exists m0 q,
  u = addTime (waitTime m0 m q) (period m). Admitted. (*1*)
(**Proof: COMMON TACTICS FOR THE ADDTIME SHIT? THERE ARE MORE THEOREMS OF A SIMILAR NATURE.
By induction on pending. In the base case, we have that the previous state was
init m and so by backtracking (...) we can show that y = 0 and u = tw(m0, m) + period m.
In the first inductive case, we can show that u does not change from one state to the next.
The other two inductive cases fail because they involve ovReadyState, which is not
ovWaitState.*)

(* If an entity is pending, and the same entity is in the state ovReadyState m u l,
then we can show that u is equal to tw(m0, m) + period m, for some m0.*)
Theorem pending_time2 (n : Network) (m : Mode) (i : nat)
  (u : Time) (l : Position) (p : reachableNet n) :
  pending i n p -> ovReadyStateNet m u l i n ->
  exists m0 q, u = addTime (waitTime m0 m q) (period m).
  Admitted. (*1*)
(**Proof: Induction on pending. BaseType case fails because it only applies to ovWait.
Discrete inductive case can be shown by (backtracking + automation) to follow from
ovWaitState m u t' i n. But then by (pending_time1), we have that u = tw(m0, m) + period m.
And since the u is the same across the transition, it holds now. The delay inductive case
fails because delay can be shown to be impossible when a state is pending (pending_urgent).*)

(*If an entity is nextSince m t, and the same entity is in the state ovReadyState m u l,
then t + u is constant, equal to the sum of the wait time to m from some mode, tw(m0, m)
and the period of broadcast for m, period m. This is the combination of two results*)
Theorem nextSince_ovWait_ovReady_time (n : Network) (m : Mode) (i : nat)
  (t u x y : Time) (l : Position) (p : reachableNet n) :
  (nextSince m t i n p -> ovWaitStateNet m u x y i n ->
  exists m0 q, addTime t x = waitTime m0 m q
  /\ addTime u y = addTime x (period m)) /\ (*Half theorem*)
  (nextSince m t i n p -> ovReadyStateNet m u l i n ->
  exists m0 q,
  addTime t u = addTime (waitTime m0 m q) (period m)). Admitted. (*1*)
(**Proof: Mutual induction on nextSince. We don't have to actually use mutual induction,
just effectively we will be by proving these two results together as a conjunction and
the splitting by case analysis later.
!Four applications of ovWait_prev?! could be tidied up! For ovWait: In the base case,
we have that the entity in the previous state was pending, and the previous state was
ovReadySate m u0 l for some u0, l. Well then, by (pending_time2), we have that
u0 = tw(m0, m) + period m, for some m. But we also have by (...ovWait_prev...)
that x = u = u0 - period m, after eliminating the initState possibility because
it causes a contradiction. So substituting for u0 and tidying up we have x = tw(m0, m).
And since this is the base case, t = 0. So t + x = tw(m0, m) as required. Also from
(...ovWait_prev...) we have that on entering the state u = x and y = period m.
So u = x - y + period m holds. In the delay inductive case, t increases and u decreases
proportionately. By the I.H. t + u = tw(m0, m), and so for a delay of d, the new sum
becomes (t + d) + (u - d) = t + u = tw(m0, m), and our constant sum is preserved.
Also, x and y decrease by this d. So we want to show u = x - d - (y - d) + period m.
But this is clearly u = x - y + period m, which is our I.H. In the discrete case,
either the previous state was ovReady, and our result follows by the I.H. or the previous
state was not ovReady. In the latter case, we can use (...ovWait_prev...) and our inductive
hypothesis of nextSince (to eliminate initState) to show that the previous state must have
been ovReadyState m u0 l i n, with u = u0 - period m, and u = x. We then separately show
(the other half of this mutually inductive proof) that this combination of nextSince m t
and ovReadyState m u0 l implies that t + u0 = tw(m0, m) + period m, for some m0. Hence we
get t + u = tw(m0, m), and u = x from before, so t + x = tw(m0, m). Also, by
(...ovWait_prev...), we have much as in the base case, that on entering the state u = x
and y = period m. So u = x - y + period m holds. For ovReady: The base case fails to match,
the delay inductive case fails also because ovReady can't delay by progress [salvaged?],
and we can't go from ovWait to ovReady by a delay. So we're left with the discrete inductive
case, where the parameter t for next since is the same across both states. By
(...ovReady_prev...) then we show that the previous state was ovWaitState m u x 0.
Note the parameter y must be 0 so that the transition is enabled. But we also have by our
mutually inductive I.H. that u = x - y + period m, in this case y = 0, so we have
u = x + period m. So t + u = t + x + period m. But we know again by our mutual I.H.
that t + x = tw(m0, m). And so t + u = tw(m0, m) + period m as required.*)

(* If an entity is nextSince m t, and the same entity is in the state
switchBcState m, then we can show that mL + max AN trans < t.*)
Theorem nextSince_switchBc_lower (n : Network) (m : Mode) (i : nat)
  (t : Time) (p : reachableNet n) :
  nextSince m t i n p -> switchBcStateNet m i n ->
  msgLatency + Rmax adaptNotif transMax < t. Admitted. (*1*)
(**Proof: Induction on nextSince. BaseType case fails. Delay follows by monotonicity of t with
nextSince, as does the discrete case where the previous state is still switchBCState. So
the only case of any complexity is the discrete inductive case where the previous state was
not a switchBcState m. In which case we can show that it must be ovWaitState m u 0 y for
some u and y (...switchBc_prev...). We then have by (nextSince_ovWait_time), with x = 0,
that t + 0 = tw(m0, m), which simplifies to t = tw(m0, m). We can then expand tw to max
(mL + max(AN, trans) + Dw) (ts m1 m2) which, due to a strictly positive Dw, is greater
than mL + max AN trans as required.*)

(* If an entity is nextSince m t, and the same entity is in the state switchCurrState m,
then we can show that mL + max AN trans < t.*)
Theorem nextSince_switchCurr_lower (n : Network) (m : Mode) (i : nat)
  (t : Time) (p : reachableNet n) :
  nextSince m t i n p -> switchCurrStateNet i n ->
  msgLatency + Rmax adaptNotif transMax < t. Admitted. (*1*)
(**Proof: SIMILAR TO ANALOGOUS PROOF FOR SWITCHBC- SHARED TACTICS?
Induction on nextSince and case analysis on switchCurrState. The base case fails.
For the inductive case, we case analyse the previous state for the predicate switchCurrState.
 If this was true, then by the I.H. the t parameter in that state exceeds the lower bound,
and so, by monotonicity of nextSince in both delay & discrete cases, so will the t' in this
state. Otherwise, the previous state is not switchCurrState m. In which case we can show
that it must be switchBcState m (...switchCurr_prev...). We then prove a similar result for
this (nextSince_switchBc_lower) & since the t parameter is the same from the last state to
this one because our transition is discrete, that result carries forward.*)


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Require Import Wf.Wf.

(*** Umi_split *)
Lemma umi_split_head_helper : forall (denv__in : DEnv) (dsub__in dsub : DSub) (exA exA1 exA2 : exvar) (a1 : A) (da : DA),
    {denv__in, dsub__in}a |= exA2 :: exA1 :: a1 ~> {da, dsub}
  -> exists dt1 dt2 dsub',
      dsub = (exA2, dt2) :: (exA1, dt1) :: dsub'
    /\ {denv__in, dsub__in}a |= exA :: a1 ~> {da, (exA, DT_Fun dt1 dt2) :: dsub'}.
Proof.
  introv INST. inv_AInst. do 3 eexists. split. auto.
  rep_app_assoc. constructor; try assumption.
  constructor; rewr; eauto.
Qed.

Lemma umi_split_head: forall (exA exA1 exA2 : exvar) (env1 : Env) (a1 a2 : A) (denv : DEnv) (dsub : DSub),
    {▪, []}|= env1 ::a (a2 ++ exA2 :: exA1 :: a1) ~> {denv, dsub}
  -> exists (dt1 dt2 : DTy) (dsub1 dsub2 : DSub),
      dsub = dsub2 ++ (exA2, dt2) :: (exA1, dt1) :: dsub1
    /\ Env_exvars (env1 ::a a1) [=] DSub_dom dsub1
    /\ {▪, []}|= env1 ::a (a2 ++ exA :: a1) ~> {denv, dsub2 ++ (exA, DT_Fun dt1 dt2) :: dsub1}.
  Proof.
    introv INST. inverts INST.
    AInst_split_destr. eassumption.
    forwards [dt1 [dt2 [dsub' [?EQ__dsub INSTA']]]]: umi_split_head_helper exA. eassumption.
    rewr*.
    forwards INST'': EInstA. eassumption. apply AInst_merge. rewr. apply INSTA'. eapply AInst_swap_subinit. rewr. eassumption.
    inverts INSTA'.
    forwards: EInst_props__base1 (env1 ::a a1). econstructor. eassumption. rewr. eassumption.
    subst. rewr*.
    do 4 eexists. splits. 3:{ apply INST''. } reflexivity. auto. rewr. fsetdec.
Qed.

Lemma umi_split_tail : forall (dsub__mid dsub__mid' : DSub) (denv__init : DEnv) (env : Env) (denv : DEnv) (dsub1 dsub2 dsub3 : DSub) (ty : Ty) (exA : exvar),
    {denv__init, dsub2 ++ dsub__mid ++ dsub1}|= subst_exvar_Env ty exA env ~> {denv, dsub3}
  -> (forall sch, SchSI.In sch (Env_Obj_Schs env)
            -> DSub_app (subst_exvar_Sch ty exA sch) (dsub__mid  ++ dsub1)
            = DSub_app sch (dsub__mid' ++ dsub1))
  -> {denv__init, dsub2 ++ dsub__mid' ++ dsub1}|= env ~> {denv, dsub3}.
Proof.
  introv INST EQ__sub. gen denv dsub3. dependent induction env; intros.
  - inverts INST. auto.
  - inverts INST.
  - inverts INST. econstructor; rewr; eauto using AInst_swap_subinit. eapply IHenv.
    intros. apply EQ__sub. rewr. assumption. assumption.
  - inverts INST. econstructor.
    eapply IHenv. intros. eapply EQ__sub. rewr. fsetdec'. assumption.
    forwards: EQ__sub Sch5. rewr. fsetdec.
    subdist*. crush.
  - inverts INST. destruct Obj5. simpl in H3. inverts H3.
    econstructor.
    eapply IHenv. intros. eapply EQ__sub. rewr. fsetdec'. eauto. eauto using AInst_swap_subinit.
    forwards: EQ__sub Sch0. rewr. fsetdec.
    subdist*. crush.
Qed.

Lemma umi_split_substr : forall (exA exA1 exA2 : exvar) (dsub : DSub) (dt1 dt2 : DTy) (sch : Sch),
    exA1 \notin free_exvars_Sch sch
  -> exA2 \notin free_exvars_Sch sch
  -> exA1 <> exA2
  -> exA \notin DSub_dom dsub
  -> exA1 \notin DSub_dom dsub
  -> exA2 \notin DSub_dom dsub
  -> DSub_app (subst_exvar_Sch (T_Fun (T_ExVar exA1) (T_ExVar exA2)) exA sch) (([(exA2, dt2)] ++ [(exA1, dt1)]) ++ dsub)
  = DSub_app sch ([(exA, DT_Fun dt1 dt2)] ++ dsub).
  Proof.
    intros.
    subdist. Sch_Ty_ind sch; rewr; auto.
    - simpl. DSub_exA_decide.
      + ifdec.
        * rewr.
          do_DSub_exA_decide dsub exA1. 2:{ assert (exA1 \in DSub_dom dsub). eauto. fsetdec. }
          do_DSub_exA_decide dsub exA2. 2:{ assert (exA2 \in DSub_dom dsub). eauto. fsetdec. }
          crush. ifdec; crush. if_taut.
        * rewrite INV. simpl.
          destruct (exA0 == exA). crush.
          destruct (exA0 == exA1). crush. simpl.
          destruct (exA0 == exA2). crush. reflexivity.
      + ifdec. subst.
        assert (exA \in DSub_dom dsub). eauto. fsetdec. crush.
    - crush.
    - crush.
Qed.

(** split main *)
Theorem umi_split : forall (denv : DEnv) (exA exA1 exA2 : exvar) (env1 : Env) (a1 a2 : A) (env2 : Env),
    FullEInst (subst_exvar_Env (T_Fun (T_ExVar exA1) (T_ExVar exA2)) exA (env1 ::a (a2 ++ (exA2 :: exA1 :: a1)) +++ env2)) denv
  -> wf(subst_exvar_Env (T_Fun (T_ExVar exA1) (T_ExVar exA2)) exA (env1 ::a (a2 ++ (exA2 :: exA1 :: a1)) +++ env2))
  -> wf(env1 ::a (a2 ++ [exA] ++ a1) +++ env2)
  -> FrA [exA2; exA1] (env1 ::a (a2 ++ [exA] ++ a1) +++ env2)
  -> FullEInst (                                                           env1 ::a (a2 ++ (exA  ::        a1)) +++ env2 ) denv.
Proof.
  introv INST WF1 WF2 FR. destr. rewr*.
  assert (exA `notin` Env_Obj_exvars env1).
  { forwards DISJ: wf_Env_exvar_disj env1. norm in WF2. rep_Env_app_assoc in WF2. apply WF2.
    eapply in_disjoint_impl_notin1. eassumption. rewr. fsetdec. }
  rewrite subst_exvar_Env_notin_Env_idempotent in *. 2,3,4,5: eauto.
  (**)
  EInst_split_destr. eassumption.
  (**)
  forwards [dt1 [dt2 [dsub1' [dsub2 [? [DOMSUB ?INST]]]]]]: umi_split_head. eassumption.
  (**)
  subst. rewr*. exists. apply EInst_merge. eassumption.
  applys_eq (umi_split_tail ([(exA2, dt2)] ++ [(exA1, dt1)]) ([(exA, DT_Fun dt1 dt2)])).
  2:{ rewr. norm in INST1. eassumption. } rewr. reflexivity.
  (**)
  intros sch IN.
  forwards SUB: fv_sch_in_wfenv_subset sch (env1 ::a (a2 ++ [exA] ++ a1) +++ env2). rewr. fsetdec'. auto.
  inv_AInst.
  (* forwards DOMSUB: EInst_props1. apply EInstA. apply INST1. rewr. eassumption. *)
  apply umi_split_substr.
  - unfold not. rewrite SUB. intros.
    assert (FR': FrA [exA1] (env1 +++ <a2 ++ [exA] ++ a1>a +++ env2)). simpl in FR. eauto.
    inverts FR'. crush.
  - unfold not. rewrite SUB. intros.
    inverts FR. crush.
  - assert (UNI: NoDup' [exA2; exA1]). apply FrA_props in FR. jauto.
    destruct (exA1 == exA2). subst. inverts UNI. crush. assumption.
  - unfold not. rewrite <- DOMSUB. intro IN'.
    assert (NI: exA \notin Env_Obj_exvars (env1 ::a a1)). eauto.
    apply NI. rewr. indestr in IN'. destr. fsetdec. auto.
  - unfold not. rewrite <- DOMSUB. intro IN'.
    assert (wf(env1 ::a (exA1 :: a1))). eauto.
    assert (FR': FrA (exA1 :: a1) env1). eauto.
    inverts FR'. apply FR0. indestr in IN'. destr; rewr; eauto.
  - unfold not. rewrite <- DOMSUB. intro IN'.
    inverts FR. apply FR0. indestr in IN'. destr; rewr. eauto. fsetdec.
Qed.

(** split drop *)
Theorem umi_split__drop: forall (n : nat) (denv : DEnv) (exA exA1 exA2 : exvar) (env1 : Env) (a1 a2 : A) (env2 : Env),
    FullEInst (Env_drop n (subst_exvar_Env (T_Fun (T_ExVar exA1) (T_ExVar exA2)) exA (env1 ::a (a2 ++ (exA2 :: exA1 :: a1)) +++ env2))) denv
  -> wf(Env_drop n (subst_exvar_Env (T_Fun (T_ExVar exA1) (T_ExVar exA2)) exA (env1 ::a (a2 ++ (exA2 :: exA1 :: a1)) +++ env2)))
  -> wf(env1 ::a (a2 ++ [exA] ++ a1) +++ env2)
  -> FrA [exA2; exA1] (env1 ::a (a2 ++ [exA] ++ a1) +++ env2)
  -> FullEInst (Env_drop n (                                                           env1 ::a (a2 ++ (exA  ::        a1)) +++ env2 )) denv.
Proof.
  introv [dsub INST] WF1 WF2 WFTY. rewrite Env_drop_subst_exvar_Env_comm in *.
  dropdistr*. destruct (le_lt_dec n (Env_length env2)).
  - forwards NIL: nat_minus_greater. eassumption. rewrite NIL in *. rewr*.
    eapply umi_split. rewr. eauto. rewr. eassumption.
    rewrite Env_drop_distr'. eauto using wf_Env_drop.
    rewrite Env_drop_distr'. eauto using FrA_drop.
  - rewrite (Env_drop_greater n) in *. 2,3,4: crush.
    rewr*.
    assert (exA `notin` Env_Obj_exvars env1).
    { forwards DISJ: wf_Env_exvar_disj env1. norm in WF2. rep_Env_app_assoc in WF2. apply WF2.
      eapply in_disjoint_impl_notin1. eassumption. rewr. fsetdec. }
    destruct (n - Env_length env2).
    + simpl in *.
      rewrite subst_exvar_Env_notin_Env_idempotent in INST. 3:{ eauto. } 2:assumption.
      forwards [dty [dsub1 [dsub2 [? [? [? ?]]]]]]: umi_split_head exA. eassumption.
      exists. eassumption.
    + simpl in *. exists.
      rewrite subst_exvar_Env_notin_Env_idempotent in INST. eassumption.
      rewrite Env_drop_Env_exvars_Obj. assumption.
      eauto using wf_Env_drop.
Qed.

(*** Umi_subst *)
Lemma umi_subst_head_helper : forall (exA : exvar) (dty : DTy) (a : A) (da : DA) (dsub : DSub) (denv__init : DEnv) (dsub__init : DSub),
    {denv__init, dsub__init}a|= a ~> {da, dsub}
  -> denv__init :::a da |=dty DS_Mono dty
  -> {denv__init, dsub__init}a|= exA :: a ~> {da, (exA, dty) :: dsub}.
Proof. introv INST WFDTY. rewrite <- (app_nil_l da). econstructor; crush. Qed.

Lemma umi_subst_head: forall (exA : exvar) (ty : Ty) (env1 : Env) (a1 a2 : A) (denv0 : DEnv) (dsub : DSub),
    {▪, []}|= env1 ::a (a2 ++ a1) ~> {denv0, dsub}
  -> (env1 ::a a1) |=ty S_Mono ty
  -> wf(env1 ::a (exA :: a1))
  -> exists (dty : DTy) (dsub1 dsub2 : DSub),
          dsub = dsub2 ++ dsub1
        /\ DSub_app_t ty dsub1 = emb_Ty dty
        /\ DSub_unique ((exA, dty) :: dsub1)
        /\ {▪, []}|= env1 ::a (a2 ++ exA :: a1) ~> {denv0, dsub2 ++ (exA, dty) :: dsub1}.
Proof.
  introv INST WFTY WF. inverts INST.
  (**)
  AInst_split_destr. eassumption.
  (**)
  forwards dsch EMB WFDTY: EInst_WfTy_impl_emb. 2:{ eassumption. } econstructor. eassumption. eassumption.
  emb_auto. rewr*.
  (**)
  forwards INSTA': umi_subst_head_helper exA a1. eassumption. eassumption. rewr in INSTA'.
  forwards INSTA'': EInstA. eassumption. eapply AInst_merge. rewr. apply INSTA'. eapply AInst_swap_subinit. rewr. eassumption.
  exists dty (dsub ++ DSub1) dsub0. splits.
  - reflexivity.
  - auto.
  - forwards WFSUB: EInst_props__wf (env1 ::a (exA :: a1)). econstructor. eassumption. rewr.
    econstructor. 2:eassumption. instantiate (2 := nil). rewr. eassumption. assumption.
    auto. crush. rewr in WFSUB. eauto.
  - rewr*. eassumption.
Qed.

Lemma umi_subst_sub : forall (exA : exvar) (ty : Ty) (dty : DTy) (dsub : DSub) (sch : Sch),
    DSub_unique ((exA, dty) :: dsub)
  -> DSub_app_t ty dsub = emb_Ty dty
  -> DSub_app (subst_exvar_Sch ty exA sch) dsub = subst_exvar_Sch (emb_Ty dty) exA (DSub_app sch dsub).
Proof.
  introv UNI EMB.
  subdist. Sch_Ty_ind sch. 1,2,4,6: crush. all:simpl.
  - ifdec'.
    + DSub_exA_decide; rewrite EMB. rewrite INV. simpl. if_taut.
      rewrite EMB0. rewrite subst_exvar_Ty_embed_idempotent.
      forwards: UNI dty dty0. rewr. fsetdec. rewr. fsetdec'. crush.
    + DSub_exA_decide. rewrite INV. simpl. if_taut.
      rewrite EMB0. rewrite subst_exvar_Ty_embed_idempotent. crush.
  - rewr. crush.
Qed.

Lemma umi_subst_tail : forall (dty : DTy) (exA : exvar) (ty : Ty) (dsub1 dsub2 : DSub) (env : Env) (denv : DEnv) (dsub : DSub) (denv__init : DEnv),
    {denv__init, dsub2 ++ dsub1}|= subst_exvar_Env ty exA env ~> {denv, dsub}
  -> DSub_app_t ty dsub1 = emb_Ty dty
  -> DSub_unique ((exA, dty) :: dsub1)
  -> {denv__init, dsub2 ++ (exA, dty) :: dsub1}|= env ~> {denv, dsub}.
Proof.
  introv INST EMB UNI.
  EInst_genind' INST env.
  - auto.
  - econstructor. eauto. eauto using AInst_swap_subinit.
  - econstructor. eauto. subdist*.
    erewrite <- umi_subst_sub; eassumption.
  - destruct Obj5; inverts H3.
    econstructor. eauto. eauto using AInst_swap_subinit. subdist*.
    erewrite <- umi_subst_sub; eassumption.
Qed.

(** subst main *)
Theorem umi_subst : forall (exA : exvar) (ty : Ty) (env1 env2 : Env) (a1 a2 : A) (denv : DEnv),
    FullEInst (subst_exvar_Env ty exA (env1 ::a (a2 ++ a1) +++ env2)) denv
  -> wf(env1 ::a (a2 ++ exA :: a1) +++ env2)
  -> env1 ::a a1 |=ty (S_Mono ty)
  -> FullEInst (env1 ::a (a2 ++ exA :: a1) +++ env2) denv.
Proof.
  introv INST WF2 WFTY. destr. rewr*.
  assert (exA `notin` Env_Obj_exvars env1).
  { forwards DISJ: wf_Env_exvar_disj env1. norm in WF2. rep_Env_app_assoc in WF2. apply WF2.
    eapply in_disjoint_impl_notin1. eassumption. rewr. fsetdec. }
  rewrite subst_exvar_Env_notin_Env_idempotent in *. 2,3: eauto.
  (**)
  EInst_split_destr. eassumption.
  (**)
  forwards [dty [dsub1' [dsub2 [? [? [? ?]]]]]]: umi_subst_head exA a1. eassumption. eassumption. constructor. eauto.
  constructor. eauto.
  assert (FrA (exA :: a1) env1). eauto. inv_FrA. eassumption.
  subst.
  (**)
  eexists. rewr*. apply EInst_merge.
  - eassumption.
  - rewr. eapply umi_subst_tail. eassumption. eassumption. eassumption.
Qed.

(** subst drop *)
Theorem umi_subst__drop : forall (n : nat) (exA : exvar) (ty : Ty) (env1 env2 : Env) (a1 a2 : A) (denv : DEnv),
    FullEInst (Env_drop n (subst_exvar_Env ty exA (env1 ::a (a2 ++ a1) +++ env2))) denv
  -> wf(Env_drop n (subst_exvar_Env ty exA (env1 ::a (a2 ++ a1) +++ env2)))
  -> wf(env1 ::a (a2 ++ exA :: a1) +++ env2)
  -> env1 ::a a1 |=ty (S_Mono ty)
  -> FullEInst (Env_drop n (env1 ::a (a2 ++ exA :: a1) +++ env2)) denv.
Proof.
  introv [dsub INST] WF1 WF2 WFTY. rewrite Env_drop_subst_exvar_Env_comm in *.
  dropdistr*. destruct (le_lt_dec n (Env_length env2)).
  - forwards NIL: nat_minus_greater. eassumption. rewrite NIL in *. rewr*.
    eapply umi_subst. rewr. eauto. rewrite Env_drop_distr'. eauto using wf_Env_drop.
    eassumption.
  - rewrite (Env_drop_greater n) in *. 2,3,4: crush.
    rewr*.
    assert (exA `notin` Env_Obj_exvars env1).
    { forwards DISJ: wf_Env_exvar_disj env1. norm in WF2. rep_Env_app_assoc in WF2. apply WF2.
      eapply in_disjoint_impl_notin1. eassumption. rewr. fsetdec. }
    destruct (n - Env_length env2).
    + simpl in *.
      rewrite subst_exvar_Env_notin_Env_idempotent in INST. 3:{ eauto. } 2:assumption.
      forwards [dty [dsub1 [dsub2 [? [? [? ?]]]]]]: umi_subst_head exA. eassumption. eassumption. constructor. eauto.
      constructor. eauto.
      assert (FrA (exA :: a1) env1). eauto. inv_FrA. eassumption.
      exists. eassumption.
    + simpl in *. exists.
      rewrite subst_exvar_Env_notin_Env_idempotent in INST. eassumption.
      rewrite Env_drop_Env_exvars_Obj. assumption.
      eauto using wf_Env_drop.
Qed.

(*** Main theorems *)
Theorem unification_maintains_instantiation : forall (env__in env__out : Env) (eqs : Eqs) (denv : DEnv),
    U env__in eqs env__out
  -> FullEInst env__out denv
  -> wf( env__in )
  -> FullEInst env__in denv.
Proof.
  introv UNI [Sub INST] WF1. inverts UNI.
  induction Us. eauto.
  forwards WF2: Uss_Wf. eassumption. auto.
  forwards [Sub__IH INST__IH]: IHUs. eassumption. assumption.
  destruct UNI; simpl in WF2; simpl in  INST__IH; eauto using umi_split, umi_subst.
Qed.

Theorem unification_maintains_instantiation__drop : forall (n : nat) (env__in env__out : Env) (eqs : Eqs) (denv : DEnv),
    U env__in eqs env__out
  -> FullEInst (Env_drop n env__out) denv
  -> wf(env__in)
  -> FullEInst (Env_drop n env__in) denv.
Proof.
  introv UNI [Sub INST] WF1. inverts UNI.
  induction Us. eauto.
  forwards WF2: Uss_Wf. eassumption. auto.
  forwards [Sub__IH INST__IH]: IHUs. eassumption. assumption.
  destruct UNI; simpl in WF2; simpl in  INST__IH; eauto using umi_split__drop, umi_subst__drop.
Qed.


Require Import Coq.Bool.Bool.

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.
Require Import compcert.common.Events.
Require Import compcert.common.Memory.
Require Import compcert.common.Values.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.semantics.
Require Import sepcomp.semantics_lemmas.
Require Import sepcomp.structured_injections.
Require Import sepcomp.reach.
Require Import sepcomp.mem_wd.

Require Import sepcomp.effect_semantics. (*for specialization below*)

Module Wholeprog_sim. Section Wholeprog_sim.

Context {G1 C1 M1 G2 C2 M2 : Type}

(Sem1 : @CoreSemantics G1 C1 M1)
(Sem2 : @CoreSemantics G2 C2 M2)

(ge1 : G1)
(ge2 : G2)

(main : val).

Variable ge_inv : G1 -> G2 -> Prop.

Variable init_inv : meminj -> G1 -> list val -> M1 -> G2 -> list val -> M2 -> Prop.

Variable halt_inv : (*SM_Injection*)meminj -> G1 -> val -> M1 -> G2 -> val -> M2 -> Prop.

Record Wholeprog_sim :=
{ core_data : Type
; match_state : core_data -> (*SM_Injection*)meminj -> C1 -> M1 -> C2 -> M2 -> Prop
; core_ord : core_data -> core_data -> Prop
; core_ord_wf : well_founded core_ord
; genv_inv : ge_inv ge1 ge2
; core_initial :
    forall j c1 vals1 m1 vals2 m2,
    initial_core Sem1 ge1 main vals1 = Some c1 ->
    init_inv j ge1 vals1 m1 ge2 vals2 m2 ->
    exists (*mu*) cd c2,
      (*as_inj mu = j*
      /\*) initial_core Sem2 ge2 main vals2 = Some c2
      /\ match_state cd (*mu*)j c1 m1 c2 m2
; core_diagram :
    forall st1 m1 st1' m1',
    corestep Sem1 ge1 st1 m1 st1' m1' ->
    forall cd st2 mu m2,
    match_state cd mu st1 m1 st2 m2 ->
    exists st2', exists m2', exists cd', exists mu',
    match_state cd' mu' st1' m1' st2' m2'
    /\ (corestep_plus Sem2 ge2 st2 m2 st2' m2'
        \/ (corestep_star Sem2 ge2 st2 m2 st2' m2' /\ core_ord cd' cd))
; core_halted :
    forall cd mu c1 m1 c2 m2 v1,
    match_state cd mu c1 m1 c2 m2 ->
    halted Sem1 c1 = Some v1 ->
    exists j v2,
       halt_inv j ge1 v1 m1 ge2 v2 m2
    /\ halted Sem2 c2 = Some v2 }.

End Wholeprog_sim.

End Wholeprog_sim.

Section CompCert_wholeprog_sim.

Context {F1 V1 C1 F2 V2 C2 : Type}

(Sem1 : @EffectSem (Genv.t F1 V1) C1)
(Sem2 : @EffectSem (Genv.t F2 V2) C2)

(ge1 : Genv.t F1 V1)
(ge2 : Genv.t F2 V2)

(main : val).

Definition cc_init_inv j (ge1 : Genv.t F1 V1) vals1 m1 (ge2 : Genv.t F2 V2) vals2 m2 :=
  Mem.inject j m1 m2 /\ Forall2 (val_inject j) vals1 vals2
  /\ meminj_preserves_globals ge1 j /\ globalfunction_ptr_inject ge1 j
  /\ mem_wd m2 /\ valid_genv ge2 m2 /\ Forall (fun v2 => val_valid v2 m2) vals2
  /\ mem_respects_readonly ge1 m1 /\ mem_respects_readonly ge2 m2.

Definition cc_halt_inv j (ge1 : Genv.t F1 V1) v1 m1 (ge2 : Genv.t F2 V2) v2 m2 :=
  meminj_preserves_globals ge1 j
  /\ val_inject j v1 v2
  /\ Mem.inject j m1 m2.

Definition CompCert_wholeprog_sim :=
  @Wholeprog_sim.Wholeprog_sim _ _ _ _ _ _
    Sem1 Sem2
    ge1 ge2
    main
    genvs_domain_eq
    cc_init_inv
    cc_halt_inv.

End CompCert_wholeprog_sim.

Require Import sepcomp.internal_diagram_trans.
Require Import Relations.
Lemma well_founded_sem_compose_ord_eq_eq: forall {D12 D23:Type}
  (ord12: D12 -> D12 -> Prop) (ord23: D23 -> D23 -> Prop)  (C2:Type)
  (WF12: well_founded ord12) (WF23: well_founded ord23),
  well_founded (sem_compose_ord_eq_eq ord12 ord23 C2).
Proof.
  intros. intro. destruct a as [[d12 c2] d23].
  revert d12.
  destruct c2.
  2: constructor; intros. 2: inv H.
  revert c.
  induction d23 using (well_founded_induction WF23).
  intros.
  induction d12 using (well_founded_induction WF12).
  constructor; intros. inv H1.
  generalize (H0 d0). simpl. intros.
  apply H1. auto.
  generalize (H d1).
  intros.
  specialize H1. auto.
Qed.

Require Import sepcomp.simulations.

Section WholeSimTrans.
Context {F1 V1 C1 F2 V2 C2 F3 V3 C3:Type}
        (Sem1 : @EffectSem (Genv.t F1 V1) C1)
        (Sem2 : @EffectSem (Genv.t F2 V2) C2)
        (Sem3 : @EffectSem (Genv.t F3 V3) C3)
        (g1 : Genv.t F1 V1)
        (g2 : Genv.t F2 V2)
        (g3 : Genv.t F3 V3).

Variable Main :val.
Variable GeInv12: (Genv.t F1 V1) -> (Genv.t F2 V2) -> Prop.
Variable InitInv12 : meminj -> (Genv.t F1 V1) -> list val -> mem -> (Genv.t F2 V2) -> list val -> mem -> Prop.
Variable HaltInv12 : (*SM_Injection*)meminj -> (Genv.t F1 V1) -> val -> mem -> (Genv.t F2 V2) -> val -> mem -> Prop.

Variable GeInv23: (Genv.t F2 V2) -> (Genv.t F3 V3) -> Prop.
Variable InitInv23 : meminj -> (Genv.t F2 V2) -> list val -> mem -> (Genv.t F3 V3) -> list val -> mem -> Prop.
Variable HaltInv23: (*SM_Injection*)meminj -> (Genv.t F2 V2) -> val -> mem -> (Genv.t F3 V3) -> val -> mem -> Prop.

Variable SIM12: Wholeprog_sim.Wholeprog_sim Sem1 Sem2 g1 g2 Main GeInv12 InitInv12 HaltInv12.
Variable SIM23: Wholeprog_sim.Wholeprog_sim Sem2 Sem3 g2 g3 Main GeInv23 InitInv23 HaltInv23.

Definition CoreData12:= Wholeprog_sim.core_data _ _ _ _ _ _ _ _  SIM12.
Definition CoreData23:= Wholeprog_sim.core_data _ _ _ _ _ _ _ _  SIM23.
Definition CoreOrd12:= Wholeprog_sim.core_ord _ _ _ _ _ _ _ _  SIM12.
Definition CoreOrd23:= Wholeprog_sim.core_ord  _ _ _ _ _ _ _ _ SIM23.
Definition MatchState12:= Wholeprog_sim.match_state _ _ _ _ _ _ _ _ SIM12.
Definition MatchState23:= Wholeprog_sim.match_state _ _ _ _ _ _ _ _ SIM23.
Definition genv_inv12 := Wholeprog_sim.genv_inv _ _ _ _ _ _ _ _ SIM12.
Definition genv_inv23 := Wholeprog_sim.genv_inv _ _ _ _ _ _ _ _ SIM23.

Definition CoreDiag12 := Wholeprog_sim.core_diagram _ _ _ _ _ _ _ _ SIM12.
Definition CoreDiag23 := Wholeprog_sim.core_diagram _ _ _ _ _ _ _ _ SIM23.
Definition Halted12:= Wholeprog_sim.core_halted _ _ _ _ _ _ _ _ SIM12.
Definition Halted23:= Wholeprog_sim.core_halted _ _ _ _ _ _ _ _ SIM23.
Definition Init12:= Wholeprog_sim.core_initial _ _ _ _ _ _ _ _ SIM12.
Definition Init23:= Wholeprog_sim.core_initial _ _ _ _ _ _ _ _ SIM23.

Definition GeInv13 (ge1:Genv.t F1 V1) (ge3: Genv.t F3 V3): Prop := exists ge2, GeInv12 ge1 ge2 /\ GeInv23 ge2 ge3.

Definition InitInv13 ge2 (j13:meminj) (ge1: Genv.t F1 V1) (vals1:list val) (m1:mem) (ge3:Genv.t F3 V3) (vals3:list val) (m3: mem): Prop :=
  exists j12 j23 vals2 m2, InitInv12 j12 ge1 vals1 m1 ge2 vals2 m2 /\
                           InitInv23 j23 ge2 vals2 m2 ge3 vals3 m3 /\
                           j13 = compose_meminj j12 j23.
Definition HaltInv13 ge2 (j13:(*SM_Injection*)meminj) (ge1: Genv.t F1 V1) (v1: val) (m1: mem)
                                                  (ge3: Genv.t F3 V3) (v3: val) (m3: mem): Prop :=
  exists j12 j23 v2 m2, HaltInv12 j12 ge1 v1 m1 ge2 v2 m2 /\
                        HaltInv23 j23 ge2 v2 m2 ge3 v3 m3 /\
                        j13 = compose_meminj j12 j23.

Definition CoreOrd:= clos_trans _ (sem_compose_ord_eq_eq CoreOrd12 CoreOrd23 C2).
Definition MatchState := fun d mu c1 m1 c3 m3 =>
      match d with (d1,X,d2) =>
        exists c2, exists m2, exists mu1, exists mu2,
          X=Some c2 /\ mu = compose_meminj mu1 mu2 /\
          MatchState12 d1 mu1 c1 m1 c2 m2 /\ MatchState23 d2 mu2 c2 m2 c3 m3
      end.

Lemma WP_corestep_trans: forall (st1 : C1) (m1 : mem) (st1' : C1) (m1' : mem)
      (CS1: corestep Sem1 g1 st1 m1 st1' m1'),
      forall cd (st3 : C3) (j : meminj) (m3 : mem), MatchState cd j st1 m1 st3 m3 ->
      exists (st3' : C3) (m3' : mem) cd' (j' : meminj),
          MatchState cd' j' st1' m1' st3' m3' /\
         (corestep_plus Sem3 g3 st3 m3 st3' m3' \/
          corestep_star Sem3 g3 st3 m3 st3' m3' /\ CoreOrd cd' cd).
Proof.  intros.
destruct cd as [[cd12 X] cd23].
destruct H as [c2 [m2 [j12 [j23 [HX [Hj [MS12 MS23]]]]]]]. subst X.
destruct (CoreDiag12 _ _ _ _ CS1 _ _ _ _ MS12) as [c2' [m2' [cd12' [j12' [MS12' Step2]]]]].
assert (ZZ: corestep_plus Sem2 g2 c2 m2 c2' m2' \/
    (c2,m2) = (c2',m2') /\ CoreOrd12 cd12' cd12).
{ destruct Step2. auto.
  destruct H.
  destruct H. destruct x.
  right. split; auto.
  left. exists x; auto.
}
clear Step2. destruct ZZ as [CS2 | [CS2 ord12']].
+ (*case1*)
  destruct CS2.
  clear CS1.
  cut (exists st3' : C3,  exists m3' : mem, exists cd23', exists j23' : meminj,
    MatchState23 cd23' j23' c2' m2' st3' m3' /\
    (corestep_plus Sem3 g3 st3 m3 st3' m3' \/
      (corestep_star Sem3 g3 st3 m3 st3' m3' /\
        clos_trans (CoreData12 * option C2 * CoreData23)
        (sem_compose_ord_eq_eq CoreOrd12 CoreOrd23 C2) (cd12', Some c2', cd23')
        (cd12, Some c2, cd23)))).
  intros XX; destruct XX as [c3' [m3' [cd23' [j23' [MC23' ZZ]]]]].
  exists c3'. exists m3'. exists (cd12', Some c2', cd23'). exists (compose_meminj j12' j23').
  split. subst. red. exists c2', m2', j12', j23'. eauto.
    apply ZZ.
  clear MS12 MS12' Hj.
  revert j23 cd23 c2 m2 st3 m3 H MS23.
  induction x; intros.
  - (*base case*)
    destruct H as [c22 [m2'' [? ?]]].
    inv H0.
    destruct (CoreDiag23 _ _ _ _ H _ _ _ _ MS23)
      as [c3' [m3' [cd23' [j23' [MS23' Step3]]]]].
    exists c3', m3', cd23', j23'.
    split; trivial.
    destruct Step3. left; assumption.
    destruct H0. right. split; trivial.
    apply t_step. constructor 2. trivial.
  - (*inductive case*)
    remember (S x) as x'.
    destruct H as [st2'' [m2'' [Step2 StepN2]]]. subst x'.
    destruct (CoreDiag23 _ _ _ _ Step2 _ _ _ _ MS23)
      as [c3' [m3' [cd23' [j23' [MS23' Step3]]]]].
    specialize (IHx j23' cd23' _ _ c3' m3' StepN2 MS23'). clear Step2 StepN2 MS23'.
    destruct IHx as [c3'' [m3'' [cd23'' [j23'' [MC' XX]]]]].
    exists c3'', m3'', cd23'', j23''.
    split. apply MC'.
    destruct Step3; destruct XX.
           (*1/4*)
              left. destruct H as [n1 ?]. destruct H0 as [n2 ?].
                      exists (n1 + S n2)%nat.
                      change (S (n1 + S n2)) with (S n1 + S n2)%nat.
                      rewrite corestepN_add. eauto.
           (*2/4*)
               destruct H0.
               left. destruct H as [n1 ?]. destruct H0 as [n2 ?].
                       exists (n1 + n2)%nat.
                       change (S (n1 + n2)) with (S n1 + n2)%nat.
                       rewrite corestepN_add. eauto.
           (*3/4*)
               left. destruct H.
                       destruct H as [n1 ?]. destruct H0 as [n2 ?].
                       exists (n1 + n2)%nat.
                       replace (S (n1 + n2)) with (n1 + S n2)%nat by omega.
                       rewrite corestepN_add. eauto.
           (*3/4*)
               right. destruct H. destruct H0.
               split. destruct H as [n1 ?]. destruct H0 as [n2 ?].
                         exists (n1 + n2)%nat.
                         rewrite corestepN_add. eauto.
              eapply t_trans; eauto.
          (*4/4*)
              apply t_step.
              constructor 2. assumption.
+ (*case 2*)
   inv CS2.
   exists st3, m3, (cd12',Some c2', cd23), (compose_meminj j12' j23).
   split. exists c2', m2', j12', j23; auto.
   right. split. exists O. simpl; auto.
   apply t_step. constructor 1; auto.
Qed.

Definition WP_trans:
        Wholeprog_sim.Wholeprog_sim Sem1 Sem3 g1 g3 Main GeInv13 (InitInv13 g2) (HaltInv13 g2).
eapply Wholeprog_sim.Build_Wholeprog_sim with
  (core_ord:=CoreOrd)(match_state:=MatchState).
{ (*well_founded*)
  eapply Transitive_Closure.wf_clos_trans.
  eapply well_founded_sem_compose_ord_eq_eq. apply SIM12. apply SIM23. }
{ exists g2; split. apply genv_inv12. apply genv_inv23. }
{ (*Init*)
  intros j13 c1 vals1 m1 vals3 m3 Init1 IInv13.
  destruct IInv13 as [j12 [j23 [vals2 [m2 [Initial12 [Initial23 Hj]]]]]].
  destruct (Init12 _ _ _ _ _ _ Init1 Initial12) as [cd12 [c2 [Init2 MS12]]].
  destruct (Init23 _ _ _ _ _ _ Init2 Initial23) as [cd23 [c3 [Init3 MS23]]].
  exists ((cd12, Some c2), cd23), c3. split; trivial.
  exists c2, m2, j12, j23; auto. }
{ apply WP_corestep_trans. }
{ (*Halted*)
  intros [[c12 X] c23] j c1 m1 c3 m3 v1 MS HALT1.
  destruct MS as [c2 [m2 [j12 [j23 [HX [Hj [MS12 MS23]]]]]]].
  destruct (Halted12 _ _ _ _ _ _ _ MS12 HALT1) as [j12' [v2 [MI12 HALT2]]].
  destruct (Halted23 _ _ _ _ _ _ _ MS23 HALT2) as [j23' [v3 [MI23 HALT3]]].
  exists (compose_meminj j12' j23'), v3; split; trivial.
  exists j12', j23', v2, m2; auto. }
Qed.
End WholeSimTrans.


From Hammer Require Import Hammer.

From compcert Require Import Coqlib.
From compcert Require Import Zbits.
From compcert Require Archi.
From compcert Require Import AST.
From compcert Require Import Integers.
From compcert Require Import Floats.
From compcert Require Import Values.

Definition size_chunk (chunk: memory_chunk) : Z :=
match chunk with
| Mint8signed => 1
| Mint8unsigned => 1
| Mint16signed => 2
| Mint16unsigned => 2
| Mint32 => 4
| Mint64 => 8
| Mfloat32 => 4
| Mfloat64 => 8
| Many32 => 4
| Many64 => 8
end.

Lemma size_chunk_pos:
forall chunk, size_chunk chunk > 0.
Proof. hammer_hook "Memdata" "Memdata.size_chunk_pos".
intros. destruct chunk; simpl; omega.
Qed.

Definition size_chunk_nat (chunk: memory_chunk) : nat :=
Z.to_nat(size_chunk chunk).

Lemma size_chunk_conv:
forall chunk, size_chunk chunk = Z.of_nat (size_chunk_nat chunk).
Proof. hammer_hook "Memdata" "Memdata.size_chunk_conv".
intros. destruct chunk; reflexivity.
Qed.

Lemma size_chunk_nat_pos:
forall chunk, exists n, size_chunk_nat chunk = S n.
Proof. hammer_hook "Memdata" "Memdata.size_chunk_nat_pos".
intros.
generalize (size_chunk_pos chunk). rewrite size_chunk_conv.
destruct (size_chunk_nat chunk).
simpl; intros; omegaContradiction.
intros; exists n; auto.
Qed.

Lemma size_chunk_Mptr: size_chunk Mptr = if Archi.ptr64 then 8 else 4.
Proof. hammer_hook "Memdata" "Memdata.size_chunk_Mptr".
unfold Mptr; destruct Archi.ptr64; auto.
Qed.

Definition align_chunk (chunk: memory_chunk) : Z :=
match chunk with
| Mint8signed => 1
| Mint8unsigned => 1
| Mint16signed => 2
| Mint16unsigned => 2
| Mint32 => 4
| Mint64 => 8
| Mfloat32 => 4
| Mfloat64 => 4
| Many32 => 4
| Many64 => 4
end.

Lemma align_chunk_pos:
forall chunk, align_chunk chunk > 0.
Proof. hammer_hook "Memdata" "Memdata.align_chunk_pos".
intro. destruct chunk; simpl; omega.
Qed.

Lemma align_chunk_Mptr: align_chunk Mptr = if Archi.ptr64 then 8 else 4.
Proof. hammer_hook "Memdata" "Memdata.align_chunk_Mptr".
unfold Mptr; destruct Archi.ptr64; auto.
Qed.

Lemma align_size_chunk_divides:
forall chunk, (align_chunk chunk | size_chunk chunk).
Proof. hammer_hook "Memdata" "Memdata.align_size_chunk_divides".
intros. destruct chunk; simpl; try apply Z.divide_refl; exists 2; auto.
Qed.

Lemma align_le_divides:
forall chunk1 chunk2,
align_chunk chunk1 <= align_chunk chunk2 -> (align_chunk chunk1 | align_chunk chunk2).
Proof. hammer_hook "Memdata" "Memdata.align_le_divides".
intros. destruct chunk1; destruct chunk2; simpl in *;
solve [ omegaContradiction
| apply Z.divide_refl
| exists 2; reflexivity
| exists 4; reflexivity
| exists 8; reflexivity ].
Qed.

Inductive quantity : Type := Q32 | Q64.

Definition quantity_eq (q1 q2: quantity) : {q1 = q2} + {q1 <> q2}.
Proof. hammer_hook "Memdata" "Memdata.quantity_eq". decide equality. Defined.
Global Opaque quantity_eq.

Definition size_quantity_nat (q: quantity) :=
match q with Q32 => 4%nat | Q64 => 8%nat end.

Lemma size_quantity_nat_pos:
forall q, exists n, size_quantity_nat q = S n.
Proof. hammer_hook "Memdata" "Memdata.size_quantity_nat_pos".
intros. destruct q; [exists 3%nat | exists 7%nat]; auto.
Qed.

Inductive memval: Type :=
| Undef: memval
| Byte: byte -> memval
| Fragment: val -> quantity -> nat -> memval.

Fixpoint bytes_of_int (n: nat) (x: Z) {struct n}: list byte :=
match n with
| O => nil
| S m => Byte.repr x :: bytes_of_int m (x / 256)
end.

Fixpoint int_of_bytes (l: list byte): Z :=
match l with
| nil => 0
| b :: l' => Byte.unsigned b + int_of_bytes l' * 256
end.

Definition rev_if_be (l: list byte) : list byte :=
if Archi.big_endian then List.rev l else l.

Definition encode_int (sz: nat) (x: Z) : list byte :=
rev_if_be (bytes_of_int sz x).

Definition decode_int (b: list byte) : Z :=
int_of_bytes (rev_if_be b).

Lemma length_bytes_of_int:
forall n x, length (bytes_of_int n x) = n.
Proof. hammer_hook "Memdata" "Memdata.length_bytes_of_int".
induction n; simpl; intros. auto. decEq. auto.
Qed.

Lemma rev_if_be_length:
forall l, length (rev_if_be l) = length l.
Proof. hammer_hook "Memdata" "Memdata.rev_if_be_length".
intros; unfold rev_if_be; destruct Archi.big_endian.
apply List.rev_length.
auto.
Qed.

Lemma encode_int_length:
forall sz x, length(encode_int sz x) = sz.
Proof. hammer_hook "Memdata" "Memdata.encode_int_length".
intros. unfold encode_int. rewrite rev_if_be_length. apply length_bytes_of_int.
Qed.

Lemma int_of_bytes_of_int:
forall n x,
int_of_bytes (bytes_of_int n x) = x mod (two_p (Z.of_nat n * 8)).
Proof. hammer_hook "Memdata" "Memdata.int_of_bytes_of_int".
induction n; intros.
simpl. rewrite Zmod_1_r. auto.
Opaque Byte.wordsize.
rewrite Nat2Z.inj_succ. simpl.
replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega.
rewrite two_p_is_exp; try omega.
rewrite Zmod_recombine. rewrite IHn. rewrite Z.add_comm.
change (Byte.unsigned (Byte.repr x)) with (Byte.Z_mod_modulus x).
rewrite Byte.Z_mod_modulus_eq. reflexivity.
apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega.
Qed.

Lemma rev_if_be_involutive:
forall l, rev_if_be (rev_if_be l) = l.
Proof. hammer_hook "Memdata" "Memdata.rev_if_be_involutive".
intros; unfold rev_if_be; destruct Archi.big_endian.
apply List.rev_involutive.
auto.
Qed.

Lemma decode_encode_int:
forall n x, decode_int (encode_int n x) = x mod (two_p (Z.of_nat n * 8)).
Proof. hammer_hook "Memdata" "Memdata.decode_encode_int".
unfold decode_int, encode_int; intros. rewrite rev_if_be_involutive.
apply int_of_bytes_of_int.
Qed.

Lemma decode_encode_int_1:
forall x, Int.repr (decode_int (encode_int 1 (Int.unsigned x))) = Int.zero_ext 8 x.
Proof. hammer_hook "Memdata" "Memdata.decode_encode_int_1".
intros. rewrite decode_encode_int.
rewrite <- (Int.repr_unsigned (Int.zero_ext 8 x)).
decEq. symmetry. apply Int.zero_ext_mod. compute. intuition congruence.
Qed.

Lemma decode_encode_int_2:
forall x, Int.repr (decode_int (encode_int 2 (Int.unsigned x))) = Int.zero_ext 16 x.
Proof. hammer_hook "Memdata" "Memdata.decode_encode_int_2".
intros. rewrite decode_encode_int.
rewrite <- (Int.repr_unsigned (Int.zero_ext 16 x)).
decEq. symmetry. apply Int.zero_ext_mod. compute; intuition congruence.
Qed.

Lemma decode_encode_int_4:
forall x, Int.repr (decode_int (encode_int 4 (Int.unsigned x))) = x.
Proof. hammer_hook "Memdata" "Memdata.decode_encode_int_4".
intros. rewrite decode_encode_int. transitivity (Int.repr (Int.unsigned x)).
decEq. apply Z.mod_small. apply Int.unsigned_range. apply Int.repr_unsigned.
Qed.

Lemma decode_encode_int_8:
forall x, Int64.repr (decode_int (encode_int 8 (Int64.unsigned x))) = x.
Proof. hammer_hook "Memdata" "Memdata.decode_encode_int_8".
intros. rewrite decode_encode_int. transitivity (Int64.repr (Int64.unsigned x)).
decEq. apply Z.mod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned.
Qed.

Lemma bytes_of_int_mod:
forall n x y,
eqmod (two_p (Z.of_nat n * 8)) x y ->
bytes_of_int n x = bytes_of_int n y.
Proof. hammer_hook "Memdata" "Memdata.bytes_of_int_mod".
induction n.
intros; simpl; auto.
intros until y.
rewrite Nat2Z.inj_succ.
replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega.
rewrite two_p_is_exp; try omega.
intro EQM.
simpl; decEq.
apply Byte.eqm_samerepr. red.
eapply eqmod_divides; eauto. apply Z.divide_factor_r.
apply IHn.
destruct EQM as [k EQ]. exists k. rewrite EQ.
rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega.
Qed.

Lemma encode_int_8_mod:
forall x y,
eqmod (two_p 8) x y ->
encode_int 1%nat x = encode_int 1%nat y.
Proof. hammer_hook "Memdata" "Memdata.encode_int_8_mod".
intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

Lemma encode_int_16_mod:
forall x y,
eqmod (two_p 16) x y ->
encode_int 2%nat x = encode_int 2%nat y.
Proof. hammer_hook "Memdata" "Memdata.encode_int_16_mod".
intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

Definition inj_bytes (bl: list byte) : list memval :=
List.map Byte bl.

Fixpoint proj_bytes (vl: list memval) : option (list byte) :=
match vl with
| nil => Some nil
| Byte b :: vl' =>
match proj_bytes vl' with None => None | Some bl => Some(b :: bl) end
| _ => None
end.

Remark length_inj_bytes:
forall bl, length (inj_bytes bl) = length bl.
Proof. hammer_hook "Memdata" "Memdata.length_inj_bytes".
intros. apply List.map_length.
Qed.

Remark proj_inj_bytes:
forall bl, proj_bytes (inj_bytes bl) = Some bl.
Proof. hammer_hook "Memdata" "Memdata.proj_inj_bytes".
induction bl; simpl. auto. rewrite IHbl. auto.
Qed.

Lemma inj_proj_bytes:
forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl.
Proof. hammer_hook "Memdata" "Memdata.inj_proj_bytes".
induction cl; simpl; intros.
inv H; auto.
destruct a; try congruence. destruct (proj_bytes cl); inv H.
simpl. decEq. auto.
Qed.

Fixpoint inj_value_rec (n: nat) (v: val) (q: quantity) {struct n}: list memval :=
match n with
| O => nil
| S m => Fragment v q m :: inj_value_rec m v q
end.

Definition inj_value (q: quantity) (v: val): list memval :=
inj_value_rec (size_quantity_nat q) v q.

Fixpoint check_value (n: nat) (v: val) (q: quantity) (vl: list memval)
{struct n} : bool :=
match n, vl with
| O, nil => true
| S m, Fragment v' q' m' :: vl' =>
Val.eq v v' && quantity_eq q q' && Nat.eqb m m' && check_value m v q vl'
| _, _ => false
end.

Definition proj_value (q: quantity) (vl: list memval) : val :=
match vl with
| Fragment v q' n :: vl' =>
if check_value (size_quantity_nat q) v q vl then v else Vundef
| _ => Vundef
end.

Definition encode_val (chunk: memory_chunk) (v: val) : list memval :=
match v, chunk with
| Vint n, (Mint8signed | Mint8unsigned) => inj_bytes (encode_int 1%nat (Int.unsigned n))
| Vint n, (Mint16signed | Mint16unsigned) => inj_bytes (encode_int 2%nat (Int.unsigned n))
| Vint n, Mint32 => inj_bytes (encode_int 4%nat (Int.unsigned n))
| Vptr b ofs, Mint32 => if Archi.ptr64 then list_repeat 4%nat Undef else inj_value Q32 v
| Vlong n, Mint64 => inj_bytes (encode_int 8%nat (Int64.unsigned n))
| Vptr b ofs, Mint64 => if Archi.ptr64 then inj_value Q64 v else list_repeat 8%nat Undef
| Vsingle n, Mfloat32 => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n)))
| Vfloat n, Mfloat64 => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n)))
| _, Many32 => inj_value Q32 v
| _, Many64 => inj_value Q64 v
| _, _ => list_repeat (size_chunk_nat chunk) Undef
end.

Definition decode_val (chunk: memory_chunk) (vl: list memval) : val :=
match proj_bytes vl with
| Some bl =>
match chunk with
| Mint8signed => Vint(Int.sign_ext 8 (Int.repr (decode_int bl)))
| Mint8unsigned => Vint(Int.zero_ext 8 (Int.repr (decode_int bl)))
| Mint16signed => Vint(Int.sign_ext 16 (Int.repr (decode_int bl)))
| Mint16unsigned => Vint(Int.zero_ext 16 (Int.repr (decode_int bl)))
| Mint32 => Vint(Int.repr(decode_int bl))
| Mint64 => Vlong(Int64.repr(decode_int bl))
| Mfloat32 => Vsingle(Float32.of_bits (Int.repr (decode_int bl)))
| Mfloat64 => Vfloat(Float.of_bits (Int64.repr (decode_int bl)))
| Many32 => Vundef
| Many64 => Vundef
end
| None =>
match chunk with
| Mint32 => if Archi.ptr64 then Vundef else Val.load_result chunk (proj_value Q32 vl)
| Many32 => Val.load_result chunk (proj_value Q32 vl)
| Mint64 => if Archi.ptr64 then Val.load_result chunk (proj_value Q64 vl) else Vundef
| Many64 => Val.load_result chunk (proj_value Q64 vl)
| _ => Vundef
end
end.

Ltac solve_encode_val_length :=
match goal with
| [ |- length (inj_bytes _) = _ ] => rewrite length_inj_bytes; solve_encode_val_length
| [ |- length (encode_int _ _) = _ ] => apply encode_int_length
| [ |- length (if ?x then _ else _) = _ ] => destruct x eqn:?; solve_encode_val_length
| _ => reflexivity
end.

Lemma encode_val_length:
forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk.
Proof. hammer_hook "Memdata" "Memdata.encode_val_length".
intros. destruct v; simpl; destruct chunk; solve_encode_val_length.
Qed.

Lemma check_inj_value:
forall v q n, check_value n v q (inj_value_rec n v q) = true.
Proof. hammer_hook "Memdata" "Memdata.check_inj_value".
induction n; simpl. auto.
unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
rewrite <- beq_nat_refl. simpl; auto.
Qed.

Lemma proj_inj_value:
forall q v, proj_value q (inj_value q v) = v.
Proof. hammer_hook "Memdata" "Memdata.proj_inj_value".
intros. unfold proj_value, inj_value. destruct (size_quantity_nat_pos q) as [n EQ].
rewrite EQ at 1. simpl. rewrite check_inj_value. auto.
Qed.

Remark in_inj_value:
forall mv v q, In mv (inj_value q v) -> exists n, mv = Fragment v q n.
Proof. hammer_hook "Memdata" "Memdata.in_inj_value".
Local Transparent inj_value.
unfold inj_value; intros until q. generalize (size_quantity_nat q). induction n; simpl; intros.
contradiction.
destruct H. exists n; auto. eauto.
Qed.

Lemma proj_inj_value_mismatch:
forall q1 q2 v, q1 <> q2 -> proj_value q1 (inj_value q2 v) = Vundef.
Proof. hammer_hook "Memdata" "Memdata.proj_inj_value_mismatch".
intros. unfold proj_value. destruct (inj_value q2 v) eqn:V. auto. destruct m; auto.
destruct (in_inj_value (Fragment v0 q n) v q2) as [n' EQ].
rewrite V; auto with coqlib. inv EQ.
destruct (size_quantity_nat_pos q1) as [p EQ1]; rewrite EQ1; simpl.
unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_false by congruence. auto.
Qed.

Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Prop :=
match v1, chunk1, chunk2 with
| Vundef, _, _ => v2 = Vundef
| Vint n, Mint8signed, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
| Vint n, Mint8unsigned, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
| Vint n, Mint8signed, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
| Vint n, Mint8unsigned, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
| Vint n, Mint16signed, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
| Vint n, Mint16unsigned, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
| Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
| Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
| Vint n, Mint32, Mint32 => v2 = Vint n
| Vint n, Many32, Many32 => v2 = Vint n
| Vint n, Mint32, Mfloat32 => v2 = Vsingle(Float32.of_bits n)
| Vint n, Many64, Many64 => v2 = Vint n
| Vint n, (Mint64 | Mfloat32 | Mfloat64 | Many64), _ => v2 = Vundef
| Vint n, _, _ => True
| Vptr b ofs, (Mint32 | Many32), (Mint32 | Many32) => v2 = if Archi.ptr64 then Vundef else Vptr b ofs
| Vptr b ofs, Mint64, (Mint64 | Many64) => v2 = if Archi.ptr64 then Vptr b ofs else Vundef
| Vptr b ofs, Many64, Many64 => v2 = Vptr b ofs
| Vptr b ofs, Many64, Mint64 => v2 = if Archi.ptr64 then Vptr b ofs else Vundef
| Vptr b ofs, _, _ => v2 = Vundef
| Vlong n, Mint64, Mint64 => v2 = Vlong n
| Vlong n, Mint64, Mfloat64 => v2 = Vfloat(Float.of_bits n)
| Vlong n, Many64, Many64 => v2 = Vlong n
| Vlong n, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mfloat32|Mfloat64|Many32), _ => v2 = Vundef
| Vlong n, _, _ => True
| Vfloat f, Mfloat64, Mfloat64 => v2 = Vfloat f
| Vfloat f, Mfloat64, Mint64 => v2 = Vlong(Float.to_bits f)
| Vfloat f, Many64, Many64 => v2 = Vfloat f
| Vfloat f, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mfloat32|Mint64|Many32), _ => v2 = Vundef
| Vfloat f, _, _ => True
| Vsingle f, Mfloat32, Mfloat32 => v2 = Vsingle f
| Vsingle f, Mfloat32, Mint32 => v2 = Vint(Float32.to_bits f)
| Vsingle f, Many32, Many32 => v2 = Vsingle f
| Vsingle f, Many64, Many64 => v2 = Vsingle f
| Vsingle f, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mint64|Mfloat64|Many64), _ => v2 = Vundef
| Vsingle f, _, _ => True
end.

Remark decode_val_undef:
forall bl chunk, decode_val chunk (Undef :: bl) = Vundef.
Proof. hammer_hook "Memdata" "Memdata.decode_val_undef".
intros. unfold decode_val. simpl. destruct chunk, Archi.ptr64; auto.
Qed.

Remark proj_bytes_inj_value:
forall q v, proj_bytes (inj_value q v) = None.
Proof. hammer_hook "Memdata" "Memdata.proj_bytes_inj_value".
intros. destruct q; reflexivity.
Qed.

Ltac solve_decode_encode_val_general :=
exact I || reflexivity ||
match goal with
| |- context [ if Archi.ptr64 then _ else _ ] => destruct Archi.ptr64 eqn:?
| |- context [ proj_bytes (inj_bytes _) ] => rewrite proj_inj_bytes
| |- context [ proj_bytes (inj_value _ _) ] => rewrite proj_bytes_inj_value
| |- context [ proj_value _ (inj_value _ _) ] => rewrite ?proj_inj_value, ?proj_inj_value_mismatch by congruence
| |- context [ Int.repr(decode_int (encode_int 1 (Int.unsigned _))) ] => rewrite decode_encode_int_1
| |- context [ Int.repr(decode_int (encode_int 2 (Int.unsigned _))) ] => rewrite decode_encode_int_2
| |- context [ Int.repr(decode_int (encode_int 4 (Int.unsigned _))) ] => rewrite decode_encode_int_4
| |- context [ Int64.repr(decode_int (encode_int 8 (Int64.unsigned _))) ] => rewrite decode_encode_int_8
| |- Vint (Int.sign_ext _ (Int.sign_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_idem; omega
| |- Vint (Int.zero_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.zero_ext_idem; omega
| |- Vint (Int.sign_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_zero_ext; omega
end.

Lemma decode_encode_val_general:
forall v chunk1 chunk2,
decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)).
Proof. hammer_hook "Memdata" "Memdata.decode_encode_val_general".
Opaque inj_value.
intros.
destruct v; destruct chunk1 eqn:C1; try (apply decode_val_undef);
destruct chunk2 eqn:C2; unfold decode_encode_val, decode_val, encode_val, Val.load_result;
repeat solve_decode_encode_val_general.
- rewrite Float.of_to_bits; auto.
- rewrite Float32.of_to_bits; auto.
Qed.

Lemma decode_encode_val_similar:
forall v1 chunk1 chunk2 v2,
type_of_chunk chunk1 = type_of_chunk chunk2 ->
size_chunk chunk1 = size_chunk chunk2 ->
decode_encode_val v1 chunk1 chunk2 v2 ->
v2 = Val.load_result chunk2 v1.
Proof. hammer_hook "Memdata" "Memdata.decode_encode_val_similar".
intros until v2; intros TY SZ DE.
destruct chunk1; destruct chunk2; simpl in TY; try discriminate; simpl in SZ; try omegaContradiction;
destruct v1; auto.
Qed.

Lemma decode_val_type:
forall chunk cl,
Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
Proof. hammer_hook "Memdata" "Memdata.decode_val_type".
intros. unfold decode_val.
destruct (proj_bytes cl).
destruct chunk; simpl; auto.
Local Opaque Val.load_result.
destruct chunk; simpl;
(exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)).
Qed.

Lemma encode_val_int8_signed_unsigned:
forall v, encode_val Mint8signed v = encode_val Mint8unsigned v.
Proof. hammer_hook "Memdata" "Memdata.encode_val_int8_signed_unsigned".
intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int16_signed_unsigned:
forall v, encode_val Mint16signed v = encode_val Mint16unsigned v.
Proof. hammer_hook "Memdata" "Memdata.encode_val_int16_signed_unsigned".
intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int8_zero_ext:
forall n, encode_val Mint8unsigned (Vint (Int.zero_ext 8 n)) = encode_val Mint8unsigned (Vint n).
Proof. hammer_hook "Memdata" "Memdata.encode_val_int8_zero_ext".
intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_zero_ext.
compute; intuition congruence.
Qed.

Lemma encode_val_int8_sign_ext:
forall n, encode_val Mint8signed (Vint (Int.sign_ext 8 n)) = encode_val Mint8signed (Vint n).
Proof. hammer_hook "Memdata" "Memdata.encode_val_int8_sign_ext".
intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma encode_val_int16_zero_ext:
forall n, encode_val Mint16unsigned (Vint (Int.zero_ext 16 n)) = encode_val Mint16unsigned (Vint n).
Proof. hammer_hook "Memdata" "Memdata.encode_val_int16_zero_ext".
intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_zero_ext. compute; intuition congruence.
Qed.

Lemma encode_val_int16_sign_ext:
forall n, encode_val Mint16signed (Vint (Int.sign_ext 16 n)) = encode_val Mint16signed (Vint n).
Proof. hammer_hook "Memdata" "Memdata.encode_val_int16_sign_ext".
intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma decode_val_cast:
forall chunk l,
let v := decode_val chunk l in
match chunk with
| Mint8signed => v = Val.sign_ext 8 v
| Mint8unsigned => v = Val.zero_ext 8 v
| Mint16signed => v = Val.sign_ext 16 v
| Mint16unsigned => v = Val.zero_ext 16 v
| _ => True
end.
Proof. hammer_hook "Memdata" "Memdata.decode_val_cast".
unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto.
unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
Qed.

Definition quantity_chunk (chunk: memory_chunk) :=
match chunk with
| Mint64 | Mfloat64 | Many64 => Q64
| _ => Q32
end.

Inductive shape_encoding (chunk: memory_chunk) (v: val): list memval -> Prop :=
| shape_encoding_f: forall q i mvl,
(chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
q = quantity_chunk chunk ->
S i = size_quantity_nat q ->
(forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) ->
shape_encoding chunk v (Fragment v q i :: mvl)
| shape_encoding_b: forall b mvl,
match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True | _ => False end ->
(forall mv, In mv mvl -> exists b', mv = Byte b') ->
shape_encoding chunk v (Byte b :: mvl)
| shape_encoding_u: forall mvl,
(forall mv, In mv mvl -> mv = Undef) ->
shape_encoding chunk v (Undef :: mvl).

Lemma encode_val_shape: forall chunk v, shape_encoding chunk v (encode_val chunk v).
Proof. hammer_hook "Memdata" "Memdata.encode_val_shape".
intros.
destruct (size_chunk_nat_pos chunk) as [sz EQ].
assert (A: forall mv q n,
(n < size_quantity_nat q)%nat ->
In mv (inj_value_rec n v q) ->
exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q).
{
induction n; simpl; intros. contradiction. destruct H0.
exists n; split; auto. omega. apply IHn; auto. omega.
}
assert (B: forall q,
q = quantity_chunk chunk ->
(chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
shape_encoding chunk v (inj_value q v)).
{
Local Transparent inj_value.
intros. unfold inj_value. destruct (size_quantity_nat_pos q) as [sz' EQ'].
rewrite EQ'. simpl. constructor; auto.
intros; eapply A; eauto. omega.
}
assert (C: forall bl,
match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True | _ => False end ->
length (inj_bytes bl) = size_chunk_nat chunk ->
shape_encoding chunk v (inj_bytes bl)).
{
intros. destruct bl as [|b1 bl]. simpl in H0; congruence. simpl.
constructor; auto. unfold inj_bytes; intros. exploit list_in_map_inv; eauto.
intros (b & P & Q); exists b; auto.
}
assert (D: shape_encoding chunk v (list_repeat (size_chunk_nat chunk) Undef)).
{
intros. rewrite EQ; simpl; constructor; auto.
intros. eapply in_list_repeat; eauto.
}
generalize (encode_val_length chunk v). intros LEN.
unfold encode_val; unfold encode_val in LEN;
destruct v; destruct chunk;
(apply B || apply C || apply D || (destruct Archi.ptr64; (apply B || apply D)));
auto.
Qed.

Inductive shape_decoding (chunk: memory_chunk): list memval -> val -> Prop :=
| shape_decoding_f: forall v q i mvl,
(chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
q = quantity_chunk chunk ->
S i = size_quantity_nat q ->
(forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) ->
shape_decoding chunk (Fragment v q i :: mvl) (Val.load_result chunk v)
| shape_decoding_b: forall b mvl v,
match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True |  _ => False end ->
(forall mv, In mv mvl -> exists b', mv = Byte b') ->
shape_decoding chunk (Byte b :: mvl) v
| shape_decoding_u: forall mvl,
shape_decoding chunk mvl Vundef.

Lemma decode_val_shape: forall chunk mv1 mvl,
shape_decoding chunk (mv1 :: mvl) (decode_val chunk (mv1 :: mvl)).
Proof. hammer_hook "Memdata" "Memdata.decode_val_shape".
intros.
assert (A: forall mv mvs bs, proj_bytes mvs = Some bs -> In mv mvs ->
exists b, mv = Byte b).
{
induction mvs; simpl; intros.
contradiction.
destruct a; try discriminate. destruct H0. exists i; auto.
destruct (proj_bytes mvs); try discriminate. eauto.
}
assert (B: forall v q mv n mvs,
check_value n v q mvs = true -> In mv mvs -> (n < size_quantity_nat q)%nat ->
exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q).
{
induction n; destruct mvs; simpl; intros; try discriminate.
contradiction.
destruct m; try discriminate. InvBooleans. apply beq_nat_true in H4. subst.
destruct H0. subst mv. exists n0; split; auto. omega.
eapply IHn; eauto. omega.
}
assert (U: forall mvs, shape_decoding chunk mvs (Val.load_result chunk Vundef)).
{
intros. replace (Val.load_result chunk Vundef) with Vundef. constructor.
destruct chunk; auto.
}
assert (C: forall q, size_quantity_nat q = size_chunk_nat chunk ->
(chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
shape_decoding chunk (mv1 :: mvl) (Val.load_result chunk (proj_value q (mv1 :: mvl)))).
{
intros. unfold proj_value. destruct mv1; auto.
destruct (size_quantity_nat_pos q) as [sz EQ]. rewrite EQ.
simpl. unfold proj_sumbool. rewrite dec_eq_true.
destruct (quantity_eq q q0); auto.
destruct (Nat.eqb sz n) eqn:EQN; auto.
destruct (check_value sz v q mvl) eqn:CHECK; auto.
simpl. apply beq_nat_true in EQN. subst n q0. constructor. auto.
destruct H0 as [E|[E|[E|E]]]; subst chunk; destruct q; auto || discriminate.
congruence.
intros. eapply B; eauto. omega.
}
unfold decode_val.
destruct (proj_bytes (mv1 :: mvl)) as [bl|] eqn:PB.
exploit (A mv1); eauto with coqlib. intros [b1 EQ1]; subst mv1.
destruct chunk; (apply shape_decoding_u || apply shape_decoding_b); eauto with coqlib.
destruct chunk, Archi.ptr64; (apply shape_decoding_u || apply C); auto.
Qed.

Inductive memval_inject (f: meminj): memval -> memval -> Prop :=
| memval_inject_byte:
forall n, memval_inject f (Byte n) (Byte n)
| memval_inject_frag:
forall v1 v2 q n,
Val.inject f v1 v2 ->
memval_inject f (Fragment v1 q n) (Fragment v2 q n)
| memval_inject_undef:
forall mv, memval_inject f Undef mv.

Lemma memval_inject_incr:
forall f f' v1 v2, memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2.
Proof. hammer_hook "Memdata" "Memdata.memval_inject_incr".
intros. inv H; econstructor. eapply val_inject_incr; eauto.
Qed.

Lemma proj_bytes_inject:
forall f vl vl',
list_forall2 (memval_inject f) vl vl' ->
forall bl,
proj_bytes vl = Some bl ->
proj_bytes vl' = Some bl.
Proof. hammer_hook "Memdata" "Memdata.proj_bytes_inject".
induction 1; simpl. congruence.
inv H; try congruence.
destruct (proj_bytes al); intros.
inv H. rewrite (IHlist_forall2 l); auto.
congruence.
Qed.

Lemma check_value_inject:
forall f vl vl',
list_forall2 (memval_inject f) vl vl' ->
forall v v' q n,
check_value n v q vl = true ->
Val.inject f v v' -> v <> Vundef ->
check_value n v' q vl' = true.
Proof. hammer_hook "Memdata" "Memdata.check_value_inject".
induction 1; intros; destruct n; simpl in *; auto.
inv H; auto.
InvBooleans. assert (n = n0) by (apply beq_nat_true; auto). subst v1 q0 n0.
replace v2 with v'.
unfold proj_sumbool; rewrite ! dec_eq_true. rewrite <- beq_nat_refl. simpl; eauto.
inv H2; try discriminate; inv H4; congruence.
discriminate.
Qed.

Lemma proj_value_inject:
forall f q vl1 vl2,
list_forall2 (memval_inject f) vl1 vl2 ->
Val.inject f (proj_value q vl1) (proj_value q vl2).
Proof. hammer_hook "Memdata" "Memdata.proj_value_inject".
intros. unfold proj_value.
inversion H; subst. auto. inversion H0; subst; auto.
destruct (check_value (size_quantity_nat q) v1 q (Fragment v1 q0 n :: al)) eqn:B; auto.
destruct (Val.eq v1 Vundef). subst; auto.
erewrite check_value_inject by eauto. auto.
Qed.

Lemma proj_bytes_not_inject:
forall f vl vl',
list_forall2 (memval_inject f) vl vl' ->
proj_bytes vl = None -> proj_bytes vl' <> None -> In Undef vl.
Proof. hammer_hook "Memdata" "Memdata.proj_bytes_not_inject".
induction 1; simpl; intros.
congruence.
inv H; try congruence.
right. apply IHlist_forall2.
destruct (proj_bytes al); congruence.
destruct (proj_bytes bl); congruence.
auto.
Qed.

Lemma check_value_undef:
forall n q v vl,
In Undef vl -> check_value n v q vl = false.
Proof. hammer_hook "Memdata" "Memdata.check_value_undef".
induction n; intros; simpl.
destruct vl. elim H. auto.
destruct vl. auto.
destruct m; auto. simpl in H; destruct H. congruence.
rewrite IHn; auto. apply andb_false_r.
Qed.

Lemma proj_value_undef:
forall q vl, In Undef vl -> proj_value q vl = Vundef.
Proof. hammer_hook "Memdata" "Memdata.proj_value_undef".
intros; unfold proj_value.
destruct vl; auto. destruct m; auto.
rewrite check_value_undef. auto. auto.
Qed.

Theorem decode_val_inject:
forall f vl1 vl2 chunk,
list_forall2 (memval_inject f) vl1 vl2 ->
Val.inject f (decode_val chunk vl1) (decode_val chunk vl2).
Proof. hammer_hook "Memdata" "Memdata.decode_val_inject".
intros. unfold decode_val.
destruct (proj_bytes vl1) as [bl1|] eqn:PB1.
exploit proj_bytes_inject; eauto. intros PB2. rewrite PB2.
destruct chunk; constructor.
assert (A: forall q fn,
Val.inject f (Val.load_result chunk (proj_value q vl1))
(match proj_bytes vl2 with
| Some bl => fn bl
| None => Val.load_result chunk (proj_value q vl2)
end)).
{ intros. destruct (proj_bytes vl2) as [bl2|] eqn:PB2.
rewrite proj_value_undef. destruct chunk; auto. eapply proj_bytes_not_inject; eauto. congruence.
apply Val.load_result_inject. apply proj_value_inject; auto.
}
destruct chunk; destruct Archi.ptr64; auto.
Qed.

Lemma inj_bytes_inject:
forall f bl, list_forall2 (memval_inject f) (inj_bytes bl) (inj_bytes bl).
Proof. hammer_hook "Memdata" "Memdata.inj_bytes_inject".
induction bl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_any:
forall f vl,
list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl.
Proof. hammer_hook "Memdata" "Memdata.repeat_Undef_inject_any".
induction vl; simpl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_encode_val:
forall f chunk v,
list_forall2 (memval_inject f) (list_repeat (size_chunk_nat chunk) Undef) (encode_val chunk v).
Proof. hammer_hook "Memdata" "Memdata.repeat_Undef_inject_encode_val".
intros. rewrite <- (encode_val_length chunk v). apply repeat_Undef_inject_any.
Qed.

Lemma repeat_Undef_inject_self:
forall f n,
list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef).
Proof. hammer_hook "Memdata" "Memdata.repeat_Undef_inject_self".
induction n; simpl; constructor; auto. constructor.
Qed.

Lemma inj_value_inject:
forall f v1 v2 q, Val.inject f v1 v2 -> list_forall2 (memval_inject f) (inj_value q v1) (inj_value q v2).
Proof. hammer_hook "Memdata" "Memdata.inj_value_inject".
intros.
Local Transparent inj_value.
unfold inj_value. generalize (size_quantity_nat q). induction n; simpl; constructor; auto.
constructor; auto.
Qed.

Theorem encode_val_inject:
forall f v1 v2 chunk,
Val.inject f v1 v2 ->
list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2).
Proof. hammer_hook "Memdata" "Memdata.encode_val_inject".
Local Opaque list_repeat.
intros. inversion H; subst; simpl; destruct chunk;
auto using inj_bytes_inject, inj_value_inject, repeat_Undef_inject_self, repeat_Undef_inject_encode_val.
- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self.
- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self.
- unfold encode_val. destruct v2; apply inj_value_inject; auto.
- unfold encode_val. destruct v2; apply inj_value_inject; auto.
Qed.

Definition memval_lessdef: memval -> memval -> Prop := memval_inject inject_id.

Lemma memval_lessdef_refl:
forall mv, memval_lessdef mv mv.
Proof. hammer_hook "Memdata" "Memdata.memval_lessdef_refl".
red. destruct mv; econstructor. apply val_inject_id. auto.
Qed.

Lemma memval_inject_compose:
forall f f' v1 v2 v3,
memval_inject f v1 v2 -> memval_inject f' v2 v3 ->
memval_inject (compose_meminj f f') v1 v3.
Proof. hammer_hook "Memdata" "Memdata.memval_inject_compose".
intros. inv H.
inv H0. constructor.
inv H0. econstructor.
eapply val_inject_compose; eauto.
constructor.
Qed.

Lemma int_of_bytes_append:
forall l2 l1,
int_of_bytes (l1 ++ l2) = int_of_bytes l1 + int_of_bytes l2 * two_p (Z.of_nat (length l1) * 8).
Proof. hammer_hook "Memdata" "Memdata.int_of_bytes_append".
induction l1; simpl int_of_bytes; intros.
simpl. ring.
simpl length. rewrite Nat2Z.inj_succ.
replace (Z.succ (Z.of_nat (length l1)) * 8) with (Z.of_nat (length l1) * 8 + 8) by omega.
rewrite two_p_is_exp. change (two_p 8) with 256. rewrite IHl1. ring.
omega. omega.
Qed.

Lemma int_of_bytes_range:
forall l, 0 <= int_of_bytes l < two_p (Z.of_nat (length l) * 8).
Proof. hammer_hook "Memdata" "Memdata.int_of_bytes_range".
induction l; intros.
simpl. omega.
simpl length. rewrite Nat2Z.inj_succ.
replace (Z.succ (Z.of_nat (length l)) * 8) with (Z.of_nat (length l) * 8 + 8) by omega.
rewrite two_p_is_exp. change (two_p 8) with 256.
simpl int_of_bytes. generalize (Byte.unsigned_range a).
change Byte.modulus with 256. omega.
omega. omega.
Qed.

Lemma length_proj_bytes:
forall l b, proj_bytes l = Some b -> length b = length l.
Proof. hammer_hook "Memdata" "Memdata.length_proj_bytes".
induction l; simpl; intros.
inv H; auto.
destruct a; try discriminate.
destruct (proj_bytes l) eqn:E; inv H.
simpl. f_equal. auto.
Qed.

Lemma proj_bytes_append:
forall l2 l1,
proj_bytes (l1 ++ l2) =
match proj_bytes l1, proj_bytes l2 with
| Some b1, Some b2 => Some (b1 ++ b2)
| _, _ => None
end.
Proof. hammer_hook "Memdata" "Memdata.proj_bytes_append".
induction l1; simpl.
destruct (proj_bytes l2); auto.
destruct a; auto. rewrite IHl1.
destruct (proj_bytes l1); auto. destruct (proj_bytes l2); auto.
Qed.

Lemma decode_val_int64:
forall l1 l2,
length l1 = 4%nat -> length l2 = 4%nat -> Archi.ptr64 = false ->
Val.lessdef
(decode_val Mint64 (l1 ++ l2))
(Val.longofwords (decode_val Mint32 (if Archi.big_endian then l1 else l2))
(decode_val Mint32 (if Archi.big_endian then l2 else l1))).
Proof. hammer_hook "Memdata" "Memdata.decode_val_int64".
intros. unfold decode_val. rewrite H1.
rewrite proj_bytes_append.
destruct (proj_bytes l1) as [b1|] eqn:B1; destruct (proj_bytes l2) as [b2|] eqn:B2; auto.
exploit length_proj_bytes. eexact B1. rewrite H; intro L1.
exploit length_proj_bytes. eexact B2. rewrite H0; intro L2.
assert (UR: forall l, length l = 4%nat -> Int.unsigned (Int.repr (int_of_bytes l)) = int_of_bytes l).
intros. apply Int.unsigned_repr.
generalize (int_of_bytes_range l). rewrite H2.
change (two_p (Z.of_nat 4 * 8)) with (Int.max_unsigned + 1).
omega.
apply Val.lessdef_same.
unfold decode_int, rev_if_be. destruct Archi.big_endian; rewrite B1; rewrite B2.
+ rewrite <- (rev_length b1) in L1.
rewrite <- (rev_length b2) in L2.
rewrite rev_app_distr.
set (b1' := rev b1) in *; set (b2' := rev b2) in *.
unfold Val.longofwords. f_equal. rewrite Int64.ofwords_add. f_equal.
rewrite !UR by auto. rewrite int_of_bytes_append.
rewrite L2. change (Z.of_nat 4 * 8) with 32. ring.
+ unfold Val.longofwords. f_equal. rewrite Int64.ofwords_add. f_equal.
rewrite !UR by auto. rewrite int_of_bytes_append.
rewrite L1. change (Z.of_nat 4 * 8) with 32. ring.
Qed.

Lemma bytes_of_int_append:
forall n2 x2 n1 x1,
0 <= x1 < two_p (Z.of_nat n1 * 8) ->
bytes_of_int (n1 + n2) (x1 + x2 * two_p (Z.of_nat n1 * 8)) =
bytes_of_int n1 x1 ++ bytes_of_int n2 x2.
Proof. hammer_hook "Memdata" "Memdata.bytes_of_int_append".
induction n1; intros.
- simpl in *. f_equal. omega.
- assert (E: two_p (Z.of_nat (S n1) * 8) = two_p (Z.of_nat n1 * 8) * 256).
{
rewrite Nat2Z.inj_succ. change 256 with (two_p 8). rewrite <- two_p_is_exp.
f_equal. omega. omega. omega.
}
rewrite E in *. simpl. f_equal.
apply Byte.eqm_samerepr. exists (x2 * two_p (Z.of_nat n1 * 8)).
change Byte.modulus with 256. ring.
rewrite Z.mul_assoc. rewrite Z_div_plus. apply IHn1.
apply Zdiv_interval_1. omega. apply two_p_gt_ZERO; omega. omega.
assumption. omega.
Qed.

Lemma bytes_of_int64:
forall i,
bytes_of_int 8 (Int64.unsigned i) =
bytes_of_int 4 (Int.unsigned (Int64.loword i)) ++ bytes_of_int 4 (Int.unsigned (Int64.hiword i)).
Proof. hammer_hook "Memdata" "Memdata.bytes_of_int64".
intros. transitivity (bytes_of_int (4 + 4) (Int64.unsigned (Int64.ofwords (Int64.hiword i) (Int64.loword i)))).
f_equal. f_equal. rewrite Int64.ofwords_recompose. auto.
rewrite Int64.ofwords_add'.
change 32 with (Z.of_nat 4 * 8).
rewrite Z.add_comm. apply bytes_of_int_append. apply Int.unsigned_range.
Qed.

Lemma encode_val_int64:
forall v,
Archi.ptr64 = false ->
encode_val Mint64 v =
encode_val Mint32 (if Archi.big_endian then Val.hiword v else Val.loword v)
++ encode_val Mint32 (if Archi.big_endian then Val.loword v else Val.hiword v).
Proof. hammer_hook "Memdata" "Memdata.encode_val_int64".
intros. unfold encode_val. rewrite H.
destruct v; destruct Archi.big_endian eqn:BI; try reflexivity;
unfold Val.loword, Val.hiword, encode_val.
unfold inj_bytes. rewrite <- map_app. f_equal.
unfold encode_int, rev_if_be. rewrite BI. rewrite <- rev_app_distr. f_equal.
apply bytes_of_int64.
unfold inj_bytes. rewrite <- map_app. f_equal.
unfold encode_int, rev_if_be. rewrite BI.
apply bytes_of_int64.
Qed.


From refinedc.typing Require Import typing.
From refinedc.project.learning.src.circuit Require Import generated_code.
From refinedc.project.learning.src.circuit Require Import generated_spec.
Set Default Proof Using "Type".

(* Generated from [src/circuit.c]. *)
Section proof_set_two.
  Context `{!typeG Σ} `{!globalG Σ}.

  (* Typing proof for [set_two]. *)
  Lemma type_set_two :
    ⊢ typed_function impl_set_two type_of_set_two.
  Proof.
    Open Scope printing_sugar.
    start_function "set_two" ([[[a b] x] p]) => arg_c arg_v.
    prepare_parameters (a b x p).
    split_blocks ((
      ∅
    )%I : gmap label (iProp Σ)) ((
      ∅
    )%I : gmap label (iProp Σ)).
    - repeat liRStep; liShow.
      all: print_typesystem_goal "set_two" "#0".
    Unshelve. all: li_unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
    all: tauto.
    all: print_sidecondition_goal "set_two".
    Unshelve. all: try done; try apply: inhabitant; print_remaining_shelved_goal "set_two".
  Qed.
End proof_set_two.