Require Import StructTact.StructTactics.
Require Import Core.Core Core.Notations Core.Tactics Core.PtrLemmas.
Require Import Spec Lists.List.

Import ListNotations.
Open Scope Z.

Notation option_lift := RingMicromega.map_option.

Definition string := list byte.

(** * Memory read *)
(* read [n] consecutive bytes from memory [m] starting at addres [a] *)
Definition bytes_of_mem (m : mem) (a : addr) (n : Z) : option (string) :=
  let '(b, ofs) := a in
  (option_lift proj_bytes) (Mem.loadbytes m b (Ptrofs.unsigned ofs) n).

Definition bytes_between (m : mem) (a1 a2 : addr) : option (string) :=
  match distance m a1 a2 with
  | Some n => bytes_of_mem m a1 (Z.of_nat n + 1%Z)
  | None => None
  end.

(** * High level spec *)
(* common bytes *)
Definition minus_char := Byte.repr 45.
Definition plus_char := Byte.repr 43.
Definition zero_char := Byte.repr 48.
Definition nine_char := Byte.repr 57.

Definition is_digit (i : byte) : bool :=
  ((zero_char <= i) && (i <= nine_char))%byte.

Definition Z_of_char (b : byte) : Z :=
  Byte.signed b - Byte.signed zero_char.

Definition is_sign (b : byte) : bool :=
  ((b == plus_char) || (b == minus_char))%byte.

Definition sign_of_char (b : byte) : Z :=
  if (b == plus_char)%byte then 1
  else if (b == minus_char)%byte then (- 1)
       else 0.

Definition bounded (n : Z) : bool :=
  (Int.min_signed <=? n) && (n <=? Int.max_signed).

(* s is not empty *)
Definition non_empty (s : string) := s <> [].

(* all characters in s are digits *)
Definition all_digits (s : string) := forallb is_digit s.

(* Valid inputs that can be successfully converted into int *)

