(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
(*Functions for working with arrays and memory in VST that are generic*)

(*These first two are not directly related to VST but are used in the later proofs*)
Lemma Zlength_concat: forall {A: Type} (n m : Z) (l: list (list A)),
  Zlength l = n ->
  Forall (fun x => Zlength x = m) l ->
  Zlength (concat l) = n * m.
Proof.
  intros A m n l. revert m. induction l; intros.
  - list_solve.
  - simpl. rewrite Zlength_app. rewrite (IHl (m-1)). 2: list_solve.
    assert (Zlength a = n). inversion H0; subst; reflexivity. rewrite H1. lia. inversion H0; auto.
Qed.

Lemma lt_plus_lt: forall z1 z2 z3,
  0 <= z1 ->
  z1 + z2 < z3 ->
  z2 < z3.
Proof.
  intros z1 z2 z3 Hz1 Hz12. rewrite Z.lt_add_lt_sub_r in Hz12. lia.
Qed.

Lemma typed_false_not_true: forall a b, typed_false a b -> ~(typed_true a b).
Proof.
  intros a b F T.
  unfold typed_true in T; unfold typed_false in F; rewrite T in F; inversion F.
Qed.

(** Facts about [combine]*)
(*This function is in the standard library, but we need a few results about how functions like Znth, Zlength,
  and sublist work with combine*)
Lemma combine_Zlength: forall {A B : Type} (l1: list A) (l2: list B),
  Zlength l1 = Zlength l2 ->
  Zlength (combine l1 l2) = Zlength l1.
Proof.
  intros A B l1 l2 Hlen. rewrite !Zlength_correct in *. rewrite combine_length. lia.
Qed.

Lemma combine_Znth: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} (l1 : list A) (l2: list B) i,
  Zlength l1 = Zlength l2 ->
  0 <= i < Zlength l1 ->
  Znth i (combine l1 l2) = (Znth i l1, Znth i l2).
Proof.
  intros. rewrite <- !nth_Znth. apply combine_nth. rewrite <- !ZtoNat_Zlength; lia.
  lia. lia. rewrite combine_Zlength; lia.
Qed.

Lemma combine_sublist: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} (lo hi : Z) (l1 : list A) (l2: list B),
  Zlength l1 = Zlength l2 ->
  0 <= lo <= hi ->
  hi <= Zlength l1 ->
  combine (sublist lo hi l1) (sublist lo hi l2) = sublist lo hi (combine l1 l2).
Proof.
  intros A B Hinh1 Hinh2 lo hi l1 l2 Hlen Hhilo Hhi.
  assert (Hsublen: Zlength (combine (sublist lo hi l1) (sublist lo hi l2)) = hi - lo). {
   rewrite combine_Zlength by (rewrite !Zlength_sublist; lia). list_solve. }
  apply Znth_eq_ext. rewrite Hsublen. rewrite Zlength_sublist; try lia.
  rewrite combine_Zlength; lia.
  intros i Hi. rewrite Hsublen in Hi. rewrite combine_Znth by list_solve.
  rewrite !Znth_sublist by lia. rewrite combine_Znth by lia. reflexivity.
Qed.

Lemma combine_app: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} (l1 l3: list A) (l2 l4: list B),
  Zlength l1 = Zlength l2 ->
  Zlength l3 = Zlength l4 ->
  combine (l1 ++ l3) (l2 ++ l4) = combine l1 l2 ++ combine l3 l4.
Proof.
  intros A B Hin1 Hin2 l1 l3 l2 l4 Hlen1 Hlen3.
  apply Znth_eq_ext.
  - rewrite !combine_Zlength by list_solve. rewrite !Zlength_app. rewrite !combine_Zlength; list_solve.
  - intros i Hilen. rewrite combine_Zlength in Hilen by list_solve. rewrite combine_Znth by list_solve.
    assert (0 <= i < Zlength l1 \/ Zlength l1 <= i < Zlength l1 + Zlength l3) by list_solve.
    destruct H as [Hfst | Hsnd].
    + rewrite !Znth_app1; try lia. rewrite combine_Znth by lia. reflexivity.
      rewrite combine_Zlength; lia.
    + rewrite !Znth_app2; try lia. rewrite combine_Znth; try lia. all: rewrite combine_Zlength; try lia.
      rewrite Hlen1. reflexivity.
Qed.

Section VSTFacts.

Context {Comp : compspecs}.

(** Working with pointers that we treat as arrays*)

(*For simplifying pointer arithmetic*)
Lemma sem_sub_pi_offset: forall ty s off n,
  isptr s ->
  complete_type cenv_cs ty = true ->
  Int.min_signed <= n <= Int.max_signed ->
  force_val (sem_sub_pi ty Signed (offset_val off s) (Vint (Int.repr n))) =
  offset_val (off - (sizeof ty) * n) s.
Proof.
  intros ty s off n Hptr Hty Hn.
  replace (off - (sizeof ty) * n) with (off + (- (sizeof ty) * n)) by lia. rewrite <- offset_offset_val.
  assert (Hptr' : isptr (offset_val off s)). rewrite isptr_offset_val; auto.
  destruct (offset_val off s) eqn : Hoff; inversion Hptr'. simpl.
  unfold sem_sub_pi. rewrite Hty. simpl. f_equal. unfold sizeof.
  assert ((Ptrofs.of_ints (Int.repr n)) = Ptrofs.repr n). unfold Ptrofs.of_ints.
  f_equal. apply Int.signed_repr; auto. rewrite H. rewrite ptrofs_mul_repr.
  rewrite Ptrofs.sub_add_opp. f_equal. replace (- Ctypes.sizeof ty * n) with (-(Ctypes.sizeof ty * n)) by lia.
  rewrite <- (Ptrofs.neg_repr). reflexivity.
Qed.

(*Indexing into arrays*)

Lemma arr_field_compatible0 : forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  field_compatible0 (tarray t size) (SUB i) p.
Proof.
  intros t size p i Hcomp Hsz.
  unfold field_compatible in *. unfold field_compatible0. destruct Hcomp as [Hptr [Hleg [Hsz_comp [Hal Hnest]]]].
  repeat(split; auto).
Qed.

Lemma arr_field_address0: forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  field_address0 (tarray t size) (SUB i) p = offset_val (sizeof t * i) p.
Proof.
  intros t size p i Hcomp Hi.
  unfold field_address0. destruct (field_compatible0_dec (tarray t size) [ArraySubsc i] p).
  simpl. auto. exfalso. apply n. apply arr_field_compatible0; auto.
Qed.

Lemma arr_field_compatible : forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i < size ->
  field_compatible (tarray t size) (SUB i) p.
Proof.
  intros t size p i Hcomp Hsz.
  unfold field_compatible in *. unfold field_compatible0. destruct Hcomp as [Hptr [Hleg [Hsz_comp [Hal Hnest]]]].
  repeat(split; auto).
Qed.

Lemma arr_field_address: forall t size p i,
  field_compatible (tarray t size) [] p ->
  0 <= i < size ->
  field_address (tarray t size) (SUB i) p = offset_val (sizeof t * i) p.
Proof.
  intros t size p i Hcomp Hi.
  unfold field_address. destruct (field_compatible_dec (tarray t size) [ArraySubsc i] p).
  simpl. auto. exfalso. apply n. apply arr_field_compatible; auto.
Qed.

(*Useful for proving that pointers are valid for conditionals*)
Lemma isptr_denote_tc_test_order: forall p1 p2,
  isptr p1 ->
  isptr p2 ->
  denote_tc_test_order p1 p2 = test_order_ptrs p1 p2.
Proof.
  intros p1 p2 Hptr1 Hptr2. destruct p1; destruct Hptr1. destruct p2; destruct Hptr2. reflexivity.
Qed.

Lemma isptr_offset_val_sameblock : forall p i,
  isptr p ->
  sameblock p (offset_val i p) = true.
Proof.
  intros. destruct p; destruct H.
  simpl. unfold proj_sumbool. apply peq_true.
Qed.

Lemma sameblock_refl : forall p,
  isptr p ->
  sameblock p p = true.
Proof.
  intros.
  destruct p; destruct H. apply peq_true.
Qed.

Lemma sameblock_symm : forall p1 p2,
  sameblock p1 p2 = true ->
  sameblock p2 p1 = true.
Proof.
  intros.
  destruct p1; destruct p2; try discriminate.
  simpl in *. destruct (peq b b0); try discriminate.
  subst.
  apply peq_true.
Qed.

Lemma sameblock_trans : forall p1 p2 p3,
  sameblock p1 p2 = true ->
  sameblock p2 p3 = true->
  sameblock p1 p3 = true.
Proof.
  intros.
  destruct p1; try discriminate.
  destruct p2; try discriminate.
  destruct p3; try discriminate.
  simpl in *.
  destruct (peq b b0); try discriminate.
  destruct (peq b0 b1); try discriminate.
  subst.
  apply peq_true.
Qed.

Lemma sameblock_offset_val: forall p n1 n2,
  isptr p ->
  sameblock (offset_val n1 p) (offset_val n2 p) = true.
Proof.
  intros p n1 n2 Hptr. eapply sameblock_trans. eapply sameblock_symm.
  all: apply isptr_offset_val_sameblock; auto.
Qed.

(*Transform the "if" condition in a pointer comparison into something usable (for the gt case)*)
Lemma ptr_comparison_gt_iff: forall t size p i j,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  0 <= j <= size ->
  0 < sizeof t ->
  isptr p ->
  typed_true tint (force_val (sem_cmp_pp Cgt (field_address0 (tarray t size) (SUB i) p)
    (field_address0 (tarray t size) (SUB j) p))) <-> i > j.
Proof.
  intros t size p i j Hcomp Hi Hj Hszof Hptr.
  assert (Hptri : isptr (field_address0 (tarray t size) [ArraySubsc i] p)).
  apply field_address0_isptr. apply arr_field_compatible0; auto.
  assert (Hptrj: isptr (field_address0 (tarray t size) [ArraySubsc j] p)).
  apply field_address0_isptr. apply arr_field_compatible0; auto.
  rewrite force_sem_cmp_pp; auto. unfold compare_pp.
  destruct (field_address0 (tarray t size) [ArraySubsc i] p) eqn : Fi; inversion Hptri.
  destruct (field_address0 (tarray t size) [ArraySubsc j] p) eqn : Fj; inversion Hptrj.
  clear Hptri Hptrj.
  assert (Hsame: sameblock (Vptr b i0) (Vptr b0 i1) = true). { rewrite <- Fi. rewrite <- Fj.
  rewrite !arr_field_address0; auto. eapply sameblock_trans. apply sameblock_symm.
  all: apply  isptr_offset_val_sameblock; auto. }
  simpl in Hsame. unfold eq_block. destruct (peq b b0); try inversion Hsame. subst. clear Hsame.
  simpl. rewrite arr_field_address0 in Fi; auto. rewrite arr_field_address0 in Fj; auto.
  destruct p; inversion Hptr. simpl in *. inversion Fi; subst. inversion Fj; subst.
  clear Fi Fj Hptr. unfold Ptrofs.ltu.
  assert (Hi2 : 0 <= Ptrofs.unsigned i2) by rep_lia. unfold field_compatible in Hcomp.
  destruct Hcomp as [Ht [Hcomp [HHsz Hrest]]]. simpl in HHsz.
  replace (Z.max 0 size) with size in HHsz by lia.
  (*We will use these a bunch of times*)
  assert (Hij: forall k, 0 <= k <= size -> 0 <= sizeof t * k < Ptrofs.modulus). {
    intros k Hk. unfold sizeof in *. split. lia.
    assert (Ctypes.sizeof t * k <= Ctypes.sizeof t * size).  apply Z.mul_le_mono_pos_l; lia.
    assert (Ctypes.sizeof t * size < Ptrofs.modulus). apply (lt_plus_lt (Ptrofs.unsigned i2)). lia. assumption.
    lia. }
  assert (Hij' : forall k, 0 <= k <= size ->
      0 <= Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * k)) < Ptrofs.modulus). {
    intros k Hk. unfold sizeof in *. rewrite Ptrofs.unsigned_repr_eq. rewrite Zmod_small.
    2: apply Hij; lia. split. lia.
    assert (Ptrofs.unsigned i2 + Ctypes.sizeof t * k <= Ptrofs.unsigned i2 + Ctypes.sizeof t * size).
    apply Zplus_le_compat_l. apply Z.mul_le_mono_nonneg_l; lia. eapply Z.le_lt_trans. apply H. assumption. }
  unfold Ptrofs.unsigned. simpl. rewrite !Ptrofs.Z_mod_modulus_eq. rewrite !Zmod_small.
  all: try apply Hij'; auto.
  destruct (zlt (Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * j)))
          (Ptrofs.unsigned i2 + Ptrofs.unsigned (Ptrofs.repr (sizeof t * i)))).
    - assert (Hptrlt: Ptrofs.unsigned (Ptrofs.repr (sizeof t * j)) < Ptrofs.unsigned (Ptrofs.repr (sizeof t * i))) by lia.
      clear l. unfold Ptrofs.unsigned in Hptrlt. simpl in Hptrlt. rewrite !Ptrofs.Z_mod_modulus_eq in Hptrlt.
      rewrite !Zmod_small in Hptrlt. rewrite <- Z.mul_lt_mono_pos_l in Hptrlt; auto. all: try apply Hij; auto.
      split; intros; auto. lia. reflexivity.
    - assert (Hptrlt: Ptrofs.unsigned (Ptrofs.repr (sizeof t * i)) <= Ptrofs.unsigned (Ptrofs.repr (sizeof t * j))) by lia.
      clear g. unfold Ptrofs.unsigned in Hptrlt. simpl in Hptrlt. rewrite !Ptrofs.Z_mod_modulus_eq in Hptrlt.
      rewrite !Zmod_small in Hptrlt. rewrite <- Z.mul_le_mono_pos_l in Hptrlt; auto. all: try apply Hij; auto.
      split; intros; try lia. inversion H.
