Require Import Lia Framework ATCDLayer File FileDiskNoninterference.
Require Import LoggedDiskRefinement LogCache.RepImplications Not_Init.
Require Import ATCD_Simulation.

Opaque LogCache.recover.
Lemma ATCD_AOE_recover:
forall l_grs u,
abstract_oracles_exist_wrt
ATCD_Refinement
(fun s1 s2 => refines_reboot (snd (snd s1)) (snd (snd s2)) /\
fst s1 = fst s2 /\
fst (snd s1)  = fst (snd s2)) u
(Simulation.Definitions.compile ATC_Refinement File.recover)
(Simulation.Definitions.compile ATC_Refinement File.recover)
(ATCD_reboot_list l_grs).
Proof.
    unfold ATCD_reboot_list,
    abstract_oracles_exist_wrt;
    induction l_grs; simpl; intros.
    { (* base case *)
      repeat invert_exec; cleanup.
      (* eapply_fresh minimal_oracle_finished_same in H7. *)
      invert_exec'' H7.
      invert_exec'' H9.
      repeat invert_exec; cleanup.
      eapply lift2_invert_exec in H12; cleanup.
      eapply lift2_invert_exec in H4; cleanup.
      repeat cleanup_pairs; eauto.
      eexists [_]; simpl.
      intuition eauto.
      left; intuition eauto.
      do 2 eexists; intuition eauto.
      repeat (rewrite cons_app;
      repeat econstructor; eauto).
      eapply lift2_exec_step.
      eapply lift2_exec_step; eauto.
      right; do 7 eexists; intuition eauto.
      3: eapply lift2_exec_step;
      eapply lift2_exec_step; eauto.
      2: simpl; repeat econstructor; eauto.
      eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      left; eexists; simpl in *; intuition eauto.
      destruct t; eauto.
      eapply LogCache.recover_finished; eauto.
    }
    { (* Inductive case *)
      repeat invert_exec; cleanup.
      (* eapply_fresh exec_crashed_minimal_oracle in H10; cleanup. *)
      invert_exec'' H10; repeat invert_exec; cleanup.
      {
        invert_exec'' H8; repeat invert_exec; cleanup.
        eapply lift2_invert_exec_crashed in H13; cleanup.
        eapply lift2_invert_exec_crashed in H4; cleanup.
        repeat cleanup_pairs; eauto.

        edestruct IHl_grs; only 2: eauto.
        simpl.
        unfold refines,
        refines_reboot in *;
        simpl in *; cleanup.
        eapply LogCache.recover_crashed in H5; eauto.
        simpl in *; cleanup.
        clear H2.
        eexists (_, (_, _)); repeat split.
        repeat split_ors.
        simpl; eapply cached_log_reboot_rep_to_reboot_rep in c; eauto.
        simpl; eapply cached_log_crash_rep_during_recovery_to_reboot_rep in c; eauto.
        simpl; eapply cached_log_crash_rep_after_commit_to_reboot_rep in c; eauto.
        apply select_total_mem_synced.

      eexists (_::_);
      simpl; intuition eauto.
      eapply recovery_oracles_refine_length in H0.
      rewrite H0; eauto.
      eauto.

      right; intuition eauto.
      eexists; intuition eauto.
      rewrite cons_app.
      econstructor.
      repeat econstructor.
      repeat eapply lift2_exec_step_crashed; eauto.
      right; do 7 eexists; intuition eauto.
      3: repeat eapply lift2_exec_step_crashed; eauto.
      2: simpl; repeat econstructor; eauto.
      eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      right; eexists; simpl in *; intuition eauto.
      eapply LogCache.recover_crashed; eauto.

      simpl; eauto.
    }
    {
      (* eapply exec_crashed_minimum_oracle in H5; cleanup.
      rewrite <- app_assoc. *)
      invert_exec'' H7; repeat invert_exec; cleanup.
      edestruct IHl_grs; only 2: eauto.
      simpl; eexists (_, (_, _)); simpl; split.
      eapply refines_reboot_to_refines_reboot; eauto.
      intuition eauto.

      eexists (_::_);
      simpl; intuition eauto.
      eapply recovery_oracles_refine_length in H2.
      rewrite H2; eauto.
      eauto.

      right; intuition eauto.
      eexists; intuition eauto.
      repeat econstructor; eauto.
      repeat cleanup_pairs.
      repeat econstructor; eauto.

      left; do 2 eexists; intuition eauto.
      repeat cleanup_pairs.
      repeat econstructor; eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      eexists; intuition eauto.
      simpl; eauto.
    }
  }
  Unshelve.
  all: exact ATCDLang.
  Qed.

  (*
  Lemma compile_lift2_comm:
  forall u T (p: LoggedDiskLang.(prog) T) o s ret,
  LayerImplementation.exec' u o s
  (RefinementLift.compile
      (HorizontalComposition AuthenticationOperation
        TransactionCacheOperation)
      (HorizontalComposition AuthenticationOperation
        (TransactionalDiskLayer.TDCore
            FSParameters.data_length)) ATCLang AD
      (HC_Core_Refinement ATCLang AD
        TDCoreRefinement) T
      (lift_L2 AuthenticationOperation p)) ret ->

      LayerImplementation.exec' u o s
      (lift_L2 AuthenticationOperation
        (TDRefinement.(Simulation.Definitions.compile) p)) ret.
  Proof.
    induction p; simpl; intros; eauto.
    invert_exec'' H0.
    eapply IHp in H7.
    eapply H in H10.
    econstructor; eauto.
    eapply IHp in H6.
    eapply ExecBindCrash; eauto.
  Qed.

  Lemma compile_lift2_comm_rev:
  forall u T (p: TD.(prog) T) o s ret,
  LayerImplementation.exec' u o s
      (lift_L2 AuthenticationOperation
        (TDRefinement.(Simulation.Definitions.compile) p)) ret ->

  LayerImplementation.exec' u o s
  (RefinementLift.compile
      (HorizontalComposition AuthenticationOperation
        TransactionCacheOperation)
      (HorizontalComposition AuthenticationOperation
        (TransactionalDiskLayer.TDCore
            FSParameters.data_length)) ATCLang AD
      (HC_Core_Refinement ATCLang AD
        TDCoreRefinement) T
      (lift_L2 AuthenticationOperation p)) ret.
  Proof.
    induction p; simpl; intros; eauto.
    invert_exec'' H0.
    eapply IHp in H7.
    eapply H in H10.
    econstructor; eauto.
    eapply IHp in H6.
    eapply ExecBindCrash; eauto.
  Qed.
*)