Inductive valid_input : string -> Prop :=
| ValidInput_EXTRA_DATA : forall s' s,
    (* s' represents a number (optionally) preceded by + or - *)
    valid_input_all_digits s' ->
    (* append any string to s' to get extra data case *)
    valid_input (app s' s)
with valid_input_all_digits : string -> Prop :=
     | ValidInput_OK_unsigned :
         forall s,
           non_empty s ->
           all_digits s = true ->
           valid_input_all_digits s
     | ValidInput_OK_signed :
         forall sg s,
           non_empty s ->
           is_sign sg = true ->
           all_digits s = true ->
           valid_input_all_digits (sg :: s).

(* Converts string into an integer:
   - returns None on empty string
   - otherwise converts s into int until a non-digit is encountered
   - on [c], with c not a digit, returns 0
     (later we will call it only on valid data so this is irrelevant)
   - records index where extra data is encountered or where we go out of range *)

Record Z_of_string_result :=
  { val : Z ;
    index : Z ;
  }.

Definition Z_of_string (sign : byte) (s : string) : option Z_of_string_result :=
  let fix Z_of_string_loop s v i :=
      match s with
      | [] => {| val := v ;
                index := i ; |}
      | c :: tl =>
        let i' := (Zlength s - (Zlength tl) - 1)%Z in (* index of c in s *)
        if is_digit c
        then let v := (v * 10 + (Byte.signed c - 48))%Z in
             if bounded v
             then Z_of_string_loop tl v i
             else Z_of_string_loop tl v i' (* recoreded where went out of range *)
        else {| val := v ;
                index := i' ; |} (* extra stuff is ignored *)
      end
  in match s with
     |  nil => None (* no data to convert *)
     |  _ => let res := (Z_of_string_loop s 0%Z 0%Z) in
            if (sign == plus_char)%byte
            then Some res
            else Some {| val := Z.opp (val res);
                         index := index res ; |}
                         end.

(** Relational spec *)

(* Store pointer (a2 + i) at address a1 *)
Definition store_pointer (m : mem) (a1 : addr) (a2 : addr) (i : Z) :=
  let (b1, ofs1) := a1 in
  let (b2, ofs2) := a2 in
  Mem.storev Mptr m (Vptr b1 ofs1) (Vptr b2 (ofs2 + (Ptrofs.repr i))%ptrofs).

(* Store v as a long value at address a *)
Definition store_value (m : mem) (a : addr) (v : Z) :=
  let (b, ofs) := a in
  Mem.storev Mint64 m (Vptr b ofs) (Vlong (Int64.repr v)).

(* could add option Z to the type to store the resulting value *)
Inductive asn_strtoimax_lim_R m str fin intp : mem -> option Z -> asn_strtox_result_e -> Prop :=

(* Input outside of supported numeric range, first read sign *)
| ASN_STRTOX_ERROR_RANGE_R_signed :
    forall sg s z m',
      bytes_between m str fin = Some (sg :: s) ->
      is_sign sg = true ->
      valid_input (sg :: s) ->
      Z_of_string sg s = Some z ->
      bounded (val z) = false ->
      store_pointer m fin str (index z) = Some m' ->
      asn_strtoimax_lim_R m str fin intp m' None ASN_STRTOX_ERROR_RANGE

(* Input outside of supported numeric range *)
| ASN_STRTOX_ERROR_RANGE_R_unsigned :
    forall s z m',
      bytes_between m str fin = Some s ->
      valid_input s ->
      Z_of_string plus_char s = Some z ->
      bounded (val z) = false ->
      store_pointer m fin str (index z) = Some m' ->
      asn_strtoimax_lim_R m str fin intp m' None ASN_STRTOX_ERROR_RANGE

(* Invalid data encountered (e.g., "+-", "a") *)
| ASN_STRTOX_ERROR_INVAL_R_Some :
    forall s,
      bytes_between m str fin = Some s ->
      ~ (valid_input s) ->
      asn_strtoimax_lim_R m str fin intp m None ASN_STRTOX_ERROR_INVAL

(* str >= * end and memory fail (could replace by just str >= *end *)
| ASN_STRTOX_ERROR_INVAL_R_None :
    bytes_between m str fin = None ->
    asn_strtoimax_lim_R m str fin intp m None ASN_STRTOX_ERROR_INVAL

(* More data expected (e.g. "+", "-") *)
| ASN_STRTOX_EXPECT_MORE_R : forall m',
    bytes_between m str fin = Some [plus_char] \/
    bytes_between m str fin = Some [minus_char] ->
    store_pointer m fin str 1%Z = Some m' ->
    asn_strtoimax_lim_R m str fin intp m' None ASN_STRTOX_EXPECT_MORE

(* Conversion succeded, but the string has extra stuff, first read sign *)
| ASN_STRTOX_EXTRA_DATA_R_signed :
    forall sg s z m' m'',
      bytes_between m str fin = Some (sg :: s) ->
      valid_input (sg :: s) ->
      (exists c, In c s /\ is_digit c = false) ->
      is_sign sg = true ->
      Z_of_string sg s = Some z ->
      bounded (val z) = true ->
      store_pointer m fin str (index z) = Some m' ->
      store_value m' intp (val z) = Some m'' ->
      asn_strtoimax_lim_R m str fin intp m'' (Some (val z)) ASN_STRTOX_EXTRA_DATA

(* Conversion succeded, but the string has extra stuff *)
| ASN_STRTOX_EXTRA_DATA_R_unsigned :
    forall s z m' m'',
      bytes_between m str fin = Some s ->
      valid_input s ->
      (exists c, In c s /\ is_digit c = false) ->
      Z_of_string plus_char s = Some z ->
      bounded (val z) = true ->
      store_pointer m fin str (index z) = Some m' ->
      store_value m' intp (val z) = Some m'' ->
      asn_strtoimax_lim_R m str fin intp m'' (Some (val z)) ASN_STRTOX_EXTRA_DATA

(* Conversion succeded, first read sign *)
| ASN_STRTOX_OK_R_signed :
    forall sg s z m' m'',
      bytes_between m str fin = Some (sg :: s) ->
      is_sign sg = true ->
      valid_input_all_digits (sg :: s) ->
      Z_of_string sg s  = Some z ->
      bounded (val z) = true ->
      store_pointer m fin str (Zlength (sg :: s)) = Some m' ->
      store_value m' intp (val z) = Some m'' ->
      asn_strtoimax_lim_R m str fin intp m'' (Some (val z)) ASN_STRTOX_OK

| ASN_STRTOX_OK_R_unsigned :
    forall s z m' m'',
      bytes_between m str fin = Some s ->
      valid_input_all_digits s ->
      Z_of_string plus_char s = Some z ->
      bounded (val z) = true ->
      store_pointer m fin str (Zlength s) = Some m' ->
      store_value m' intp (val z) = Some m'' ->
      asn_strtoimax_lim_R m str fin intp m'' (Some (val z)) ASN_STRTOX_OK.

Theorem asn_strtoimax_lim_func_correct :
  forall m str fin intp res v m' ret,

    asn_strtoimax_lim_R m str fin intp m' (Some v) res <->
    (asn_strtoimax_lim m str fin intp = Some ret
     /\ value ret = Some (Int64.repr v)
     /\ memory ret = Some m').
Admitted.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Coq.Unicode.Utf8.

Local Open Scope program_scope.

Require Import FinProof.Common.
Require Import FinProof.ProgrammingWith.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.

Local Open Scope record.

Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolSpec.

(* Module SML (xt: XTypesSig) (sm: StateMonadSig). *)

Module DePoolSpec := DePoolSpec XTypesSig StateMonadSig.
Import DePoolSpec.
Import LedgerClass.
Import SolidityNotations.

Require Import ZArith.
Require Import Psatz.
Local Open Scope Z_scope.

Compute (xIntPlus 0%Z 1%Z).

(*  Lemma foo : forall a y, let x := (Z.modulo a 13%Z) - (a + a) / (a +13) in  y <= y + x.
Proof.
    intros.
    match goal with
    | |- ?G => match G with
              | context [y <= y + ?x] => remember x
              end
    end.
    zify.

    enough ( z >= 0).
    lia.   *)

(* Import xt. Import sm. *)

Local Open Scope solidity_scope.
Local Open Scope string_scope.

Inductive LedgerFunction : Type -> Type :=
 | LedgerFunction0: forall X, LedgerFunction (LedgerT X)
 | LedgerFunction_Next: forall X Y, LedgerFunction Y -> LedgerFunction (X -> Y).

 Class Ledgerable (X: Type) :=
 {
     ledgerable : LedgerFunction X ;
     ledgerFirstType : Type ;
     ledgerTailType : Type ;
     ledgerJoin : LedgerT X -> X ;
     sApply : X -> LedgerT ledgerFirstType -> ledgerTailType
 }.

(*  Notation "◯" := (LedgerFunction0) (at level 100).
 Notation " a ⇉ b " := (LedgerFunction1 a b) (at level 100, right associativity).

Check ◯ nat.
Check  nat ⇉ ◯ nat.
Check  nat ⇉ nat ⇉ ◯ nat. *)

Inductive SolidityExpression : Type -> Type :=
| SolidityScalar : forall {X}, LedgerT X -> SolidityExpression X
| SolidityState : forall {X U} {m: Ledger -> U}`{Accessor Ledger U m}`{EmbeddedType Ledger U} (f: U -> X)`{Accessor U X f} ,  SolidityExpression X
| SolidityField : forall {S U}`{Struct S} (f:S->U)`{Accessor _ _ f}, SolidityExpression S -> SolidityExpression U
| SolidityIndex : forall {K V}`{XBoolEquable XBool K}`{XDefault V}, SolidityExpression K -> SolidityExpression (XHMap K V) -> SolidityExpression V
(* | SolidityFunction: forall {X B}`{Ledgerable X B}, X -> SolidityExpression B *)
(* | SolidityFunctionCall: forall {X A B}`{Ledgerable X (A -> B)}, X -> SolidityExpression A -> SolidityExpression B
 *).

 Instance LedgerT_Ledgerable {X} : Ledgerable (LedgerT X) := {
    ledgerable := LedgerFunction0 X ;
    ledgerFirstType := True ;
    ledgerTailType :=  SolidityExpression X ;
    ledgerJoin := fun mx => mx >>= Datatypes.id ;
    (*sApply : X -> ledgerFirstType -> ledgerTailType*)
    sApply := fun f _ => SolidityScalar f
 }.

 Instance LedgerTNext_Ledgerable {X Y}`{Ledgerable Y} :
                      Ledgerable (X -> Y) := {
    ledgerable := LedgerFunction_Next X Y ledgerable ;
    (* toLedgerBaseType := fun (f: X -> Y) => inject (fun (x: X) => toLedgerBaseType (f x))  *)
    ledgerFirstType := X ;
    ledgerTailType := Y ;
    (* LedgerT (X -> Y) -> X -> Y *)
    ledgerJoin := fun (mf: LedgerT (X -> Y)) => fun x => ledgerJoin (mf >>= fun f => return! (f x)) ;
    (*sApply : X -> ledgerFirstType -> ledgerTailType*)
    sApply := fun (f : X -> Y) (mx: LedgerT X) => ledgerJoin (mx >>= fun x => return! (f x))
 }.

(* Definition sApply {L} (f: L)`{Ledgerable L} (x: LedgerT ledgerFirstType) : ledgerTailType.
Proof.
    intros.
    remember (ledgerable_dec L ledgerFirstType ledgerTailType).
    assert (match ledgerable with
    | LedgerFunction0 _ => L = ledgerTailType
    | LedgerFunction_Next _ Y _ => L = (ledgerFirstType → ledgerTailType)
    end).
    apply y; auto. clear y Heqy.
    remember ledgerable.
    generalize dependent ledgerable.
    induction l; intros.
    rewrite <- H0.
    refine f.
    apply forall_dec in H0.
    inversion_clear H0.
    rewrite <- H2 in * |- *.
    assert (Ledgerable Y).
    apply ledgerableFunction with (X:=X); auto.
    assert (H = @LedgerTNext_Ledgerable X Y X0).
    apply instance_irr.
    rewrite H0 in * |- *.
    rewrite <- H1 in * |- *.

    remember (do x' ← x; return! (f x')).
    apply sJoin.
    refine l1.
Defined. *)

(*  := {
    ledgerable := LedgerFunction0 X ;
    ledgerFirstType := True ;
    ledgerTailType :=  LedgerT X
 }. *)

Check ledgerable (X:=nat -> nat -> LedgerT nat).
Compute ledgerFirstType (X:=nat -> nat -> LedgerT nat).
Compute ledgerTailType (X:=nat -> nat -> LedgerT nat).
Compute ledgerFirstType (X:= LedgerT nat).
Compute ledgerTailType (X:= LedgerT nat).

(* (X -> LedgerT Y) --> (LedgerT (X -> Y)) *)

(* Fixpoint ledgerableDegree (X: Type)`{Ledgerable X} : nat :=
    match ledgerable with
    | LedgerFunction0 _ => 0
    | LedgerFunction_Next X Y L => S (@ledgerableDegree Y {| ledgerable  := L ;
                                                             ledgerFirstType
                                                               |})
    end. *)

Fixpoint ledgerableDegree {X} (a: LedgerFunction X) : nat :=
    match a with
    | LedgerFunction0 _ => 0
    | LedgerFunction_Next _ _ f => S (ledgerableDegree f)
    end.

(* Lemma ledgerable0_first: forall X, ledgerFirstType (X:=LedgerT X) = True.
Proof.
    intros.
    auto.
Qed.

Lemma ledgerable0_tail: forall X, ledgerTailType (X:=LedgerT X) = LedgerT X.
Proof.
    intros.
    auto.
Qed.  *)

(* Check (ledgerFirstType -> ledgerTailType).

Axiom instance_irr: forall X (i j: Ledgerable X), i = j.

Axiom forall_dec: forall (X Y A B: Type), ((forall (_:X), Y) = (forall (_:A), B)) ->
(X = A) /\ (Y = B).

Axiom ledgerableFunction : forall X Y`{ Ledgerable (X -> Y) } , Ledgerable Y.

Axiom ledgerable_dec: forall (L: Type)`{H: Ledgerable L} (f t: Type),
f = @ledgerFirstType L H ->
t = @ledgerTailType L H ->
match @ledgerable L H with
| LedgerFunction0 _ => (L = t)
| LedgerFunction_Next _ _ _ => (L = forall (a: f), t )
end. *)

(* Instance ledgerTailType_Ledgerable {L}`{Ledgerable L} : Ledgerable ledgerTailType.
remember (ledgerable_dec L ledgerFirstType ledgerTailType).
assert (match ledgerable with
| LedgerFunction0 _ => L = ledgerTailType
| LedgerFunction_Next _ Y _ => L = (ledgerFirstType → ledgerTailType)
end).
apply y; auto.
clear Heqy y.
induction ledgerable.
rewrite <- H0.
refine H.
destruct l.
apply forall_dec in H0 .
inversion_clear H0.
rewrite <- H2.
apply LedgerT_Ledgerable.
apply forall_dec in H0 .
inversion_clear H0.
rewrite <- H2.
assert (LedgerFunction (X0->Y)).
apply LedgerFunction_Next; auto.
refine {| ledgerable := X1 ;
          ledgerFirstType := X0 ;
          ledgerTailType := Y  |}.
Defined. *)

Check SolidityScalar ($ xInt0).
Check SolidityState DePoolContract_ι_m_association.
Check SolidityField contractAddress (SolidityScalar ($ default)).
Check SolidityIndex (SolidityScalar ($xInt0)) (SolidityScalar ($xHMapEmpty)).
(* Check SolidityFunction (fun x: nat => return! x : LedgerT nat).
Check SolidityFunction (fun (x: Z) (y: Z) => return! (x + y) : LedgerT Z).
Check SolidityFunction (fun (x: Z) (y: Z) => (x + y) : Z).
Check SolidityFunction (return! 0 : LedgerT Z). *)

Definition sReader {X} (e : SolidityExpression X): LedgerT X.
Proof.
    induction e.
    - exact l.
    - exact (↑ (ε f)).
    - exact (do r' ← IHe;
             $ (f r')).
    - exact (
        do k' ← IHe1;
        do m' ← IHe2;
        $ ( m' [ k' ] )
    ) . (*
    - destruct H. exact (toLedgerBaseType0 x).
    - inversion e1.
     + exact (do x' ← IHe2;
              do f' ← X1;
              $ (f' x')).
     + exact (do x' ← IHe2;
              do f' ← IHe1;
              $ (f' x')).
     + exact (do x' ← IHe2;
     do f' ← IHe1;
     $ (f' x')).
     + exact (do x' ← IHe2;
     do f' ← IHe1;
     $ (f' x')).
     + destruct H.
     inversion ledgerable0.
     exact (do x' ← IHe2;
     do f' ← IHe1;
     $ (f' x')). *)
Defined.

(* Definition sApply {X Y} (f: X -> LedgerT Y) (x: SolidityExpression X) :=
           do x' ← sReader x ;
           f x'. *)

(* (X -> M Y) -> M X -> M Y *)

(* Axiom onlySimpleTypes: forall X Y (lf: LedgerFunction (LedgerT (X -> Y))),  False. *)

(* Definition sJoin {L}`{Ledgerable L} (a: LedgerT L) : L.
Proof.
    remember (ledgerable_dec L ledgerFirstType ledgerTailType).
    assert (match ledgerable with
    | LedgerFunction0 _ => L = ledgerTailType
    | LedgerFunction_Next _ Y _ => L = (ledgerFirstType → ledgerTailType)
    end).
    apply y; auto.
    clear Heqy y.
    remember ledgerable.
    generalize dependent ledgerable.
    induction l; intros.
    refine (a >>= Datatypes.id).
    apply forall_dec in H0.
    inversion_clear H0.
    intros.
    remember (a >>= fun f => return! (f X0)).
    assert (Ledgerable Y).
    rewrite H2.
    apply ledgerTailType_Ledgerable.
    remember (IHl X1 l1).
    clear Heqy IHl.
    apply y with  (l0:=l); auto.
    destruct l.
    symmetry.
    assert (X1 = LedgerT_Ledgerable ).
    apply instance_irr.
    rewrite H0.
(*     clear  y X1 Heql1 l1 X0 a. *)
    apply (ledgerable0_tail X2).
    remember (@ledgerTailType_Ledgerable (X2 → Y) X1).
    clear Heql2.
    remember (@ledgerable_dec (X2 → Y) X1 (@ledgerFirstType (X2 → Y) X1) (@ledgerTailType (X2 → Y) X1)).
    clear Heqy0.
    assert (match (@ledgerable (X2 → Y) X1) with
    | LedgerFunction0 _ => (X2 → Y) = @ledgerTailType (X2 → Y) X1
    | LedgerFunction_Next _ Y0 _ =>
        (X2 → Y) = (@ledgerFirstType (X2 → Y)  X1 → @ledgerTailType (X2 → Y) X1)
    end).
    apply y0; auto. clear y0.
    remember (@ledgerableFunction X2  Y X1).
    assert (X1 = @LedgerTNext_Ledgerable X2 Y l3).
    apply instance_irr.
    rewrite H3 in * |- *.
    compute.
    auto.
Defined.
 *)

(* Definition sApply {L} (f: L)`{Ledgerable L} (x: LedgerT ledgerFirstType) : ledgerTailType.
Proof.
    intros.
    remember (ledgerable_dec L ledgerFirstType ledgerTailType).
    assert (match ledgerable with
    | LedgerFunction0 _ => L = ledgerTailType
    | LedgerFunction_Next _ Y _ => L = (ledgerFirstType → ledgerTailType)
    end).
    apply y; auto. clear y Heqy.
    remember ledgerable.
    generalize dependent ledgerable.
    induction l; intros.
    rewrite <- H0.
    refine f.
    apply forall_dec in H0.
    inversion_clear H0.
    rewrite <- H2 in * |- *.
    assert (Ledgerable Y).
    apply ledgerableFunction with (X:=X); auto.
    assert (H = @LedgerTNext_Ledgerable X Y X0).
    apply instance_irr.
    rewrite H0 in * |- *.
    rewrite <- H1 in * |- *.

    remember (do x' ← x; return! (f x')).
    apply sJoin.
    refine l1.
Defined. *)

(*     simpl in x.
    (* remember H as HL. clear HeqHL. *)
    destruct H.
    inversion ledgerable0.
    rewrite <- H in f.
    remember (SolidityScalar f). clear Heqs.
    rewrite <- ledgerable0_tail in s.

    refine s.

    rewrite ledgerable0_tail.
    (* refine (SolidityScalar f). *)
    assert (ledgerTailType (X:=L) (Ledgerable := HL) = SolidityExpression X).
    compute.
    destruct HL.
    rewrite <- H in HL.
    refine (SolidityScalar f).

    setoid_rewrite <- H in x. *)

(*     match e with
    | SolidityScalar c =>  c
    | SolidityState m =>  ↑ (ε m)
    | SolidityField f r => do r' ← (sReader r);
                           $ (f r')
    | SolidityIndex k m =>  do k' ← (sReader k);
                            do m' ← (sReader m);
                            $ ( m' [ k' ] )
    | SolidityFunction f => toLedgerBaseType f  (* match ( ledgerable (X:=X) ) with
                            | LedgerFunction0 _ => f
                            | LedgerFunction_Next _ _ f =>
                            end *)
    | SolidityFunctionCall f x => do x' ← sReader x;
                                  do f' ← sReader f;
                                  $ (f' x')

    end. *)

Notation " # e " := (SolidityScalar e) (at level 100).
Notation " 'μ' e " := (SolidityState e) (at level 100).
Notation " r ^^ f " := (SolidityField f r) (at level 100).
Notation " m [[ i ]] " := (SolidityIndex i m) (at level 100).
(* Notation " 'ϕ' f " := (SolidityFunction f) (at level 100).*)
Notation " 'α' " := (sApply ) (at level 100).

Check #$xInt0.
Check μ DePoolContract_ι_m_association.
Check (#$default) ^^ contractAddress.
Check (#$xHMapEmpty) [[ #$xInt0 ]].
Check (#$xHMapEmpty) [[ #$xInt0 ]] ^^ contractAddress.
Check (#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress.
Check @SolidityState.

 Check α.

Existing Instance monadStateT.
Existing Instance monadStateStateT.

Check (α (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger) ($xInt2)) : XInteger -> LedgerT XInteger.
Let a := (α (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger) ($xInt2)) : XInteger -> LedgerT XInteger.
Let b := α a ($xInt100).

Lemma foo1:  eval_state b default  = 102 .
Proof.
    compute.
    auto.
Qed.

(* Check (ϕ (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger)).
Check  (ϕ (fun (x: XInteger) => (↑2 U1! ValidatorBase_ι_m_validatorWallet := $ x) : LedgerT True)).
 *)
Let g := sReader (α (α (fun (x: XInteger) => (↑2 U1! ValidatorBase_ι_m_validatorWallet := $ x): LedgerT True) ($xInt2)) ($I)).

Lemma foo2: eval_state (↑2 D2! ValidatorBase_ι_m_validatorWallet)  (exec_state g default) = 2.
Proof.
    compute.
    auto.
Qed.

Definition sWriter {X} (e : SolidityExpression X) (v : LedgerT X): LedgerT True.
Proof.
    intros.
    induction e. exact ($I).

    exact (do v' ← v;
    modify (fun r => {$ r with m := {$ (r ->> m) with f := v' $} $} ) >> $ I).

    exact (do v' ← v;
    do o ← sReader e;
    IHe ($ {$ o with f := v' $} )
    ).

    exact (do v' ← v;
    do k' ← sReader e1;
    do m' ← sReader e2;
    IHe2 ($  (m' [k'] ← v') )
    ).
Defined.

Definition sAssign {X} (el er : SolidityExpression X) :=
    sWriter el (sReader er).

Check sAssign (μ DePoolContract_ι_m_association) (#$xInt0).
Check sAssign ((μ RoundsBase_ι_m_rounds) [[ μ DePoolContract_ι_m_association  ]] ^^ RoundsBase_ι_Round_ι_id )
              ((#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress).

(* Inductive foo : Type -> Type := | Foo: forall X, list X -> list X -> foo X.

Definition bar {X} (f g: foo X) : foo X.
Proof.
    intros.
    destruct f. destruct g.
    exact (Foo X l l2).
Defined.

Print bar.

Definition bar' {X} (f g: foo X) : foo X :=
    match f  with
    | Foo _ l1 _ =>
        fun g0  => match g0 with
                    |  Foo _  _ l2 =>  fun l1 => Foo _ l1 l2
                   end l1
    end g.

Definition bar' {X} (f g: foo X) : foo X :=
    match f (* in (foo T) return (foo T -> foo T) *) with
    | Foo _ l1 _ =>
    fun g0 (* : foo X0 *) => match g0 (* in foo T return (list T -> foo T ) *) with
    |  Foo _  _ l2 =>  fun l1(* : list X1 *) => Foo _ l1 l2
    end l1 end g.

Set Asymmetric Patterns.

Arguments Foo {X} _ _.
Print Implicit Foo.

Fixpoint bar {X} (f g: foo X) : foo X :=
    match f in (foo X), g in (foo X) return (foo X) with
    | Foo _ l1 _ , Foo _  _ l2 =>  @Foo  X l1 l2
    end.

Check bar.  *)

Fail Fixpoint sWriter' {X} (e : SolidityExpression X) (v : LedgerT X): LedgerT True :=
    match e in SolidityExpression X with
    | SolidityScalar c => $I
    | @SolidityState _ _ m _ _ _ f _ _ => do v' ← v;
                         modify ( fun r => {$ r with m := {$ (r ->> m) with f := v' $} $} ) >> $ I
    | _ => $I
    end.

End SML.


Require Import QuickChick.

Require Import common.
Require Import concrete.
Require Import concrete_exec.
Require Import concrete_int_32.
Require Import concrete_monitor.
Require Import fault_handler.
Require Import testing.

Require Import ZArith.
Require Import Integers.
Require Import List.
Require Import Coq.Strings.String.
Import ListNotations.

Import Concrete.

Definition state       := state       concrete_int_32_t.
Definition word        := word        concrete_int_32_t.
Definition monitor_regs := monitor_regs concrete_int_32_t concrete_int_32_fh.
Definition reg         := reg         concrete_int_32_t.
Definition atom        := atom        concrete_int_32_t.
Definition mkatom      := mkatom      concrete_int_32_t.
Definition registers   := registers   concrete_int_32_t.
Definition memory      := memory      concrete_int_32_t.

Definition word_eq_dec : forall (x y : word), {x = y} + {~ (x = y)} :=
  word_mt_eq_dec reflect_eq_word.

Definition gen_word : Gen word := liftGen Z_to_word arbitrary.

(* Generates a valid register :
   - The value of the register is an arbitrary integer (TODO: Fix? Does it matter?)
   - The tag of the register depends on the register ID (monitor/non-monitor) *)
Definition gen_register (r : reg) : Gen atom :=
  liftGen2 mkatom gen_word
           (if in_dec word_eq_dec r monitor_regs then
              returnGen TMonitor
            else returnGen TNone).

Definition nat_to_reg (n : nat) : reg :=
  Z_to_word (Z_of_nat n).

Definition gen_register_nat (n : nat) : Gen atom :=
  gen_register (nat_to_reg n).

(* TODO: How many should I generate??? *)
Definition gen_registers (n : nat) : Gen registers :=
  foldGen (fun a b => liftGen (upd_reg a (nat_to_reg b)) (gen_register_nat b))
          (seq 0 n) initial_regs.

(* TODO: Maybe we want to generate random cache configurations? *)
Definition gen_cache : Gen (rules word) := returnGen concrete_ground_rules.

(* First thousand  -> Monitor constants
   Second thousand -> User Program
   Third thousand  -> Faulthandler *)
Definition gen_memory : Gen memory := returnGen initial_memory.

(*
Fixpoint constants_from {A : Type} (i : int) (n : nat) (x : A)
                        (mem : Int32PMap.t A) : Int32PMap.t A :=
  match n with
    | O    => mem
    | S n' => constants_from (add i one) n' x (Int32PMap.set i x mem)
  end.

Definition initial_memory : Concrete.memory concrete_int_32_t :=
  let monitorZero := Concrete.mkatom concrete_int_32_t zero Concrete.TMonitor in
  let withNone w := w @ Concrete.TNone
  in ( constants_from zero        1000 monitorZero
     ∘ insert_from_as (repr 1000) hello_world      withNone
     ∘ insert_from_as (repr 2000) faulthandler_bin withNone )
     (Int32PMap.empty _).
*)

Definition gen_pc : Gen atom := returnGen (pc initial_state).

Definition gen_state : Gen state :=
  bindGen gen_memory         (fun m  =>
  bindGen (gen_registers 42) (fun r  =>
  bindGen gen_cache          (fun c  =>
  bindGen gen_pc             (fun pc =>
  returnGen {|
    mem   := m;
    regs  := r;
    cache := c;
    pc    := pc;
    epc   := epc (initial_state)
  |})))).

Require Import Integers.

Definition prop_mi :=
  forAllShrink (fun _ => "Foo"%string) (returnGen initial_state) (fun _ => [])
               (fun s =>
   invariant_exec concrete_int_32_fh reflect_eq_word (Z_to_word 2000)
                  (mem s) (regs s) (cache s)).

Definition toTest := quickCheck prop_mi.

QuickCheck toTest.


Require Import Util LengthEq IL RenamedApart LabelsDefined OptionR.
Require Import Keep Drop Take Restrict SetOperations OUnion.
Require Import Annotation Liveness.Liveness Coherence Delocation.
Require Import AddParam AddAdd MoreListSet PartialOrder.

Set Implicit Arguments.

Fixpoint computeParameters (DL: list (set var)) (AP:list (set var))
         (s:stmt) (an:ann (set var)) {struct s}
: ann (list params) * list (option (set var)) :=
  match s, an with
    | stmtLet x e s, ann1 _ an =>
      let (ar, r) := computeParameters DL (addParam x DL AP) s an in
      (ann1 nil ar, r)
    | stmtIf x s t, ann2 _ ans ant =>
      let (ars, rs) := computeParameters DL AP s ans in
      let (art, rt) := computeParameters DL AP t ant in
      (ann2 nil ars art, zip ounion rs rt)
    | stmtApp f Y, ann0 lv => (ann0 nil, keep (counted f) AP)
    | stmtReturn x, ann0 _ => (ann0 nil, (List.map (fun _ => None) AP))
    | stmtFun F t, annF lv ans ant =>
      let DL' := (getAnn ⊝ ans) \\ (fst ⊝ F) in
      let Zset := list_union (fst ∘ of_list ⊝ F) in
      let AP' := ((fun _ => ∅) ⊝ F ++ AP) in
      let ars_rF :=
          zip (fun Zs a => computeParameters (DL' ++ DL) AP' (snd Zs) a)
              F ans in
      let (art, rt) := computeParameters (DL' ++ DL) AP' t ant in
      let rFt := fold_left (zip ounion) (List.map snd ars_rF) rt in
      let ZaF := list_union (oget ⊝ (take ❬F❭ rFt)) in
      let ur : list (option (set var)) :=
          zip (addAdd (ZaF ∪ Zset)) (DL' ++ DL) rFt in
      (annF (List.map oto_list (take (length F) ur))
            (List.map fst ars_rF) art, drop (length F) ur)
    | s, a => (ann0 nil, nil)
  end.

Notation "'computeParametersF' F als DL ZL AP" :=
  ((fun Zs a0 => computeParameters
                ((getAnn ⊝ als ++ DL) \\ ((fst ⊝ F) ++ ZL))
                (List.map (fun _ => ∅) F ++ AP)
                (snd Zs) a0)
     ⊜ F als)
    (at level 50, DL, ZL, AP, F, als at level 0).

Notation "'olu' F als Lv ZL AP s alb" :=
  (olist_union (snd ⊝ computeParametersF F als Lv ZL AP)
               (snd (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                                       (tab {} ‖F‖ ++ AP) s alb)))
(at level 50, als, Lv, ZL, AP, F, s, alb at level 0).

Ltac lnorm :=
  repeat (match goal with
          | [ H : context [ zip _ _ _ ++ zip _ _ _ ] |- _ ] => rewrite <- zip_app in H; [| eauto with len]
          | [ |- context [ zip _ _ _ ++ zip _ _ _ ] ] => rewrite <- zip_app; [| eauto with len]
          end).

Create HintDb rew.
Hint Extern 20 => rewrite <- zip_app : rew.
Hint Extern 20 => rewrite <- live_globals_zip; eauto with len : rew.

Lemma computeParameters_AP_LV Lv ZL AP s lv
:live_sound Imperative ZL Lv s lv
  -> length AP = length Lv
  -> length Lv = length ZL
  -> PIR2 (ifSndR Subset) AP (snd (computeParameters (Lv \\ ZL) AP s lv)).
Proof.
  intros LS. revert AP.
  induction LS; simpl in * |- *; intros; repeat let_pair_case_eq; subst; simpl.
  - eapply PIR2_ifSndR_Subset_left; eauto.
    eapply IHLS; eauto with len.
    eapply PIR2_addParam; eauto with len.
  - eauto using ifSndR_zip_ounion.
  - eauto using PIR2_ifSndR_keep.
  - eapply PIR2_get; eauto with len.
    intros; inv_get; eauto using @ifSndR.
  - rewrite <- zip_app; eauto. len_simpl.
    eapply PIR2_ifSndR_Subset_left.
    eapply PIR2_drop.
    eapply ifSndR_zip_addAdd.
    Focus 2.
    eapply ifSndR_fold_zip_ounion; eauto.
    Focus 2.
    eapply IHLS; eauto with len.
    + clear IHLS. intros.
      inv_get.
      eapply H1;
        eauto using PIR2_drop, live_globals_zip, pair_eta with len rew.
    + eauto 20 with len.
    + rewrite drop_length_ass; eauto with len.
    + eauto with len.
Qed.

Corollary computeParameters_length AP s lv DL ZL
  : live_sound Imperative ZL DL s lv
    -> length AP = length DL
    -> length DL = length ZL
    -> length (snd (computeParameters (DL \\ ZL) AP s lv)) = length DL.
Proof.
  intros. exploit computeParameters_AP_LV; eauto.
  eapply PIR2_length in H2. eauto with len.
Qed.

Lemma computeParametersF_length AP (ZL:list params) (Lv: list (set var)) F als k
  : (forall n Zs a, get F n Zs -> get als n a ->
               live_sound Imperative (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) (snd Zs) a)
    -> k = ❬getAnn ⊝ als ++ Lv❭
    -> length F = length als
    -> length AP = length Lv
    -> length Lv = length ZL
    -> forall n a, get (snd ⊝ computeParametersF F als Lv ZL AP) n a -> ❬a❭ = k.
Proof.
  intros LIVE EQ LEN1 LEN2 LEN3 n a GET. subst.
  inv_get. rewrite computeParameters_length; eauto with len.
Qed.

Lemma computeParameters_length' (F:list (params * stmt)) als Lv ZL AP t alb
      (LS:live_sound Imperative (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) t alb)
      (LEN1 : ❬Lv❭ = ❬ZL❭)
      (LEN2 : ❬ZL❭ = ❬AP❭)
      (LEN3 : ❬F❭ = ❬als❭)
  : ❬(getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL)❭ =
    ❬snd
       (computeParameters ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
                          (tab {} ‖F‖ ++ AP) t alb)❭.
Proof.
  len_simpl.
  rewrite computeParameters_length; eauto with len.
Qed.

Lemma computeParameters_length_help_1 (F : 〔params * stmt〕)
      (als : 〔ann ⦃nat⦄〕)  (Lv : 〔⦃nat⦄〕) (ZL : 〔params〕)
 (LEN1 : ❬Lv❭ = ❬ZL❭) (LEN2 : ❬F❭ = ❬als❭)
  : ❬getAnn ⊝ als ++ Lv❭ = ❬fst ⊝ F ++ ZL❭.
Proof.
  eauto with len.
Qed.

Lemma computeParameters_length_help_2 (F : 〔params * stmt〕)
      (als : 〔ann ⦃nat⦄〕)  (Lv AP : 〔⦃nat⦄〕) (ZL : 〔params〕)
 (LEN1 : ❬Lv❭ = ❬ZL❭) (LEN2:❬ZL❭ = ❬AP❭) (LEN3 : ❬F❭ = ❬als❭)
  : ❬tab {} ‖F‖ ++ AP❭ = ❬getAnn ⊝ als ++ Lv❭.
Proof.
  eauto with len.
Qed.

Hint Resolve computeParameters_length' | 0 : len.
Hint Resolve computeParameters_length_help_1 computeParameters_length_help_2 | 0 : len.

Lemma computeParametersF_length_pair AP (ZL:list params) (Lv: list (set var)) F als k
  : (forall n Zs a, get F n Zs -> get als n a ->
               live_sound Imperative (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) (snd Zs) a)
    -> k = ❬getAnn ⊝ als ++ Lv❭
    -> length F = length als
    -> length AP = length Lv
    -> length Lv = length ZL
    -> forall n a, get (computeParametersF F als Lv ZL AP) n a -> ❬snd a❭ = k.
Proof.
  intros LIVE EQ LEN1 LEN2 LEN3 n a GET. subst.
  inv_get. rewrite computeParameters_length; eauto with len.
Qed.

Lemma computeParameters_LV_DL ZL Lv AP s lv
: live_sound Imperative ZL Lv s lv
  -> length AP = length Lv
  -> length Lv = length ZL
  -> AP ⊑ (Lv \\ ZL)
  -> PIR2 (ifFstR Subset) (snd (computeParameters (Lv \\ ZL) AP s lv)) (Lv \\ ZL).
Proof.
  intros LS Len1 Len2 LEQ.
  general induction LS; simpl in * |- *; repeat let_pair_case_eq; subst; simpl.
  - eapply IHLS; eauto using addParam_Subset with len.
  - eauto using ifFstR_zip_ounion.
  - eauto using PIR2_ifFstR_Subset_right, PIR2_ifFstR_keep.
  - eapply PIR2_get; eauto with len.
    intros. inv_get; econstructor.
  - assert (EQ: Lv \\ ZL = drop ❬F❭ ((getAnn ⊝ als) \\ (fst ⊝ F) ++ Lv \\ ZL))
      by (rewrite drop_length_ass; eauto with len).
    rewrite EQ at 4.
    lnorm.
    eapply PIR2_drop.
    eapply ifFstR_addAdds; eauto.
    eapply ifFstR_fold_zip_ounion; eauto.
    + intros ? ? GET. inv_get.
      eapply H1; eauto using PIR2_Subset_tab_extend with len.
    + eapply IHLS; eauto 20 using PIR2_Subset_tab_extend with len.
Qed.

Lemma computeParametersF_LV_DL ZL Lv AP F als A
: (forall n Zs a, get F n Zs -> get als n a ->
            live_sound Imperative (fst ⊝ F ++ ZL) (getAnn ⊝ als ++ Lv) (snd Zs) a)
  -> PIR2 Subset AP (Lv \\ ZL)
  -> PIR2 (ifFstR Subset) A ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL))
  -> length AP = length Lv
  -> length Lv = length ZL
  -> length F = length als
  -> PIR2 (ifFstR Subset) (olist_union (snd ⊝ computeParametersF F als Lv ZL AP) A)
         ((getAnn ⊝ als ++ Lv) \\ (fst ⊝ F ++ ZL)).
Proof.
  intros. eapply PIR2_olist_union_bound; eauto.
  intros; inv_get.
  eapply computeParameters_LV_DL; eauto using PIR2_Subset_tab_extend with len.
Qed.