Qed.

(*Switch Cgt and Clt*)
Lemma cgt_clt_ptr: forall p1 p2,
  sem_cmp_pp Cgt p1 p2 = sem_cmp_pp Clt p2 p1.
Proof.
  intros p1 p2. unfold sem_cmp_pp. simpl. f_equal. unfold Val.cmplu_bool.
  destruct p1; destruct p2; auto. destruct (Archi.ptr64); auto; simpl.
  destruct (eq_block b b0). subst. destruct (eq_block b0 b0); try contradiction.
  reflexivity. destruct (eq_block b0 b); subst; auto. contradiction.
Qed.

(*Same for the lt case. This is an easy corollary of the above 2 lemmas*)
Lemma ptr_comparison_lt_iff: forall t size p i j,
  field_compatible (tarray t size) [] p ->
  0 <= i <= size ->
  0 <= j <= size ->
  0 < sizeof t ->
  isptr p ->
  typed_true tint (force_val (sem_cmp_pp Clt (field_address0 (tarray t size) (SUB i) p)
    (field_address0 (tarray t size) (SUB j) p))) <-> i < j.
Proof.
  intros t sz p i j Hcompat Hi Hj Ht Hptr. rewrite <- cgt_clt_ptr.
  rewrite ptr_comparison_gt_iff by auto. lia.
Qed.

(** Working with 2D Arrays*)

(*We can consider an instance of t at position p to be a valid array of length 1 at p*)
Lemma data_at_array_len_1: forall sh t a p,
data_at sh t a p |-- !! field_compatible (tarray t 1) [] p.
Proof.
  intros. erewrite <- data_at_singleton_array_eq. 2: reflexivity. entailer!.
Qed.

(*The crucial lemma for showing the relationship between 1D and 2D arrays: if we move over 1 array (in the 2D array)
  or m places (in the 1D array), the result is still compatible*)
Lemma field_compatible0_1d_2d: forall n m t p,
  0 <= m ->
  0 < n ->
  field_compatible (Tarray t m noattr) [] p ->
  (field_compatible0 (tarray (tarray t m) n)) [ArraySubsc 1] p <->
  (field_compatible0 (tarray t (n * m)) [ArraySubsc m] p).
Proof.
  intros n m t p Hm Hn Hfst.
  unfold field_compatible in Hfst. unfold field_compatible0.
  simpl in *. destruct Hfst as [Hptr1 [Hleg1 [Hszc1 [Hal1 Hlegn1]]]].
  clear Hlegn1.
  (*The interesting part*)
  assert (size_compatible (tarray (tarray t m) n) p /\ align_compatible (tarray (tarray t m) n) p <->
    size_compatible (tarray t (n * m)) p /\ align_compatible (tarray t (n * m)) p ). {
   unfold size_compatible. destruct p; inversion Hptr1. simpl in *.
    replace (Z.max 0 m) with m by lia.
    replace (Z.max 0 n) with n by lia.
    replace (Z.max 0 (n * m)) with (m * n) by lia.
    rewrite Z.mul_assoc. split; intros [Hszc2 Hal2].
    - split. assumption. inversion Hal2; subst. inversion H.
      inversion Hal1; subst. inversion H.
      apply align_compatible_rec_Tarray. intros j Hj.
      assert (m = 0 \/ m > 0) by lia. destruct H as [H | Hm0]. subst. lia.
      assert (0 <= j < m \/ m <= j < n * m) by lia. destruct H as [Hfst | Hrest].
      + specialize (H4 _ Hfst). apply H4.
      + (*To index into the rest of the array, we need to use j/ m and j %m, which gives lots of annoying proof obligations*)
        assert (0 <= j / m  < n). { split. assert (1 <= j / m). rewrite <- (Z_div_same _ Hm0).
        apply Z_div_le; lia. lia. apply Z.div_lt_upper_bound; lia. }
        specialize (H3 _ H). clear H4. inversion H3; subst. inversion H0.
        assert (0 <= j mod m < m). { apply Z.mod_pos_bound; lia. }
        specialize (H5 _ H0). replace (Ptrofs.unsigned i + Ctypes.sizeof t * j) with
        (Ptrofs.unsigned i + Ctypes.sizeof (tarray t m) * (j / m) + Ctypes.sizeof t * (j mod m)). apply H5.
        rewrite <- !Z.add_assoc. f_equal. simpl Ctypes.sizeof. replace (Z.max 0 m) with m by lia.
        rewrite <- Z.mul_assoc. rewrite <- Z.mul_add_distr_l. f_equal.
        replace (Z.max 0 m) with m by lia.
        rewrite <- Z_div_mod_eq_full. reflexivity.
    - split. assumption. inversion Hal2; subst. inversion H.
      inversion Hal1; subst. inversion H.  apply align_compatible_rec_Tarray. intros j Hj.
      apply align_compatible_rec_Tarray. intros k Hk.
      assert (0 = j \/ 1 <= j) by lia. destruct H as [Hfst | Hrest].
      + subst. rewrite Z.mul_0_r. rewrite Z.add_0_r. apply H4. apply Hk.
      + assert (0 = m \/ 0 < m) by lia. destruct H as [H | Hm0]. lia.
        assert (0 <= j * m + k < n * m). { split; try lia.
        assert (j * m + k < j * m + m) by lia. replace (j * m + m) with ((j+1) * m) in H by lia.
        assert ((j+1) * m <= n * m). apply Zmult_le_compat_r; lia. lia. }
        specialize (H3 _ H). simpl. replace ( Z.max 0 m ) with m by lia.
        replace (Ptrofs.unsigned i + Ctypes.sizeof t * m * j + Ctypes.sizeof t * k) with
        (Ptrofs.unsigned i + Ctypes.sizeof t * (j * m + k)). apply H3. rewrite <- !Z.add_assoc. f_equal.
        rewrite <- Z.mul_assoc. rewrite <- Z.mul_add_distr_l. f_equal. lia. }
  split; intros [Hptr2 [Hleg2 [Hszc2 [Hal2 [Hlegn2 Hbound2]]]]].
  repeat(split; auto). apply H. split; auto.
  apply H. split; auto. replace m with (1 * m) at 1 by lia. apply Z.mul_le_mono_nonneg_r; lia.
  repeat(split; auto). apply H. split; auto. apply H; split; auto. lia. lia.
Qed.

(*The full relationship between 1D and 2D arrays*)
Lemma data_at_2darray_concat : forall sh t n m (al : list (list (reptype t))) p,
  Zlength al = n ->
  Forall (fun l => Zlength l = m) al ->
  complete_legal_cosu_type t = true ->
  data_at sh (tarray (tarray t m) n) al p
    = data_at sh (tarray t (n * m)) (concat al) p.
