Require Import Examples.StatDb.Impl.

Require Import Helpers.RelationRewriting.

Require Import Spec.Hoare.
Require Import Spec.HoareTactics.
Require Import Spec.AbstractionSpec.

Definition absr : relation DB.l.(State) Var.l.(State) unit :=
  fun l s _ =>
    fst s = fold_right plus 0 l /\
    snd s = length l.

Definition init_hspec : Specification InitStatus unit Var.State :=
  fun state =>
    {|
      pre := state = (0, 0);
      post := fun state' _ => state' = (0, 0);
      alternate := fun state' (_:unit) => True
    |}.

Definition add_hspec n : Specification unit unit Var.State :=
  fun state =>
    {|
      pre := True;
      post := fun state' (_:unit) => fst state' = (n + fst state) /\
                                     snd state' =  S (snd state);
      alternate := fun state' (_:unit) => state' = (0, 0)
    |}.

Definition add_rspec n : Specification unit unit Var.State :=
  fun state =>
    {|
      pre := True;
      post := fun state' (_:unit) => fst state' = (n + fst state) /\
                                     snd state' =  S (snd state);
      alternate := fun state' (_:unit) => state' = (0, 0)
    |}.

Definition avg_hspec : Specification nat unit Var.State :=
  fun state =>
    {|
      pre := True;
      post := fun state' v => state = state' /\ v = (fst state / snd state');
      alternate := fun state' v => state' = (0, 0)
    |}.

Definition avg_rspec : Specification nat unit Var.State :=
  fun state =>
    {|
      pre := True;
      post := fun state' v => state = state' /\ v = (fst state / snd state');
      alternate := fun state' v => state' = (0, 0)
    |}.

Definition recover_spec : Specification unit unit Var.State :=
  fun state =>
    {|
      pre := state = (0, 0);
      post := fun state' (_:unit) => state' = (0, 0);
      alternate := fun state' (_:unit) => state' = (0, 0);
    |}.

Lemma read_op_ok :
  forall i,
    proc_hspec Var.dynamics (read i) (op_spec Var.dynamics (Var.Read i)).
Proof. intros. eapply op_spec_sound. Qed.

Lemma write_op_ok :
  forall i v,
    proc_hspec Var.dynamics (write i v) (op_spec Var.dynamics (Var.Write i v)).
Proof. intros. eapply op_spec_sound. Qed.

Global Hint Resolve read_op_ok write_op_ok : core.

Ltac simplify :=
  repeat match goal with
         | |- forall _, _ => intros
         | _ => deex
         | _ => destruct_tuple
         | _ => destruct_tuple
         | [ H: reads _ _ _ _ |- _] => unfold reads in H
         | [ H: puts _ _ _ _ |- _] => unfold puts in H
         | [ u: unit |- _ ] => destruct u
         | |- _ /\ _ => split; [ solve [auto] | ]
         | |- _ /\ _ => split; [ | solve [auto] ]
         | _ => progress simpl in *
         | _ => progress safe_intuition
         | _ => progress subst
         | _ => progress autorewrite with array in *
         end.

Ltac step :=
  unshelve (step_proc); simplify; finish.

Lemma recover_cok : proc_hspec Var.dynamics (impl.(recover)) recover_spec.
Proof. simpl. eapply ret_hspec; firstorder. Qed.

Lemma recover_idempotent :
  idempotent (fun (t: unit) => recover_spec).
Proof.
  unfold idempotent; intuition; exists tt; simpl in *.
  unfold puts in *; firstorder; congruence.
Qed.

Global Hint Resolve recover_cok recover_idempotent : core.

Lemma recover_rok : proc_rspec Var.dynamics (impl.(recover)) (impl.(recover)) recover_spec.
Proof. eapply proc_hspec_to_rspec; eauto. intros []; eauto. Qed.

Lemma init_cok :
  proc_hspec Var.dynamics (impl.(init)) (init_hspec).
Proof. eapply ret_hspec; firstorder. Qed.

Lemma util_and3 (P Q R:Prop) :
  P -> Q -> R -> P /\ Q /\ R.
Proof. firstorder. Qed.

Ltac extract_pre H :=
  let P := type of H in
  match eval hnf in P with
  | True => clear H
  | ?v = _ =>
    is_var v;
    hnf in H; subst
  | (?v = _) /\ _ =>
    is_var v;
    hnf in H;
    let Heq := fresh "Heq" in
    destruct H as (Heq&H); subst
  | _ => idtac
  end.

Lemma crash_step_simp s s' r :
  Var.dynamics.(crash_step) s s' r ->
  s' = (0, 0).
Proof.
  compute; auto.
Qed.

Lemma op_step_crash T (op: Var.Op T) u s' r :
  (op_spec Var.dynamics op u).(alternate) s' r ->
  s' = (0, 0).
Proof.
  intros.
  hnf in H; propositional.
  destruct H0; propositional.
Qed.

Ltac extract_crash H :=
  lazymatch type of H with
  | Var.dynamics.(crash_step) _ _ _ =>
    apply crash_step_simp in H; subst
  | (op_spec Var.dynamics _ _).(alternate) _ _ =>
    apply op_step_crash in H; subst
  | _ => idtac
  end.

Ltac extract_post :=
  lazymatch goal with
  | |- pre _ => simpl
  | |- alternate _ _ _ => simpl
  | |- post _ _ _ => simpl
  | _ => idtac
  end.

Ltac step_bind :=
  eapply proc_hspec_rx; [ solve [ eauto ] | cbn [pre post alternate] .. ];
  (let H := fresh "Hpre" in
   intros * H; extract_pre H);
  apply util_and3;
  swap 1 2;
  [ intros
  | extract_post
  | let H := fresh "Hcrash" in
    intros * H; extract_crash H;
    extract_post ].

Ltac step_ret :=
  apply ret_hspec; cbn [pre post alternate];
  (let H := fresh "Hpre" in
   intros * H; extract_pre H);
  apply conj;
  [ extract_post
  | let H := fresh "Hcrash" in
    intros * H; extract_crash H; extract_post ].

Ltac newstep :=
  monad_simpl;
  lazymatch goal with
  | |- proc_hspec _ (compile_op _ _) _ => simpl
  | |- proc_hspec _ (Ret _) _ => step_ret
  | |- proc_hspec _ (Bind _ _) _ => step_bind
  end.

Lemma add_cok n :
  proc_hspec Var.dynamics (impl.(compile_op) (DB.Add n)) (add_hspec n).
Proof.
  repeat newstep; auto.
  destruct state0; simpl; auto.
Qed.

Lemma avg_cok :
  proc_hspec Var.dynamics (impl.(compile_op) (DB.Avg)) (avg_hspec).
Proof.
  repeat newstep; auto.
Qed.

Lemma add_ok n :
  proc_rspec Var.dynamics (impl.(compile_op) (DB.Add n)) impl.(recover) (add_rspec n).
Proof. eapply proc_hspec_to_rspec; [ eapply add_cok |..]; eauto. intros []; eauto. Qed.

Lemma avg_ok :
  proc_rspec Var.dynamics (impl.(compile_op) (DB.Avg)) impl.(recover) (avg_rspec).
Proof. eapply proc_hspec_to_rspec; [ eapply avg_cok |..]; eauto. intros []; eauto. Qed.

Global Hint Resolve add_ok avg_ok init_cok : core.

Definition rf : LayerRefinement Var.l DB.l.
Proof.
  refine {| Layer.impl := impl;
            Layer.absr := absr; |}.
  - red; intros.
    destruct op.
    + eapply proc_rspec_crash_refines_op; eauto; unfold spec_impl, absr in *; simplify.
      eapply proc_rspec_impl; [| eapply add_ok].
      unfold spec_impl; simplify; firstorder.
      ** exists (n :: sA). unfold puts; firstorder; simpl; congruence.
      ** exists nil. subst. simplify; firstorder.
    + eapply proc_rspec_crash_refines_op; eauto; unfold spec_impl, absr in *; simplify.
      eapply proc_rspec_impl; [| eapply avg_ok].
      unfold spec_impl; simplify; firstorder.
      ** exists sA. unfold puts; firstorder; simpl; congruence.
      ** exists nil. subst. simplify; firstorder.
  - eapply proc_rspec_recovery_refines_crash_step; [ intros; eapply recover_rok |..]; simplify.
    intuition; exists nil; unfold absr in *; simplify; intuition; subst; simplify; try congruence.
  - eapply proc_hspec_init_ok; [ eapply init_cok |..]; firstorder.
    simpl in H. unfold absr. exists nil. simpl; subst; firstorder.
Qed.


Require Export SO_sem_mods high_mods.
Require Import SO_facts1 Monotonicity_SO Correctness_ST pos SO_facts_syn.

Lemma step1_empty : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder) (P : predicate),
  SOQFree alpha = true ->
  Pred_is_pos_SO alpha P ->
  SOturnst W Iv Ip Ir (replace_pred alpha P (Var 1)
                          (negSO (eqFO (Var 1) (Var 1)))) ->
    forall pa : W -> Prop,
      SOturnst W Iv (alt_Ip Ip pa P) Ir alpha.
Proof.
  intros W Iv Ip Ir alpha P SOQFree Hpos SOt pa.
  apply rep_pred_false_pa_f in SOt; auto.
  apply mono_pos; auto.
Qed.

Lemma step2_empty : forall (l : list predicate)
                    (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder),
  SOQFree alpha = true ->
  pos_SO alpha ->
    (SOturnst W Iv Ip Ir (replace_pred_l alpha l
          (nlist_list _ (nlist_var (length l) (Var 1)))
          (nlist_list _ (nlist_empty (length l))))) ->
  forall pa_l : nlist_pa W (length l),
    SOturnst W Iv (alt_Ip_list Ip
     (nlist_list_pa W (length l) pa_l) l) Ir alpha.
Proof.
  induction l; intros W Iv Ip Ir alpha Hno Huni SOt pa_l;
    simpl in *. rewrite alt_Ip_list_nil. auto.
  destruct (nlist_cons W (length l) pa_l) as [pa [pa_l' Heq]].
  rewrite Heq in *. simpl in *.
  destruct (Pred_in_SO_dec alpha a) as [HPocc | HPocc].
  - apply step1_empty; auto.
    apply IHl; auto.
    + apply SOQFree_rep_pred_empty. auto.
    + apply pos_rep_pred; auto.
    + rewrite rep_pred__l_switch_empty; auto.
  - apply P_not_occ_alt. auto.
    apply IHl; auto.
    rewrite rep_pred_Pred_in_SO_f in SOt. auto.
    apply P_occ_rep_pred_l_empty; auto.
Qed.

Lemma step3_empty : forall (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (alpha : SecOrder),
  SOQFree alpha = true ->
  pos_SO alpha ->
    (SOturnst W Iv Ip Ir (replace_pred_l alpha (preds_in alpha)
          (nlist_list _ (nlist_var (length (preds_in alpha)) (Var 1)))
          (nlist_list _ (nlist_empty (length (preds_in alpha)))))) ->
  SOturnst W Iv Ip Ir (uni_closed_SO alpha).
Proof.
  intros. unfold uni_closed_SO.
  apply nlist_list_closed_SO.
  apply step2_empty; auto.
Qed.

Lemma Sahlqvist_pos_pre : forall (phi : Modal) (x : FOvariable),
  pos phi ->
    exists (alpha : SecOrder),
      (forall (D : Set) (Iv:FOvariable -> D) (Ip: predicate -> D -> Prop)
             (Ir: D -> D -> Prop),
      SOturnst D Iv Ip Ir (uni_closed_SO (allFO x (ST phi x))) <->
        SOturnst D Iv Ip Ir alpha) /\
      FO_frame_condition alpha = true.
Proof.
  intros phi x Hun.
  exists (replace_pred_l (allFO x (ST phi x))
          (preds_in (allFO x (ST phi x)))
          (nlist_list _ (nlist_var (length (preds_in (ST phi x))) (Var 1)))
          (nlist_list _ (nlist_empty (length (preds_in (ST phi x)))) )).
  apply conj.
  + intros D Iv Ip Ir.
    apply conj. apply instant_uni_closed; auto.
    simpl; intros H.
    apply step3_empty. apply SOQFree_ST.
    apply pos_SO_allFO. apply pos__SO ; auto.
    auto.
  + rewrite rep_pred_l_allFO. simpl.
    apply FO_frame_condition_rep_pred_l.
    apply FO_frame_condition_l_empty.
Defined.

Lemma Sahlqvist_pos : forall (phi : Modal),
  pos phi ->
    exists (alpha : SecOrder),
    ((forall (W : Set) (R : W -> W -> Prop) (Iv : FOvariable -> W)
           (Ip : predicate -> W -> Prop),
    mturnst_frame W R phi <-> SOturnst W Iv Ip R alpha) /\
    FO_frame_condition alpha = true).
Proof.
  intros phi Hpos.
  destruct (Sahlqvist_pos_pre phi (Var 1) Hpos) as [alpha H].
  exists alpha. apply conj; [|apply H].
  intros W R Iv Ip. split; intros H2.
  apply H. apply correctness_ST; auto.
  apply H in H2. apply correctness_ST in H2. auto.
Defined.


Require Import coqutil.Map.Interface coqutil.Map.Properties bedrock2.Map.Separation bedrock2.Map.SeparationLogic bedrock2.Lift1Prop bedrock2.Array.
Require Import bedrock2.Memory.
Require Import Coq.Lists.List Coq.ZArith.ZArith.
Require Import coqutil.Word.Interface coqutil.Word.Properties coqutil.Map.Interface.
Require Import coqutil.Z.div_mod_to_equations.
Import HList List PrimitivePair.
Require Import coqutil.Z.Lia.
Require Import coqutil.Byte.
Require Import Coq.ZArith.ZArith.

Open Scope Z_scope.

Require Import coqutil.Map.OfListWord.
Require Import Ring_tac.
Section WithWord.
  Local Coercion Z.of_nat : nat >-> Z.
  Local Infix "$+" := map.putmany (at level 70).
  Local Notation "xs $@ a" := (map.of_list_word_at a xs) (at level 10, format "xs $@ a").
  Local Infix "*" := sep : type_scope.
  Local Open Scope sep_scope.
  Context {width : Z} {word : Word.Interface.word width} {word_ok : word.ok word}.
  Context [value] [map : map.map word value] {ok : map.ok map}.
  Add Ring __wring: (@word.ring_theory width word word_ok).
  Lemma sep_eq_of_list_word_at_app (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs) (Htotal : length xs + length ys <= 2^width)
    : Lift1Prop.iff1 (eq ((xs ++ ys)$@a))
      (sep (eq (xs$@a)) (eq (ys$@(word.add a (word.of_Z lxs))))).
  Proof.
    etransitivity.
    2: eapply sep_comm.
    etransitivity.
    2: eapply sep_eq_putmany, map.adjacent_arrays_disjoint_n; trivial.
    erewrite map.of_list_word_at_app_n by eauto; reflexivity.
  Qed.

  Lemma list_word_at_app_of_adjacent_eq (a b : word) (xs ys : list value)
    (Hl: word.unsigned (word.sub b a) = Z.of_nat (length xs))
    (Htotal : length xs + length ys <= 2^width)
    : Lift1Prop.iff1 (eq(xs$@a)*eq(ys$@b)) (eq((xs++ys)$@a)).
  Proof.
    etransitivity.
    2:symmetry; eapply sep_eq_of_list_word_at_app; trivial.
    do 3 Morphisms.f_equiv. rewrite <-Hl, word.of_Z_unsigned. ring.
  Qed.

  Lemma array1_iff_eq_of_list_word_at (a : word) (bs : list value)
    (H : length bs <= 2 ^ width) :
    iff1 (array ptsto (word.of_Z 1) a bs) (eq(bs$@a)).
  Proof.
    symmetry.
    revert H; revert a; induction bs; cbn [array]; intros.
    { rewrite map.of_list_word_nil; cbv [emp iff1]; intuition auto. }
    { etransitivity.
      2: eapply Proper_sep_iff1.
      3: eapply IHbs.
      2: reflexivity.
      2: cbn [length] in H; blia.
      change (a::bs) with (cons a nil++bs).
      rewrite map.of_list_word_at_app.
      etransitivity.
      1: eapply sep_eq_putmany, map.adjacent_arrays_disjoint; cbn [length] in *; blia.
      etransitivity.
      2:eapply sep_comm.
      Morphisms.f_equiv.
      rewrite map.of_list_word_singleton; try exact _.
      cbv [ptsto iff1]; intuition auto. }
  Qed.
End WithWord.

Section Scalars.
  Context {width : Z} {word : Word.Interface.word width} {word_ok : word.ok word}.

  Context {mem : map.map word byte} {mem_ok : map.ok mem}.

  Definition ptsto_bytes (n : nat) (addr : word) (value : tuple byte n) : mem -> Prop :=
    array ptsto (word.of_Z 1) addr (tuple.to_list value).

  Local Notation "xs $@ a" := (map.of_list_word_at a xs) (at level 10, format "xs $@ a").
  Lemma ptsto_bytes_iff_eq_of_list_word_at (n : nat) (addr : word) (value : tuple byte n)
    (H : (Z.of_nat n <= 2 ^ width)%Z) :
    iff1 (ptsto_bytes n addr value) (eq(tuple.to_list value$@addr)).
  Proof. eapply array1_iff_eq_of_list_word_at; rewrite ?tuple.length_to_list; trivial. Qed.

  Lemma load_bytes_of_sep a n bs R m
    (Hsep : sep (ptsto_bytes n a bs) R m)
    : Memory.load_bytes n m a = Some bs.
  Proof.
    cbv [load_bytes footprint].
    revert bs m R a Hsep.
    induction n; [solve[cbn; intros []; trivial]|].
    intros [b0 bs] m R a Hsep.
    cbn in Hsep; eapply SeparationLogic.sep_assoc in Hsep.
    cbn [map.getmany_of_tuple tuple.option_all tuple.map tuple.unfoldn].
    erewrite SeparationLogic.get_sep by exact Hsep.
    match goal with IH: _ |- _ => setoid_rewrite IH; [exact eq_refl|] end.
    unfold ptsto_bytes.
    SeparationLogic.ecancel_assumption.
  Qed.

  Arguments Z.of_nat: simpl never.

  Lemma invert_getmany_of_tuple_Some_footprint
    (n : nat) (a: word) (vs : tuple byte (S n)) (m : mem)
    (D: Z.of_nat n < 2 ^ width)
    (H: map.getmany_of_tuple m (footprint a (S n)) = Some vs):
    exists m', map.split m (map.put map.empty a (pair._1 vs)) m' /\
      map.getmany_of_tuple m' (footprint (word.add a (word.of_Z 1)) n) = Some (pair._2 vs).
  Proof.
    apply map.invert_getmany_of_tuple_Some in H. destruct H as [B1 B2].
    exists (map.remove m a).
    repeat split.
    - apply map.map_ext. intros k.
      pose proof (map.putmany_spec (map.put map.empty a (pair._1 vs)) (map.remove m a) k) as P.
      destruct P as [[v [A B]] | [A B]].
      + rewrite B.
        destruct (word.eqb a k) eqn: E.
        * apply word.eqb_true in E. subst k.
          rewrite map.get_remove_same in A. discriminate.
        * apply word.eqb_false in E.
          rewrite map.get_remove_diff in A by congruence. exact A.
      + rewrite B.
        destruct (word.eqb a k) eqn: E.
        * apply word.eqb_true in E. subst k.
          rewrite map.get_put_same. exact B1.
        * apply word.eqb_false in E.
          rewrite map.get_remove_diff in A by congruence.
          rewrite map.get_put_diff by congruence.
          rewrite map.get_empty. exact A.
    - unfold map.disjoint. intros k ? ? G1 G2.
      destruct (word.eqb a k) eqn: E.
        * apply word.eqb_true in E. subst k.
          rewrite map.get_remove_same in G2. discriminate.
        * apply word.eqb_false in E.
          rewrite map.get_put_diff in G1 by congruence.
          rewrite map.get_empty in G1. discriminate.
    - simpl in B2.
      clear -B2 mem_ok word_ok D. destruct vs as [v vs]. simpl in *.
      assert (0 < 1) as Y by blia.
      assert (1 + Z.of_nat n <= 2 ^ width)%Z as X by blia. clear D.
      revert Y X B2. generalize 1%Z as d. clear v. revert a vs. induction n;
      intros a vs d Y X B2; simpl in *.
      + destruct vs. reflexivity.
      + apply map.invert_getmany_of_tuple_Some in B2. simpl in B2. destruct B2 as [A B].
        destruct vs as [v vs]. simpl in *.
        apply map.build_getmany_of_tuple_Some; simpl.
        * rewrite map.get_remove_diff; [assumption|].
          clear -X Y word_ok.
          intro C.
          apply (f_equal word.unsigned) in C.
          rewrite word.unsigned_add in C.
          rewrite <- word.wrap_unsigned in C at 2.
          apply Z.sub_move_0_r in C.
          apply (f_equal (fun x => x mod (2 ^ width))) in C.
          change (0 mod 2 ^ width) with 0 in C.
          unfold word.wrap in C.
          rewrite <- Zminus_mod in C.
          rewrite Z.add_simpl_l in C.
          rewrite word.unsigned_of_Z in C.
          unfold word.wrap in C.
          rewrite Z.mod_mod in C by blia.
          apply Z.mod_divide in C; [|blia].
          unfold Z.divide in C.
          destruct C as [k C].
          subst d.
          assert (0 < 2 ^ width). {
            pose proof word.width_pos.
            apply Z.pow_pos_nonneg; blia.
          }
          assert (0 < k) by Lia.nia.
          Lia.nia.
        * match goal with IH: _ |- _ => specialize (IH a vs (d + 1)%Z); rename IH into IHn end.
          replace (word.add a (word.of_Z (d + 1)))
            with (word.add (word.add a (word.of_Z d)) (word.of_Z 1)) in IHn.
          { apply IHn; blia || assumption. }
          { rewrite (morph_add word.ring_morph). rewrite word.add_assoc. reflexivity. }
  Qed.

  Lemma sep_of_load_bytes_aux: forall (n: nat) (a: word) (bs: tuple byte n) (m: mem) (Q: mem -> Prop),
      Z.of_nat n <= 2 ^ width ->
      sep (fun m0 => Memory.load_bytes n m0 a = Some bs) Q m ->
      exists R, sep (ptsto_bytes n a bs) (sep R Q) m.
  Proof.
    cbv [load_bytes footprint]. unfold ptsto_bytes.
    intro n; induction n; intros.
    - cbv [ptsto_bytes array tuple.to_list].
      simpl in *. unfold map.getmany_of_tuple, tuple.option_all in *.
      match goal with
      | H: sep _ _ _ |- _ => destruct H as (mp & mq & A & B & C)
      end.
      exists (eq mp).
      apply sep_emp_l. split; auto.
      unfold sep. eauto.
    - match goal with
      | H: sep _ _ _ |- _ => destruct H as (mp & mq & A & B & C)
      end.
      apply invert_getmany_of_tuple_Some_footprint in B; [|blia].
      destruct B as (mo & B1 & B2).
      match goal with
      | x: tuple _ (S _) |- _ => destruct x as [b bs]; simpl in *
      end.

      Fail (* TODO ecancel_assumption why does it fail? *)
      edestruct IHn as [R IH]; [..|exists R; ecancel_assumption].

      Ltac ecancel_assumption_fix_just_for_here :=
        seplog;
        simple refine (cancel_seps_at_indices 0 1 _ _ _ _);
        cbn [SeparationLogic.firstn SeparationLogic.skipn SeparationLogic.app SeparationLogic.hd SeparationLogic.tl];
        [exact (RelationClasses.reflexivity _)|];
        ecancel.

      edestruct IHn as [R IH]; [..|exists R; ecancel_assumption_fix_just_for_here].
      + blia.
      + match goal with
        | |- sep ?BS (sep ?P ?Q) ?m => assert (sep (sep P BS) Q m); [|ecancel_assumption]
        end.
        unfold sep, ptsto, footprint in *. eauto 10.
  Qed.

  (* The side condition is actually needed: If n was bigger than 2^width,
     ptsto_bytes would star together the same address more than once. *)
  Lemma sep_of_load_bytes: forall (n: nat) (a: word) (bs: tuple byte n) (m: mem),
      Z.of_nat n <= 2 ^ width ->
      Memory.load_bytes n m a = Some bs ->
      exists R, sep (ptsto_bytes n a bs) R m.
  Proof.
    intros. edestruct sep_of_load_bytes_aux as [R P].
    - eassumption.
    - apply sep_comm. apply sep_emp_l. split; [apply I|eassumption].
    - eexists; ecancel_assumption.
  Qed.

  Lemma unchecked_store_bytes_of_sep(a: word)(n: nat)(oldbs bs: tuple byte n)(R: mem -> Prop)(m: mem)
    (Hsep : sep (ptsto_bytes n a oldbs) R m)
    : sep (ptsto_bytes n a bs) R (Memory.unchecked_store_bytes n m a bs).
  Proof.
    revert oldbs bs m R a Hsep; induction n; [solve[cbn; intros []; trivial]|].
    intros [oldb0 oldbs] [b0 bs] m R a Hsep.
    cbn in *.
    apply sep_assoc.
    eapply sep_put.
    apply sep_assoc in Hsep.
    match goal with
    | IH: _ |- _ => unshelve epose proof (IH oldbs bs m _ (word.add a (word.of_Z 1)) _)
    end.
    - shelve.
    - unfold ptsto_bytes. ecancel_assumption.
    - seplog.
  Qed.

  Lemma unchecked_store_bytes_of_sep'
      (a: word)(n: nat)(bs1 bs2: tuple byte n)(R1 R2 F: mem -> Prop)(m: mem):
      R1 m ->
      iff1 R1 (sep (ptsto_bytes n a bs1) F) ->
      iff1 R2 (sep (ptsto_bytes n a bs2) F) ->
      R2 (Memory.unchecked_store_bytes n m a bs2).
  Proof. intros A B C. eapply C, unchecked_store_bytes_of_sep, B, A. Qed.

  Lemma store_bytes_of_sep(a: word)(n: nat)(oldbs bs: tuple byte n)(R post: mem -> Prop)(m: mem)
    (Hsep : sep (ptsto_bytes n a oldbs) R m)
    (Hpost : forall m, sep (ptsto_bytes n a bs) R m -> post m)
    : exists m1, Memory.store_bytes n m a bs = Some m1 /\ post m1.
  Proof.
    cbv [store_bytes]. erewrite load_bytes_of_sep; eauto using unchecked_store_bytes_of_sep.
  Qed.
End Scalars.


Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Require TransExpression.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Definition join_branch_info (bi1 : branch_info) (bi2 : branch_info) : res branch_info :=
  match (expr bi1) with
  | None =>
    OK {| expr := (expr bi2); stmt := (stmt bi1 ++ stmt bi2) |}
  | Some e1 =>
    match (expr bi2) with
    | None =>
      OK {| expr := (expr bi1); stmt := (stmt bi1 ++ stmt bi2) |}
    | Some e2 =>
      OK {| expr := (Some (Binary_Expression Binary_AndAnd e1 e2)); stmt := (stmt bi1 ++ stmt bi2) |}
    end
  end.

Fixpoint multiply_inner (bi : branch_info) (bil : list branch_info) : res (list branch_info) :=
  match bil with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- join_branch_info bi hd;
    do v2 <- multiply_inner bi tl;
    OK (v1 :: v2)
  end.

Fixpoint multiply_outer (bil1 : list branch_info) (bil2 : list branch_info) : res (list branch_info) :=
  match bil1 with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- multiply_inner hd bil2;
    do v2 <- multiply_outer tl bil2;
    OK (v1 ++ v2)
  end.

Fixpoint multiply_branch_info (bil1 : list branch_info) (bil2 : list branch_info) : res (list branch_info) :=
  match bil1 with
  | nil =>
    OK bil2
  | _ =>
    match bil2 with
    | nil =>
      OK bil1
    | _ =>
      multiply_outer bil1 bil2
    end
  end.

Fixpoint cons_branch_info_list (el : list expression) (sl : list statement) : res (list branch_info) :=
  match el with
  | nil =>
    OK nil
  | hd :: tl =>
    do v2 <- cons_branch_info_list tl sl;
    OK ({| expr := (Some hd); stmt := sl |} :: v2)
  end.

Definition trans_if_branch (ib : if_branch) : res (list branch_info) :=
  match ib with
  | If_Branch expr stmt_list =>
    do expr_list <- TransExpression.reorder_expression expr;
    cons_branch_info_list expr_list stmt_list
  end.

Fixpoint trans_if_branch_list (ibl : list if_branch) : res (list branch_info) :=
  match ibl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_if_branch hd;
    do v2 <- trans_if_branch_list tl;
    OK (v1 ++ v2)
  end.

Definition trans_select_statement (s : select_statement) : res (list branch_info) :=
  match s with
  | As_If if_stmt =>
    match if_stmt with
    | If_Statement if_branch_list else_branch =>
      trans_if_branch_list if_branch_list
    end
  | As_Simple simple_stmt =>
    OK ({| expr := None; stmt := (simple_stmt :: nil) |} :: nil)
  end.

Fixpoint trans_select_statement_list (sl : list select_statement) : res (list branch_info) :=
  match sl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_select_statement hd;
    do v2 <- trans_select_statement_list tl;
    multiply_branch_info v1 v2
  end.

Fixpoint mix_branch_info (bill : list (list branch_info)) : res (list branch_info) :=
  match bill with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- mix_branch_info tl;
    multiply_branch_info hd v1
  end.


Require Import Spec.ConcurExec.
Require Import Spec.ThreadsState.
Require Import Spec.Equiv.Execution.

Require Import ProofAutomation.
Require Import Spec.Equiv.Automation.
Require Import Helpers.Instances.

Require Import Relations.Relation_Operators.
Require Import Morphisms.
Require Import List.
Require Import Omega.

Global Set Implicit Arguments.
Global Generalizable All Variables.

Section OpSemantics.

  Context {Op:Type -> Type}.
  Context {State:Type}.
  Variable op_step: OpSemantics Op State.

  Local Obligation Tactic := try RelInstance_t.

  (** Trace inclusion for an entire threads_state *)

  Definition trace_incl_ts_s s (ts1 ts2 : threads_state Op) :=
    forall tr,
      exec op_step s ts1 tr ->
      exec op_step s ts2 tr.

  Definition trace_incl_ts (ts1 ts2 : threads_state Op) :=
    forall tr (s : State),
      exec op_step s ts1 tr ->
      exec op_step s ts2 tr.

  Global Program Instance trace_incl_ts_preorder :
    PreOrder trace_incl_ts.
  Next Obligation.
    hnf; intros.
    eauto.
  Qed.
  Next Obligation.
    unfold trace_incl_ts in *; eauto.
  Qed.

  Global Instance exec_equiv_ts_to_trace_incl_ts :
    subrelation (exec_equiv_ts op_step) trace_incl_ts.
  Proof.
    unfold subrelation; intros.
    unfold trace_incl_ts; intros.
    apply H in H0.
    eauto.
  Qed.

  (** Trace inclusion for a single thread *)

  Definition trace_incl_s `(s : State) tid `(p1 : proc Op T) (p2 : proc _ T) :=
    forall ts,
      trace_incl_ts_s s
                      (ts [[ tid := Proc p1 ]])
                      (ts [[ tid := Proc p2 ]]).

  Definition trace_incl {T} (p1 p2 : proc Op T) :=
    forall (ts : threads_state Op) tid,
      trace_incl_ts
        (ts [[ tid := Proc p1 ]])
        (ts [[ tid := Proc p2 ]]).

  (* natural definition of trace_incl_rx, defined in terms of all executions
     (that is, without requiring counters be identical) *)
  Definition trace_incl_rx' {T} (p1 p2 : proc Op T) :=
    forall TF (rx1 rx2: _ -> proc _ TF),
      (forall a, trace_incl (rx1 a) (rx2 a)) ->
      trace_incl (Bind p1 rx1) (Bind p2 rx2).

  Hint Constructors exec_tid.
  Hint Constructors exec_till.

  Theorem trace_incl_trace_incl_s : forall T (p1 p2 : proc Op T),
      trace_incl p1 p2 <->
      (forall s tid,
          trace_incl_s s tid p1 p2).
  Proof.
    unfold trace_incl, trace_incl_s, trace_incl_ts, trace_incl_ts_s.
    split; eauto.
  Qed.

  Ltac forward_chaining :=
    repeat (hnf; intros);
    repeat match goal with
           | [ H: _ |- _ ] => apply H
           end.

  Local Obligation Tactic := try solve [ forward_chaining ].

  Global Program Instance trace_incl_s_preorder :
    PreOrder (@trace_incl_s s tid T).

  Global Program Instance trace_incl_preorder :
    PreOrder (@trace_incl T).

  Global Program Instance exec_equiv_to_trace_incl :
    subrelation (exec_equiv op_step (T:=T)) (@trace_incl T).

  Global Program Instance trace_incl_proper :
    Proper (Basics.flip (@trace_incl T) ==>
                        @trace_incl T ==>
                        Basics.impl) (@trace_incl T).

  Global Program Instance trace_incl_proper_flip :
    Proper (@trace_incl T ==>
                        Basics.flip (@trace_incl T) ==>
                        Basics.flip Basics.impl) (@trace_incl T).

  Global Program Instance trace_incl_s_proper :
    Proper (Basics.flip (@trace_incl T) ==>
                        @trace_incl T ==>
                        Basics.impl) (@trace_incl_s s tid T).

  Global Program Instance trace_incl_s_proper_flip :
    Proper (@trace_incl T ==>
                        Basics.flip (@trace_incl T) ==>
                        Basics.flip Basics.impl) (@trace_incl_s s tid T).

  Global Program Instance trace_incl_s_exec_equiv_proper :
    Proper (exec_equiv op_step ==> exec_equiv op_step ==> iff)
           (@trace_incl_s s tid T).
  Next Obligation.
    split; forward_chaining.
  Qed.

  Global Program Instance trace_incl_exec_equiv_proper :
    Proper (exec_equiv op_step ==> exec_equiv op_step ==> iff)
           (@trace_incl T).
  Next Obligation.
    split; forward_chaining.
  Qed.

  Local Lemma trace_incl_ts_s_proof_helper :
    forall `(p1 : proc Op T) (p2 : proc _ T) ts tid s,
      (forall (ts: threads_state _) tid' s0 s' result tr spawned evs,
          exec_others op_step tid s s0 ->
          ts tid' = NoProc ->
          tid <> tid' ->
          exec_tid op_step tid s0 p1 s' result spawned evs ->
          exec op_step s' (ts [[tid' := spawned]] [[tid := match result with
                                                           | inl _ => NoProc
                                                           | inr p' => Proc p'
                                                           end]]) tr ->
          exec op_step s0 (ts [[tid := Proc p2]]) (prepend tid evs tr)) ->
      trace_incl_ts_s s
                      (ts [[ tid := Proc p1 ]])
                      (ts [[ tid := Proc p2 ]]).
  Proof.
    unfold trace_incl_ts_s.
    intros.
    ExecEquiv tt.
    ExecPrefix tid0 tid'.
    abstract_ts.
    eapply IHexec; intros; eauto with exec.
    auto with nocore exec.

    Grab Existential Variables.
    all: exact (Ret tt).
  Qed.

  Lemma trace_incl_proof_helper :
    forall `(p1 : proc Op T) p2,
      (forall tid tid' (ts: threads_state _) s s' result tr spawned evs,
          exec_tid op_step tid s p1 s' result spawned evs ->
          ts tid' = NoProc ->
          tid <> tid' ->
          exec op_step s' (ts [[tid' := spawned]] [[tid := match result with
                                                           | inl _ => NoProc
                                                           | inr p' => Proc p'
                                                           end]]) tr ->
          exec op_step s (ts [[tid := Proc p2]]) (prepend tid evs tr)) ->
      trace_incl p1 p2.
  Proof.
    unfold trace_incl, trace_incl_ts.
    intros.

    eapply trace_incl_ts_s_proof_helper; eauto.
  Qed.

  Lemma trace_incl_s_proof_helper :
    forall `(p1 : proc Op T) p2 s tid,
      (forall (ts: threads_state _) tid' s0 s' result tr spawned evs,
          exec_others op_step tid s s0 ->
          ts tid' = NoProc ->
          tid <> tid' ->
          exec_tid op_step tid s0 p1 s' result spawned evs ->
          exec op_step s' (ts [[tid' := spawned]] [[tid := match result with
                                                           | inl _ => NoProc
                                                           | inr p' => Proc p'
                                                           end]]) tr ->
          exists tr',
            exec op_step s0 (ts [[tid := Proc p2]]) tr' /\
            prepend tid evs tr = tr') ->
      trace_incl_s s tid p1 p2.
  Proof.
    unfold trace_incl_s.
    intros.

    eapply trace_incl_ts_s_proof_helper.
    intros.
    eapply H in H2; eauto.
    propositional.
  Qed.

  Theorem trace_incl_op :
    forall `(p : T -> proc Op T') op,
      trace_incl
                 (Bind (Call op) p)
                 (Bind (Atomic (Call op)) p).
  Proof.
    intros.
    eapply trace_incl_proof_helper; intros.
    repeat exec_tid_inv.

    ExecPrefix tid tid'.
  Qed.

  Theorem trace_incl_bind_a : forall `(p : proc Op T) `(p2 : T -> proc _ T') p2',
      (forall x, trace_incl (p2 x) (p2' x)) ->
      trace_incl (Bind p p2) (Bind p p2').
  Proof.
    unfold trace_incl, trace_incl_ts, trace_incl_ts_s.
    intros.

    ExecEquiv p.
    destruct result0; guess_ExecPrefix.
  Qed.

  Theorem trace_incl_s_bind_a : forall `(p : proc Op T) `(p2 : T -> proc _ T') p2' s tid,
      (forall s' x,
          exec_any op_step tid s p x s' ->
          trace_incl_s s' tid (p2 x) (p2' x)) ->
      trace_incl_s s tid (Bind p p2) (Bind p p2').
  Proof.
    unfold trace_incl_s, trace_incl_ts_s.
    intros.

    thread_upd_ind p.

    cmp_ts tid0 tid.
    + repeat maybe_proc_inv.
      exec_tid_inv.
      destruct result0.

      * ExecPrefix tid tid'.
        eauto.
      * ExecPrefix tid tid'.
        eauto.

    + ExecPrefix tid0 tid'.
      abstract_ts.
      eapply IHexec; intros; eauto with exec.
      eauto with exec.
  Qed.

  Global Instance Bind_trace_incl_proper_2 :
    Proper (eq ==> pointwise_relation T0 (@trace_incl T) ==>
               @trace_incl T) Bind.
  Proof.
    intros.
    intros p1a p1b H1; subst.
    intros p2a p2b H2.
    eapply trace_incl_bind_a; intros.
    eapply H2.
  Qed.

End OpSemantics.

(** Correspondence between different layers *)

Definition traces_match_ts {OpLo OpHi State} lo_step hi_step
           (ts1 : threads_state OpLo)
           (ts2 : threads_state OpHi) :=
  forall (s : State) tr1,
    exec lo_step s ts1 tr1 ->
    exec hi_step s ts2 tr1.

Global Instance traces_match_ts_proper :
  Proper (@trace_incl_ts OpLo State lo_step ==>
                         @exec_equiv_ts OpHi State hi_step ==>
                         Basics.flip Basics.impl)
         (@traces_match_ts OpLo OpHi State lo_step hi_step).
Proof.
  repeat (hnf; intros).
  repeat match goal with
         | [ H: _ |- _ ] => apply H
         end.
Qed.


Require Import List.

Set Universe Polymorphism.

Class Monad@{d c} (m : Type@{d} -> Type@{c}) : Type :=
{ ret : forall {t : Type@{d}}, t -> m t
; bind : forall {t u : Type@{d}}, m t -> (t -> m u) -> m u
}.

Class MonadExc E (m : Type -> Type) : Type :=
{ raise : forall {T}, E -> m T
; catch : forall {T}, m T -> (E -> m T) -> m T
}.

Delimit Scope monad_scope with monad.

Notation "c >>= f" := (@bind _ _ _ _ c f) (at level 50, left associativity) : monad_scope.
Notation "f =<< c" := (@bind _ _ _ _ c f) (at level 51, right associativity) : monad_scope.

Notation "x <- c1 ;; c2" := (@bind _ _ _ _ c1 (fun x => c2))
  (at level 100, c1 at next level, right associativity) : monad_scope.

Notation "e1 ;; e2" := (_ <- e1%monad ;; e2%monad)%monad
  (at level 100, right associativity) : monad_scope.

Instance option_monad : Monad option :=
  {| ret A a := Some a ;
     bind A B m f :=
       match m with
       | Some a => f a
       | None => None
       end
  |}.

Open Scope monad.

Section MapOpt.
  Context {A} (f : A -> option A).

  Fixpoint mapopt (l : list A) : option (list A) :=
    match l with
    | nil => ret nil
    | x :: xs => x' <- f x ;;
                xs' <- mapopt xs ;;
                ret (x' :: xs')
    end.
End MapOpt.

Section MonadOperations.
  Context {T} {M : Monad T}.
  Context {A B} (f : A -> T B).
  Fixpoint monad_map (l : list A)
    : T (list B)
    := match l with
       | nil => ret nil
       | x :: l => x' <- f x ;;
                  l' <- monad_map l ;;
                  ret (x' :: l')
       end.

  Context (g : A -> B -> T A).
  Fixpoint monad_fold_left (l : list B) (x : A) : T A
    := match l with
       | nil => ret x
       | y :: l => x' <- g x y ;;
                   monad_fold_left l x'
       end.

  Context (h : nat -> A -> T B).
  Fixpoint monad_map_i_aux (n0 : nat) (l : list A) : T (list B)
    := match l with
       | nil => ret nil
       | x :: l => x' <- (h n0 x) ;;
                   l' <- (monad_map_i_aux (S n0) l) ;;
                   ret (x' :: l')
       end.

  Definition monad_map_i := @monad_map_i_aux 0.
End MonadOperations.

(* Error monad *)
Inductive result E A :=
| Success : A -> result E A
| Error : E -> result E A.

Arguments Success {_ _} _.
Arguments Error {_ _} _.

Instance error_monad E : Monad (result E) :=
  {| ret A a := Success a ;
     bind A B m f :=
       match m with
       | Success a => f a
       | Error e => Error e
       end
  |}.

Instance monad_exc E : MonadExc E (result E) :=
  { raise A e := Error e;
    catch A m f :=
      match m with
      | Success a => m
      | Error t => f t
      end
  }.


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

Require Import String List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Named Require Import Core Elab SimpleSubst Matches.
Import Core.Notations.

Require Coq.derive.Derive.

(*TODO: flip rule*)
Definition prod_lang :=
  [
  [:= "G" : #"env", "A" : #"ty", "B" : #"ty",
      "e" : #"exp" "G" (#"prod" "A" "B"),
      "G'" : #"env",
      "g" : #"sub" "G'" "G"
      ----------------------------------------------- ("proj_2_subst")
      #"subst" "g" (#".2" "e")
      = #".2" (#"subst" "g" "e")
      : #"exp" "G'" "B"
  ];
  [:= "G" : #"env", "A" : #"ty", "B" : #"ty",
      "e" : #"exp" "G" (#"prod" "A" "B"),
      "G'" : #"env",
      "g" : #"sub" "G'" "G"
      ----------------------------------------------- ("proj_1_subst")
      #"subst" "g" (#".1" "e")
      = #".1" (#"subst" "g" "e")
      : #"exp" "G'" "A"
  ];
  [:= "G" : #"env", "A" : #"ty", "B" : #"ty",
      "e" : #"exp" "G" "A",
      "e'" : #"exp" "G" "B",
      "G'" : #"env",
      "g" : #"sub" "G'" "G"
      ----------------------------------------------- ("pair_subst")
      #"subst" "g" (#"pair" "e" "e'")
      = #"pair" (#"subst" "g" "e") (#"subst" "g" "e'")
      : #"exp" "G'" (#"prod" "A" "B")
  ];
  [:= "G" : #"env", "A" : #"ty", "B" : #"ty",
      "v" : #"exp" "G" (#"prod" "A" "B")
      ----------------------------------------------- ("prod_eta")
      #"pair" (#".1" "v") (#".2" "v") = "v"
      : #"exp" "G" (#"prod" "A" "B")
  ];
  [:= "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "v1" : #"exp" "G" "A",
      "v2" : #"exp" "G" "B"
      ----------------------------------------------- ("project 2")
      #".2" (#"pair" "v1" "v2") = "v2"
      : #"exp" "G" "B"
  ];
  [:= "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "v1" : #"exp" "G" "A",
      "v2" : #"exp" "G" "B"
      ----------------------------------------------- ("project 1")
      #".1" (#"pair" "v1" "v2") = "v1"
      : #"exp" "G" "A"
  ];
    [:| "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"exp" "G" (#"prod" "A" "B")
      -----------------------------------------------
      #".2" "e" : #"exp" "G" "B"
   ];
  [:| "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"exp" "G" (#"prod" "A" "B")
      -----------------------------------------------
      #".1" "e" : #"exp" "G" "A"
   ];
  [:| "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e1" : #"exp" "G" "A",
      "e2" : #"exp" "G" "B"
      -----------------------------------------------
      #"pair" "e1" "e2" : #"exp" "G" (#"prod" "A" "B")
   ];
  [:| "A" : #"ty", "B": #"ty"
      -----------------------------------------------
      #"prod" "A" "B" : #"ty"
  ]]%rule.

Derive prod_elab
       SuchThat (Pre.elab_lang subst_elab prod_lang prod_elab)
       As prod_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve prod_wf : elab_pfs.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^212 - 29
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 32;
    bitwidth := 32;
    s := 2^212;
    c := [(1, 29)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.