Fixpoint non_colliding_selector_rec {T}
u (R: state ATCDLang -> T -> Prop) l_selector (rec: prog ATCDLang unit) l_o s1 :=
  match l_selector with
  | nil => True
  | selector :: ls =>
    match l_o with
    | nil => True
    | o::lo =>
    forall s1',
    (exists s2, R s1 s2) ->
    exec ATCDLang u o s1 rec (Crashed s1') ->
    non_colliding_selector selector (snd (snd (snd s1'))) /\
    non_colliding_selector_rec u R ls rec lo
    (ATCD_reboot_f selector s1')
    end
  end.

Definition non_colliding_selector_list {T T'}
u (R: state ATCDLang -> T -> Prop)
(Rc: state ATCDLang -> T -> Prop)
l_selector
(p: prog ATCDLang T')
(rec: prog ATCDLang unit) l_o s1 :=
match l_selector with
  | nil => True
  | selector :: ls =>
    match l_o with
    | nil => True
    | o::lo =>
    forall s1',
    (exists s2, R s1 s2) ->
    exec ATCDLang u o s1 p (Crashed s1') ->
    non_colliding_selector selector (snd (snd (snd s1'))) /\
    non_colliding_selector_rec u Rc ls rec lo
    (ATCD_reboot_f selector s1')
    end
  end.

Lemma ATCD_AOE':
forall u T (p: ATCLang.(prog) T) l_grs l_o s1 s2,

(forall o s s' r,
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s
(ATCD_Refinement.(Simulation.Definitions.compile) p) (Finished s' r) ->
exists oa, forall grs,
oracle_refines _ _
  ATCDLang ATCLang
  ATCD_CoreRefinement T u s p grs o oa) ->

(forall o s s',
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s (ATCD_Refinement.(Simulation.Definitions.compile) p) (Crashed s') ->
non_colliding_selector
  (seln l_grs 0 (fun _ : addr => 0))
  (snd (snd (snd s'))) ->
exists oa,
oracle_refines _ _
  ATCDLang ATCLang
  ATCD_CoreRefinement T u s p
  (ATCD_reboot_f (seln l_grs 0 (fun _ => 0))) o oa) ->

(forall o s s',
(exists s1, ATCD_Refinement.(Simulation.Definitions.refines) s s1) ->
exec ATCDLang u o s
(ATCD_Refinement.(Simulation.Definitions.compile) p) (Crashed s') ->
non_colliding_selector
  (seln l_grs 0 (fun _ : addr => 0))
  (snd (snd (snd s'))) ->
exists s1',
ATCD_refines_reboot (seln l_grs 0 (fun _ => 0)) s' s1') ->

non_colliding_selector_list
u (ATCD_Refinement.(Simulation.Definitions.refines))
(ATCD_Refinement.(Simulation.Definitions.refines_reboot)) l_grs
(ATCD_Refinement.(Simulation.Definitions.compile) p)
(ATCD_Refinement.(Simulation.Definitions.compile)
 (ATC_Refinement.(Simulation.Definitions.compile) File.recover))
  l_o s1 ->

abstract_oracles_exist_wrt_explicit ATCD_Refinement
  (ATCD_Refinement.(Simulation.Definitions.refines)) u p
  (ATC_Refinement.(Simulation.Definitions.compile) File.recover)
  (ATCD_reboot_list l_grs) l_o s1 s2.
Proof.
    intros; destruct l_grs; simpl; eauto.
    {
      unfold abstract_oracles_exist_wrt_explicit, ATCD_reboot_list in *;
      simpl in *; intros.
      repeat invert_exec.
      simpl.
      edestruct H; eauto.

      eexists [_]; simpl; eauto.
      split; intuition eauto.
      left; do 2 eexists; intuition eauto.
    }
    {
      unfold abstract_oracles_exist_wrt_explicit, ATC_reboot_list in *;
      simpl in *; intros.
      repeat invert_exec.
      cleanup.
      edestruct H2; eauto.
      edestruct ATCD_AOE_recover; eauto.
      {
        unfold HC_refines in *;
        simpl in *; cleanup.
        edestruct H1; eauto.
      }

      edestruct H0; eauto.

      eexists (_ :: _).
      simpl.
      intuition eauto.
      eapply recovery_oracles_refine_length in H6; eauto.
      }
Qed.

Lemma ATCD_AOE:
forall T (p: ATCLang.(prog) T) l_selector u l_o s1 s2,
not_init p ->
non_colliding_selector_list
u (ATCD_Refinement.(Simulation.Definitions.refines))
(ATCD_Refinement.(Simulation.Definitions.refines_reboot)) l_selector
(ATCD_Refinement.(Simulation.Definitions.compile) p)
(ATCD_Refinement.(Simulation.Definitions.compile)
 (ATC_Refinement.(Simulation.Definitions.compile) File.recover))
  l_o s1 ->
abstract_oracles_exist_wrt_explicit ATCD_Refinement
(Simulation.Definitions.refines ATCD_Refinement) u p
(Simulation.Definitions.compile ATC_Refinement File.recover)
(ATCD_reboot_list l_selector) l_o s1 s2.
Proof.
intros; eapply ATCD_AOE'.
{
  intros.
  eapply ATCD_oracle_refines_finished; eauto.
}
{
  intros.
  eapply ATCD_oracle_refines_crashed; eauto.
}
{
  intros; edestruct ATCD_simulation_crash; eauto.
}
eauto.
Qed.


Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Import MonadNotation.
Local Open Scope monad_scope.

Section except.
  Variable T : Type.

  Global Instance Monad_either : Monad (sum T) :=
  { ret  := fun _ v => inr v
  ; bind := fun _ _ c1 c2 => match c1 with
                               | inl v => inl v
                               | inr v => c2 v
                             end
  }.

  Global Instance Exception_either : MonadExc T (sum T) :=
  { raise := fun _ v => inl v
  ; catch := fun _ c h => match c with
                            | inl v => h v
                            | x => x
                          end
  }.

  Variable m : Type -> Type.

  Inductive eitherT A := mkEitherT { unEitherT : m (sum T A) }.

  Variable M : Monad m.

  Global Instance Monad_eitherT : Monad eitherT :=
  { ret := fun _ x => mkEitherT (ret (inr x))
  ; bind := fun _ _ c f => mkEitherT (
      xM <- unEitherT c ;;
      match xM with
      | inl x => ret (inl x)
      | inr x => unEitherT (f x)
      end
    )
  }.

  Global Instance Exception_eitherT : MonadExc T eitherT :=
  { raise := fun _ v => mkEitherT (ret (inl v))
  ; catch := fun _ c h => mkEitherT (
      xM <- unEitherT c ;;
      match xM with
        | inl x => unEitherT (h x)
        | inr x => ret (inr x)
      end
    )
  }.

  Global Instance MonadPlus_eitherT : MonadPlus eitherT :=
  { mplus _A _B mA mB := mkEitherT (
      x <- unEitherT mA ;;
      match x with
      | inl _ =>
          y <- unEitherT mB ;;
          match y with
          | inl t => ret (inl t)
          | inr b => ret (inr (inr b))
          end
      | inr a => ret (inr (inl a))
      end
    )
  }.

  Global Instance MonadT_eitherT : MonadT eitherT m :=
  { lift := fun _ c => mkEitherT (liftM ret c) }.

  Global Instance MonadState_eitherT {T} (MS : MonadState T m) : MonadState T eitherT :=
  { get := lift get
  ; put := fun v => lift (put v)
  }.

  Global Instance MonadReader_eitherT {T} (MR : MonadReader T m) : MonadReader T eitherT :=
  { ask := lift ask
  ; local := fun _ f cmd => mkEitherT (local f (unEitherT cmd))
  }.

  Global Instance MonadWriter_eitherT {T} (Mon : Monoid T) (MW : MonadWriter Mon m) : MonadWriter Mon eitherT :=
  { tell := fun x => lift (tell x)
  ; listen := fun _ c => mkEitherT (
    x <- listen (unEitherT c) ;;
    match x with
      | (inl l, _) => ret (inl l)
      | (inr a, t) => ret (inr (a, t))
    end)
  ; pass := fun _ c => mkEitherT (
    x <- unEitherT c ;;
    match x with
      | inl s => ret (inl s)
      | inr (a,f) => pass (ret (inr a, f))
    end)
  }.

  Global Instance MonadFix_eitherT (MF : MonadFix m) : MonadFix eitherT :=
  { mfix := fun _ _ r v =>
    mkEitherT (mfix (fun f x => unEitherT (r (fun x => mkEitherT (f x)) x)) v)
  }.

End except.

Arguments mkEitherT {T} {m} {A} (_).
Arguments unEitherT {T} {m} {A} (_).


Require Import Bedrock.Platform.AutoSep.

Set Implicit Arguments.

Section TopLevel.

  Variable vars : list string.

  Variable var : option string.

  Definition is_state sp vs : HProp :=
    locals vars vs 0 (sp ^+ $8).

  Definition new_pre : assert :=
    x ~> ExX, Ex vs,
    ![^[is_state x#Sp vs] * #0]x.

  Require Import Bedrock.Platform.Cito.Semantics.

  Definition runs_to x_pre x :=
    forall specs other vs,
      interp specs (![is_state x_pre#Sp vs * other ] x_pre) ->
      Regs x Sp = x_pre#Sp /\
      interp specs (![is_state (Regs x Sp) (upd_option vs var x_pre#Rv) * other ] (fst x_pre, x)).

  Definition post (pre : assert) :=
    st ~> Ex st_pre,
    pre (fst st, st_pre) /\
    [| runs_to (fst st, st_pre) (snd st) |].

  Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

  Definition syn_req :=
    match var with
      | Some x => List.In x vars
      | None => True
    end.

  Definition verifCond pre := imply pre new_pre :: syn_req :: nil.

  Variable imports : LabelMap.t assert.

  Variable imports_global : importsGlobal imports.

  Variable modName : string.

  Definition Strline := Straightline_ imports modName.

  Definition SaveRv lv := Strline (IL.Assign lv (RvLval (LvReg Rv)) :: nil).

  Definition vars_start := 4 * 2.
  Definition var_slot x := LvMem (Sp + (vars_start + variablePosition vars x)%nat)%loc.

  Definition Skip := Straightline_ imports modName nil.

  Definition body :=
    match var with
      | None => Skip
      | Some x => SaveRv (var_slot x)
    end.

  Require Import Bedrock.Platform.Wrap.

  Opaque mult.
  Opaque evalInstrs.

  Lemma evalInstrs_write_var : forall sm x s,
    evalInstrs sm x (Assign (var_slot s) Rv :: nil)
    = evalInstrs sm x (Assign (LvMem (Imm ((Regs x Sp ^+ natToW vars_start) ^+ natToW (variablePosition vars s)))) Rv :: nil).
    Transparent evalInstrs.
    simpl.
    intros.
    replace (Regs x Sp ^+ natToW (vars_start + variablePosition vars s))
      with (Regs x Sp ^+ natToW vars_start ^+ natToW (variablePosition vars s)); auto.
    rewrite natToW_plus.
    words.
    Opaque evalInstrs.
  Qed.

  Lemma postOk : forall specs pre x,
    interp specs (Postcondition (body pre) x)
    -> imply pre new_pre
    -> syn_req
    -> exists x0, interp specs (pre (fst x, x0))
      /\ runs_to (fst x, x0) (snd x).
    intros.
    unfold syn_req, body, runs_to in *.
    destruct var; simpl in *; post.

    Focus 2.
    Transparent evalInstrs.
    simpl in H2.
    Opaque evalInstrs.
    injection H2; clear H2; intros; subst.
    descend; eauto.

    Opaque mult.

    Opaque mult.
    Opaque evalInstrs.

    rewrite evalInstrs_write_var in *.
    generalize H2; intro Hs.
    apply H0 in Hs; clear H0; post.
    clear_fancy.
    unfold vars_start in H3.
    change (4 * 2) with 8 in *.
    descend.
    eauto.
    clear H.
    unfold is_state in H0.
    evaluate auto_ext.
    destruct x; simpl in *.
    intuition.
    unfold is_state.
    step auto_ext.
  Qed.
  Opaque evalInstrs.

  Lemma verifCondOk : forall pre,
    imply pre new_pre
    -> syn_req
    -> vcs (VerifCond (body pre)).
    unfold syn_req, body; intros.
    destruct var; wrap0.
    rewrite evalInstrs_write_var in *.
    apply H in H1; clear H; post.
    unfold is_state in H.
    unfold vars_start in *.
    change (4 * 2) with 8 in *.
    clear_fancy.
    evaluate auto_ext.
    Transparent evalInstrs.
    discriminate.
    Opaque evalInstrs.
  Qed.

  Definition compile : cmd imports modName.
    refine (Wrap imports imports_global modName body post verifCond _ _).

    Opaque mult.
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0;
      match goal with
        | [ H : interp _ _ |- _ ] =>
          apply postOk in H; post; descend; eauto
      end).

    Opaque mult.
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0; eauto using verifCondOk).
 Defined.

End TopLevel.


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

Set Implicit Arguments.

Require Import TLC.LibLN.
Require Import String.

Require Import Coq.Program.Equality.

Require Import Definitions RecordAndInertTypes Decompose ConstrLangAlt.

(** * Constraint Interpretation *)

(** ** Ground assignments *)

Definition tctx := env typ.
Definition vctx := env var.

Reserved Notation "e '⊧' C" (at level 40).
Reserved Notation "es '⊢t' T1 '⪯' T2" (at level 40, T1 at level 59, T2 at level 59).
Reserved Notation "es '⊢d' d1 '⪯' d2" (at level 40, d1 at level 59, d2 at level 59).
Reserved Notation "es '⊢v' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vv' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vd' x '⪯' y" (at level 40, x at level 59, y at level 59).
Reserved Notation "es '⊢vds' x '⪯' y" (at level 40, x at level 59, y at level 59).

(** *** Mapping with ground assignments *)

(** Map a constraint variable to concrete variable. *)
Inductive map_cvar : vctx -> cvar -> avar -> Prop :=
| map_cvar_f : forall vm x y,
    binds x y vm ->
    map_cvar vm (cvar_f x) (avar_f y)
| map_cvar_x : forall vm x,
    map_cvar vm (cvar_x x) x
.

(** Map a type containing type variables to a concrete type. *)
Inductive map_ctyp : (tctx * vctx) -> ctyp -> typ -> Prop :=

| map_ctyp_top : forall tm vm,
    (tm, vm) ⊢t ctyp_top ⪯ typ_top

| map_ctyp_bot : forall tm vm,
    (tm, vm) ⊢t ctyp_bot ⪯ typ_bot

| map_ctyp_tvar : forall tm vm x T,
    binds x T tm ->
    (tm, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T

| map_ctyp_rcd : forall tm vm D D',
    (tm, vm) ⊢d D ⪯ D' ->
    (tm, vm) ⊢t ctyp_rcd D ⪯ typ_rcd D'

| map_ctyp_and : forall tm vm T T' U U',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t U ⪯ U' ->
    (tm, vm) ⊢t ctyp_and T U ⪯ typ_and T' U'

| map_ctyp_sel : forall tm vm x y T,
    map_cvar vm x y ->
    (tm, vm) ⊢t ctyp_sel x T ⪯ typ_sel y T

| map_ctyp_bnd : forall tm vm T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t ctyp_bnd T ⪯ typ_bnd T'

| map_ctyp_all : forall tm vm T T' U U',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢t U ⪯ U' ->
    (tm, vm) ⊢t ctyp_all T U ⪯ typ_all T' U'

where "es '⊢t' T1 '⪯' T2" := (map_ctyp es T1 T2)
with map_cdec : (tctx * vctx) -> cdec -> dec -> Prop :=
| map_cdec_typ : forall tm vm A S S' T T',
    (tm, vm) ⊢t S ⪯ S' ->
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢d cdec_typ A S T ⪯ dec_typ A S' T'
| map_cdec_trm : forall tm vm a T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢d cdec_trm a T ⪯ dec_trm a T'
where "es '⊢d' D1 '⪯' D2" := (map_cdec es D1 D2).

Inductive map_ctrm : (tctx * vctx) -> ctrm -> trm -> Prop :=
| map_ctrm_cvar : forall tm vm x y,
    map_cvar vm x y ->
    (tm, vm) ⊢v ctrm_cvar x ⪯ trm_var y
| map_ctrm_val : forall tm vm v v',
    map_cval (tm, vm) v v' ->
    (tm, vm) ⊢v ctrm_val v ⪯ trm_val v'
where "es '⊢v' t1 '⪯' t2" := (map_ctrm es t1 t2)
with map_cval : (tctx * vctx) -> cval -> val -> Prop :=
| map_cval_new : forall tm vm T T' ds ds',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢vds ds ⪯ ds' ->
    (tm, vm) ⊢vv cval_new T ds ⪯ val_new T' ds'
| map_cval_lambda : forall tm vm T T' t t',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢vv cval_lambda T t ⪯ val_lambda T' t'
where "es '⊢vv' t1 '⪯' t2" := (map_cval es t1 t2)
with map_cdef : (tctx * vctx) -> cdef -> def -> Prop :=
| map_cdef_typ : forall tm vm A T T',
    (tm, vm) ⊢t T ⪯ T' ->
    (tm, vm) ⊢vd cdef_typ A T ⪯ def_typ A T'
| map_cdef_trm : forall tm vm a t t',
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢vd cdef_trm a t ⪯ def_trm a t'
where "es '⊢vd' t1 '⪯' t2" := (map_cdef es t1 t2)
with map_cdefs : (tctx * vctx) -> cdefs -> defs -> Prop :=
| map_cdefs_nil : forall tm vm,
    (tm, vm) ⊢vds cdefs_nil ⪯ defs_nil
| map_cdefs_cons : forall tm vm ds ds' d d',
    (tm, vm) ⊢vds ds ⪯ ds' ->
    (tm, vm) ⊢vd d ⪯ d' ->
    (tm, vm) ⊢vds cdefs_cons ds d ⪯ defs_cons ds' d'
where "es '⊢vds' t1 '⪯' t2" := (map_cdefs es t1 t2).

Scheme map_ctyp_mut    := Induction for map_ctyp Sort Prop
with   map_cdec_mut    := Induction for map_cdec Sort Prop.
Combined Scheme map_ctyp_mutind from map_ctyp_mut, map_cdec_mut.

Scheme map_ctrm_mut     := Induction for map_ctrm Sort Prop
with   map_cval_mut     := Induction for map_cval Sort Prop
with   map_cdef_mut     := Induction for map_cdef Sort Prop
with   map_cdefs_mut    := Induction for map_cdefs Sort Prop.
Combined Scheme map_ctrm_mutind from map_ctrm_mut, map_cval_mut, map_cdef_mut, map_cdefs_mut.

(** *** Properties of mapping *)

Lemma map_ctyp_unique_typ : forall tm vm T T1 T2,
    (tm, vm) ⊢t T ⪯ T1 ->
    (tm, vm) ⊢t T ⪯ T2 ->
    T1 = T2
with map_cdec_unique_dec : forall tm vm D D1 D2,
    (tm, vm) ⊢d D ⪯ D1 ->
    (tm, vm) ⊢d D ⪯ D2 ->
    D1 = D2.
Proof.
  all: introv Hm1 Hm2.
  - dependent induction T; inversion Hm1; inversion Hm2; subst; trivial; try f_equal.
    -- inversion H7; subst. eapply binds_functional; eassumption.
    -- apply~ map_cdec_unique_dec; eassumption.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- destruct c.
       + inversion H4; inversion H10; subst.
         lets Heqy: (binds_functional H1 H6). subst. f_equal.
       + inversion H4; inversion H10; subst.
       + inversion H4; inversion H10; subst. trivial.
    -- apply~ IHT.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
    -- specialize (IHT1 _ _ H4 H11). specialize (IHT2 _ _ H5 H12). subst. trivial.
  - dependent induction D; inversion Hm1; inversion Hm2; subst; f_equal.
    -- eapply map_ctyp_unique_typ; eassumption.
    -- eapply map_ctyp_unique_typ; eassumption.
    -- eapply map_ctyp_unique_typ; eassumption.
Qed.

Lemma map_tvar_tail : forall tm vm x T,
    (tm & x ~ T, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T.
Proof.
  introv. constructor. apply binds_push_eq.
Qed.

Lemma map_tvar_tail_eq : forall tm vm x T T',
    (tm & x ~ T, vm) ⊢t ctyp_tvar (tvar_f x) ⪯ T' ->
    T = T'.
Proof.
  introv Hmx. inversion Hmx; subst.
  symmetry. eapply binds_push_eq_inv. eauto.
Qed.

Lemma strengthen_map_ctyp : forall tm vm x T S S',
    (tm & x ~ T, vm) ⊢t S ⪯ S' ->
    x \notin ftv_ctyp S ->
    (tm, vm) ⊢t S ⪯ S'
with strengthen_map_cdec : forall tm vm x T D D',
    (tm & x ~ T, vm) ⊢d D ⪯ D' ->
    x \notin ftv_cdec D ->
    (tm, vm) ⊢d D ⪯ D'.
Proof.
  all: introv Hmx Hn.
  - induction S;
      try (inversion Hmx; subst; constructor*);
      try (apply* strengthen_map_ctyp; simpl in Hn; auto).
    -- apply binds_concat_left_inv with (E2 := x ~ T); auto.
       unfold notin. introv Hin. rewrite dom_single in Hin.
       rewrite in_singleton in Hin. subst x0. simpl in Hn.
       apply Hn. rewrite -> in_singleton. trivial.
   - induction D; inversion Hmx; subst;
       simpl in Hn; constructor; apply* strengthen_map_ctyp.
Qed.

Lemma map_iso_ctyp : forall tm vm T T',
    T ⩭ T' ->
    (tm, vm) ⊢t T ⪯ T'
with map_iso_cdec : forall tm vm D D',
    iso_cdec_dec D D' ->
    (tm, vm) ⊢d D ⪯ D'.
Proof.
  all: introv Hc.
  - dependent induction Hc; try constructor; try apply IHHc1; try apply IHHc2;
      try apply IHHc.
    -- apply* map_iso_cdec.
    -- constructor.
  - dependent induction Hc; try constructor; try apply IHHc;
      try apply* map_iso_ctyp.
Qed.

Lemma map_iso_ctyp_eq : forall tm vm T T1 T2,
    T ⩭ T1 ->
    (tm, vm) ⊢t T ⪯ T2 ->
    T1 = T2
with map_iso_cdec_eq : forall tm vm D D1 D2,
    iso_cdec_dec D D1 ->
    (tm, vm) ⊢d D ⪯ D2 ->
    D1 = D2.
Proof.
  all: introv Hc Hm.
  - gen T2. dependent induction Hc; introv Hm.
    -- inversion Hm; subst. reflexivity.
    -- inversion Hm; subst. reflexivity.
    -- inversion Hm; subst. f_equal. apply* map_iso_cdec_eq.
    -- inversion Hm; subst. f_equal; try apply* IHHc1. apply* IHHc2.
    -- inversion Hm; subst. f_equal. inversion H4; subst. reflexivity.
    -- inversion Hm; subst. f_equal. apply* IHHc.
    -- inversion Hm; subst. f_equal. apply* IHHc1. apply* IHHc2.
  - gen D2. dependent induction Hc; introv Hm.
    -- inversion Hm; subst. f_equal; apply* map_iso_ctyp_eq.
    -- inversion Hm; subst. f_equal. apply* map_iso_ctyp_eq.
Qed.

Inductive satisfy_constr : (tctx * vctx * ctx) -> constr -> Prop :=

| sat_true : forall tm vm G,
    (tm, vm, G) ⊧ ⊤

| sat_and : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C1 ->
    (tm, vm, G) ⊧ C2 ->
    (tm, vm, G) ⊧ C1 ⋏ C2

| sat_or1 : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C1 ->
    (tm, vm, G) ⊧ C1 ⋎ C2

| sat_or2 : forall tm vm G C1 C2,
    (tm, vm, G) ⊧ C2 ->
    (tm, vm, G) ⊧ C1 ⋎ C2

| sat_exists_typ : forall L tm vm G T C,
    (forall x, x \notin L -> (tm & x ~ T, vm, G) ⊧ C ^^t x) ->
    (tm, vm, G) ⊧ (∃t C)

| sat_exists_var : forall L tm vm G u C,
    (forall x, x \notin L -> (tm, vm & x ~ u, G) ⊧ C ^^v x) ->
    (tm, vm, G) ⊧ (∃v C)

| sat_typ : forall tm vm G t t' T T',
    (tm, vm) ⊢v t ⪯ t' ->
    (tm, vm) ⊢t T ⪯ T' ->
    G ⊢ t' : T' ->
    (tm, vm, G) ⊧ t ⦂ T

| sat_sub : forall tm vm G S S' T T',
    (tm, vm) ⊢t S ⪯ S' ->
    (tm, vm) ⊢t T ⪯ T' ->
    G ⊢ S' <: T' ->
    (tm, vm, G) ⊧ S <⦂ T

where "e '⊧' C" := (satisfy_constr e C).

Hint Constructors satisfy_constr constr.

Definition constr_satisfiable (C : constr) (G : ctx) :=
  exists tm vm, (tm, vm, G) ⊧ C.

Notation "G '⊨' C" := (constr_satisfiable C G) (at level 40).


Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import Coq.Lists.List. Import ListNotations.
Require Import sha.general_lemmas.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.tweetNaclBase.
Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.

Lemma data_at_ext sh t v v' p: v=v' -> data_at sh t v p |-- data_at sh t v' p.
Proof. intros; subst. auto. Qed.

(*
Definition EightWord (q:QuadWord * QuadWord) (v:val) : mpred :=
  match q with ((q0, q1, q2, q3),(q4, q5, q6, q7)) =>
    data_at Tsh (Tarray tuchar 4 noattr) (map Vint [q0; q1; q2; q3; q4; q5; q6; q7]) v
  end.*)
Definition QuadByte2ByteList (B:QuadByte) : list byte :=
  match B with (b0, b1, b2, b3) => [b0; b1; b2; b3]
  end.

Definition QuadByte2ValList (B:QuadByte) : list val :=
   map Vint (map Int.repr (map Byte.unsigned (QuadByte2ByteList B))).

Lemma QuadByteValList_length q: length (QuadByte2ValList q) = 4%nat.
  destruct q as [[[? ?] ?] ?]. reflexivity. Qed.

Definition EightByte (q:QuadByte * QuadByte) (v:val) : mpred :=
  match q with (q1, q2) =>
    data_at Tsh (Tarray tuchar 8 noattr) ((QuadByte2ValList q1) ++ (QuadByte2ValList q2)) v
  end.

Definition SixteenByte2ByteList (B:SixteenByte) : list byte :=
  match B with (q0, q1, q2, q3) =>
   QuadByte2ByteList q0 ++ QuadByte2ByteList q1 ++ QuadByte2ByteList q2 ++ QuadByte2ByteList q3
  end.

Definition SixteenByte2ValList (B:SixteenByte) : list val :=
   map Vint (map Int.repr (map Byte.unsigned (SixteenByte2ByteList B))).

Lemma SixteenByte2ValList_char B: SixteenByte2ValList B =
  match B with (q0, q1, q2, q3) =>
   QuadByte2ValList q0 ++ QuadByte2ValList q1 ++ QuadByte2ValList q2 ++ QuadByte2ValList q3
  end.
Proof. unfold SixteenByte2ValList, QuadByte2ValList .
 destruct B as [[[? ?] ?] ?]. simpl. repeat rewrite map_app. trivial.
Qed.

Definition ThirtyTwoByte (q:SixteenByte * SixteenByte) (v:val) : mpred :=
  match q with (q1, q2) =>
    @data_at CompSpecs Tsh (Tarray tuchar 32 noattr) ((SixteenByte2ValList q1) ++ (SixteenByte2ValList q2)) v
  end.

Definition QByte (q:QuadByte) (v:val) : mpred :=
  data_at Tsh (Tarray tuchar 4 noattr) (QuadByte2ValList q) v.

Definition QuadChunks2ValList (l: list QuadByte) : list val :=
  List.fold_right (fun q vals => QuadByte2ValList q ++ vals) nil l.

Definition flatten16 (B:SixteenByte) : list QuadByte :=
  match B with (q0, q1, q2, q3) => [q0; q1; q2; q3] end.
Lemma SixteenByte2ValList_flatten B:
  QuadChunks2ValList (flatten16 B) = SixteenByte2ValList B.
  destruct B as (((q0, q1), q2), q3). simpl.
  rewrite SixteenByte2ValList_char, app_nil_r. trivial.
Qed.

Lemma QuadByteByteList_ZLength q: 4 = Zlength (QuadByte2ByteList q).
  destruct q as (((q0, q1), q2), q3). simpl. reflexivity. Qed.
Lemma QuadByteValList_ZLength q: 4 = Zlength (QuadByte2ValList q).
  destruct q as (((q0, q1), q2), q3). simpl. reflexivity. Qed.

Lemma SixteenByte2ValList_Zlength C: 16 = Zlength (SixteenByte2ValList C).
  destruct C as (((q0, q1), q2), q3). unfold SixteenByte2ValList.
  repeat rewrite Zlength_map.  simpl.
  repeat rewrite Zlength_app. repeat rewrite <- QuadByteByteList_ZLength.
  reflexivity. Qed.

Definition SByte (q:SixteenByte) (v:val) : mpred :=
  @data_at CompSpecs Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList q) v.

Lemma ThirtyTwoByte_split16 q v:
  field_compatible (Tarray tuchar 32 noattr) [] v ->
  ThirtyTwoByte q v =
  (SByte (fst q) v * SByte (snd q) (offset_val 16 v))%logic.
Proof. destruct q as [s1 s2]. simpl; intros. unfold SByte.
  rewrite split2_data_at_Tarray_tuchar with (n1:= Zlength (SixteenByte2ValList s1));
     try rewrite Zlength_app; repeat rewrite <- SixteenByte2ValList_Zlength; try omega.
  unfold offset_val. red in H. destruct v; intuition.
  rewrite field_address0_offset. simpl.
  rewrite sublist_app1; try rewrite <- SixteenByte2ValList_Zlength; try omega.
  rewrite sublist_app2; try rewrite <- SixteenByte2ValList_Zlength; try omega.
  rewrite sublist_same; try rewrite <- SixteenByte2ValList_Zlength; trivial.
  rewrite sublist_same; try rewrite <- SixteenByte2ValList_Zlength; trivial.
  red; intuition.
Qed.

Lemma QuadByte2ValList_firstn4 q l:
         firstn 4 (QuadByte2ValList q ++ l) = QuadByte2ValList q.
   Proof. destruct q as (((b0, b1), b2), b3); trivial. Qed.

Lemma QuadByte2ValList_skipn4 q l:
         skipn 4 (QuadByte2ValList q ++ l) = l.
   Proof. destruct q as (((b0, b1), b2), b3); trivial. Qed.

Definition Select16Q (Q:SixteenByte) i :QuadByte :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then b0 else
    if zeq i 1 then b1 else
    if zeq i 2 then b2 else b3
  end.
Definition UnSelect16Q (Q:SixteenByte) i : list QuadByte :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then [b1;b2;b3] else
    if zeq i 1 then [b0;b2;b3] else
    if zeq i 2 then [b0;b1;b3] else [b0;b1;b2]
  end.
Definition SplitSelect16Q (Q:SixteenByte) i : (list QuadByte * list QuadByte) :=
  match Q with (((b0, b1), b2), b3) =>
    if zeq i 0 then ([], [b1;b2;b3]) else
    if zeq i 1 then ([b0], [b2;b3]) else
    if zeq i 2 then ([b0;b1], [b3]) else ([b0;b1;b2], [])
  end.
Lemma Select_SplitSelect16Q Q i front back:
    (front, back) = SplitSelect16Q Q i ->
    SixteenByte2ValList Q =
    QuadChunks2ValList front ++ QuadChunks2ValList [Select16Q Q i] ++ QuadChunks2ValList back.
Proof.
  unfold Select16Q, SplitSelect16Q; intros.
  destruct Q as (((q0, q1), q2), q3). simpl.
  destruct (zeq i 0); simpl. inv H; simpl. repeat rewrite app_nil_r. apply SixteenByte2ValList_char.
  destruct (zeq i 1); simpl. inv H; simpl. repeat rewrite app_nil_r. apply SixteenByte2ValList_char.
  destruct (zeq i 2); simpl. inv H; simpl. repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
  destruct (zeq i 3); simpl; inv H; simpl. repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
  repeat rewrite app_nil_r. repeat rewrite <- app_assoc. apply SixteenByte2ValList_char.
Qed.

Lemma QuadChunk2ValList_ZLength: forall l, Zlength (QuadChunks2ValList l) = (4 * Zlength l)%Z.
Proof.
  unfold QuadChunks2ValList. induction l; simpl. reflexivity.
  rewrite Zlength_app, IHl, <- QuadByteValList_ZLength.
  rewrite Zlength_cons; omega.
Qed.

Lemma Select_SplitSelect16Q_Zlength Q i front back:
    (front, back) = SplitSelect16Q Q i -> 0<= i < 4 ->
    Zlength front = i /\ Zlength back = 3-i.
Proof.
  unfold SplitSelect16Q; intros.
  destruct Q as (((q0, q1), q2), q3).
  destruct (zeq i 0). inv H. split; reflexivity.
  destruct (zeq i 1). inv H. split; reflexivity.
  destruct (zeq i 2). inv H. split; reflexivity.
  destruct (zeq i 3). inv H. split; reflexivity. omega.
Qed.

Definition QBytes (l:list QuadByte) (v:val) : mpred :=
  data_at Tsh (Tarray tuchar (4*Zlength l) noattr) (QuadChunks2ValList l) v.

Lemma QBytes16 s: SByte s = QBytes (flatten16 s).
Proof.
  destruct s as (((q0, q1), q2), q3). simpl.
  unfold SByte, QBytes. extensionality v. simpl. rewrite app_nil_r.
  rewrite SixteenByte2ValList_char. trivial.
Qed.

Definition QuadWordRep (q:QuadWord):list val :=
  match q with (q0, q1, q2, q3) => map Vint [q0;q1;q2;q3] end.
Definition SixteenWordRep (w:SixteenWord):list val :=
  match w with (q0, q1, q2, q3) => QuadWordRep q0 ++ QuadWordRep q1 ++ QuadWordRep q2 ++ QuadWordRep q3 end.

Definition littleendian_of_SixteenByte (x:SixteenByte): QuadWord :=
  match x with (q0, q1, q2, q3) => (littleendian q0, littleendian q1, littleendian q2, littleendian q3) end.

     Lemma QuadWR_length q: length (QuadWordRep q) = 4%nat.
        destruct q as [[[? ?] ?] ?]. simpl. reflexivity. Qed.
     Lemma QuadWR_zlength q: Zlength (QuadWordRep q) = 4.
        rewrite Zlength_correct, QuadWR_length. trivial. Qed.
     Lemma SixteenWR_length s: length (SixteenWordRep s) = 16%nat.
        destruct s as [[[? ?] ?] ?]. simpl.
        repeat rewrite app_length. repeat rewrite  QuadWR_length. reflexivity. Qed.
     Lemma SixteenWR_zlength s: Zlength (SixteenWordRep s) = 16.
        rewrite Zlength_correct, SixteenWR_length. trivial. Qed.

Lemma QuadWR_int q i: (0<=i<4)%nat -> exists ii, nth i (QuadWordRep q) Vundef = Vint ii.
  intros. destruct q as [[[? ?] ?] ?]. simpl.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity. omega. Qed.

Lemma SixteenWR_int s i: (0<=i<16)%nat -> exists ii, nth i (SixteenWordRep s) Vundef = Vint ii.
  intros. destruct s as [[[? ?] ?] ?]. simpl.
  destruct q as [[[? ?] ?] ?]. destruct q0 as [[[? ?] ?] ?].
  destruct q1 as [[[? ?] ?] ?]. destruct q2 as [[[? ?] ?] ?]. simpl.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity.
  destruct i. eexists; reflexivity. omega.
Qed.

Lemma SixteenWR_Znth_int i s: (0 <= i < 16) ->
       exists ii : int, Znth i (SixteenWordRep s) = Vint ii.
Proof. intros. unfold Znth. if_tac; try omega.
   apply SixteenWR_int. destruct H. apply Z2Nat.inj_lt in H1; simpl in *; omega.
Qed.

Lemma QuadWR_Z_int: forall (q : QuadWord) (i : Z),
               0 <= i < 4 -> exists ii : int, Znth i (QuadWordRep q) = Vint ii.
Proof. intros. unfold Znth. if_tac. omega.
       apply QuadWR_int. destruct H.
       split.
         apply Z2Nat.inj_le in H. apply H. omega. omega.
         apply Z2Nat.inj_lt in H1. apply H1. omega. omega.
Qed.

Lemma SixteenWordRep_MapVint ss: exists l, SixteenWordRep ss = map Vint l.
Proof.
destruct ss as [[[s0 s1] s2] s3].
destruct s0 as [[[x0 x1] x2] x3].
destruct s1 as [[[x4 x5] x6] x7].
destruct s2 as [[[x8 x9] x10] x11].
destruct s3 as [[[x12 x13] x14] x15]. simpl.
exists [x0; x1; x2; x3; x4; x5; x6; x7;
    x8; x9; x10; x11; x12; x13; x14; x15].
reflexivity.
Qed.

Definition QuadWordRepI (q : QuadWord) :=
  match q with (q0, q1, q2, q3) => [q0; q1; q2; q3] end.
Lemma QuadWordRepI_QuadWordRep q: QuadWordRep q = map Vint  (QuadWordRepI q).
Proof. destruct q as [[[q0 q1] q2] q3]. reflexivity. Qed.

Definition SixteenWordRepI (w : SixteenWord) :=
  match w with (q0, q1, q2, q3) =>
    QuadWordRepI q0 ++ QuadWordRepI q1 ++ QuadWordRepI q2 ++ QuadWordRepI q3
  end.
Lemma SixteenWordRepI_SixteenWordRep w: SixteenWordRep w = map Vint (SixteenWordRepI w).
Proof. destruct w as [[[q0 q1] q2] q3]. simpl.
   repeat rewrite QuadWordRepI_QuadWordRep. repeat rewrite map_app. reflexivity.
Qed.

    Lemma QuadWordRepI_length s: length (QuadWordRepI s) = 4%nat.
    Proof. destruct s as [[[q0 q1] q2] q3]. reflexivity. Qed.
    Lemma SixteenWordRepI_length s: length (SixteenWordRepI s) = 16%nat.
    Proof. destruct s as [[[q0 q1] q2] q3]. simpl.
      repeat rewrite app_length. repeat rewrite QuadWordRepI_length. reflexivity.
    Qed.

Lemma QuadByte2ValList_bytes q: exists bytes, length bytes = 4%nat /\
      QuadByte2ValList q = map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. destruct q as [[[b0 b1] b2] b3]. unfold QuadByte2ValList; simpl.
  exists [b0;b1;b2;b3]. split; trivial.
Qed.

Lemma SixteenByte2ValList_bytes N: exists bytes, length bytes = 16%nat /\
      SixteenByte2ValList N =  map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. destruct N as [[[q0 q1] q2] q3]. rewrite SixteenByte2ValList_char.
  destruct (QuadByte2ValList_bytes q0) as [bytes0 [L0 Q0]]. rewrite Q0.
  destruct (QuadByte2ValList_bytes q1) as [bytes1 [L1 Q1]]; rewrite Q1.
  destruct (QuadByte2ValList_bytes q2) as [bytes2 [L2 Q2]]; rewrite Q2.
  destruct (QuadByte2ValList_bytes q3) as [bytes3 [L3 Q3]]; rewrite Q3.
  exists (bytes0 ++ bytes1 ++ bytes2 ++ bytes3).
  repeat rewrite map_app. repeat rewrite app_length. rewrite L0, L1, L2, L3.
  split; trivial.
Qed.

Lemma QuadByte2ValList_ints q: exists ints, length ints = 4%nat /\
      QuadByte2ValList q = map Vint ints.
Proof. destruct q as [[[b0 b1] b2] b3]. unfold QuadByte2ValList; simpl.
  exists [Int.repr (Byte.unsigned b0); Int.repr (Byte.unsigned b1);
          Int.repr (Byte.unsigned b2); Int.repr (Byte.unsigned b3)].
  split; trivial.
Qed.

Lemma SixteenByte2ValList_ints N: exists ints, length ints = 16%nat /\
      SixteenByte2ValList N = map Vint ints.
Proof. destruct N as [[[q0 q1] q2] q3]. rewrite SixteenByte2ValList_char.
  destruct (QuadByte2ValList_ints q0) as [ints0 [L0 Q0]]; rewrite Q0.
  destruct (QuadByte2ValList_ints q1) as [ints1 [L1 Q1]]; rewrite Q1.
  destruct (QuadByte2ValList_ints q2) as [ints2 [L2 Q2]]; rewrite Q2.
  destruct (QuadByte2ValList_ints q3) as [ints3 [L3 Q3]]; rewrite Q3.
  exists (ints0 ++ ints1 ++ ints2 ++ ints3).
  repeat rewrite map_app. repeat rewrite app_length. rewrite L0, L1, L2, L3.
  split; trivial.
Qed.

Lemma QuadChunks2ValList_bytes: forall l,
        exists bytes, length bytes = (4*length l)%nat /\
        QuadChunks2ValList l = map Vint (map Int.repr (map Byte.unsigned bytes)).
  Proof. unfold QuadChunks2ValList.
    induction l; simpl; intros. exists nil; split; trivial.
    destruct IHl as [? [X1 X2]]; rewrite X2; clear X2.
    destruct (QuadByte2ValList_bytes a) as [? [Y1 Y2]]; rewrite Y2; clear Y2.
    repeat rewrite <- map_app. exists (x0 ++ x); split; trivial.
    rewrite app_length, X1, Y1. omega.
  Qed.

Fixpoint upd_upto (x: SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) i (l:list val):list val :=
  match i with
    O => l
  | S n =>
     match x with (Nonce, C, (Key1, Key2)) =>
     ((upd_Znth (11 + (Z.of_nat n))
     (upd_Znth(6 + (Z.of_nat n))
        (upd_Znth (1 + (Z.of_nat n))
           (upd_Znth (5 * (Z.of_nat n)) (upd_upto x n l)
              (Vint (littleendian (Select16Q C (Z.of_nat n)))))
           (Vint (littleendian (Select16Q Key1 (Z.of_nat n)))))
        (Vint (littleendian (Select16Q Nonce (Z.of_nat n)))))
     (Vint (littleendian (Select16Q Key2 (Z.of_nat n))))))
     end
  end.

Lemma upd_upto_Sn Nonce C Key1 Key2 n l: upd_upto (Nonce, C, (Key1, Key2)) (S n) l =
     ((upd_Znth (11 + (Z.of_nat n))
     (upd_Znth (6 + (Z.of_nat n))
        (upd_Znth (1 + (Z.of_nat n))
           (upd_Znth (5 * (Z.of_nat n)) (upd_upto (Nonce, C, (Key1, Key2))  n l)
              (Vint (littleendian (Select16Q C (Z.of_nat n)))))
           (Vint (littleendian (Select16Q Key1 (Z.of_nat n)))))
        (Vint (littleendian (Select16Q Nonce (Z.of_nat n)))))
     (Vint (littleendian (Select16Q Key2 (Z.of_nat n)))))).
 reflexivity. Qed.

Lemma upd_upto_Zlength data l (H: Zlength l = 16): forall i (I:(0<=i<=4)%nat),
      Zlength (upd_upto data i l) = 16.
  Proof. apply Zlength_length in H. 2: omega. simpl in H.
    destruct l; simpl in H. exfalso; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. intros; omega.
    destruct l; simpl in H. intros; omega. destruct l; simpl in H. 2: intros; omega. clear H.
    intros.
    induction i; destruct data as [[N C] [K1 K2]]. reflexivity.
    rewrite upd_upto_Sn. remember (11 + Z.of_nat i) as z1. remember (6 + Z.of_nat i) as z2.
    remember (1 + Z.of_nat i) as z3. remember (5 * Z.of_nat i)%Z as z4.
    remember (Vint (littleendian (Select16Q C (Z.of_nat i)))) as u4.
    remember (Vint (littleendian (Select16Q K1 (Z.of_nat i)))) as u3.
    remember (Vint (littleendian (Select16Q N (Z.of_nat i)))) as u2.
    remember (Vint (littleendian (Select16Q K2 (Z.of_nat i)))) as u1.
    assert ((0 <= i <= 4)%nat).
      split. omega. omega. (*rewrite Nat2Z.inj_succ in I. omega.*)
    repeat rewrite upd_Znth_Zlength; rewrite (IHi H); intros; try omega.
Qed.

Lemma upd_upto_Vint data: forall n, 0<=n<16 ->
      exists i, Znth n (upd_upto data 4 (list_repeat 16 Vundef)) = Vint i.
  Proof. unfold upd_upto; intros. destruct data as [[N C] [K1 K2]].
   repeat rewrite (upd_Znth_lookup' 16); trivial; simpl; try omega.
   if_tac. eexists; reflexivity.   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity.
   if_tac. eexists; reflexivity. omega.
Qed.

(*cf xsalsa-paper, beginning of Section 2*)
Lemma upd_upto_char data l: Zlength l = 16 ->
      upd_upto data 4 l = match data with ((Nonce, C), (Key1, Key2)) =>
          match Nonce with (N1, N2, N3, N4) =>
          match C with (C1, C2, C3, C4) =>
          match Key1 with (K1, K2, K3, K4) =>
          match Key2 with (L1, L2, L3, L4) =>
      map Vint (map littleendian [C1; K1; K2; K3;
                                  K4; C2; N1; N2;
                                  N3; N4; C3; L1;
                                  L2; L3; L4; C4]) end end end end end.
Proof. intros. apply Zlength_length in H. 2: omega.
   destruct data as [[Nonce C] [Key1 Key2]].
   destruct Nonce as [[[N1 N2] N3] N4].
   destruct C as [[[C1 C2] C3] C4].
   destruct Key1 as [[[K1 K2] K3] K4].
   destruct Key2 as [[[L1 L2] L3] L4].
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. omega.
   destruct l; simpl in H. 2: omega. clear H. reflexivity.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export DistributedReferenceCounting.machine3.machine.
Require Export DistributedReferenceCounting.machine3.cardinal.
Require Export DistributedReferenceCounting.machine3.comm.
Require Export DistributedReferenceCounting.machine3.still_to_prove.

Unset Standard Proposition Elimination Names.

Section ROOTED.

Variable s0 : Site.

Definition rooted_fun (s1 s2 : Site) (m : Message) :=
  match m with
  | copy => if eq_site_dec s1 s0 then 1%Z else 0%Z
  | dec => if eq_site_dec s2 s0 then 1%Z else 0%Z
  | inc_dec s3 =>
      if eq_site_dec s3 s0
      then
       if eq_site_dec s2 owner then 1%Z else 0%Z
      else 0%Z
  end.

Definition rooted (s1 s2 : Site) (q : queue Message) :=
  reduce Message (rooted_fun s1 s2) q.

Definition sigma_rooted (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) rooted bm.

End ROOTED.

Section ROOTED1.

Lemma sigma_rooted_post_message :
 forall (m : Message) (s0 s1 s2 : Site) (b : Bag_of_message),
 s0 <> owner ->
 sigma_rooted s0 (Post_message Message m b s1 s2) =
 (sigma_rooted s0 b + rooted_fun s0 s1 s2 m)%Z.
Proof.
  unfold sigma_rooted in |- *.
  unfold Post_message in |- *.
  unfold change_queue in |- *.
  intros.
  rewrite sigma_table2_change.
  simpl in |- *.
  omega.
  apply finite_site.
  apply finite_site.
Qed.

Lemma rooted_first_out :
 forall (s0 s1 s2 : Site) (q : queue Message) (m : Message),
 first Message q = value Message m ->
 rooted s0 s1 s2 (first_out Message q) =
 (rooted s0 s1 s2 q - rooted_fun s0 s1 s2 m)%Z.
Proof.
  intros.
  unfold rooted in |- *.
  apply reduce_first_out.
  auto.
Qed.

Lemma sigma_rooted_collect_message :
 forall (m : Message) (s0 s1 s2 : Site) (b : Bag_of_message),
 first Message (b s1 s2) = value Message m ->
 s0 <> owner ->
 sigma_rooted s0 (Collect_message Message b s1 s2) =
 (sigma_rooted s0 b - rooted_fun s0 s1 s2 m)%Z.
Proof.
  unfold sigma_rooted, Collect_message, change_queue in |- *.
  intros.
  rewrite sigma_table2_change.
  rewrite (rooted_first_out s0 s1 s2 (b s1 s2) m).
  simpl in |- *.
  omega.
  auto.
  apply finite_site.
  apply finite_site.
Qed.

Lemma rooted_fun_positive_or_null :
 forall (s0 x y : Site) (a : Message), (rooted_fun s0 x y a >= 0)%Z.
Proof.
  intros.
  unfold rooted_fun in |- *.
  elim a.
  case (eq_site_dec y s0).
  intro; omega.
  intro; omega.
  intro.
  case (eq_site_dec s s0).
  case (eq_site_dec y owner).
  intros; omega.
  intros; omega.
  intros; omega.
  case (eq_site_dec x s0).
  intros; omega.
  intros; omega.
Qed.

Lemma rooted_positive_or_null :
 forall (s0 x y : Site) (q : queue Message), (rooted s0 x y q >= 0)%Z.
Proof.
  intros.
  unfold rooted in |- *.
  apply reduce_positive_or_null.
  intro.
  apply rooted_fun_positive_or_null.
Qed.

Axiom
  sigma_rooted_change_queue :
    forall (s0 s1 s2 : Site) (b : Bag_of_message) (q : queue Message),
    s0 <> owner ->
    b s1 owner = input Message dec (input Message (inc_dec s2) q) ->
    sigma_rooted s0 (change_queue (queue Message) b s1 owner q) =
    (sigma_rooted s0 b - rooted_fun s0 s1 owner dec -
     rooted_fun s0 s1 owner (inc_dec s2))%Z.

End ROOTED1.

Section INVARIANT2.

Lemma invariant2_init :
 forall s0 : Site, st config_init s0 = sigma_rooted s0 (bm config_init).
Proof.
  intros.
  simpl in |- *.
  unfold send_init, sigma_rooted, bag_init in |- *.
  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  unfold Z_id in |- *.
  unfold rooted in |- *.
  simpl in |- *.
  rewrite sigma_null.
  rewrite sigma_null.
  auto.
Qed.

Lemma invariant2_ind :
 forall s0 : Site,
 s0 <> owner ->
 forall (c : Config) (t : class_trans c),
 legal c ->
 st c s0 = sigma_rooted s0 (bm c) ->
 st (transition c t) s0 = sigma_rooted s0 (bm (transition c t)).
Proof.
  simple induction t.

  (* 1 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  unfold Inc_send_table in |- *.
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  intro; rewrite e.
  unfold update_table in |- *; rewrite here.
  omega.
  intro; unfold update_table in |- *; rewrite elsewhere.
  omega.
  auto.
  auto.

  (* 2 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_collect_message with (m := dec).
  unfold Dec_send_table in |- *.
  unfold rooted_fun in |- *.
  case (eq_site_dec s2 s0).
  intro; rewrite e0.
  unfold update_table in |- *; rewrite here.
  omega.
  intros; unfold update_table in |- *; rewrite elsewhere.
  omega.
  auto.
  auto.
  auto.

  (* 3 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := inc_dec s3).
  unfold Inc_send_table, rooted_fun in |- *.
  unfold update_table in |- *; rewrite elsewhere.
  case (eq_site_dec s3 s0).
  case (eq_site_dec owner owner).
  intros; omega.
  intro; elim n.
  auto.
  intros; omega.
  auto.
  auto.
  auto.
  auto.

  (* 4 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  intro; omega.
  intro; omega.
  auto.
  auto.
  auto.

  (* 5 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  rewrite case_ineq.
  omega.
  auto.
  auto.
  auto.

  (* 6 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_collect_message with (m := copy).
  unfold rooted_fun in |- *.
  case (eq_site_dec s1 s0).
  rewrite case_eq.
  intro; omega.
  intro; omega.
  auto.
  auto.
  auto.

  (* 7 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  unfold rooted_fun in |- *.
  rewrite case_ineq.
  omega.
  auto.
  auto.

  (* optim 1 *)

  intros; simpl in |- *.
  rewrite sigma_rooted_post_message.
  rewrite sigma_rooted_change_queue with (s2 := s2).
  unfold rooted_fun in |- *.
  case (eq_site_dec owner s0); intro.
  elim H; auto.

  case (eq_site_dec s2 s0); intro.
  case (eq_site_dec owner owner); intro.
  omega.

  elim n1; auto.
  omega.
  auto.
  auto.
  auto.
Qed.

Lemma invariant2 :
 forall (c0 : Config) (s0 : Site),
 legal c0 -> s0 <> owner -> st c0 s0 = sigma_rooted s0 (bm c0).

Proof.
  intros.
  elim H.
  apply invariant2_init.
  intros.
  apply invariant2_ind.
  auto.
  auto.
  auto.
Qed.

Lemma positive_st :
 forall (c : Config) (s0 s5 : Site),
 s0 <> owner ->
 legal c -> In_queue Message (inc_dec s0) (bm c s5 owner) -> (st c s0 > 0)%Z.
Proof.
  intros c s0 s5 H HA.
  rewrite invariant2.
  unfold sigma_rooted in |- *.
  intros.
  apply sigma2_strictly_positive with (x := s5) (y := owner).
  auto.
  exact eq_site_dec.

  apply in_s_LS.
  apply in_s_LS.
  intros.
  unfold rooted in |- *.
  intros.
  simpl in |- *.
  intros.
  simpl in |- *.
  apply reduce_positive_or_null.
  intro.
  apply rooted_fun_positive_or_null.

  generalize H0.
  elim (bm c s5 owner).
  simpl in |- *; intuition.

  intros.
  generalize H2.
  case d.
  simpl in |- *.
  intros.
  elim H3.
  intro; discriminate.

  intro.
  generalize (H1 H4).
  intro.
  case (eq_site_dec owner s0).
  intros; omega.

  intros; omega.

  simpl in |- *.
  intros.
  case (eq_site_dec s s0).
  intro.
  case (eq_site_dec owner owner).
  intro.
  generalize (rooted_positive_or_null s0 s5 owner q).
  intro.
  omega.

  intro.
  elim n; auto.

  intro.
  elim H3.
  intro; elim n.
  inversion H4.
  auto.

  intro.
  generalize (H1 H4).
  intro.
  omega.

  simpl in |- *.
  intro.
  elim H3.
  intro; discriminate.

  intro.
  generalize (H1 H4).
  intro.
  case (eq_site_dec s5 s0).
  intro; omega.

  intro; omega.

  auto.

  auto.
Qed.

End INVARIANT2.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.CommonDefinitions.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.

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

Require Import VerdiRaft.TermsAndIndicesFromOneInterface.
Require Import VerdiRaft.TermsAndIndicesFromOneLogInterface.

Section TermsAndIndicesFromOne.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.
  Context {rri : raft_refinement_interface}.
  Context {taifoli : terms_and_indices_from_one_log_interface}.

  Lemma terms_and_indices_from_one_vwl_init :
    refined_raft_net_invariant_init terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_init, terms_and_indices_from_one_vwl.
    simpl. contradiction.
  Qed.

  Lemma lifted_terms_and_indices_from_one_log : forall net0 h,
    refined_raft_intermediate_reachable net0 ->
    terms_and_indices_from_one (log (snd (nwState net0 h))).
  Proof using taifoli rri.
    intros.
    pose proof (lift_prop _ terms_and_indices_from_one_log_invariant).
    unfold terms_and_indices_from_one_log in *.
    rewrite <- deghost_spec with (net := net0). auto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_client_request :
    refined_raft_net_invariant_client_request terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_client_request, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update;
      eauto using votesWithLog_update_elections_data_client_request.
  Qed.

  Lemma terms_and_indices_from_one_vwl_timeout :
    refined_raft_net_invariant_timeout terms_and_indices_from_one_vwl.
  Proof using taifoli rri.
    unfold refined_raft_net_invariant_timeout, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_eapply_lem_hyp votesWithLog_update_elections_data_timeout; eauto.
    intuition; eauto. subst. find_apply_lem_hyp handleTimeout_log_same. find_rewrite.
    apply lifted_terms_and_indices_from_one_log; auto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_append_entries :
    refined_raft_net_invariant_append_entries terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_append_entries, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update;
      eauto using votesWithLog_update_elections_data_append_entries.
  Qed.

  Lemma terms_and_indices_from_one_vwl_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_request_vote :
    refined_raft_net_invariant_request_vote terms_and_indices_from_one_vwl.
  Proof using taifoli rri.
    unfold refined_raft_net_invariant_request_vote, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_eapply_lem_hyp votesWithLog_update_elections_data_request_vote; eauto.
    intuition; eauto. subst. find_apply_lem_hyp handleRequestVote_log. find_rewrite.
    apply lifted_terms_and_indices_from_one_log; auto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_request_vote_reply, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; rewrite_update;
      eauto using votesWithLog_update_elections_data_request_vote_reply.
  Qed.

  Lemma terms_and_indices_from_one_vwl_do_leader :
    refined_raft_net_invariant_do_leader terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_do_leader, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_do_generic_server :
    refined_raft_net_invariant_do_generic_server terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, terms_and_indices_from_one_vwl.
    simpl. intuition. find_reverse_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_reboot :
    refined_raft_net_invariant_reboot terms_and_indices_from_one_vwl.
  Proof using.
    unfold refined_raft_net_invariant_reboot, terms_and_indices_from_one_vwl.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_vwl_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      terms_and_indices_from_one_vwl net.
  Proof using taifoli rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply terms_and_indices_from_one_vwl_init.
    - apply terms_and_indices_from_one_vwl_client_request.
    - apply terms_and_indices_from_one_vwl_timeout.
    - apply terms_and_indices_from_one_vwl_append_entries.
    - apply terms_and_indices_from_one_vwl_append_entries_reply.
    - apply terms_and_indices_from_one_vwl_request_vote.
    - apply terms_and_indices_from_one_vwl_request_vote_reply.
    - apply terms_and_indices_from_one_vwl_do_leader.
    - apply terms_and_indices_from_one_vwl_do_generic_server.
    - apply terms_and_indices_from_one_vwl_state_same_packet_subset.
    - apply terms_and_indices_from_one_vwl_reboot.
  Qed.

  Lemma terms_and_indices_from_one_ll_init :
    refined_raft_net_invariant_init terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_init, terms_and_indices_from_one_ll.
    simpl. contradiction.
  Qed.

  Lemma terms_and_indices_from_one_ll_client_request :
    refined_raft_net_invariant_client_request terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_client_request, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_rewrite_lem update_elections_data_client_request_leaderLogs. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_timeout :
    refined_raft_net_invariant_timeout terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_timeout, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_rewrite_lem update_elections_data_timeout_leaderLogs. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_append_entries :
    refined_raft_net_invariant_append_entries terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_append_entries, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_rewrite_lem update_elections_data_appendEntries_leaderLogs. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_request_vote :
    refined_raft_net_invariant_request_vote terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    simpl in *. find_rewrite_lem leaderLogs_update_elections_data_requestVote. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply terms_and_indices_from_one_ll.
  Proof using taifoli rri.
    unfold refined_raft_net_invariant_request_vote_reply, terms_and_indices_from_one_ll.
    simpl. intuition. repeat find_higher_order_rewrite. update_destruct; rewrite_update; eauto.
    simpl in *. find_eapply_lem_hyp leaderLogs_update_elections_data_RVR; eauto.
    find_apply_lem_hyp handleRequestVoteReply_log.
    intuition; eauto; subst. find_rewrite.
    apply lifted_terms_and_indices_from_one_log; auto.
  Qed.

  Lemma terms_and_indices_from_one_ll_do_leader :
    refined_raft_net_invariant_do_leader terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_do_leader, terms_and_indices_from_one_ll.
    simpl. intuition. find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_do_generic_server :
    refined_raft_net_invariant_do_generic_server terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, terms_and_indices_from_one_ll.
    simpl. intuition. find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, terms_and_indices_from_one_ll.
    simpl. intuition. find_reverse_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_reboot :
    refined_raft_net_invariant_reboot terms_and_indices_from_one_ll.
  Proof using.
    unfold refined_raft_net_invariant_reboot, terms_and_indices_from_one_ll.
    simpl. intuition. find_higher_order_rewrite. update_destruct; subst; rewrite_update; eauto.
    eapply H0. find_higher_order_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_ll_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      terms_and_indices_from_one_ll net.
  Proof using taifoli rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply terms_and_indices_from_one_ll_init.
    - apply terms_and_indices_from_one_ll_client_request.
    - apply terms_and_indices_from_one_ll_timeout.
    - apply terms_and_indices_from_one_ll_append_entries.
    - apply terms_and_indices_from_one_ll_append_entries_reply.
    - apply terms_and_indices_from_one_ll_request_vote.
    - apply terms_and_indices_from_one_ll_request_vote_reply.
    - apply terms_and_indices_from_one_ll_do_leader.
    - apply terms_and_indices_from_one_ll_do_generic_server.
    - apply terms_and_indices_from_one_ll_state_same_packet_subset.
    - apply terms_and_indices_from_one_ll_reboot.
  Qed.

  Instance taifoi : terms_and_indices_from_one_interface.
  Proof.
    constructor. split.
    - auto using terms_and_indices_from_one_vwl_invariant.
    - auto using terms_and_indices_from_one_ll_invariant.
  Qed.
End TermsAndIndicesFromOne.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Neededness analysis for x86_64 operators *)

Require Import Coqlib.
Require Import AST Integers Floats Values Memory Globalenvs.
Require Import Op NeedDomain RTL.

Definition op1 (nv: nval) := nv :: nil.
Definition op2 (nv: nval) := nv :: nv :: nil.

Definition needs_of_condition (cond: condition): list nval :=
  match cond with
  | Cmaskzero n | Cmasknotzero n => op1 (maskzero n)
  | _ => nil
  end.

Definition needs_of_addressing_32 (addr: addressing) (nv: nval): list nval :=
  match addr with
  | Aindexed n => op1 (modarith nv)
  | Aindexed2 n => op2 (modarith nv)
  | Ascaled sc ofs => op1 (modarith (modarith nv))
  | Aindexed2scaled sc ofs => op2 (modarith nv)
  | Aglobal s ofs => nil
  | Abased s ofs => op1 (modarith nv)
  | Abasedscaled sc s ofs => op1 (modarith (modarith nv))
  | Ainstack ofs => nil
  end.

Definition needs_of_addressing_64 (addr: addressing) (nv: nval): list nval :=
  match addr with
  | Aindexed n => op1 (default nv)
  | Aindexed2 n => op2 (default nv)
  | Ascaled sc ofs => op1 (default nv)
  | Aindexed2scaled sc ofs => op2 (default nv)
  | Aglobal s ofs => nil
  | Abased s ofs => op1 (default nv)
  | Abasedscaled sc s ofs => op1 (default nv)
  | Ainstack ofs => nil
  end.

Definition needs_of_addressing (addr: addressing) (nv: nval): list nval :=
  if Archi.ptr64 then needs_of_addressing_64 addr nv else needs_of_addressing_32 addr nv.

Definition needs_of_operation (op: operation) (nv: nval): list nval :=
  match op with
  | Omove => op1 nv
  | Ointconst n => nil
  | Olongconst n => nil
  | Ofloatconst n => nil
  | Osingleconst n => nil
  | Oindirectsymbol id => nil
  | Ocast8signed => op1 (sign_ext 8 nv)
  | Ocast8unsigned => op1 (zero_ext 8 nv)
  | Ocast16signed => op1 (sign_ext 16 nv)
  | Ocast16unsigned => op1 (zero_ext 16 nv)
  | Oneg => op1 (modarith nv)
  | Osub => op2 (default nv)
  | Omul => op2 (modarith nv)
  | Omulimm n => op1 (modarith nv)
  | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv)
  | Oand => op2 (bitwise nv)
  | Oandimm n => op1 (andimm nv n)
  | Oor => op2 (bitwise nv)
  | Oorimm n => op1 (orimm nv n)
  | Oxor => op2 (bitwise nv)
  | Oxorimm n => op1 (bitwise nv)
  | Onot => op1 (bitwise nv)
  | Oshl => op2 (default nv)
  | Oshlimm n => op1 (shlimm nv n)
  | Oshr => op2 (default nv)
  | Oshrimm n => op1 (shrimm nv n)
  | Oshrximm n => op1 (default nv)
  | Oshru => op2 (default nv)
  | Oshruimm n => op1 (shruimm nv n)
  | Ororimm n => op1 (ror nv n)
  | Oshldimm n => op1 (default nv)
  | Olea addr => needs_of_addressing_32 addr nv
  | Omakelong => op2 (default nv)
  | Olowlong | Ohighlong => op1 (default nv)
  | Ocast32signed => op1 (default nv)
  | Ocast32unsigned => op1 (default nv)
  | Onegl => op1 (default nv)
  | Oaddlimm _ => op1 (default nv)
  | Osubl => op2 (default nv)
  | Omull => op2 (default nv)
  | Omullimm _ => op1 (default nv)
  | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv)
  | Oandl => op2 (default nv)
  | Oandlimm _ => op1 (default nv)
  | Oorl => op2 (default nv)
  | Oorlimm _ => op1 (default nv)
  | Oxorl => op2 (default nv)
  | Oxorlimm _ => op1 (default nv)
  | Onotl => op1 (default nv)
  | Oshll => op2 (default nv)
  | Oshllimm _ => op1 (default nv)
  | Oshrl => op2 (default nv)
  | Oshrlimm _ => op1 (default nv)
  | Oshrxlimm n => op1 (default nv)
  | Oshrlu => op2 (default nv)
  | Oshrluimm _ => op1 (default nv)
  | Ororlimm _ => op1 (default nv)
  | Oleal addr => needs_of_addressing_64 addr nv
  | Onegf | Oabsf => op1 (default nv)
  | Oaddf | Osubf | Omulf | Odivf | Omaxf | Ominf => op2 (default nv)
  | Onegfs | Oabsfs => op1 (default nv)
  | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
  | Osingleoffloat | Ofloatofsingle => op1 (default nv)
  | Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv)
  | Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv)
  | Ocmp c => needs_of_condition c
  | Osel c ty => nv :: nv :: needs_of_condition c
  end.

Definition operation_is_redundant (op: operation) (nv: nval): bool :=
  match op with
  | Ocast8signed => sign_ext_redundant 8 nv
  | Ocast8unsigned => zero_ext_redundant 8 nv
  | Ocast16signed => sign_ext_redundant 16 nv
  | Ocast16unsigned => zero_ext_redundant 16 nv
  | Oandimm n => andimm_redundant nv n
  | Oorimm n => orimm_redundant nv n
  | _ => false
  end.

Ltac InvAgree :=
  match goal with
  | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
  | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
  | _ => idtac
  end.

Ltac TrivialExists :=
  match goal with
  | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
  | _ => idtac
  end.

Section SOUNDNESS.

Variable ge: genv.
Variable sp: block.
Variables m m': mem.
Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.

Lemma needs_of_condition_sound:
  forall cond args b args',
  eval_condition cond args m = Some b ->
  vagree_list args args' (needs_of_condition cond) ->
  eval_condition cond args' m' = Some b.
Proof.
  intros. destruct cond; simpl in H;
  try (eapply default_needs_of_condition_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree.
- eapply maskzero_sound; eauto.
- destruct (Val.maskzero_bool v n) as [b'|] eqn:MZ; try discriminate.
  erewrite maskzero_sound; eauto.
Qed.

Lemma needs_of_addressing_32_sound:
  forall sp addr args v nv args',
  eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args = Some v ->
  vagree_list args args' (needs_of_addressing_32 addr nv) ->
  exists v',
     eval_addressing32 ge (Vptr sp Ptrofs.zero) addr args' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_addressing_32; intros.
  destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists;
  auto using add_sound, mul_sound with na.
  apply add_sound; auto with na. apply add_sound; rewrite modarith_idem; auto.
  apply add_sound; auto. apply add_sound; rewrite modarith_idem; auto with na.
  apply mul_sound; rewrite modarith_idem; auto with na.
Qed.

(*
Lemma needs_of_addressing_64_sound:
  forall sp addr args v nv args',
  eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args = Some v ->
  vagree_list args args' (needs_of_addressing_64 addr nv) ->
  exists v',
     eval_addressing64 ge (Vptr sp Ptrofs.zero) addr args' = Some v'
  /\ vagree v v' nv.
*)

Lemma needs_of_operation_sound:
  forall op args v nv args',
  eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v ->
  vagree_list args args' (needs_of_operation op nv) ->
  nv <> Nothing ->
  exists v',
     eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree; TrivialExists.
- apply sign_ext_sound; auto. compute; auto.
- apply zero_ext_sound; auto. lia.
- apply sign_ext_sound; auto. compute; auto.
- apply zero_ext_sound; auto. lia.
- apply neg_sound; auto.
- apply mul_sound; auto.
- apply mul_sound; auto with na.
- apply and_sound; auto.
- apply andimm_sound; auto.
- apply or_sound; auto.
- apply orimm_sound; auto.
- apply xor_sound; auto.
- apply xor_sound; auto with na.
- apply notint_sound; auto.
- apply shlimm_sound; auto.
- apply shrimm_sound; auto.
- apply shruimm_sound; auto.
- apply ror_sound; auto.
- eapply needs_of_addressing_32_sound; eauto.
- change (eval_addressing64 ge (Vptr sp Ptrofs.zero) a args')
    with (eval_operation ge (Vptr sp Ptrofs.zero) (Oleal a) args' m').
  eapply default_needs_of_operation_sound; eauto.
  destruct a; simpl in H0; auto.
- destruct (eval_condition cond args m) as [b|] eqn:EC; simpl in H2.
  erewrite needs_of_condition_sound by eauto.
  subst v; simpl. auto with na.
  subst v; auto with na.
- destruct (eval_condition c args m) as [b|] eqn:EC.
  erewrite needs_of_condition_sound by eauto.
  apply select_sound; auto.
  simpl; auto with na.
Qed.

Lemma operation_is_redundant_sound:
  forall op nv arg1 args v arg1' args',
  operation_is_redundant op nv = true ->
  eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v ->
  vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
  vagree v arg1' nv.
Proof.
  intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
- apply sign_ext_redundant_sound; auto. lia.
- apply zero_ext_redundant_sound; auto. lia.
- apply sign_ext_redundant_sound; auto. lia.
- apply zero_ext_redundant_sound; auto. lia.
- apply andimm_redundant_sound; auto.
- apply orimm_redundant_sound; auto.
Qed.

End SOUNDNESS.