Proof.
  intros.
  generalize dependent n; generalize dependent p; induction al; intros.
  - simpl. replace n with 0 by list_solve. rewrite Z.mul_0_l.
    apply pred_ext; entailer!; rewrite !data_at_zero_array_eq; auto.
  - rewrite Zlength_cons in H. simpl. assert (Hmlen: Zlength a = m) by (inversion H0; subst; reflexivity).
    apply pred_ext.
    + (*We will need these later, when we have transformed the [data_at] predicates, so they are harder to prove*)
      assert_PROP (field_compatible (tarray (tarray t m) (Z.succ (Zlength al))) [] p). { entailer!. }
      assert_PROP (field_compatible0 (tarray (tarray t m) n) [ArraySubsc 1] p). { entailer!.
        apply arr_field_compatible0. auto. list_solve. }
      change (a :: al) with ([a] ++ al).
      change (list (reptype t)) with (reptype (tarray t m)) in a.
      rewrite (split2_data_at_Tarray_app 1 _ _ _ [a]). 2: Zlength_solve.
      change (reptype (tarray t m)) with  (list (reptype t)) in a. 2: { rewrite <- H.
      assert (forall x, x = Z.succ x - 1). intros; lia. apply H4. }
      rewrite (split2_data_at_Tarray_app m).
      replace (n * m - m) with ((n-1) * m) by lia.
      erewrite data_at_singleton_array_eq. 2: reflexivity.
      assert (Hm: 0 <= m). rewrite <- Hmlen. list_solve.
      entailer!. rewrite !field_address0_clarify; auto.
      simpl. unfold sizeof. rewrite <- Z.mul_assoc.
      replace (Z.max 0 (Zlength a) * 1) with (Zlength a) by lia. rewrite IHal. cancel.
      inversion H0; subst; auto. lia. unfold field_address0.
      rewrite field_compatible0_1d_2d in H3.
      destruct (field_compatible0_dec (tarray t (Z.succ (Zlength al) * Zlength a)) [ArraySubsc (Zlength a)] p); [| contradiction].
    apply isptr_is_pointer_or_null; auto. list_solve. list_solve. auto.
    inversion H0; subst; reflexivity.
    rewrite (Zlength_concat (n-1) m). lia. list_solve. inversion H0; auto.
    + assert_PROP ((field_compatible0 (tarray t (n * m)) [ArraySubsc m] p)). { entailer!.
      apply arr_field_compatible0. apply H2.
       split. list_solve. rewrite <- (Z.mul_1_l (Zlength a)) at 1. apply Z.mul_le_mono_nonneg_r; list_solve. }
      change (a :: al) with ([a] ++ al).
      change (list (reptype t)) with (reptype (tarray t m)) in a.
      rewrite (split2_data_at_Tarray_app 1 _ _ _ [a]). 2: Zlength_solve.
      change (reptype (tarray t m)) with  (list (reptype t)) in a. 2: { rewrite <- H.
      assert (forall x, x = Z.succ x - 1). intros; lia. apply H3. }
      rewrite (split2_data_at_Tarray_app m). 2: auto.
      replace (n * m - m) with ((n-1) * m) by lia.
      erewrite data_at_singleton_array_eq. 2: reflexivity.
      assert (Hm: 0 <= m). rewrite <- Hmlen. list_solve.
      entailer!. rewrite !field_address0_clarify; auto.
      simpl. unfold sizeof. rewrite <- Z.mul_assoc.
      replace (Z.max 0 (Zlength a) * 1) with (Zlength a) by lia. rewrite IHal. cancel.
      inversion H0; subst; auto. lia. unfold field_address0.
      rewrite <- field_compatible0_1d_2d in H2.
      destruct (field_compatible0_dec (tarray (tarray t (Zlength a)) (Z.succ (Zlength al))) [ArraySubsc 1] p); [| contradiction].
      apply isptr_is_pointer_or_null; auto. list_solve. list_solve. auto.
      rewrite (Zlength_concat (n-1) m). lia. list_solve. inversion H0; auto.
Qed.

(** Working with Arrays of Pointers*)

(*Represents the fact that there is a list of pointers (ptrs), and the contents of those pointers
  are described by contents - in essence, a 2D array with possibly different lengths*)
(*For now, only defined for tuchar, could extend to other int types*)
Definition iter_sepcon_arrays (ptrs : list val) (contents: list (list byte)) :=
  iter_sepcon (fun (x: (list byte * val)) => let (l, ptr) := x in
            data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) ptr) (combine contents ptrs).

Lemma iter_sepcon_arrays_Znth: forall ptrs contents i,
  Zlength ptrs = Zlength contents ->
  0 <= i < Zlength contents ->
  iter_sepcon_arrays ptrs contents |--
    data_at Ews (tarray tuchar (Zlength (Znth i contents))) (map Vubyte (Znth i contents)) (Znth i ptrs) * TT.
Proof.
  intros ptrs contents i Hlen Hi. unfold iter_sepcon_arrays.
  sep_apply (iter_sepcon_in_true (fun x : list byte * val => let (l, ptr) := x in
    data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) ptr) (combine contents ptrs)
    (Znth i contents, Znth i ptrs)); [|cancel].
  rewrite In_Znth_iff. exists i. split. rewrite combine_Zlength; lia.
  apply combine_Znth; lia.
Qed.

Lemma remove_lead_eq: forall {A: Type} (P: Prop) (x: A),
  (x = x -> P) <-> P.
Proof.
  intros. tauto.
Qed.

(*We don't actually use this, but we prove a [local_facts] so that we could use this with entailer! if we wanted*)
Lemma iter_sepcon_arrays_local_facts: forall ptrs contents,
  iter_sepcon_arrays ptrs contents |-- !! (Zlength ptrs = Zlength contents ->
        forall i, 0 <= i < Zlength contents ->
         field_compatible (tarray tuchar (Zlength (Znth i contents))) [] (Znth i ptrs) /\
         Forall (value_fits tuchar) (map Vubyte (Znth i contents))).
Proof.
  intros ptrs contents.
  assert (Zlength ptrs = Zlength contents \/ Zlength ptrs <> Zlength contents) as [Heq | Hneq] by lia;
  [ | entailer!]. rewrite Heq. rewrite remove_lead_eq. eapply derives_trans. 2:
  apply (@allp_prop_left _ _ Z (fun (i: Z) => 0 <= i < Zlength contents ->
        field_compatible (tarray tuchar (Zlength (Znth i contents))) [] (Znth i ptrs) /\
        Forall (value_fits tuchar) (map Vubyte (Znth i contents)))).
  apply allp_right. intros i.
  (*This is not particularly elegant; is there a way to get an implication out directly?*)
  assert (0 <= i < Zlength contents \/ ~ (0 <= i < Zlength contents)) as [Hlt | Hgt] by lia; [| entailer ].
  (*why doesn't entailer! work?*)
  sep_apply (iter_sepcon_arrays_Znth _ _ _ Heq Hlt).
  assert (forall m P Q, P -> (m |-- !! Q) -> (m |-- !! (P -> Q))). { intros. sep_apply H. entailer!. }
  apply H. assumption. entailer!.
Qed.

(*We would also like another, more general fact. For [iter_sepcon] that gives an mpred
  as well as [iter_sepcon_arrays]), we can remove
  the nth element and keep the rest*)

(*An easier definition than [delete_nth], since it uses Z and there are lots of lemmas/automation about sublist*)
Definition remove_nth {A: Type} (n: Z) (l: list A): list A :=
  sublist 0 n l ++ sublist (n+1) (Zlength l) l.

Lemma iter_sepcon_remove_one: forall {B : Type} `{Inhabitant B} (p: B -> mpred) (l: list B) (n: Z),
  0 <= n < Zlength l ->
  iter_sepcon p l = ((p (Znth n l)) * iter_sepcon p (remove_nth n l))%logic.
Proof.
  intros B Hinhab p l n Hn. unfold remove_nth. rewrite <- (sublist_same 0 (Zlength l) l) at 1 by auto.
  rewrite (sublist_split 0 n (Zlength l) l) by lia.
  rewrite (sublist_split n (n+1) (Zlength l) l) by lia. rewrite !iter_sepcon_app.
  rewrite sublist_len_1 by lia. simpl. apply pred_ext; cancel.
Qed.

Lemma combine_remove_nth: forall {A B: Type} `{Inhabitant A} `{Inhabitant B} n (l1: list A) (l2: list B),
  Zlength l1 = Zlength l2 ->
  0 <= n < Zlength l1 ->
  combine (remove_nth n l1) (remove_nth n l2) = remove_nth n (combine l1 l2).
Proof.
  intros A B Hinh1 Hinh2 n l1 l2 Hlens Hn.
  unfold remove_nth. rewrite combine_app by list_solve. rewrite Hlens. rewrite !combine_sublist by lia.
  rewrite combine_Zlength by lia. rewrite Hlens. reflexivity.
Qed.

Lemma iter_sepcon_arrays_remove_one: forall ptrs contents i,
  Zlength ptrs = Zlength contents ->
  0 <= i < Zlength contents ->
  iter_sepcon_arrays ptrs contents =
    (data_at Ews (tarray tuchar (Zlength (Znth i contents))) (map Vubyte (Znth i contents)) (Znth i ptrs) *
    iter_sepcon_arrays (remove_nth i ptrs) (remove_nth i contents))%logic.
Proof.
  intros ptrs contents i Hlens Hi. unfold iter_sepcon_arrays. rewrite (iter_sepcon_remove_one _ _ i).
  rewrite combine_Znth by auto. f_equal. rewrite combine_remove_nth by lia. reflexivity.
  rewrite combine_Zlength; lia.
Qed.

Lemma remove_upd_Znth: forall {A: Type} (l: list A) (i : Z) (x: A),
  0 <= i < Zlength l ->
  remove_nth i (upd_Znth i l x) = remove_nth i l.
Proof.
  intros. unfold remove_nth.
  rewrite sublist_upd_Znth_l by lia.
  rewrite Zlength_upd_Znth, sublist_upd_Znth_r by lia.
  reflexivity.
Qed.

(* We want a similar definition for when only some of the data exists, and the others are null pointers*)

Definition iter_sepcon_options (ptrs: list val) (contents: list (option (list byte))) : mpred :=
  iter_sepcon (fun (x: option (list byte) * val) => let (o, ptr) := x in
    match o with
      | None => emp
      | Some l => data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) ptr
    end) (combine contents ptrs).

Lemma iter_sepcon_options_remove_one: forall ptrs contents i l,
  Zlength ptrs = Zlength contents ->
  0 <= i < Zlength contents ->
  Znth i contents = Some l ->
  iter_sepcon_options ptrs contents =
    (data_at Ews (tarray tuchar (Zlength l)) (map Vubyte l) (Znth i ptrs) *
    iter_sepcon_options (remove_nth i ptrs) (remove_nth i contents))%logic.
Proof.
  intros ptrs contents i l Hlens Hi Hnth. unfold iter_sepcon_options. rewrite (iter_sepcon_remove_one _ _ i).
  destruct (Znth i (combine contents ptrs)) as [o ptr] eqn : Hnth'.
  rewrite combine_Znth in Hnth' by auto. inversion Hnth'; subst. rewrite Hnth.
  rewrite combine_remove_nth by lia. reflexivity. rewrite combine_Zlength; lia.
Qed.

End VSTFacts.


(* Oblivious transfer in IPDL. *)

Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Base Ipdl.Big Pars Lib.Set Typ.

(* Oblivious transfer is parametrized by the type of messages.  The ideal protocol reads a tuple from channel 'm' (coming from the sender), reads a boolean from channel 'i' (coming from the receiver), and outputs the i'th element of m (back to the receiver. *)
Definition OTIdeal {chan : Type -> Type} (L : Type) (i : chan bool) (m : chan (L * L)%type)
           (o : chan L) :=
  o ::= (
        x_i <-- Read i ;;
        x_m <-- Read m ;;
        Ret (if x_i then x_m.2 else x_m.1)).

(* We additionally consider the 1-out-of-4 variant. *)
Definition OT14Ideal {chan : Type -> Type} L (i : chan (bool * bool)%type)
           (m : chan ((L * L) * (L * L))%type)
           (o : chan L) :=
  Out o (
        x <-- Read i ;;
        y <-- Read m ;;
        Ret (((y # x.1) # x.2))).

(* The following is a combinator that spawns a 1-out-of-4 OT protocol, to be used in P. *)
Definition withOT14 {chan : Type -> Type} L (P : chan (bool * bool)%type * chan ((L * L) * (L * L))%type * chan L -> ipdl) :=
  i <- new (bool * bool) ;;
  m <- new ((L * L) * (L * L)) ;;
  o <- new L ;;
  pars [:: OT14Ideal _ i m o; P (i, m, o) ].

Lemma withOT14_irrel {chan} L r :
  @withOT14 chan L (fun '(i, m, o) => pars [:: i ::= Read i; m ::= Read m; r]) =p r.
  rewrite /withOT14.
  swap_tac 0 1.
  setoid_rewrite pars_pars; simpl.
  rewrite /OT14Ideal.
  swap_tac 0 3.
  setoid_rewrite new_pars_remove.
  setoid_rewrite new_pars_remove.
  swap_tac 0 1.
  rewrite new_pars_remove.
  rewrite pars1 //=.
Qed.

#[global]
Instance withOT14_NewLike chan L : NewLike chan (withOT14 L).
   constructor.
   intros.
   rewrite /withOT14.
   repeat setoid_rewrite newComp.
   Intro => i.
   Intro => m.
   Intro => o.
   rewrite pars_rcons //=.
   symmetry; swap_tac 0 1.
   rewrite par_in_pars //=.
   align.
   intros.
   rewrite /withOT14.
   Intro => i.
   Intro => m.
   Intro => o.
   rewrite H.
   done.
   intros.
   rewrite /withOT14.
   symmetry.
   rewrite EqNewExch.
   Intro => i.
   rewrite EqNewExch.
   Intro => m.
   rewrite EqNewExch.
   Intro => o.
   symmetry.
   swap_tac 0 1.
   rewrite newPars.
   Intro => c.
   swap_tac 0 1; done.
Qed.

Require Import Lib.SeqOps.

Lemma OTIdeal_t {chan} L i (m : chan (L * L)%type) o :
  ipdl_t [:: tag o] (OTIdeal L i m o).
  rewrite /OTIdeal.
  repeat type_tac.
Qed.

Lemma withOT14_t {chan} L P o :
  (forall x y z, @ipdl_t chan [:: tag x, tag y & o] (P (x, y, z))) ->
  ipdl_t o (withOT14 L P).
  rewrite /withOT14; intros.
  apply new_t => i.
  apply new_t => m.
  apply new_t => v.
  rewrite /OT14Ideal.
  repeat type_tac.
  setoid_rewrite (Perm_swap 1 2) at 1; rewrite /swap //= /lset //= !insert_0 //=.
Qed.


(*

Author:  Adam Petz, ampetz@ku.edu
*)

Theorem app_inj_l: forall A (l1 l2 suf : list A),
    l1 ++ suf = l2 ++ suf -> l1 = l2.
Proof.
  Admitted.

Lemma headShouldersKneesAndToes : forall A (h : A) t l1 l2,
    h :: t = l1 ++ l2 ->
    forall prefix i, t = prefix ++ i :: l2 ->
    l1 = h :: prefix ++ [i].
Proof.
  intros. subst.
  assert (H0 : i :: l2 = [i] ++ l2). reflexivity.
  rewrite H0 in H; clear H0.
  apply app_inj_l with (suf := l2).
  simpl. rewrite <- app_assoc. auto.
Qed.

Theorem vm_multi_suffix : forall il1 il2 tr,
    vm_multi {| vm_list := il1 |} {| vm_list := il2 |} tr ->
    exists prefix, il1 = prefix ++ il2.
Proof.
(*  intros il1 il2 tr H. inversion H.
  - exists []. reflexivity.
  - subst. Print refl_trans_1n_trace. Print vm_step.
*)
  intros il1 il2 tr H. dependent induction H.
  - exists []. reflexivity.
  - apply IHrefl_trans_1n_trace.
    + admit.
    + reflexivity.
Admitted.

Lemma il1_pieces' : forall i0 vm_list0 il1 il2 i tr,
    i0 :: vm_list0 = il1 ++ il2 ->
    vm_multi {| vm_list := vm_list0 |} {| vm_list := i :: il2 |} tr ->
    exists bla, il1 = [i0] ++ bla ++ [i].
Proof.
  intros i0 vm_list0 il1 il2 i tr H0 H1.
  remember (vm_multi_suffix _ _ _ H1) as e. destruct e. exists x.
  apply headShouldersKneesAndToes with (t := vm_list0) (l2 := il2); try assumption.
Qed.


Inductive test : bool -> bool -> Type :=
| test00 : test false false
| test01 : test false true
| test10 : test true false
.

(* This does not work *)
Definition test_a (t : test true false) : test true false :=
  match t with
    | test10 => test10
  end.

(* The following definition shows that test_a SHOULD work *)
Definition test_a_workaround (t : test true false) : test true false :=
  match t with
    | test10 => test10
    | _ => tt
  end.

(* Surprisingly, this works *)
Definition test_b (t : test false true) : test false true :=
  match t with
    | test01 => test01
  end.

(* This, too, works *)
Definition test_c x (t : test false x) : test false x :=
  match t with
    | test00 => test00
    | test01 => test01
  end.

Inductive test2 : bool -> bool -> Type :=
| test201 : test2 false true
| test210 : test2 true false
| test211 : test2 true true
.

(* Now this works *)
Definition test2_a (t : test2 true false) : test2 true false :=
  match t with
    | test210 => test210
  end.

(* Accordingly, this now fails *)
Definition test2_b (t : test2 false true) : test2 false true :=
  match t with
    | test201 => test201
  end.

(* This, too, fails *)
Definition test2_c x (t : test2 false x) : test2 false x :=
  match t with
    | test201 => test201
  end.


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

(***
Modulus : 2^511 - 481
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 64;
    bitwidth := 64;
    s := 2^511;
    c := [(1, 481)];
    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.


Require Import
        CertifiedExtraction.Extraction.QueryStructures.Basics
        CertifiedExtraction.Extraction.QueryStructures.TupleToListW
        CertifiedExtraction.Extraction.QueryStructures.EnsemblesOfTuplesAndListW
        CertifiedExtraction.Extraction.QueryStructures.CallRules.CallRules.

Require Import CertifiedExtraction.Extraction.QueryStructures.Wrappers.
Require Import Fiat.QueryStructure.Implementation.DataStructures.BagADT.QueryStructureImplementation.

Require Import Bedrock.Platform.Facade.CompileUnit2.

Require Export
        CertifiedExtraction.ADT2CompileUnit
        CertifiedExtraction.Extraction.Extraction
        CertifiedExtraction.Extraction.QueryStructures.Decompose.

Require Import
        Bedrock.Memory
        Bedrock.Platform.Facade.DFModule
        Bedrock.Platform.Facade.CompileUnit2.

Transparent CallBagMethod.
Arguments CallBagMethod : simpl never.
Arguments wrap : simpl never.
Arguments ListWToTuple: simpl never.

Definition BagSanityConditions {N} tbl :=
  TuplesF.functional (IndexedEnsemble_TupleToListW (N := N) tbl)
  /\ exists idx, TuplesF.minFreshIndex (IndexedEnsemble_TupleToListW tbl) idx.

Lemma Lift_Ensemble :
  forall n r idx (el: FiatWTuple n),
    Ensembles.In _ r
                 {| IndexedEnsembles.elementIndex := idx;
                    IndexedEnsembles.indexedElement := el |} <->
    Ensembles.In _ (IndexedEnsemble_TupleToListW r)
                 {| TuplesF.elementIndex := idx;
                    TuplesF.indexedElement := TupleToListW el |}.
Proof.
  split; intros.
  - econstructor; intuition eauto.
    unfold RelatedIndexedTupleAndListW; split; simpl; eauto.
  - destruct H;  unfold RelatedIndexedTupleAndListW in *; intuition.
    simpl in *; subst.
    destruct x; simpl in *; subst.
    unfold TupleToListW in H2.
    apply ilist2ToListW_inj in H2; subst; eauto.
Qed.

Lemma BagSanityConditions_Add:
  forall n (r : FiatWBag n) el,
    TuplesF.functional (IndexedEnsemble_TupleToListW r) ->
    IndexedEnsembles.UnConstrFreshIdx r (IndexedEnsembles.elementIndex el) ->
    BagSanityConditions (Ensembles.Add IndexedEnsembles.IndexedElement r el).
Proof.
  split; unfold TuplesF.functional, TuplesF.minFreshIndex; intros; intuition.
  - destruct t1; destruct t2; simpl in *; subst; f_equal.
    destruct H2; destruct H1; intuition.
    destruct H2; destruct H3; subst.
    + unfold TuplesF.tupl in *.
      unfold RelatedIndexedTupleAndListW in *; simpl in *; intuition.
      subst.
      destruct x; destruct x0; simpl in *; subst.
      apply Lift_Ensemble in H2; apply Lift_Ensemble in H1.
      pose proof (H _ _ H1 H2 (eq_refl _)); injections; eauto.
    + destruct H2.
      unfold RelatedIndexedTupleAndListW in *; simpl in *; intuition; subst.
      destruct x0; destruct el; simpl in *; subst.
      unfold TuplesF.UnConstrFreshIdx in H1.
      unfold IndexedEnsembles.UnConstrFreshIdx in H0.
      apply H0 in H1; simpl in *.
      omega.
    + destruct H1.
      unfold RelatedIndexedTupleAndListW in *; simpl in *; intuition; subst.
      destruct x; destruct el; simpl in *; subst.
      unfold IndexedEnsembles.UnConstrFreshIdx in H0.
      apply H0 in H2; simpl in *.
      omega.
    + destruct H2; destruct H1.
      unfold RelatedIndexedTupleAndListW in *; simpl in *; intuition; subst.
      reflexivity.
  - exists (S (IndexedEnsembles.elementIndex el)); split.
    + unfold TuplesF.UnConstrFreshIdx in *; intros.
      destruct H1 as [? [? ? ] ].
      unfold RelatedIndexedTupleAndListW in *; simpl in *; intuition; subst.
      destruct element; simpl in *; subst.
      * destruct H1.
        destruct x; simpl in *.
        apply H0 in H1; simpl in *; omega.
        destruct H1; omega.
    + intros.
      inversion H1; subst.
      unfold TuplesF.UnConstrFreshIdx in *.
      assert (lt (TuplesF.elementIndex (IndexedElement_TupleToListW el)) (IndexedEnsembles.elementIndex el) ).
      eapply H2.
      econstructor; split.
      unfold Ensembles.Add.
      econstructor 2.
      reflexivity.
      unfold RelatedIndexedTupleAndListW; eauto.
      destruct el; simpl in *; omega.
      unfold TuplesF.UnConstrFreshIdx in *; intros.
      assert (lt (IndexedEnsembles.elementIndex el) idx').
      eapply (H2 {| TuplesF.elementIndex := _;
                    TuplesF.indexedElement := _ |}); simpl.
      unfold IndexedEnsemble_TupleToListW.
      simpl; eexists; split.
      econstructor 2.
      reflexivity.
      unfold RelatedIndexedTupleAndListW; simpl; split; eauto.
      omega.
Qed.

Ltac _compile_CallBagFind :=
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            match constr:((pre, post)) with
            | (Cons (NTSome (H := ?h) ?vdb) (ret (prim_fst ?db)) (fun _ => ?tenv), Cons NTNone ?bf _) =>
              match bf with
              | CallBagMethod Fin.F1 BagFind ?db ?kwd =>
                let vsnd := gensym "snd" in
                let vtmp := gensym "tmp" in
                eapply CompileSeq
                with ([[bf as retv]]
                        :: [[(NTSome (H := h) vdb)
                              ->> prim_fst (Refinements.UpdateIndexedRelation
                                            (QueryStructureSchema.QueryStructureSchemaRaw
                                               ProcessScheduler.SchedulerSchema)
                                            (icons3 ProcessScheduler.SearchUpdateTerm inil3)
                                            db Fin.F1 (fst retv)) as _]]
                        :: [[`vsnd ->> snd retv as s]]
                        :: tenv);
                [ match kwd with
                  | (Some ?v, (None, fun _ => true)) =>
                    let vkwd := find_fast (wrap (WrappingType := Value QsADTs.ADTValue) v) ext in
                    match vkwd with
                    | Some ?vkwd => apply (WBagOfTuples2Compilation.CompileFindFirst_spec
                                            (* FIXME get (Fin.FS Fin.F1) generically *)
                                            (Fin.FS Fin.F1) (vkey := vkwd) _ (table := prim_fst db))
                    end
                  | (None, (Some ?v, fun _ => true)) =>
                    let vkwd := find_fast (wrap (WrappingType := Value QsADTs.ADTValue) v) ext in
                    match vkwd with
                    | Some ?vkwd => apply (WBagOfTuples2Compilation.CompileFindSecond_spec
                                            (* FIXME get (Fin.F1) generically *)
                                            _ (Fin.F1) (vkey := vkwd) (table := prim_fst db))
                    end
                  end | ]
              end
            end).

Ltac _compile_length :=
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            match constr:((pre, post)) with
            | (?pre, Cons ?k (ret (bool2w (EqNat.beq_nat (Datatypes.length (rev ?seq)) 0))) (fun _ => ?pre')) =>
              let vlst := find_fast (wrap (FacadeWrapper := WrapInstance (H := QS_WrapFiatWTupleList)) seq) ext in
              match vlst with
              | Some ?vlst => eapply (WTupleListCompilation.CompileEmpty_spec (idx := 3) (vlst := vlst))
              end
            end).

Ltac _compile_CallBagInsert := (* FIXME should do the insert in the second branch *)
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            match constr:((pre, post)) with
            | (Cons (NTSome (H := ?h) ?vrep) (ret ?db) (fun _ => ?tenv),
               Cons NTNone ?bm (fun a => Cons ?vret _ (fun _ => Cons (NTSome ?vrep') (ret a) (fun _ => ?tenv')))) =>
              unify vrep vrep';
                match bm with
                | (CallBagMethod _ BagInsert _ (ilist2.icons2 ?a (ilist2.icons2 ?b (ilist2.icons2 ?c ilist2.inil2)))) =>
                  let vtmp := gensym "tmp" in
                  let vtup := gensym "tup" in
                  (* match pre with *)
                  change (ilist2.icons2 a (ilist2.icons2 b (ilist2.icons2 c ilist2.inil2))) with (ListWToTuple [[[a; b; c]]]);
                    apply CompileSeq with (Cons (NTSome (H := h) vrep) (ret db)
                                                (fun _ => Cons (NTSome (H := WrapInstance (H := WTupleCompilation.FiatWrapper)) vtup) (ret ((ListWToTuple [[[a; b; c]]]): FiatWTuple 3)) (fun _ => tenv)));
                    [ | eapply CompileSeq; [ let vtmp := gensym "vtmp" in eapply (WBagOfTuples2Compilation.CompileInsert_spec (vtmp := vtmp)) | ] ]
                end
            end).

Ltac explode n :=
  match n with
  | 0 => idtac
  | S ?n =>
    compile_do_use_transitivity_to_handle_head_separately;
      [ | apply ProgOk_Chomp_Some; [ | intros; explode n ] ]
  end.

Ltac _compile_allocTuple :=
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            match constr:((pre, post)) with
            | (?pre, Cons ?k (ret ?tup) (fun _ => ?pre)) =>
              match type of tup with
              | FiatWTuple _ =>
                let v1 := gensym "v1" in
                let v2 := gensym "v2" in
                let v3 := gensym "v3" in
                let o1 := gensym "o1" in
                let o2 := gensym "o2" in
                let o3 := gensym "o3" in
                let vlen := gensym "vlen" in
                let vtmp := gensym "vtmp" in
                apply (WTupleCompilation.CompileNew_spec (v1 := "v1") (v2 := "v2") (v3 := "v3") (o1 := "o1") (o2 := "o2") (o3 := "o3") (vlen := "vlen") (vtmp := "vtmp")); try explode 6
              end
            end).

Ltac _compile_destructor_unsafe vtmp tenv tenv' ::=
     let vtmp2 := gensym "tmp'" in
     let vsize := gensym "size" in
     let vtest := gensym "test" in
     let vhead := gensym "head" in
     first [ unify tenv tenv';
             apply (WTupleListCompilation.CompileDeleteAny_spec
                      (N := 3) (vtmp := vtmp) (vtmp2 := vtmp2) (vsize := vsize)
                      (vtest := vtest) (vhead := vhead))
           | eapply CompileSeq;
             [ apply (WTupleListCompilation.CompileDeleteAny_spec
                        (N := 3) (vtmp := vtmp) (vtmp2 := vtmp2) (vsize := vsize)
                        (vtest := vtest) (vhead := vhead)) | ] ].

Lemma map_rev_def :
  forall {A B} f seq,
    @map A B f (rev seq) = revmap f seq.
Proof.
  intros; reflexivity.
Qed.

Ltac _compile_map ::= (* ‘_compile_map’ from the stdlib uses generic push-pop methods *)
  match_ProgOk
     ltac:(fun prog pre post ext env =>
             let vhead := gensym "head" in
             let vhead' := gensym "head'" in
             let vtest := gensym "test" in
             let vtmp := gensym "tmp" in
             match constr:((pre, post)) with
             | (Cons (NTSome ?vseq) (ret ?seq) ?tenv, Cons (NTSome ?vret) (ret (revmap _ ?seq')) ?tenv') =>
               unify seq seq';
               apply (WTupleListCompilation.CompileMap_TuplesToWords
                        (N := 3) seq (vhead := vhead) (vhead' := vhead') (vtest := vtest) (vtmp := vtmp))
             end).

Ltac _compile_get :=
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            let vtmp := gensym "tmp" in
            match constr:((pre, post)) with
            | (Cons (NTSome (H:=?h) ?k) (ret ?tup) ?tenv, Cons (NTSome (H:=?h') ?k') (ret (GetAttributeRaw ?tup' ?idx')) _) =>
              unify tup tup';
                let vpos := gensym "pos" in
                eapply CompileSeq with (Cons (NTSome (H:=h) k) (ret tup)
                                             (fun a => Cons (NTSome (H:=h') k') (ret (ilist2.ith2 tup' idx'))
                                                         (fun _ => tenv a)));
                  [ apply (WTupleCompilation.CompileGet_spec (N := 3) tup' idx' (vpos := vpos)) |
                    let vtmp := gensym "tmp" in
                    let vsize := gensym "size" in
                    apply (WTupleCompilation.CompileDelete_spec (vtmp := vtmp) (vsize := vsize)) ]
            end).

Lemma GLabelMapFacts_map_add_1 :
  (* This is a hack to transform a rewrite into an apply (setoid_rewrite is too slow). *)
  forall (elt B : Type) (f : elt -> B) (k : GLabelMapFacts.M.key) (v : elt) (m : GLabelMapFacts.M.t elt) m0,
    GLabelMapFacts.M.Equal (GLabelMapFacts.M.map f m) m0 ->
    GLabelMapFacts.M.Equal (GLabelMapFacts.M.map f (m ### k ->> v)) (m0 ### k ->> f v).
Proof.
  intros * H; rewrite GLabelMapFacts.map_add, H; reflexivity.
Qed.

Require Import Fiat.CertifiedExtraction.PureFacadeLemmas.

Ltac GLabelMap_fast_apply_map :=
  (* This tactic simplifies an expression like [map f (add k1 v1 (add ...))]
     into [add k1 (f v1) (add ...)]. Using setoid_rewrite repeatedly was too
     slow, so it relies on a separate lemma and an evar to do its job. *)
  etransitivity;
  [ |
    match goal with
    | [  |- GLabelMap.Equal ?ev ?complex_expr ] =>
      match complex_expr with (* Not a lazy match: not all [GLabelMap.map]s can be removed *)
      | context Ctx [GLabelMap.map ?f ?m] =>
        lazymatch type of f with
        | ?elt -> ?elt' =>
          let m' := fresh in
          evar (m' : GLabelMap.t elt');
          (* This block is essentially [setoid_replace (GLabelMap.map f m) m'] with
               relation [@GLabelMap.Equal elt'], but it fails before calling the setoid
               machinery if the relation doesn't actually hold. *)
          let __eq := fresh in
          assert (@GLabelMap.Equal elt' (GLabelMap.map f m) m') as __eq;
          [ unfold m' in *; clear m'; try unfold m;
            solve [repeat apply GLabelMapFacts_map_add_1; apply GLabelMapFacts.map_empty] | ];
          (* Now that we have an equality between subterms, plug it in the larger term *)
          (* This because setoid_rewrite __eq took one hour *)
          let simpler_term := context Ctx[m'] in
          unify ev simpler_term;
          symmetry in __eq;
          repeat match goal with
                 | [  |- GLabelMap.Equal ?x ?x ] => reflexivity
                 | [  |- GLabelMap.Equal (GLabelMapFacts.UWFacts.WFacts.P.update _ _)
                                        (GLabelMapFacts.UWFacts.WFacts.P.update _ _) ] =>
                   apply GLabelMapFacts_UWFacts_WFacts_P_update_morphism
                 | _ => exact __eq
                 end
        end
      end
    end ].

Ltac _compile_cleanup_env_helper :=
  GLabelMap_fast_apply_map;
  GLabelMap_fast_apply_map;
  reflexivity.

Ltac __compile_cleanup_env :=
  match_ProgOk
    ltac:(fun prog pre post ext env =>
            match env with
            | GLabelMapFacts.UWFacts.WFacts.P.update _ _ =>
              eapply Proper_ProgOk; [ reflexivity | _compile_cleanup_env_helper | reflexivity.. | idtac ];
              match_ProgOk ltac:(fun prog pre post ext env => set env)
            end).

Ltac __compile_prepare_merged_env_for_compile_do_side_conditions :=
  lazymatch goal with
  | [ |- GLabelMap.MapsTo _ _ ?env ] =>
    lazymatch eval unfold env in env with
    | GLabelMapFacts.UWFacts.WFacts.P.update _ _ =>
      unfold env; apply GLabelMapFacts.UWFacts.WFacts.P.update_mapsto_iff; left
    end
  end.

Ltac __compile_pose_query_structure :=
  (* Removing this pose makes the [apply CompileTuples2_findFirst_spec] loop.
     No idea why. *)
  match goal with
  | [ r: IndexedQueryStructure _ _ |- _ ] =>
    match goal with
    | [ r' := _ : IndexedQueryStructure _ _ |- _ ] => fail 1
    | _ => pose r
    end
  end.

Ltac __compile_discharge_bag_side_conditions_step :=
  match goal with
  | _ => cleanup
  | _ => progress injections
  | _ => progress simpl in *
  | _ => progress computes_to_inv
  | _ => progress unfold CallBagMethod in *
  | _ => progress (find_if_inside; simpl in * )
  | [  |- BagSanityConditions (Ensembles.Add _ _ _) ] => apply BagSanityConditions_Add
  | [  |- BagSanityConditions _ ] => split; solve [intuition eauto]
  | _ => eassumption
  end.

Ltac __compile_discharge_bag_side_conditions_internal :=
  solve [repeat __compile_discharge_bag_side_conditions_step].

Ltac __compile_discharge_bag_side_conditions :=
  match goal with
  | [  |- TuplesF.functional _ ] => __compile_discharge_bag_side_conditions_internal
  | [  |- TuplesF.minFreshIndex _ _ ] => __compile_discharge_bag_side_conditions_internal
  | [  |- BagSanityConditions _ ] => __compile_discharge_bag_side_conditions_internal
  end.

Ltac __compile_unfold :=
     match goal with
     | _ => progress unfold If_Then_Else in *
     end.

Ltac __compile_clear_bodies_of_ax_spec :=
  repeat (unfold GenExports, map_aug_mod_name, aug_mod_name,
          GLabelMapFacts.uncurry; simpl);
  repeat lazymatch goal with
    | |- context[GenAxiomaticSpecs ?a0 ?a1 ?a2 ?a3 ?a4 ?a5 ?a6 ?a7] =>
      let a := fresh in
      pose (GenAxiomaticSpecs a0 a1 a2 a3 a4 a5 a6 a7) as a;
      change (GenAxiomaticSpecs a0 a1 a2 a3 a4 a5 a6 a7) with a;
      clearbody a
    end.

Ltac __compile_start_compiling_module imports :=
  lazymatch goal with
  | [  |- sigT (fun _ => BuildCompileUnit2TSpec  _ _ _ _ _ _ _ _ _ _ _ _ _ _ ) ] =>
    eexists;
    unfold DecomposeIndexedQueryStructure', DecomposeIndexedQueryStructurePre', DecomposeIndexedQueryStructurePost';
    eapply (BuildCompileUnit2T' imports); try apply eq_refl (* reflexivity throws an Anomaly *)
  | [  |- forall _: (Fin.t _), (sigT _)  ] =>
    __compile_clear_bodies_of_ax_spec;
    eapply IterateBoundedIndex.Lookup_Iterate_Dep_Type; repeat (apply Build_prim_prod || exact tt)
  end.

Ltac __compile_start_compiling_method :=
  lazymatch goal with
  | [  |- sigT (fun (_: Stmt) => _) ] =>
    eexists; repeat match goal with
                    | _ => progress simpl
                    | _ => progress intros
                    | [  |- _ /\ _ ] => split
                    end
  end.

Ltac __compile_decide_NoDup :=
  repeat lazymatch goal with
    | [  |- NoDup _ ] => econstructor
    | [  |- not (List.In _ _) ] => simpl; intuition congruence
    end.

Ltac __compile_start_compiling_step imports :=
  match goal with
  | [ H: BagSanityConditions _ |- _ ] => destruct H as [ ? [ ? ? ] ]
  | _ => __compile_start_compiling_module imports
  | _ => __compile_start_compiling_method
  | _ => __compile_discharge_bag_side_conditions
  | _ => __compile_decide_NoDup
  end.

Ltac __compile_method_step :=
  match goal with
  | _ => __compile_unfold
  | _ => __compile_cleanup_env
  | _ => __compile_pose_query_structure
  | _ => __compile_prepare_merged_env_for_compile_do_side_conditions
  | _ => __compile_discharge_bag_side_conditions
  | _ => _compile_step
  | _ => _compile_CallBagFind
  | _ => _compile_CallBagInsert
  | _ => _compile_length
  | _ => _compile_allocTuple
  | _ => _compile_get
  | _ => apply CompileConstantBool
  | _ => reflexivity
  | _ => progress simpl
  | _ => setoid_rewrite map_rev_def
  end.

Ltac _compile env :=
  repeat __compile_start_compiling_step env;
  repeat __compile_method_step.

Transparent Vector.to_list.

Definition QSEnv_Ax : GLabelMap.t (AxiomaticSpec QsADTs.ADTValue) :=
  (GLabelMap.empty _)
  ### ("ADT", "WordList_new") ->> (QsADTs.WordListADTSpec.New)
  ### ("ADT", "WordList_delete") ->> (QsADTs.WordListADTSpec.Delete)
  ### ("ADT", "WordList_pop") ->> (QsADTs.WordListADTSpec.Pop)
  ### ("ADT", "WordList_empty") ->> (QsADTs.WordListADTSpec.Empty)
  ### ("ADT", "WordList_push") ->> (QsADTs.WordListADTSpec.Push)
  ### ("ADT", "WordList_copy") ->> (QsADTs.WordListADTSpec.Copy)
  ### ("ADT", "WordList_rev") ->> (QsADTs.WordListADTSpec.Rev)
  ### ("ADT", "WordList_length") ->> (QsADTs.WordListADTSpec.Length)

  ### ("ADT", "WTuple_new") ->> (QsADTs.WTupleADTSpec.New)
  ### ("ADT", "WTuple_delete") ->> (QsADTs.WTupleADTSpec.Delete)
  ### ("ADT", "WTuple_copy") ->> (QsADTs.WTupleADTSpec.Copy)
  ### ("ADT", "WTuple_get") ->> (QsADTs.WTupleADTSpec.Get)
  ### ("ADT", "WTuple_put") ->> (QsADTs.WTupleADTSpec.Put)

  ### ("ADT", "WTupleList_new") ->> (QsADTs.WTupleListADTSpec.New)
  ### ("ADT", "WTupleList_delete") ->> (QsADTs.WTupleListADTSpec.Delete)
  ### ("ADT", "WTupleList_copy") ->> (QsADTs.WTupleListADTSpec.Copy)
  ### ("ADT", "WTupleList_pop") ->> (QsADTs.WTupleListADTSpec.Pop)
  ### ("ADT", "WTupleList_empty") ->> (QsADTs.WTupleListADTSpec.Empty)
  ### ("ADT", "WTupleList_push") ->> (QsADTs.WTupleListADTSpec.Push)
  ### ("ADT", "WTupleList_rev") ->> (QsADTs.WTupleListADTSpec.Rev)
  ### ("ADT", "WTupleList_length") ->> (QsADTs.WTupleListADTSpec.Length)

  ### ("ADT", "WBagOfTuples0_new") ->> (QsADTs.WBagOfTuples0ADTSpec.New)
  ### ("ADT", "WBagOfTuples0_insert") ->> (QsADTs.WBagOfTuples0ADTSpec.Insert)
  ### ("ADT", "WBagOfTuples0_enumerate") ->> (QsADTs.WBagOfTuples0ADTSpec.Enumerate)

  ### ("ADT", "WBagOfTuples1_new") ->> (QsADTs.WBagOfTuples1ADTSpec.New)
  ### ("ADT", "WBagOfTuples1_insert") ->> (QsADTs.WBagOfTuples1ADTSpec.Insert)
  ### ("ADT", "WBagOfTuples1_find") ->> (QsADTs.WBagOfTuples1ADTSpec.Find)
  ### ("ADT", "WBagOfTuples1_enumerate") ->> (QsADTs.WBagOfTuples1ADTSpec.Enumerate)

  ### ("ADT", "WBagOfTuples2_new") ->> (QsADTs.WBagOfTuples2ADTSpec.New)
  ### ("ADT", "WBagOfTuples2_insert") ->> (QsADTs.WBagOfTuples2ADTSpec.Insert)
  ### ("ADT", "WBagOfTuples2_findBoth") ->> (QsADTs.WBagOfTuples2ADTSpec.FindBoth)
  ### ("ADT", "WBagOfTuples2_findFirst") ->> (QsADTs.WBagOfTuples2ADTSpec.FindFirst)
  ### ("ADT", "WBagOfTuples2_findSecond") ->> (QsADTs.WBagOfTuples2ADTSpec.FindSecond)
  ### ("ADT", "WBagOfTuples2_enumerate") ->> (QsADTs.WBagOfTuples2ADTSpec.Enumerate).


(** * EIP20 Token Implementation *)
(**
  This file contains correctness proofs of the EIP20 token implementation.
*)
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.
From Coq Require Import Lia.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Utils Require Import Automation.
From ConCert.Utils Require Import Extras.
From ConCert.Examples.EIP20 Require Import EIP20Token.

(** * Properties *)
Section Theories.
  Context {BaseTypes : ChainBase}.
  Open Scope N_scope.
  Open Scope bool.

  (** ** EIP20 functions not payable *)

  (** [receive] only returns Some if the sender amount is zero *)
  Lemma EIP20_not_payable : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state msg = Ok (new_state, new_acts) ->
      ((ctx_amount ctx) <= 0)%Z.
  Proof.
    intros * receive_some.
    unfold receive in receive_some.
    destruct_match eqn:amount in receive_some.
    - (* case: ctx_amount > 0 *)
      discriminate.
    - (* case: ctx_amount <= 0 *)
      now rewrite Z.gtb_ltb, Z.ltb_ge in amount.
  Qed.

  (** Lemma for simplifying the [receive] function by eliminating the case
      where sender amount is larger than zero *)
  Lemma receive_not_payable : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state (Some msg) = Ok (new_state, new_acts) ->
      match msg with
      | transfer to amount => (try_transfer (ctx_from ctx) to amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      | transfer_from from to amount =>
          (try_transfer_from (ctx_from ctx) from to amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      | approve delegate amount =>
          (try_approve (ctx_from ctx) delegate amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      end = Ok (new_state, new_acts).
  Proof.
    intros * receive_some.
    apply EIP20_not_payable in receive_some as amount_zero.
    unfold receive in receive_some.
    rewrite <- Z.ltb_ge, <- Z.gtb_ltb in amount_zero.
    now rewrite amount_zero in receive_some.
  Qed.

  (** ** EIP20 functions produce no acts *)

  (** [receive] never produces any [new_acts] *)
  Lemma EIP20_no_acts : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state msg = Ok (new_state, new_acts) ->
      new_acts = [].
  Proof.
    intros * receive_some.
    unfold receive, option_map in receive_some.
    repeat (destruct_match in receive_some; cbn in *); easy.
  Qed.

  Lemma receive_no_acts : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state (Some msg) = Ok (new_state, new_acts) ->
      receive chain ctx prev_state (Some msg) = Ok (new_state, []).
  Proof.
    intros.
    now erewrite <- EIP20_no_acts.
  Qed.

  (** Default entrypoint always fail *)
  Lemma default_none : forall prev_state chain ctx,
    receive chain ctx prev_state None = Err default_error.
  Proof.
    intros.
    unfold receive.
    now destruct_match.
  Qed.

  (* begin hide *)
  (* FMap partial alter is FMap add *)
  Lemma add_is_partial_alter_plus : forall (account : Address) amount (balances : FMap Address N) (f : N -> N),
    FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) account balances =
    FMap.add account (with_default 0 (FMap.find account balances) + amount) balances.
  Proof.
    intros.
    now apply fin_maps.partial_alter_ext.
  Qed.

  Lemma increment_balanace_is_partial_alter_plus : forall (addr : Address) amount (m : FMap Address N),
    increment_balance m addr amount =
    FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) addr m.
  Proof.
    intros.
    unfold increment_balance, AddressMap.add, AddressMap.find.
    rewrite add_is_partial_alter_plus by auto.
    destruct_match eqn:addr_in_map;
      now setoid_rewrite addr_in_map.
  Qed.

  (* Tactic to simplify proof steps *)
  Ltac eip_simpl :=
    match goal with
    | H : receive _ _ _ (Some _) = Ok (_, _) |- _ =>
      apply receive_no_acts, receive_not_payable in H; cbn in H
    | |- receive _ _ _ (Some _) = Ok (_, _) =>
      apply receive_no_acts, receive_not_payable; cbn
    | H : context[try_transfer] |- _ => unfold try_transfer in H
    | H : context[try_transfer_from] |- _ => unfold try_transfer_from in H
    | H : context[try_approve] |- _ => unfold try_approve in H
    | H : context[error] |- _ => unfold error in H
    | |- context[try_transfer] => unfold try_transfer
    | |- context[try_transfer_from] => unfold try_transfer_from
    | |- context[try_approve] => unfold try_approve
    | |- context[error] => unfold error
    end.

  Ltac address_map_convert :=
    match goal with
    | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H
    | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H
    | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H
    | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible
    | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible
    | |- context [ increment_balance _ _ _ ] => rewrite increment_balanace_is_partial_alter_plus
    end.

  Tactic Notation "contract_simpl" :=
    repeat (
      try eip_simpl;
      try address_map_convert;
      try contract_simpl_step @receive @init).

  Ltac FMap_simpl_step :=
    match goal with
      | |- context [ FMap.find ?x (FMap.add ?x _ _) ] => setoid_rewrite FMap.find_add
      | H : FMap.find ?t ?m = Some _ |- FMap.find ?t ?m = Some _ => cbn; rewrite H; f_equal; lia
      | H : ?x <> ?y |- context [ FMap.find ?x (FMap.add ?y _ _) ] => setoid_rewrite FMap.find_add_ne; eauto
      | H : ?y <> ?x |- context [ FMap.find ?x (FMap.add ?y _ _) ] => setoid_rewrite FMap.find_add_ne; eauto
      | H : FMap.find ?x _ = Some _ |- context [ FMap.elements (FMap.add ?x _ _) ] => setoid_rewrite FMap.elements_add_existing; eauto
      | |- context [ FMap.add ?x _ (FMap.add ?x _ _) ] => setoid_rewrite FMap.add_add
      | H : FMap.find ?x _ = None |- context [ FMap.elements (FMap.add ?x _ _) ] => setoid_rewrite FMap.elements_add; eauto
      | |- context [ FMap.remove ?x (FMap.add ?x _ _) ] => rewrite fin_maps.delete_insert_delete
      | |- context [ FMap.find ?x (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter
      | H : ?x' <> ?x |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne; auto
      | H : ?x <> ?x' |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne
      | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H
      | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H
      | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H
      | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible
      | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible
      | |- context [ increment_balance _ _ _ ] => rewrite increment_balanace_is_partial_alter_plus
    end.

  Tactic Notation "FMap_simpl" := repeat (FMap_simpl_step; cbn).

  Ltac destruct_message :=
    repeat match goal with
    | msg : option Msg |- _ => destruct msg
    | msg : Msg |- _ => destruct msg
    | H : Blockchain.receive _ _ _ _ None = Ok _ |- _ => now contract_simpl
    | H : receive _ _ _ None = Ok _ |- _ => now contract_simpl
    end.

  (* sumN function *)
  (* sumN of balances is the same after transfer changes if sender has enough balance *)
  Lemma sumN_FMap_add_sub : forall from to amount (balances : FMap Address N),
    amount <= with_default 0 (FMap.find from balances) ->
      (sumN (fun '(_, v) => v) (FMap.elements balances)) =
      (sumN(fun '(_, v) => v)
        (FMap.elements
            (FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) to
              (FMap.add from (with_default 0 (FMap.find from balances) - amount) balances)))).
  Proof.
    intros from to amount balances from_enough_balance.
    rewrite add_is_partial_alter_plus; auto.
    edestruct (address_eqb from to) eqn:from_to_eq;
      destruct FMap.find eqn:from_prev;
      destruct_address_eq; try discriminate; subst; cbn in *;
      repeat match goal with
      | H : _ <= 0 |- _ => apply N.lt_eq_cases in H as [H | H]; try lia; subst
      | |- context [ with_default _ (FMap.find to balances) ] => destruct (FMap.find to balances) eqn:to_prev; cbn
      | |- context [ FMap.find ?x (FMap.add ?x _ _) ] => rewrite FMap.find_add
      | H : FMap.find ?t ?m = Some _ |- FMap.find ?t ?m = Some _ => cbn; rewrite H; f_equal; lia
      | H : ?x <> ?y |- context [ FMap.find ?x (FMap.add ?y _ _) ] => rewrite FMap.find_add_ne; eauto
      | H : ?y <> ?x |- context [ FMap.find ?x (FMap.add ?y _ _) ] => rewrite FMap.find_add_ne; eauto
      | H : FMap.find ?x _ = Some _ |- context [ FMap.elements (FMap.add ?x _ _) ] => rewrite FMap.elements_add_existing; eauto
      | |- context [ FMap.add ?x _ (FMap.add ?x _ _) ] => rewrite FMap.add_add
      | H : FMap.find ?x _ = None |- context [ FMap.elements (FMap.add ?x _ _) ] => rewrite FMap.elements_add; eauto
      | |- context [ FMap.remove ?x (FMap.add ?x _ _) ] => rewrite fin_maps.delete_insert_delete
      | H : FMap.find ?x ?m = Some _ |- context [ sumN _ ((_, _) :: FMap.elements (FMap.remove ?x ?m)) ] => rewrite fin_maps.map_to_list_delete; auto
      | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: FMap.elements (FMap.remove ?x _)) ] => rewrite fin_maps.map_to_list_delete; auto
      | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: (_, _) :: FMap.elements (FMap.remove ?x _)) ] => rewrite sumN_swap, fin_maps.map_to_list_delete; auto
      | |- context [ _ + 0 ] => rewrite N.add_0_r
      | |- context [ 0 + _ ] => rewrite N.add_0_l
      | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x := (t, n)) (y := (_, m)) by lia
      | |- context [ sumN _ ((_, ?n) :: (_, ?m - ?n) :: _) ] => erewrite <- sumN_split with (z := (_, n + m - n)) by lia
    end.
    Unshelve. eauto.
  Qed.

  (* end hide *)

  (** ** Expected behaviour of EIP20 functions *)
  Definition transfer_balance_update_correct old_state new_state from to tokens :=
    let get_balance addr state := with_default 0 (FMap.find addr state.(balances)) in
    let from_balance_before := get_balance from old_state in
    let to_balance_before := get_balance to old_state in
    let from_balance_after := get_balance from new_state in
    let to_balance_after := get_balance to new_state in
    (** if the transfer is a self-transfer, balances should remain unchained *)
    if address_eqb from to
    then
      (from_balance_before =? from_balance_after) &&
      (to_balance_before =? to_balance_after)
    else
      (from_balance_before =? from_balance_after + tokens) &&
      (to_balance_before + tokens =? to_balance_after).

  Definition transfer_from_allowances_update_correct (old_state new_state : State) (from delegate : Address) (tokens : TokenValue) :=
    let delegate_allowance_before := get_allowance old_state from delegate in
    let delegate_allowance_after := get_allowance new_state from delegate in
      delegate_allowance_before =? delegate_allowance_after + tokens.

  Definition approve_allowance_update_correct (new_state : State) (from delegate : Address) (tokens : TokenValue) :=
    let delegate_allowance_after := get_allowance new_state from delegate in
      delegate_allowance_after =? tokens.

  (** ** Transfer correct *)

  (** [try_transfer] correctly moves [amount] from [sender] to [to] *)
  Lemma try_transfer_balance_correct : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
    transfer_balance_update_correct prev_state new_state ctx.(ctx_from) to amount = true.
  Proof.
    intros * receive_some.
    unfold transfer_balance_update_correct.
    contract_simpl.
    rename H0 into sender_enough_balance.
    apply N.ltb_ge in sender_enough_balance.
    destruct_address_eq; destruct (FMap.find (ctx_from ctx) (balances prev_state)) eqn:from_prev;
      try congruence; subst; try (rewrite from_prev || setoid_rewrite from_prev);
      clear from_prev new_acts chain; cbn in *.
      - (* case: from = to && find from = Some n && amount <= n *)
        FMap_simpl.
        now rewrite N.sub_add, N.eqb_refl.
      - (* case: from = to && find from = None && amount = 0 *)
        apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst].
        now FMap_simpl.
      - (* case: from <> to && find from = Some n && amount <= n *)
        FMap_simpl.
        rewrite N.sub_add; auto.
        now rewrite !N.eqb_refl.
      - (* case: from <> to && find from = None && amount = 0 *)
        apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst].
        FMap_simpl.
        apply N.eqb_refl.
  Qed.

  (** [try_transfer] does not change the total supply of tokens *)
  Lemma try_transfer_preserves_total_supply : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer] does not change allowances *)
  Lemma try_transfer_preserves_allowances : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (allowances prev_state) = (allowances new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer] only modifies the [sender] and [to] balances *)
  Lemma try_transfer_preserves_other_balances : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) -> account <> to ->
        FMap.find account (balances prev_state) = FMap.find account (balances new_state).
  Proof.
    intros * receive_some account account_not_sender account_not_receiver.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** If the requirements are met then receive on transfer msg must succeed and
      if receive on transfer msg succeeds then requirements must hold *)
  Lemma try_transfer_is_some : forall state chain ctx to amount,
    (ctx_amount ctx <= 0)%Z /\
    amount <= with_default 0 (FMap.find (ctx_from ctx) (balances state))
      <-> isOk (receive chain ctx state (Some (transfer to amount))) = true.
  Proof.
    intros.
    split.
    - intros (amount_positive & sender_enough_balance);
      contract_simpl; destruct_match eqn:amount_from; auto.
      + now propify.
      + rewrite <- N.ltb_ge in sender_enough_balance.
        now setoid_rewrite sender_enough_balance.
    - intros receive_some.
      contract_simpl.
      destruct_match eqn:amount_positive in receive_some;
        try now inversion receive_some.
      destruct_match eqn:amount_from in receive_some.
      + destruct_match eqn:amount_from_ in amount_from.
        * discriminate.
        * now propify.
      + now propify.
  Qed.

  (** ** Transfer_from correct *)

  (** [try_transfer_from] correctly updates balance and allowance *)
  Lemma try_transfer_from_balance_correct : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
    transfer_balance_update_correct prev_state new_state from to amount = true /\
    transfer_from_allowances_update_correct prev_state new_state from ctx.(ctx_from) amount = true.
  Proof.
    intros * receive_some.
    unfold transfer_balance_update_correct,
      transfer_from_allowances_update_correct,
      get_allowance.
    contract_simpl.
    rename H0 into from_allowances.
    rename H1 into sender_allowance.
    rewrite result_of_option_eq_some in from_allowances.
    rewrite result_of_option_eq_some in sender_allowance.
    propify.
    destruct H2 as (sender_enough_allowance & from_enough_balance).
    split.
      + (* proof of balance updated correct *)
      destruct_address_eq;
        destruct (FMap.find from (balances prev_state)) eqn:from_bal_prev;
        subst; try (rewrite from_bal_prev || setoid_rewrite from_bal_prev); cbn in *.
        * (* case: from = to && find from = Some n && amount <= n *)
          FMap_simpl.
          now rewrite N.sub_add, N.eqb_refl.
        * (* case: from = to && find from = None && amount = 0 *)
          apply N.lt_eq_cases in from_enough_balance as []; [lia | subst].
          now FMap_simpl.
        * (* case: from <> to && find from = Some n && amount <= n *)
          FMap_simpl.
          rewrite N.sub_add by auto.
          now rewrite ?N.eqb_refl.
        * (* case: from <> to && find from = None && amount = 0 *)
          apply N.lt_eq_cases in from_enough_balance as []; [lia | subst].
          FMap_simpl.
          apply N.eqb_refl.
      + (* proof of allowances updated correct *)
        rewrite from_allowances.
        cbn.
        setoid_rewrite sender_allowance.
        FMap_simpl.
        now rewrite N.sub_add.
  Qed.

  (** [try_transfer_from] does not change total supply of tokens *)
  Lemma try_transfer_from_preserves_total_supply : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer_from] only changes [from] and [to] balances *)
  Lemma try_transfer_from_preserves_other_balances : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> from -> account <> to ->
        FMap.find account (balances prev_state) = FMap.find account (balances new_state).
  Proof.
    intros * receive_some account account_not_from account_not_to.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** [try_transfer_from] only changes allowance map of [from] *)
  Lemma try_transfer_from_preserves_other_allowances : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> from ->
        FMap.find account (allowances prev_state) = FMap.find account (allowances new_state).
  Proof.
    intros * receive_some account account_not_from.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** [try_transfer_from] only changes allowance of [sender] *)
  Lemma try_transfer_from_preserves_other_allowance : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) ->
        get_allowance prev_state from account = get_allowance new_state from account.
  Proof.
    intros * receive_some account account_not_sender.
    unfold get_allowance.
    contract_simpl.
    rewrite result_of_option_eq_some in H0.
    rewrite result_of_option_eq_some in H1.
    rewrite H0.
    cbn.
    FMap_simpl.
  Qed.

  Set Keyed Unification.

  (** If the requirements are met then receive on transfer_from msg must succeed and
      if receive on transfer_from msg succeeds then requirements must hold *)
  Lemma try_transfer_from_is_some : forall state chain ctx from to amount,
    let get_allowance_ account := FMap.find account (with_default (@FMap.empty (FMap Address TokenValue) _) (FMap.find from (allowances state))) in
    (ctx_amount ctx >? 0)%Z = false ->
    isSome (FMap.find from (allowances state)) = true
    /\ isSome (get_allowance_ (ctx_from ctx)) = true
    /\ amount <= with_default 0 (FMap.find from (balances state))
    /\ amount <= with_default 0 (get_allowance_ (ctx_from ctx))
      <-> isOk (receive chain ctx state (Some (transfer_from from to amount))) = true.
  Proof.
    intros * sender_amount_zero.
    split; contract_simpl; rewrite sender_amount_zero in *;
      unfold get_allowance_; clear get_allowance_; cbn.
    - intros (from_allowances_some &
              sender_allowance &
              from_enough_balance%N.ltb_ge &
              sender_enough_allowance%N.ltb_ge).
      destruct_match eqn:receive_some; cbn in *; auto.
      destruct_match eqn:allowances_ctx in receive_some;
        try (apply result_of_option_eq_none in allowances_ctx; now rewrite allowances_ctx in from_allowances_some).
      rewrite result_of_option_eq_some in allowances_ctx.
      rewrite allowances_ctx in *.
      clear from_allowances_some allowances_ctx.
      cbn in *.
      destruct_match eqn:allowance_ctx in receive_some;
        try (apply result_of_option_eq_none in allowance_ctx; now rewrite allowance_ctx in sender_allowance).
      rewrite result_of_option_eq_some in allowance_ctx.
      rewrite allowance_ctx in *.
      clear allowance_ctx sender_allowance.
      destruct_match eqn:amount_from in receive_some; try discriminate.
      rewrite from_enough_balance in amount_from.
      now rewrite sender_enough_allowance in amount_from.
    - intros receive_some.
      destruct_match eqn:H in receive_some; try discriminate.
      destruct_match eqn:allowances_ctx in H; try discriminate.
      destruct_match eqn:allowance_ctx in H; try discriminate.
      destruct_match eqn:amount_from in H; try discriminate.
      cbn in *.
      propify.
      rewrite result_of_option_eq_some in allowances_ctx.
      rewrite result_of_option_eq_some in allowance_ctx.
      now rewrite allowances_ctx, allowance_ctx.
  Qed.

  (** ** Approve correct *)

  (** [try_approve] correctly replaces allowance *)
  Lemma try_approve_allowance_correct : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
    approve_allowance_update_correct new_state ctx.(ctx_from) delegate amount = true.
  Proof.
    intros * receive_some.
    unfold approve_allowance_update_correct, get_allowance.
    contract_simpl.
    destruct_match eqn:from_allowance in H;
      inversion H; cbn;
      FMap_simpl; apply N.eqb_refl.
  Qed.

  (** [try_approve] does not change total supply of tokens *)
  Lemma try_approve_preserves_total_supply : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** [try_approve] does not change balances *)
  Lemma try_approve_preserves_balances : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (balances prev_state) = (balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** [try_approve] does not change allowances map of other addresses *)
  Lemma try_approve_preserves_other_allowances : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) ->
        FMap.find account (allowances prev_state) = FMap.find account (allowances new_state).
  Proof.
    intros * receive_some account account_not_sender.
    contract_simpl.
    destruct_match in H;
      inversion H;
      cbn; FMap_simpl.
  Qed.

  (** [try_approve] does not change allowance of other addresses *)
  Lemma try_approve_preserves_other_allowance : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      forall account, account <> delegate ->
        get_allowance prev_state (ctx_from ctx) account = get_allowance new_state (ctx_from ctx) account.
  Proof.
    intros * receive_some account account_not_delegate.
    contract_simpl.
    unfold get_allowance.
    destruct_match eqn:allowances_from in H;
      inversion H;
      cbn; FMap_simpl.
  Qed.

  (** If the requirements are met then receive on approve msg must succeed and
      if receive on approve msg succeeds then requirements must hold *)
  Lemma try_approve_is_some : forall state chain ctx delegate amount,
    (ctx_amount ctx >? 0)%Z = false <-> isOk (receive chain ctx state (Some (approve delegate amount))) = true.
  Proof.
    split; contract_simpl.
    - intros sender_amount_zero.
      rewrite sender_amount_zero.
      destruct_match eqn:H; auto.
      destruct_match in H; discriminate.
    - intros receive_some.
      now destruct_match in receive_some.
  Qed.

  (** ** EIP20 functions preserve sum of balances *)

  (** Sum of all balances remain the same after processing transfer msg *)
  Lemma try_transfer_preserves_balances_sum : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    propify.
    unfold sum_balances. cbn.
    now apply sumN_FMap_add_sub.
  Qed.

  (** Sum of all balances remain the same after processing transfer_from msg *)
  Lemma try_transfer_from_preserves_balances_sum : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    propify.
    unfold sum_balances. cbn.
    now apply sumN_FMap_add_sub.
  Qed.

  (** Sum of all balances remain the same after approve transfer msg *)
  Lemma try_approve_preserves_balances_sum : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** ** Contract never produces any actions *)
  Lemma outgoing_acts_nil : forall (bstate : ChainState) (caddr : Address),
    reachable bstate ->
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    outgoing_acts bstate caddr = [].
  Proof.
    intros * reach deployed.
    apply (lift_outgoing_acts_nil contract); eauto.
    intros.
    unfold Blockchain.receive in *.
    now eapply EIP20_no_acts.
  Qed.

  (** ** Total supply always equals initial supply *)
  Lemma total_supply_eq_init_supply bstate caddr (trace : ChainTrace empty_state bstate) :
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    exists deploy_info cstate,
      deployment_info _ trace caddr = Some deploy_info
      /\ contract_state bstate caddr = Some cstate
      /\ let init_supply := init_amount deploy_info.(deployment_setup) in
        init_supply = total_supply cstate.
  Proof.
    apply (lift_dep_info_contract_state_prop contract); intros *.
    - intros init_some.
      now inversion init_some.
    - intros IH receive_some.
      destruct_message.
      + now apply try_transfer_preserves_total_supply in receive_some.
      + now apply try_transfer_from_preserves_total_supply in receive_some.
      + now apply try_approve_preserves_total_supply in receive_some.
  Qed.

  (** ** Sum of balances always equals total supply *)
  Lemma sum_balances_eq_total_supply bstate caddr :
    reachable bstate ->
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    exists cstate,
      contract_state bstate caddr = Some cstate
      /\ (total_supply cstate) = (sum_balances cstate).
  Proof.
    intros.
    apply (lift_contract_state_prop contract); eauto; intros *.
    - intros init_some.
      inversion_clear init_some.
      unfold sum_balances.
      setoid_rewrite FMap.elements_add; auto.
      setoid_rewrite FMap.elements_empty. cbn. lia.
    - intros IH receive_some.
      unfold Blockchain.receive in *.
      cbn in *.
      destruct_message.
      + now erewrite try_transfer_preserves_balances_sum,
          try_transfer_preserves_total_supply in IH.
      + now erewrite try_transfer_from_preserves_balances_sum,
          try_transfer_from_preserves_total_supply in IH.
      + now erewrite try_approve_preserves_balances_sum,
          try_approve_preserves_total_supply in IH.
  Qed.

End Theories.