(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Greg Morrisett
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Require Import String.
Require Import List.
Require Import Ascii.
Require Import Omega.
(*Require Import Eqdep.*)
Require Import Data.Stream.

Set Implicit Arguments.

(* This section defines grammars and parsers -- should be turned into a
 * functor over the char and char_eq variables.
 *)
Section PARSE.
  Variable char : Set.
  Variable char_eq : forall (c1 c2:char), {c1 = c2} + {c1 <> c2}.

  Section GRAMMAR.
  (* We describe the syntax of grammars using Adam's approach from ltamer *)
  Section VARS.
    Variable var : Set -> Type.

    Inductive term: Set -> Type :=
    | GVar     : forall t:Set, var t -> term t
    | GEpsilon : forall t:Set, t -> term t
    | GSatisfy : (char -> bool) -> term char
    | GCat     : forall (t1 t2:Set), term t1 -> term t2 -> term (t1 * t2)
    | GAlt     : forall t, term t -> term t -> term t
    | GTry     : forall t, term t -> term t
    | GRec     : forall t:Set, (var t -> term t) -> term t
    | GMap     : forall (t1 t2:Set), (t1 -> t2) -> term t1 -> term t2.

    (* A relational definition of substitution for terms -- used in the definition
     * of the semantics below, in particular for the rec case *)
    Inductive Subst :
    forall (t1 t2:Set), (var t1->term t2)->(term t1)->(term t2)->Type :=
    | SEpsilon : forall (t1 t2:Set) (v:t2) (e:term t1),
      Subst (fun _ => GEpsilon v) e (GEpsilon v)
    | SSatisfy : forall t1 (f:char->bool) (e:term t1),
      Subst (fun _ => GSatisfy f) e (GSatisfy f)
    | SCat :
      forall t1 t2 t3 (f1:var t1 -> term t2) (f2:var t1 -> term t3) (e:term t1)
        (e1:term t2)(e2:term t3),
        Subst f1 e e1 -> Subst f2 e e2 ->
        Subst (fun v => GCat (f1 v) (f2 v)) e (GCat e1 e2)
    | SAlt :
      forall t1 t2 (f1 f2:var t1 -> term t2) (e:term t1)(e1 e2:term t2),
        Subst f1 e e1 -> Subst f2 e e2 ->
        Subst (fun v => GAlt (f1 v) (f2 v)) e (GAlt e1 e2)
    | SMap :
      forall (t1 t2 t3:Set)
        (f:var t1 -> term t2) (e:term t1) (g:t2->t3) (e1:term t2),
        Subst f e e1 ->
        Subst (fun v => GMap g (f v)) e (GMap g e1)
    | STry :
      forall t1 t2 (f1:var t1 -> term t2) (e : term t1) (e1:term t2),
        Subst f1 e e1 -> Subst (fun v => GTry (f1 v)) e (GTry e1)
    | SVarEq :
      forall t (e:term t), Subst (@GVar t) e e
    | SVarNeq :
      forall t1 t2 (v:var t2) (e:term t1), Subst (fun _ => GVar v) e (GVar v)
    | SRec :
      forall t1 t2 (f1:var t1->var t2->term t2) (f2:var t2->term t2)(e:term t1),
        (forall v', Subst (fun v => f1 v v') e (f2 v')) ->
        Subst (fun v => GRec (f1 v)) e (GRec f2).
  End VARS.

  Definition Term t := forall V, term V t.
  Implicit Arguments GVar     [var t].
  Implicit Arguments GEpsilon [var t].
  Implicit Arguments GSatisfy [var].
  Implicit Arguments GCat     [var t1 t2].
  Implicit Arguments GAlt     [var t].
  Implicit Arguments GTry     [var t].
  Implicit Arguments GRec     [var t].
  Implicit Arguments GMap     [var t1 t2].

  Fixpoint flatten(V:Set->Type)(t:Set)(e: term (term V) t) {struct e} : term V t :=
    match e in (term _ t) return (term V t) with
    | GVar _ v => v
    | GEpsilon t v => GEpsilon v
    | GSatisfy f => GSatisfy f
    | GCat t1 t2 e1 e2 => GCat (flatten e1) (flatten e2)
    | GAlt t e1 e2 => GAlt (flatten e1) (flatten e2)
    | GMap t1 t2 f e => GMap f (flatten e)
    | GTry t e => GTry (flatten e)
    | GRec t f => GRec (fun (v:V t) => flatten (f (GVar v)))
    end.

  Definition unroll(t:Set)(f:forall V, V t -> term V t) : Term t :=
    fun V => flatten (f (term V) (GRec (f V))).

  Inductive empty_set : Set := .
  Definition empvar := (fun _:Set => empty_set).

  (* It would be nice if we could prove the following axiom so that the definition
   * of Gfix was simpler:
  Axiom Unroll : forall (t:Set)(f:forall var, var t -> term var t),
    Subst (f empvar) (GRec (f empvar)) (unroll f empvar).
  *)

  Inductive consumed_t : Set := Consumed | NotConsumed.

  Inductive reply_t(a:Set) : Set :=
  | Okay : consumed_t -> a -> list char -> reply_t a
  | Error : consumed_t -> reply_t a.

  Implicit Arguments Error [a].

  Definition join_cons (nc1 nc2 : consumed_t) : consumed_t :=
    match (nc1, nc2) with
    | (Consumed, _) => Consumed
    | (_, Consumed) => Consumed
    | (_, _) => NotConsumed
    end.

  (* We give meaning to grammars here, following the style of Parsec combinators.
   * In particular, note that we only try the second grammar of an alternation when
   * the first one does not consume input.  The presentation here is slightly different
   * from Parsec in that (a) we don't worry about space leaks since this is intended
   * for specification only, and (b) instead of representing concatenation with a
   * bind-like construct, we simply return a pair of the results.  We have a separate
   * operation GMap that allows us to transform a t1 grammar to a t2 grammar.  The
   * intention here is that grammars should use a minimum of meta-level stuff in
   * revealing their structure, so that we can potentially analyze and transform them.
   *)

  Section DENOTE.

  (* What I'm doing here is defining a denotational semantics that maps grammar terms
   * down to a simpler language with a monadic structure.  Then we give an operational
   * semantics to the monadic structure.  Note that I've instantiated the var in the
   * phoas so that it always yields an empty set.  This ensures that the term does not
   * have a free variable.  *)
  Inductive M: Set -> Type :=
  | MReturn : forall t, reply_t t -> M t
  | MBind : forall t1 t2, M t1 -> (reply_t t1 -> M t2) -> M t2
  | MFix : forall t (f:empvar t -> term empvar t), list char -> M t.

  Notation "'Return' x" := (MReturn x) (at level 75) : gdenote_scope.
  Notation "x <- c1 ; c2" := (MBind c1 (fun x => c2))
    (right associativity, at level 84, c1 at next level) : gdenote_scope.

  Definition wfCoerce (t:Set)(v:empvar t) : M t := match v with end.

  Open Local Scope gdenote_scope.

  (* here we map a term e to a computation over lists of characters -- this is
   * essentially the same as with Parsec-style combinators, though I've chosen
   * slightly different combinators that are closer to arrows than the monadic
   * interpretation.  *)
  Fixpoint denote(t:Set)(e:term empvar t)(s:list char) {struct e} : M t :=
    match e in term _ t return M t with
      | GVar _ v => wfCoerce v
      | GEpsilon _ x => Return Okay NotConsumed x s
      | GSatisfy test =>
        Return match s with
                 | c :: cs => if (test c) then Okay Consumed c cs else
                   Error NotConsumed
                 | nil => Error NotConsumed
               end
      | GMap t1 t2 f e =>
        r <- denote e s ;
        Return match r with
                 | Okay nc v s2 => Okay nc (f v) s2
                 | Error nc => Error nc
               end
      | GTry t e =>
        r <- denote e s ;
        Return match r with
                 | Error Consumed => Error NotConsumed
                 | Okay Consumed v s2 => Okay NotConsumed v s2
                 | _ => r
               end
      | GCat t1 t2 e1 e2 =>
        r1 <- denote e1 s ;
        match r1 with
          | Error nc => Return Error nc
          | Okay nc1 v1 s1 =>
            r2 <- denote e2 s1 ;
            Return match r2 with
                     | Error nc2 => Error (join_cons nc1 nc2)
                     | Okay nc2 v2 s2 => Okay (join_cons nc1 nc2) (v1,v2) s2
                   end
        end
      | GAlt t e1 e2 =>
        r1 <- denote e1 s ;
        match r1 with
          | Error Consumed => Return Error Consumed
          | Error NotConsumed => denote e2 s
          | Okay NotConsumed v s2 =>
            r2 <- denote e2 s ;
            Return match r2 with
                     | Error NotConsumed => Okay NotConsumed v s2
                     | Okay NotConsumed _ _ => Okay NotConsumed v s2
                     | r2 => r2
                   end
          | Okay Consumed v s2 => Return Okay Consumed v s2
        end
      | GRec t f => MFix f s
    end.

  (* We now give an operational semantics to the monadic terms generated by the
   * denotation function.  Note that in essence, we just delay unrolling the
   * fix operator.  *)
  Inductive evals : forall t, M t -> reply_t t -> Prop :=
  | eMReturn : forall t (r:reply_t t), evals (MReturn r) r
  | eMBind : forall t1 t2 (c:M t1) (r1:reply_t t1) (f:reply_t t1 -> M t2) r2,
    evals c r1 -> evals (f r1) r2 -> evals (MBind c f) r2
  | eMFix :
    forall t (f:empvar t -> term empvar t) (s:list char) (e:term empvar t) (r:reply_t t),
      Subst f (GRec f) e -> evals (denote e s) r -> evals (MFix f s) r.

  (* Then we say that a term t parses string s yielding result r if the following
   * if evaluating the denotation of e, when applied to s yields r. *)
  Definition parses(t:Set)(e:Term t)(s:list char)(r:reply_t t) :=
    evals (denote (e empvar) s) r.

  End DENOTE.
  End GRAMMAR.

  Require Import Ynot.

  Inductive parse_reply_t(t:Set) : Set :=
  | OKAY : consumed_t -> nat -> t -> parse_reply_t t
  | ERROR : consumed_t -> string -> parse_reply_t t.

  Fixpoint nthtail(A:Type)(cs:list A)(n:nat) {struct n} : list A :=
    match (n,cs) with
    | (0,cs) => cs
    | (S n, c::cs) => nthtail cs n
    | (S n, nil) => nil
    end.

  Definition okay(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(c:consumed_t)(m:nat)(v:t) :=
    (n ~~ let elts := stream_elts i in
          elts ~~ [parses e (nthtail elts n) (Okay c v (nthtail elts (m+n)))])%hprop.

  Definition okaystr(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(c:consumed_t)(m:nat)(v:t) :=
    (okay n i e c m v * (n ~~ rep i (m+n)))%hprop.

  Definition error(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(c:consumed_t) :=
    (n ~~ let elts := stream_elts i in
          elts ~~ [parses e (nthtail elts n) (Error t c)])%hprop.

  Definition errorstr(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(c:consumed_t) :=
    (error n i e c * (Exists m :@ nat, rep i m))%hprop.

  Definition ans_correct(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(ans:parse_reply_t t) :=
    match ans with
    | OKAY c m v => okay n i e c m v
    | ERROR c _ => error n i e c
    end.

  Definition ans_str_correct(t:Set)(n:[nat])(i:instream_t char)(e:Term t)(ans:parse_reply_t t) :=
    match ans with
    | OKAY c m v => okaystr n i e c m v
    | ERROR c _ => errorstr n i e c
    end.

  Definition parser_t(t:Set)(e:Term t) :=
    forall (ins:instream_t char)(n:[nat]), STsep (n ~~ rep ins n) (ans_str_correct n ins e).
  Implicit Arguments parser_t [t].

  Open Local Scope stsep_scope.

  Lemma EmpImpInj(P:Prop) :
    P -> __ ==> [P].
  Proof.
    intros. sep fail auto.
  Qed.

  Lemma NthErrorNoneNthTail(A:Type)(i:nat)(vs:list A) :
   nth_error vs i = None -> nthtail vs i = nil.
  Proof.
    induction i ; destruct vs ; auto ; simpl ; intros. unfold value in H. congruence.
    apply IHi. auto.
  Qed.

  Lemma NthErrorSomeNthTail(A:Type)(i:nat)(vs:list A)(v:A) :
    nth_error vs i = Some v ->
      exists vs1, exists vs2, vs = vs1 ++ v::vs2 /\ nthtail vs i = v::vs2.
  Proof.
    induction i ; destruct vs ; auto ; simpl ; intros. unfold Specif.error in H. congruence.
    unfold value in H. inversion H. subst. exists (nil(A:=A)). simpl. eauto.
    unfold Specif.error in H. congruence. pose (IHi _ _ H). destruct e as [vs1 [vs2 [H1 H2]]].
    exists (a::vs1). exists vs2. split. rewrite H1. simpl. auto. auto.
  Qed.

  Lemma NthTailSucc(A:Type)(i:nat)(vs vs2:list A)(v:A) :
    nthtail vs i = v::vs2 -> nthtail vs (S i) = vs2.
  Proof.
    induction i ; simpl ; intros. rewrite H. auto. destruct vs. congruence.
    pose (IHi _ _ _ H). apply e.
  Qed.

  Lemma PlusAssoc(n m p:nat) : n + (m + p) = n + m + p. intros ; omega. Qed.

  Ltac mysep :=
    match goal with
    | [ |- (__ ==> [ _ ])%hprop ] => apply EmpImpInj
    | [ |- evals (MReturn ?r) ?r ] => constructor
    | [ |- evals (MBind _ _) _] => econstructor
    | [ |- context[?n + (?m + ?p)]] => rewrite (PlusAssoc n m p)
    | [ |- context[if (?f ?c) then _ else _] ] =>
      let H := fresh "H" in
      assert (H: f c = true \/ f c = false) ; [ destruct (f c) ; tauto |
              destruct H ; [ rewrite H ; simpl | rewrite H ; simpl ]]
    | _ => auto
    end.

  Definition gsatisfy(f:char -> bool) vars := GSatisfy vars f.
  Definition gepsilon(t:Set)(v:t) vars := GEpsilon vars v.
  Definition galt(t:Set)(e1 e2:Term t) vars := GAlt (e1 vars) (e2 vars).
  Definition gmap(t1 t2:Set)(f:t1 -> t2)(e:Term t1) vars := GMap f (e vars).
  Definition gcat(t1 t2:Set)(e1:Term t1)(e2:Term t2) vars := GCat (e1 vars) (e2 vars).
  Definition gtry(t:Set)(e:Term t) vars := GTry (e vars).
  Definition grec(t:Set)(f:forall (var:Set->Type), var t -> term var t)(var:Set -> Type) :=
    GRec (f var).

  Ltac myunfold := unfold ans_str_correct, ans_correct, okaystr, okay, errorstr, error,
    parses, gsatisfy, gepsilon, galt, gmap, gcat, gtry, grec.

  Ltac psimp := (myunfold ; sep fail auto ; mysep ; simpl ; eauto).

  Ltac rsimp := psimp ;
    match goal with
    | [ |- context[match ?a with | OKAY c m v => _ | ERROR c _ => _ end] ] => destruct a
    | [ |- context[match ?c with | Consumed => _ | NotConsumed => _ end] ] => destruct c
    | _ => idtac
    end.

  Lemma NthError(x:list char)(n:nat) :
    (nth_error x n = None \/ exists c, nth_error x n = Some c).
  Proof.  intros. destruct (nth_error x n). right. eauto. left. eauto.
  Qed.

  Lemma EvalsMReturn(t:Set)(r1 r2:reply_t t) : r1 = r2 -> evals (MReturn r1) r2.
  Proof. intros. rewrite <- H. constructor. Qed.

  (* the parser for a single character *)
  Definition satisfy(f:char -> bool) : parser_t (gsatisfy f).
    intros f instream n.
    refine (copt <- next instream n ;
            Return (match copt with
                    | None => ERROR char NotConsumed "bad character"
                    | Some c => if f c then OKAY Consumed 1 c
                                else ERROR char NotConsumed "bad character"
                    end) <@>
              match copt with
              | None => errorstr n instream (gsatisfy f) NotConsumed
              | Some c => if f c then okaystr n instream (gsatisfy f) Consumed 1 c
                          else errorstr n instream (gsatisfy f) NotConsumed
              end @> _) ; psimp ;
    match goal with
      [ |- _ ==> match nth_error ?x ?n with | Some c => _ | None => _ end] =>
      let H := fresh in pose (H := NthError x n) ; destruct H ; [ rewrite H ; psimp ;
        rewrite (NthErrorNoneNthTail _ _ H) ; psimp | destruct H ; rewrite H ; psimp ; psimp ;
          let H1 := fresh in let v1 := fresh in let v2 := fresh in
            let H2 := fresh in let H3 := fresh in
          pose (H1 := NthErrorSomeNthTail _ _ H) ; destruct H1 as [v1 [v2 [H1 H2]]] ;
          rewrite H2 ; psimp ; pose (H3 := (NthTailSucc _ _ H2)) ;
          simpl in H3 ; eapply EvalsMReturn ; congruence]
      | [ |- match ?copt with | Some c => _ | None => _ end ==> _] => destruct copt ;
        repeat psimp
    end.
  Defined.

  (* the parser for the empty string *)
  Definition epsilon(t:Set)(v:t) : parser_t (gepsilon v).
    intros t v instream n.
    refine ({{Return (OKAY NotConsumed 0 v) <@> (n ~~ rep instream n)}}) ;
    repeat psimp.
  Defined.

  (* left-biased alternation -- need to fix error message propagation here *)
  Definition alt(t:Set)(e1 e2:Term t)(p1:parser_t e1)(p2:parser_t e2) : parser_t (galt e1 e2).
    intros t e1 e2 p1 p2 instream n.
    unfold galt.
    refine (n0 <- position instream n @> (fun n0 => n ~~ rep instream n * [n0=n])%hprop ;
            ans1 <- p1 instream n <@> (n ~~ [n0=n])%hprop @>
               (fun ans1 => ans_str_correct n instream e1 ans1 * (n ~~ [n0=n]))%hprop ;
            let frame := fun ans => ((n ~~ [n0=n]) * ans_correct n instream e1 ans)%hprop in
            match ans1 as ans1'
              return STsep (ans_str_correct n instream e1 ans1' * (n ~~ [n0=n]))%hprop
                           (ans_str_correct n instream (galt e1 e2))
            with
            | ERROR NotConsumed msg1 =>
                seek instream n0 <@> frame (ERROR t NotConsumed msg1) ;;
                p2 instream n <@> frame  (ERROR t NotConsumed msg1) @> _
            | OKAY NotConsumed m1 v1 =>
                seek instream n0 <@> frame (OKAY NotConsumed m1 v1) ;;
                ans2 <- p2 instream n <@> frame (OKAY NotConsumed m1 v1) ;
                match ans2 as ans2'
                  return STsep (frame (OKAY NotConsumed m1 v1) *
                                   ans_str_correct n instream e2 ans2')
                               (ans_str_correct n instream (galt e1 e2))
                with
                | ERROR NotConsumed msg2 =>
                    (* interestingly, I forgot to do the seek here and in the next
                       case and then got stuck doing the proof! *)
                    seek instream (m1 + n0) <@>
                        frame (OKAY NotConsumed m1 v1) *
                        ans_correct n instream e2 (ERROR t NotConsumed msg2) ;;
                    Return OKAY NotConsumed m1 v1 <@>
                        frame (OKAY NotConsumed m1 v1) *
                        rep instream (m1 + n0) *
                        ans_correct n instream e2 (ERROR t NotConsumed msg2) @> _
                | OKAY NotConsumed m2 v2 =>
                    seek instream (m1 + n0) <@>
                        frame (OKAY NotConsumed m1 v1) *
                        ans_correct n instream e2 (OKAY NotConsumed m2 v2) ;;
                    Return OKAY NotConsumed m1 v1 <@>
                        frame (OKAY NotConsumed m1 v1) *
                        rep instream (m1 + n0) *
                        ans_correct n instream e2 (OKAY NotConsumed m2 v2) @> _
                | ans =>
                    {{Return ans <@>
                        frame (OKAY NotConsumed m1 v1) * ans_str_correct n instream e2 ans}}
                end
          | ans =>
              {{Return ans <@>
                 ((n ~~ [n0=n]) * ans_str_correct n instream e1 ans)%hprop}}
          end) ; (try unfold frame) ; repeat rsimp.
  Defined.

  (* the parser for (gmap f e) given f and a parser p for e *)
  Definition map(t1 t2:Set)(f:t1->t2)(e:Term t1)(p:parser_t e) : parser_t (gmap f e).
    intros t1 t2 f e p instream n.
    refine (ans <- p instream n;
            Return (match ans with
                    | OKAY c m v => OKAY c m (f v)
                    | ERROR c msg => ERROR t2 c msg
                    end) <@> ans_str_correct n instream e ans @> _) ; psimp.
    destruct ans ; repeat psimp.
  Defined.

  (* parser for concatenation *)
  Definition cat(t1 t2:Set)(e1:Term t1)(e2:Term t2)(p1:parser_t e1)(p2:parser_t e2) :
    parser_t (gcat e1 e2).
    intros t1 t2 e1 e2 p1 p2 instream n.
    refine (n0 <- position instream n ;
            ans1 <- p1 instream n <@> (n ~~ [n0 = n])%hprop ;
            match ans1 as ans1' return
              STsep (ans_str_correct n instream e1 ans1' * (n ~~ [n0 = n])%hprop)
                    (ans_str_correct n instream (gcat e1 e2))
            with
            | OKAY c1 m1 v1 =>
                ans2 <- p2 instream (inhabits (m1+n0))<@>
                   (ans_correct n instream e1 (OKAY c1 m1 v1) * (n ~~ [n0=n]))%hprop;
                Return match ans2 with
                       | OKAY c2 m2 v2 => OKAY (join_cons c1 c2) (m2 + m1) (v1,v2)
                       | ERROR c2 msg => ERROR (t1*t2)%type (join_cons c1 c2) msg
                       end <@>
                  (ans_correct n instream e1 (OKAY c1 m1 v1) * (n ~~ [n0=n]) *
                   ans_str_correct (inhabits (m1+n0)) instream e2 ans2)%hprop @> _
            | ERROR c1 msg =>
                {{Return ERROR (t1*t2) c1 msg <@>
                  (ans_str_correct n instream e1 (ERROR t1 c1 msg) * (n ~~ [n0 = n]))%hprop}}
            end) ; repeat rsimp.
  Defined.

  (* try combinator *)
  Definition try(t:Set)(e:Term t)(p:parser_t e) : parser_t (gtry e).
    intros t e p instream n.
    refine (ans <- p instream n ;
            Return match ans with
                   | ERROR Consumed msg => ERROR t NotConsumed msg
                   | OKAY Consumed m v => OKAY NotConsumed m v
                   | ans => ans
                   end <@> ans_str_correct n instream e ans @> _) ; psimp.
    destruct ans ; destruct c ; repeat psimp.
  Defined.

  (* used in construction of fixed-point *)
  Definition coerce_parse_fn(t:Set)(f:forall var, var t -> term var t)(e:Term t)
                            (H:Subst (f empvar) (GRec (f empvar)) (e empvar))
                            (F:parser_t (grec f) -> parser_t e) :
                       parser_t (grec f) -> parser_t (grec f).
    intros t f e H1 F p instream n.
    refine ((F p instream n) @> _). destruct v ; psimp ; econstructor ; eauto.
  Qed.

  Definition parser_t'(t:Set)(e:Term t)(p:(instream_t char * [nat])) :=
    let ins := fst p in
    let n := snd p in
      STsep (n ~~ rep ins n) (ans_str_correct n ins e).

  (* Alas, note that we need H here -- can't easily prove this once and for all *)
  Definition Gfix(t:Set)(f:forall V, V t -> term V t)
                  (F:parser_t (grec f) -> parser_t (unroll f))
                  (H: Subst (f empvar) (GRec (f empvar)) (unroll f empvar)) :
                  parser_t (grec f) :=
    (* coerce F so that its result is re-rolled *)
    let Fc : parser_t (grec f) -> parser_t (grec f) := coerce_parse_fn H F in
    (* Grrr. To call SepFix, I have to uncurry Fc *)
    let Fu : (forall p, parser_t' (grec f) p) -> (forall p, parser_t' (grec f) p) :=
       fun f arg => Fc (fun ins n => f (ins,n)) (fst arg) (snd arg) in
    fun instream n => (SepFix _ _ Fu) (instream,n).
  Implicit Arguments Gfix [t f].
End PARSE.

Section Examples.
  Delimit Scope grammar_scope with grammar.

  Notation "!!!! v" := (GVar _ _ _ v) (at level 1) : grammar_scope.
  Notation "# c" := (GSatisfy(char:=ascii) _
                     (fun c2 => if ascii_dec (c%char) c2 then true else false))
  (at level 1) : grammar_scope.
  Notation "e1 ^ e2" := (GCat e1 e2)
     (right associativity, at level 30) : grammar_scope.
  Notation "e @ f" := (GMap f e)
     (left associativity, at level 78) : grammar_scope.
  Notation "e1 '|||' e2" := (GAlt e1 e2)
    (right associativity, at level 79) : grammar_scope.
  Notation "% v" := (GEpsilon ascii _ v) (at level 1) : grammar_scope.

  Delimit Scope parser_scope with parser.

  Notation "e1 ^ e2" := (cat e1 e2)
     (right associativity, at level 30) : parser_scope.
  Notation "e @ f" := (map f e)
     (left associativity, at level 78) : parser_scope.
  Notation "e1 '|||' e2" := (alt e1 e2)
    (right associativity, at level 79) : parser_scope.
  Notation "# c" := (satisfy (fun c2 => if ascii_dec (c%char) c2 then true else false))
    (at level 1) : parser_scope.
  Notation "% v" := (epsilon(char:=ascii) v) : parser_scope.
  Notation "'gfix' e" := (Gfix e _) (at level 70).

  Ltac gtac := unfold unroll, grec ; simpl ; repeat (progress constructor).

  (* Example grammar :  N -> a | b N b *)
  Definition g : Term ascii unit :=
    grec (fun var N => #"a"             @ (fun _ => tt)
                    ||| #"b" ^ !!!!N ^ #"b" @ (fun _ => tt))%grammar.

  (* Example parser for grammar g *)
  Definition g_parser : parser_t g.
      refine (gfix (fun (p:parser_t g) =>
                      #"a"            @ (fun _ => tt)
                   ||| #"b" ^ p ^ #"b" @ (fun _ => tt))%parser) ;
      gtac.
  Defined.

  (* A grammar for digits *)
  Definition is_digit(c:ascii):bool :=
    if le_lt_dec (nat_of_ascii "0"%char) (nat_of_ascii c) then
      (if le_lt_dec (nat_of_ascii c) (nat_of_ascii "9"%char) then true else false)
    else false.

  Definition digit : Term ascii ascii := gsatisfy is_digit.

  (* A parser for digits *)
  Definition digit_p : parser_t digit := satisfy is_digit.

  (* A grammar for numbers:  note that this computes the value of the number *)
  Definition number :=
    grec (fun V number =>
              digit _           @ nat_of_ascii
           ||| !!!!number ^ digit _ @ (fun p => 10 * fst p + nat_of_ascii (snd p)))%grammar.

  (* A parser for numbers:  number := digit | number digit *)
  Definition number_p : parser_t number.
    refine (gfix (fun (number:parser_t number) =>
                digit_p          @ nat_of_ascii
             ||| number ^ digit_p @ (fun p => 10 * fst p + nat_of_ascii (snd p)))%parser).
    unfold digit, gsatisfy. gtac.
  Defined.

  Definition tab : ascii := ascii_of_nat 9.
  Definition cr : ascii := ascii_of_nat 10.

  (* whitespace *)
  Definition ws :=
    grec (fun V ws =>
              % tt
          |||  (#" " ^ !!!!ws ||| #tab ^ !!!!ws ||| #cr ^ !!!!ws) @ (fun _ => tt))%grammar.

  Definition ws_p : parser_t ws.
    refine (gfix (fun (ws_p:parser_t ws) =>
                 % tt
              ||| (#" " ^ ws_p ||| #tab ^ ws_p ||| #cr ^ ws_p) @ (fun _ => tt))%parser).
    gtac.
  Defined.

  (* A grammar for expressions that computes the result of evaluating the expression:
     expr := number | expr + expr | expr - expr *)
  Definition expr :=
    grec (fun V expr =>
              ws _ ^ number _ ^ ws _   @ (fun t => fst (snd t))
           ||| !!!!expr ^ #"+" ^ !!!!expr     @ (fun t => fst t + (snd (snd t)))
           ||| !!!!expr ^ #"-" ^ !!!!expr     @ (fun t => fst t - (snd (snd t))))%grammar.

  (* A parser for expressions *)
  Definition expr_p : parser_t expr.
    refine (gfix (fun (expr_p:parser_t expr) =>
               ws_p ^ number_p ^ ws_p    @ (fun t => fst (snd t))
            ||| expr_p ^ #"+" ^ expr_p    @ (fun t => fst t + (snd (snd t)))
            ||| expr_p ^ #"-" ^ expr_p    @ (fun t => fst t - (snd (snd t))))%parser).
    unfold number, digit, ws, gsatisfy ; gtac.
  Defined.

End Examples.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import fastapile.
Require Import spec_stdlib.
Require Import spec_fastpile.
Require Import spec_fastpile_private.
Require Import spec_apile.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.

Section Apile_VSU.
Variable M: MallocFreeAPD.
Variable PILEPRIV: FastpilePrivateAPD. (*apile is parametric in a PRIVATE pile predicate structure*)

Definition apile (sigma: list Z) (gv: globals) : mpred :=
  pilerep PILEPRIV sigma (gv _a_pile).
(*We define apile in terms of pilerep and then,
  in the proof of make_apile below, use the axiom
  spec_pile_private.pile_rep_exposed
  to exploit the representation exposure*)

Lemma make_apile: forall gv,
  globals_ok gv ->
  data_at Ews tuint (Vint (Int.repr 0)) (gv apile._a_pile) |-- apile nil gv.
Proof.
intros. unfold apile. rewrite pile_rep_exposed. (*HERE*)
unfold fastprep.
 Exists 0.
 assert_PROP (headptr (gv _a_pile)) by entailer!.
 entailer!.
 unfold_data_at (data_at _ tpile _ _).
 rewrite field_at_data_at. simpl.
 rewrite field_compatible_field_address
   by auto with field_compatible.
 simpl. normalize. rewrite data_at_tuint_tint.
assert (change_composite_env CompSpecs FastpileCompSpecs).
{ make_cs_preserve CompSpecs FastpileCompSpecs. }
change_compspecs FastpileCompSpecs.
apply derives_refl.
Qed.

Lemma apile_Init: VSU_initializer prog (apile nil).
  Proof.
    InitGPred_tac.  rewrite sepcon_emp.
    apply make_apile; auto.
Qed.

Definition APILE: APileAPD := Build_APileAPD apile (*APileCompSpecs make_apile*).

Definition Apile_ASI: funspecs := ApileASI M APILE.

Definition apile_imported_specs:funspecs :=
     [ Pile_add_spec M PILEPRIV; Pile_count_spec PILEPRIV].

Definition apile_internal_specs: funspecs := Apile_ASI.

Definition ApileVprog: varspecs. mk_varspecs prog. Defined.
Definition ApileGprog: funspecs := apile_imported_specs ++ apile_internal_specs.

Lemma body_Apile_add: semax_body ApileVprog ApileGprog f_Apile_add (Apile_add_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile.
forward_call (gv _a_pile, n,sigma,gv).
entailer!.
Qed.

Lemma body_Apile_count: semax_body ApileVprog ApileGprog f_Apile_count (Apile_count_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile in *.
forward_call (gv _a_pile, sigma).
forward.
Qed.

Definition ApileVSU: @VSU NullExtension.Espec
      nil apile_imported_specs ltac:(QPprog prog) Apile_ASI (apile nil).
  Proof.
    mkVSU prog apile_internal_specs.
    + solve_SF_internal body_Apile_add.
    + solve_SF_internal body_Apile_count.
    + apply apile_Init.
  Qed.

End Apile_VSU.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.nested_field_lemmas.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.reptype_lemmas.
Require Import VST.floyd.aggregate_type.
Require Import VST.floyd.sublist.

Section PROJ_REPTYPE.

Context {cs: compspecs}.

Definition proj_gfield_reptype (t: type) (gf: gfield) (v: reptype t): reptype (gfield_type t gf) :=
  match t, gf return (REPTYPE t -> reptype (gfield_type t gf))
  with
  | Tarray t0 hi a, ArraySubsc i => fun v => Znth i v (default_val _)
  | Tstruct id _, StructField i => fun v => proj_struct i (co_members (get_co id)) v (default_val _)
  | Tunion id _, UnionField i => fun v => proj_union i (co_members (get_co id)) v (default_val _)
  | _, _ => fun _ => default_val _
  end (unfold_reptype v).

Fixpoint proj_reptype (t: type) (gfs: list gfield) (v: reptype t) : reptype (nested_field_type t gfs) :=
  let res :=
  match gfs as gfs'
    return reptype (match gfs' with
                    | nil => t
                    | gf :: gfs0 => gfield_type (nested_field_type t gfs0) gf
                    end)
  with
  | nil => v
  | gf :: gfs0 => proj_gfield_reptype _ gf (proj_reptype t gfs0 v)
  end
  in eq_rect_r reptype res (nested_field_type_ind t gfs).

End PROJ_REPTYPE.


From exercises Require Export safety.

(** * Parametricity *)
Section parametricity.
  Context `{!heapG Σ}.

  (** * The polymorphic identity function *)
  Lemma identity_param `{!heapPreG Σ} e (v : val) σ w es σ' :
    (∀ `{!heapG Σ}, ⊢ ∅ ⊨ e : ∀ A, A → A) →
    rtc erased_step ([e <_> v]%E, σ) (of_val w :: es, σ') → w = v.
  Proof.
    intros He.
    apply sem_gen_type_safety with (φ := λ u, u = v)=> ?.
    pose (T := SemTy (λ w, ⌜w = v⌝)%I : sem_ty Σ).
    exists T. split.
    { by iIntros (?) "?". }
    iIntros (vs) "!# #Hvs".
    iPoseProof (He with "Hvs") as "He /=".
    wp_apply (wp_wand with "He").
    iIntros (u) "#Hu".
    iSpecialize ("Hu" $! T).
    wp_apply (wp_wand with "Hu"). iIntros (w') "Hw'". by iApply "Hw'".
  Qed.

  (** * Exercise (empty_type_param, easy) *)
  Lemma empty_type_param `{!heapPreG Σ} e (v : val) σ w es σ' :
    (∀ `{!heapG Σ}, ⊢ ∅ ⊨ e : ∀ A, A) →
    rtc erased_step ([e <_>]%E, σ) (of_val w :: es, σ') →
    False.
  Proof.
    (* exercise *)
  Admitted.

  (** * Exercise (boolean_param, moderate) *)
  Lemma boolean_param `{!heapPreG Σ} e (v1 v2 : val) σ w es σ' :
    (∀ `{!heapG Σ}, ⊢ ∅ ⊨ e : ∀ A, A → A → A) →
    rtc erased_step ([e <_> v1 v2]%E, σ) (of_val w :: es, σ') → w = v1 ∨ w = v2.
  Proof.
    (* exercise *)
  Admitted.

  (** * Exercise (nat_param, hard) *)
  Lemma nat_param `{!heapPreG Σ} e σ w es σ' :
    (∀ `{!heapG Σ}, ⊢ ∅ ⊨ e : ∀ A, (A → A) → A → A) →
    rtc erased_step ([e <_> (λ: "n", "n" + #1)%V #0]%E, σ)
      (of_val w :: es, σ') → ∃ n : nat, w = #n.
  Proof.
    (* exercise *)
  Admitted.

  (** * Exercise (strong_nat_param, hard) *)
  Lemma strong_nat_param `{!heapPreG Σ} e σ w es σ' (vf vz : val) φ :
    (∀ `{!heapG Σ}, ∃ Φ : sem_ty Σ,
      (⊢ ∅ ⊨ e : ∀ A, (A → A) → A → A) ∧
      (∀ w, ⊢ {{{ Φ w }}} vf w {{{ w', RET w'; Φ w' }}}) ∧
      (⊢ Φ vz) ∧
      (∀ w, Φ w -∗ ⌜φ w⌝)) →
    rtc erased_step ([e <_> vf vz]%E, σ) (of_val w :: es, σ') → φ w.
  Proof.
    (* exercise *)
  Admitted.
End parametricity.


Require Import VST.floyd.proofauto.
Require Import VST.progs.field_loadstore.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Lemma Znth_map: forall {A B} n xs d (f: A -> B),
  Znth n (map f xs) (f d) = f (Znth n xs d).
Proof.
  intros.
  unfold Znth.
  if_tac.
  + reflexivity.
  + apply map_nth.
Qed.

Lemma legal_Znth_map: forall {A B} n xs dA dB (f: A -> B),
  0 <= n < Zlength xs ->
  Znth n (map f xs) dB = f (Znth n xs dA).
Proof.
  intros.
  unfold Znth.
  if_tac.
  + omega.
  + apply nth_map'.
    rewrite Zlength_correct in H.
    destruct H.
    apply Z2Nat.inj_lt in H1; [ | omega | omega].
    rewrite Nat2Z.id in H1.
    exact H1.
Qed.

Definition t_struct_b := Tstruct _b noattr.

Definition sub_spec (sub_id: ident) :=
 DECLARE sub_id
  WITH v : val * list (val*val) , p: val
  PRE  []
        PROP  (is_int I8 Signed (snd (nth 1%nat (snd v) (Vundef, Vundef))))
        LOCAL (gvar _p p)
        SEP   (data_at Ews t_struct_b v p)
  POST [ tvoid ]
        PROP() LOCAL()
        SEP(data_at Ews t_struct_b (snd (nth 1%nat (snd v) (Vundef, Vundef)), snd v) p).

Definition sub_spec' (sub_id: ident) :=
 DECLARE sub_id
  WITH v : reptype t_struct_b, p: val
  PRE  []
        PROP  (is_int I8 Signed (proj_reptype _ (DOT _y2 SUB 1 DOT _x2) v))
        LOCAL (gvar _p p)
        SEP   (data_at Ews t_struct_b v p)
  POST [ tvoid ]
        PROP() LOCAL()
        SEP(data_at Ews t_struct_b
           (upd_reptype t_struct_b (DOT _y1) v
             (proj_reptype t_struct_b (StructField _x2 :: ArraySubsc 1 :: StructField _y2 :: nil) v))
           p).

Lemma spec_coincide: sub_spec' = sub_spec.
Proof.
(*reflexivity.*)
Abort.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    sub_spec _sub1; sub_spec _sub2; sub_spec _sub3]).

Lemma body_sub1:  semax_body Vprog Gprog f_sub1 (sub_spec _sub1).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
Qed.

Lemma body_sub2:  semax_body Vprog Gprog f_sub2 (sub_spec _sub2).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
  forward.
Qed.

Lemma body_sub3:  semax_body Vprog Gprog f_sub3 (sub_spec _sub3).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
  forward.
  forward.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

Some results concerning typing of terms of simply typed
lambda-calculus are introduced in this file.
*)

Set Implicit Arguments.

From Coq Require Import Eqdep_dec.
From CoLoR Require Import RelExtras ListExtras LogicUtil.
From CoLoR Require TermsDef.

Module TermsTyping (Sig : TermsSig.Signature).

  Module Export TD := TermsDef.TermsDef Sig.

  Lemma baseType_dec : forall A, {isBaseType A} + {isArrowType A}.

  Proof. destruct A; fo. Qed.

  Lemma type_discr : forall A B, ~A = A --> B.

  Proof.
    induction A; unfold not; simpl; intros. discr.
    unfold not in *. inversion H. eapply IHA1. apply H1.
  Qed.

  Lemma type_discr2 : forall A B C, ~A = (A --> B) --> C.

  Proof.
    induction A; unfold not; simpl; intros. discr.
    unfold not in *. inversion H. eapply IHA1. apply H1.
  Qed.

(*Section Equality_Decidable.*)

(* FIXME: eq_nat_dec has to be redefined here for the following Hint
Resolve, otherwise it does not work! *)
  Lemma eq_nat_dec : forall (m n: nat), {m=n}+{m<>n}.

  Proof. decide equality. Qed.

  #[global] Hint Resolve eq_nat_dec : terms.

  Lemma eq_SimpleType_dec : forall (A B: SimpleType), {A=B} + {A<>B}.

  Proof. decide equality; auto with terms. Defined.

  #[global] Hint Resolve eq_SimpleType_dec : terms.

  Lemma eq_Env_dec : forall (E1 E2 : Env), {E1=E2} + {E1<>E2}.

  Proof.
    decide equality; generalize a o; decide equality; apply eq_SimpleType_dec.
  Defined.

  #[global] Hint Resolve eq_Env_dec : terms.

  Lemma eq_Preterm_dec : forall (F G: Preterm), {F=G}+{F<>G}.

  Proof. decide equality; auto with terms. Defined.

  #[global] Hint Resolve eq_Preterm_dec : terms.

  Lemma isVarDecl_dec : forall E x,
    {A: SimpleType | E |= x := A} + {E |= x :!}.

  Proof.
    intros; unfold VarUD.
    destruct (nth_error_In E x) as [[A ExA] | Exn].
    destruct A.
    left; exists s; trivial.
    right; auto.
    right; auto.
  Defined.

  Lemma eq_EPS_dec :
    forall (a b : Env * Preterm * SimpleType), {a=b} + {a<>b}.

  Proof.
    decide equality.
    apply eq_SimpleType_dec.
    generalize a p; decide equality.
    apply eq_Preterm_dec.
    apply eq_Env_dec.
  Defined.

(*Section Typing.*)

  Lemma VarD_unique : forall E x A (v1 v2 : VarD E x A), v1 = v2.

  Proof.
    unfold VarD; intros; generalize v1 v2; rewrite v1.
    intros; apply K_dec_type;
      [idtac |  pattern v0; apply K_dec_type];
      auto; decide equality; generalize a o; decide equality;
      apply eq_SimpleType_dec.
  Qed.

  Lemma Type_unique : forall Pt E T1 T2 (d1 : Typing E Pt T1)
    (d2 : Typing E Pt T2), T1 = T2.

  Proof.
    induction Pt; intros; inversion d1;
      inversion d2; trivial.
    unfold  VarD in * .
    assert(Some (Some T1) = Some (Some T2)).
    trans (nth_error E x); auto.
    injection H7; trivial.
    rewrite(@IHPt _ _ _ X X0); auto.
    set(e0 := IHPt1 _ _ _ X X1); injection e0; auto.
  Qed.

  Lemma typing_unique : forall E Pt T (d1 d2 : Typing E Pt T), d1 = d2.

  Proof.
    refine(
      fix Deriv_unique e t T (d1 d2 : Typing e t T) {struct d1}
       : d1 = d2 :=
      match d1 as d1' in Typing e1 t1 T1,
	    d2 as d2' in Typing e2 t2 T2
      return
        forall (cast : (e1,t1,T1) = (e2,t2,T2)),
          (e1,t1,T1) = (e,t,T) ->
          eq_rect (e1,t1,T1)
	  (fun etT =>
	     match etT with
	    (e,t,T) => Typing e t T
	    end)
	  d1' _ cast = d2'
      with
      | TVar _, TVar _ => _
      | TFun _ _, TFun _ _ => _
      | TAbs _, TAbs _ => _
      | TApp _ _, TApp _ _ => _
      | _, _ => _
      end (eq_refl _) (eq_refl _));
    intros; destruct t; try discr;
    try discr cast; try discr dis;
    injection cast; intros; gen cast; clear cast.

    revert v v0.
    rewrite H0; rewrite H1; rewrite H2.
    intros; pattern cast; apply (K_dec_type eq_EPS_dec).
    rewrite (VarD_unique v v0); apply eq_refl.

    rewrite H1; rewrite H2.
    intros; pattern cast; apply (K_dec_type eq_EPS_dec);
      apply eq_refl.

    revert t1.
    rewrite <- H0; rewrite <- H1; rewrite <- H2; rewrite <- H4.
    intros; pattern cast; apply (K_dec_type eq_EPS_dec).
    rewrite(Deriv_unique _ _ _ t0 t1); apply eq_refl.

    revert t2 t3.
    rewrite <- H0; rewrite <- H1; rewrite <- H2; rewrite <- H3.
    intros t2 t3.
    intros; pattern cast; apply (K_dec_type eq_EPS_dec).
    set(h1 := Type_unique t0 t2); injection h1; intro H7.
    clear h1. revert t2 t3. rewrite <- H7.
    intros; rewrite(Deriv_unique _ _ _ t0 t2);
      rewrite(Deriv_unique _ _ _ t1 t3);
    apply eq_refl.
  Qed.

  Lemma deriv_uniq : forall M N, env M = env N -> term M = term N ->
    type M = type N -> M = N.

  Proof.
    intros [??? typingM] [??? typingN] H H0 H1; simpl in *.
    revert typingM.
    rewrite H; rewrite H0; rewrite H1.
    intros.
    rewrite(typing_unique typingM typingN).
    apply eq_refl.
  Qed.

  Lemma typing_uniq : forall M N, env M = env N -> term M = term N ->
    type M = type N.

  Proof.
    intros; destruct M as [??? typingM]; destruct N as [??? typingN]; simpl in *.
    revert typingM.
    rewrite H; rewrite H0; intros.
    apply (Type_unique typingM typingN).
  Qed.

  Lemma term_eq : forall M N, env M = env N -> term M = term N -> M = N.

  Proof.
    intros; apply deriv_uniq; auto.
    apply typing_uniq; auto.
  Qed.

  Lemma eq_Term_dec : forall (M N: Term), {M=N} + {M<>N}.

  Proof.
     intros M N.
     case (eq_Env_dec M.(env) N.(env));
       case (eq_Preterm_dec M.(term) N.(term));
       case (eq_SimpleType_dec M.(type) N.(type));
       try solve [right; congruence].
     left; apply deriv_uniq; trivial.
  Qed.

  #[global] Hint Resolve typing_uniq deriv_uniq term_eq : terms.

(*Section Auto_Typing.*)

  Definition autoType : forall E Pt, {N: Term | env N = E & term N = Pt} +
    {~exists N: Term, env N = E /\ term N = Pt}.

  Proof.
    intros E Pt. revert Pt E. induction Pt; intro E.
     (* -) variable *)
    destruct (isVarDecl_dec E x) as [[A xt] | xut].
     (*   - variable declared *)
    left.
    exists (buildT (TVar xt)); trivial.
     (*   - variable undeclared *)
    right.
    intro abs; destruct abs as [T [T_env T_term]].
    term_inv T.
    unfold VarD in T0.
    destruct xut; congruence.
     (* -) function symbol *)
    left.
    assert (t: E |- ^f := f_type f).
    constructor.
    exists (buildT t); trivial.
     (* -) abstraction *)
    destruct (IHPt (decl A E)) as [[T T_env T_term] | Tne].
     (*   - typable *)
    left.
    assert (t: E |- \A => Pt := A --> type T).
    constructor.
    rewrite <- T_env.
    rewrite <- T_term.
    exact (typing T).
    exists (buildT t); trivial.
     (*   - no-typable *)
    right.
    intro Nt.
    destruct Nt as [T [T_env T_term]].
    absurd (exists N, env N = decl A E /\ term N = Pt); trivial.
    destruct T as [TE TPt TA TT].
    inversion TT; simpl in *; try congruence.
    exists (buildT X); split; simpl; congruence.
     (* -) application *)
    destruct (IHPt1 E) as [[Tl Tl_env Tl_term] | Tln].
    destruct (IHPt2 E) as [[Tr Tr_env Tr_term] | Trn].
    destruct Tl as [EL PtL AL TypL].
    destruct Tr as [ER PtR AR TypR].
    simpl in *.
    destruct AL.
     (*   - bad: left argument of simple type *)
    right.
    intro Tl; destruct Tl as [Tl [envL termL]].
    destruct Tl as [EL' PtL' AL TypL'].
    simpl in *.
    rewrite termL in TypL'.
    inversion TypL'.
    assert (buildT X = buildT TypL).
    apply term_eq; simpl; congruence.
    absurd (A --> AL = #T).
    discr.
    eapply Type_unique. apply X.
    rewrite envL; rewrite <- Tl_env; rewrite <- Tl_term; hyp.
    destruct (eq_SimpleType_dec AL1 AR) as [AL1_AR | AL1_ne_AR].
     (*   - all ok *)
    left.
    assert (t: E |- PtL @@ PtR := AL2).
    constructor 4 with AL1.
    rewrite <- Tl_env; trivial.
    rewrite <- Tr_env; rewrite AL1_AR; trivial.
    exists (buildT t); trivial.
    simpl; congruence.
     (*   - bad: types do not match *)
    right.
    intro Tl; destruct Tl as [Tl [envL termL]].
    destruct Tl as [EL' PtL' AL TypL'].
    simpl in *.
    rewrite termL in TypL'.
    inversion TypL'.
    absurd (AL1 = AR).
    trivial.
    assert (type (buildT TypL) = type (buildT X)).
    apply typing_uniq; simpl; congruence.
    assert (type (buildT TypR) = type (buildT X0)).
    apply typing_uniq; simpl; congruence.
    simpl in *; congruence.
     (*   - bad: right argument not typable *)
    right.
    intro Tr; destruct Tr as [Tr [envR termR]].
    destruct Tr as [ER PtR AR TypR].
    simpl in *.
    rewrite termR in TypR.
    inversion TypR.
    apply Trn.
    exists (buildT X0); auto.
     (*   - bad: left argument not typable *)
    right.
    intro Tl; destruct Tl as [Tl [envL termL]].
    destruct Tl as [EL PtL AL TypL].
    simpl in *.
    rewrite termL in TypL.
    inversion TypL.
    apply Tln.
    exists (buildT X); auto.
  Defined.

  Definition typeTerm (E: Env) (Pt: Preterm) (T: SimpleType) : option Term.

  Proof.
     intros.
     destruct (autoType E Pt) as [[W Wenv Wterm] | x].
     destruct (eq_SimpleType_dec (type W) T).
     exact (Some W).
     exact None.
     exact None.
  Defined.

Module TermsSet <: SetA.
  Definition A := Term.
End TermsSet.

Module TermsEqset <: Eqset := Eqset_def TermsSet.

Module TermsEqset_dec <: Eqset_dec.

  Module Export Eq := TermsEqset.

  Definition eqA_dec := eq_Term_dec.

End TermsEqset_dec.

Ltac infer_tt :=
  compute;
    match goal with
    | |- _ |- ?t := _ =>
      match t with
      | App _ _ => eapply TApp; infer_tt
      | Abs _ _ => eapply TAbs; infer_tt
      | Fun _ => intuition
      | Var _ => eapply TVar; compute; trivial
      end
    end.

End TermsTyping.


From Perennial.goose_lang Require Import prelude.
From Perennial.goose_lang Require Export ffi.grove_prelude.
From Perennial.program_proof Require Import proof_prelude.
From iris.algebra Require Export mono_nat.
From Perennial.program_proof.grove_shared Require Import urpc_spec urpc_proof.
From Perennial.program_proof Require Import marshal_proof.
From Perennial.base_logic Require Import lib.ghost_map lib.saved_spec.

Section interface.

Context `{!inG Σ mono_natUR}.

Definition localhost : chan := U64 53021371269120.

Definition counter_lb γ (x:nat) : iProp Σ := own γ (◯MN x).
Definition counter_own γ (x:nat) : iProp Σ := own γ (●MN x).

Context `{!urpcregG Σ}.

Context `{HPRE: !gooseGlobalGS Σ}.

(* HOCAP-style spec *)
Program Definition FAISpec (γ:gname) : savedSpecO Σ (list u8) (list u8) :=
  λ reqData, λne (Φ : list u8 -d> iPropO Σ),
  (
      ∀ (x:nat), counter_own γ x ={⊤}=∗ counter_own γ (x + 1) ∗
                                    (∀ l, ⌜has_encoding l [EncUInt64 x]⌝ -∗ Φ l)
    )%I
.
Next Obligation.
  solve_proper.
Defined.

(* TaDa-style spec *)
Program Definition FAISpec_tada (γ:gname) : savedSpecO Σ (list u8) (list u8) :=
  λ reqData, λne (Φ : list u8 -d> iPropO Σ),
  (
       ∃ Eo Ei,
       |={Eo,Ei}=> ∃ x, counter_own γ x ∗
                      (counter_own γ (x+1) ={Ei,Eo}=∗ (∀ l, ⌜has_encoding l [EncUInt64 x]⌝ -∗ Φ l))
    )%I
.

Next Obligation.
  solve_proper.
Defined.

Definition is_CtrServer_urpc γurpc_gn γ : iProp Σ :=
  handler_spec γurpc_gn localhost 0 (FAISpec γ) ∗
  handlers_dom (γurpc_gn) {[ U64 0 ]}.

End interface.


Require Import Classical Peano_dec Setoid PeanoNat.
From hahn Require Import Hahn.
Require Import Lia.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_bob.
Require Import imm_s.
Require Import imm_s_ppo.
Require Import imm_s_rfppo.
Require Import AuxDef.
Require Import SetSize.
Require Import FairExecution.
Require Import AuxRel2.
Require Import travorder.TraversalOrder.
Require Import travorder.TLSCoherency.
Require Import travorder.IordCoherency.
Require Import travorder.SimClosure.
Require Import AuxRel2.
Require Import ImmFair.
Require Import EnumPrefix.
Require Import FinThreads.

Import ListNotations.

Set Implicit Arguments.

Section IordTraversal.
  Variable (G: execution) (sc: relation actid).
  Implicit Types (WF : Wf G) (COMP : complete G)
         (WFSC : wf_sc G sc) (CONS : imm_consistent G sc)
         (MF : mem_fair G).

  Notation "'sb'" := (sb G).
  Notation "'rmw'" := (rmw G).
  Notation "'data'" := (data G).
  Notation "'addr'" := (addr G).
  Notation "'ctrl'" := (ctrl G).
  Notation "'rf'" := (rf G).
  Notation "'co'" := (co G).
  Notation "'coe'" := (coe G).
  Notation "'fr'" := (fr G).

  Notation "'fwbob'" := (fwbob G).
  Notation "'ppo'" := (ppo G).
  Notation "'ar'" := (ar G sc).
  Notation "'fre'" := (fre G).
  Notation "'rfi'" := (rfi G).
  Notation "'rfe'" := (rfe G).
  Notation "'deps'" := (deps G).
  Notation "'detour'" := (detour G).

  Notation "'lab'" := (lab G).
  Notation "'loc'" := (loc lab).
  Notation "'val'" := (val lab).
  Notation "'mod'" := (Events.mod lab).
  Notation "'same_loc'" := (same_loc lab).

  Notation "'E'" := (acts_set G).
  Notation "'R'" := (fun x => is_true (is_r lab x)).
  Notation "'W'" := (fun x => is_true (is_w lab x)).
  Notation "'F'" := (fun x => is_true (is_f lab x)).
  Notation "'Sc'" := (fun x => is_true (is_sc lab x)).
  Notation "'RW'" := (R ∪₁ W).
  Notation "'FR'" := (F ∪₁ R).
  Notation "'FW'" := (F ∪₁ W).
  Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).
  Notation "'W_ex'" := (W_ex G).
  Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

  Notation "'iord'" := (iord G sc).
  Notation "'SB'" := (SB G sc).
  Notation "'RF'" := (RF G).
  Notation "'AR'" := (AR G sc).
  Notation "'FWBOB'" := (FWBOB G).

  Section IordEnum.
    (* This generalization is used to support traversal
       of both complete exec_tls and its parts *)

  Variable (steps: nat -> trav_label).
  Variable (dom: trav_label -> Prop).
  Hypothesis (IORD_DOM: iord ⊆ dom × dom).
  Hypothesis (DOM_EXEC: dom ⊆₁ exec_tls G).
  Hypothesis (ENUM: enumerates steps dom).
  Hypothesis (RESP: respects_rel steps iord⁺ dom).

  Lemma trav_prefix_in_exec_tls i
        (DOMi: NOmega.le (NOnum i) (set_size dom)):
    trav_prefix steps i ⊆₁ exec_tls G.
  Proof using ENUM DOM_EXEC.
    apply enumeratesE' in ENUM. cdes ENUM.
    unfold trav_prefix. apply set_subset_bunion_l. intros.
    rewrite <- DOM_EXEC. apply set_subset_single_l. apply INSET.
    liaW (set_size dom).
  Qed.

  Lemma trav_prefix_step
        i (DOMsi: NOmega.lt_nat_l i (set_size dom)):
    iord_step G sc (trav_prefix steps i) (trav_prefix steps (S i)).
  Proof using RESP ENUM IORD_DOM.
    red. exists (steps i). do 2 red.
    splits; try by (red; eapply trav_prefix_r_closed; eauto; liaW (set_size dom)).
    apply seq_eqv_l. split.
    { eapply prefix_border; eauto. }
    eapply trav_prefix_ext; eauto.
  Qed.

  Definition tc_enum (i: nat): trav_label -> Prop  :=
    sim_clos G (trav_prefix steps i) ∪₁ init_tls G.

  (* TODO: group similar lemmas about union with init_tls *)
  Lemma trav_prefix_init_tls_iord_coherent i
        (DOMi : NOmega.le (NOnum i) (set_size dom)):
    iord_coherent G sc (trav_prefix steps i ∪₁ init_tls G).
  Proof using RESP IORD_DOM ENUM.
    red. rewrite id_union, seq_union_r, dom_union.
    apply set_subset_union_l. split.
    { apply set_subset_union_r. left. eapply trav_prefix_r_closed; eauto. }
    unfold "iord". rewrite init_tls_EI at 1. basic_solver.
  Qed.

  Lemma tc_enum_tls_coherent WF i
      (DOMi: NOmega.le (NOnum i) (set_size dom)):
    tls_coherent G (tc_enum i).
  Proof using ENUM DOM_EXEC.
    unfold tc_enum. split; [basic_solver| ].
    apply set_subset_union_l. split; [| basic_solver].
    erewrite sim_clos_mori.
    2: { apply trav_prefix_in_exec_tls; eauto. }
    pose proof (exec_tls_sim_coh WF). red in H. rewrite <- H. basic_solver.
  Qed.

  Lemma trav_prefix_union_init_tls_coherent WF i
      (DOMi: NOmega.le (NOnum i) (set_size dom)):
    tls_coherent G (trav_prefix steps i ∪₁ init_tls G).
  Proof using ENUM DOM_EXEC.
    apply tls_coherent_defs_equiv. exists (trav_prefix steps i).
    split; [| basic_solver]. now apply trav_prefix_in_exec_tls.
  Qed.

  Lemma trav_prefix_step_ext
        i (DOMsi: NOmega.lt_nat_l i (set_size dom)):
    iord_step G sc (trav_prefix steps i ∪₁ init_tls G)
              (trav_prefix steps (S i) ∪₁ init_tls G).
  Proof using RESP IORD_DOM ENUM DOM_EXEC.
    forward eapply trav_prefix_step as [l STEP]; eauto.
    red. exists l. do 2 red.
    splits; try by (apply trav_prefix_init_tls_iord_coherent; liaW (set_size dom)).
    do 2 red in STEP. desc. apply seq_eqv_l in STEP. desc.
    apply seq_eqv_l. split.
    2: { rewrite STEP2. basic_solver. }
    apply set_compl_union. split; auto.
    apply set_disjoint_eq_r. eapply set_disjoint_mori; [reflexivity| ..].
    2: by apply init_exec_tls_disjoint.
    red. rewrite <- DOM_EXEC.
    forward eapply @trav_prefix_in_dom with (i := S i) as XX; eauto.
    rewrite <- XX. rewrite STEP2. basic_solver.
  Qed.

  Lemma sim_traversal_next WF CONS:
    forall i (DOMi: NOmega.lt_nat_l i (set_size dom)),
      (sim_clos_step G sc)^* (tc_enum i) (tc_enum (1 + i)).
  Proof using RESP ENUM IORD_DOM DOM_EXEC.
    ins. unfold tc_enum.
    forward eapply init_tls_sim_coh as INIT_SCOH; eauto. red in INIT_SCOH.
    rewrite INIT_SCOH, <- !sim_clos_dist; auto.
    apply iord_step_implies_sim_clos_step; auto.
    red. splits; try by (apply trav_prefix_union_init_tls_coherent; liaW (set_size dom)).
    apply trav_prefix_step_ext; auto.
  Qed.

  End IordEnum.

  Lemma iord_enum_exists WF COMP WFSC CONS MF
        (IMM_FAIR: imm_s_fair G sc)
        (TB: fin_threads G)
        dom:
  exists (steps: nat -> trav_label),
    enumerates steps dom /\
    respects_rel steps iord⁺ dom.
  Proof using.
    edestruct countable_ext with (s := dom) (r := ⦗event ↓₁ (set_compl is_init)⦘ ⨾ iord⁺)
      as [| [steps [ENUM RESP]]].
    { eapply countable_subset; [| by apply set_subset_full_r].
      apply trav_label_countable. }
    { red. split.
      { rewrite inclusion_seq_eqv_l. by apply iord_acyclic. }
      red. intros ? ? ? ?%seq_eqv_l  ?%seq_eqv_l. desc.
      apply seq_eqv_l. split; auto. eapply transitive_ct; eauto. }
    { eapply iord_ct_fsupp; eauto. }
    { edestruct H. constructor. econstructor; vauto. }
    exists steps. splits; eauto.
    red. ins. apply RESP; auto.
    1, 2: by apply set_lt_size.
    apply seq_eqv_l. split; auto.
    apply enumeratesE' in ENUM. desc. apply INSET in DOMi.
    apply ct_begin in Rij. generalize Rij. unfold iord. basic_solver.
  Qed.

  Lemma sim_traversal_inf WF CONS
        (FAIR: mem_fair G)
        (IMM_FAIR: imm_s_fair G sc)
        (TB: fin_threads G)
        (dom: trav_label -> Prop)
        (IORD_DOM: iord ⊆ dom × dom)
        (DOM_EXEC: dom ⊆₁ exec_tls G)
        (DOM_COVERS: eq ta_cover <*> (E \₁ is_init) ⊆₁ dom)
        (DOM_SIM_CLOSURE: forall (S: trav_label -> Prop) (S_DOM: S ⊆₁ dom),
            (@sim_clos G S) ⊆₁ dom):
    exists (sim_enum: nat -> (trav_label -> Prop)),
      ⟪INIT: sim_enum 0 ≡₁ init_tls G ⟫ /\
      ⟪COH: forall i (DOMi: NOmega.le (NOnum i) (set_size dom)),
          tls_coherent G (sim_enum i)⟫ /\
      ⟪STEPS: forall i (DOMi: NOmega.lt_nat_l i (set_size dom)),
          (sim_clos_step G sc)^* (sim_enum i) (sim_enum (1 + i)) ⟫ /\
      ⟪ENUM: forall e (Ee: (E \₁ is_init) e), exists i,
           NOmega.le (NOnum i) (set_size dom) /\
             (sim_enum i) (mkTL ta_cover e)⟫ /\
      ⟪DOM: forall i (DOMi: NOmega.le (NOnum i) (set_size dom)),
          sim_enum i ⊆₁ init_tls G ∪₁ dom⟫.
  Proof using.
    edestruct iord_enum_exists as [steps_enum [ENUM RESP]]; eauto.
    1, 2: by apply CONS.
    exists (tc_enum steps_enum). splits.
    { unfold tc_enum. rewrite trav_prefix_init.
      rewrite sim_clos_empty. basic_solver. }
    { apply tc_enum_tls_coherent; eauto. }
    { apply sim_traversal_next; auto. }
    { intros e Ee.
      pose proof ENUM as ENUM'. apply enumeratesE' in ENUM. desc.
      specialize (IND (mkTL ta_cover e)). specialize_full IND.
      { apply DOM_COVERS. vauto. }
      desc. exists (S i). split; [by vauto| ].
      eapply set_equiv_exp.
      { unfold tc_enum. rewrite trav_prefix_ext; eauto. }
      rewrite IND0. unfold sim_clos. basic_solver 10.  }
    ins. unfold tc_enum. rewrite set_unionC. apply set_subset_union; [done| ].
    rewrite <- DOM_SIM_CLOSURE; [reflexivity| ].
    eapply trav_prefix_in_dom; eauto.
  Qed.

  Lemma sim_traversal_inf_cip WF CONS
        (FAIR: mem_fair G)
        (IMM_FAIR: imm_s_fair G sc)
        (TB: fin_threads G) :
    exists (sim_enum: nat -> (trav_label -> Prop)),
      ⟪INIT: sim_enum 0 ≡₁ init_tls G ⟫ /\
      ⟪COH: forall i (DOMi: NOmega.le (NOnum i) (set_size (exec_tls_cip G))),
          tls_coherent G (sim_enum i)⟫ /\
      ⟪STEPS: forall i (DOMi: NOmega.lt_nat_l i (set_size (exec_tls_cip G))),
          (sim_clos_step G sc)^* (sim_enum i) (sim_enum (1 + i)) ⟫ /\
      ⟪ENUM: forall e (Ee: (E \₁ is_init) e), exists i,
           NOmega.le (NOnum i) (set_size (exec_tls_cip G)) /\
             (sim_enum i) (mkTL ta_cover e)⟫ /\
      ⟪DOM: forall i (DOMi: NOmega.le (NOnum i) (set_size (exec_tls_cip G))),
          sim_enum i ⊆₁ init_tls G ∪₁ exec_tls_cip G⟫.
  Proof using.
    forward eapply sim_traversal_inf with (dom := exec_tls_cip G) as TRAV; eauto.
    { apply dom_helper_3. rewrite <- restr_relE. apply iord_exec_tls_cip. }
    { unfold exec_tls_cip, exec_tls. rewrite !set_pair_alt. basic_solver 10. }
    { unfold exec_tls_cip, exec_tls. rewrite !set_pair_alt. basic_solver 10. }
    ins. rewrite exec_tls_cip_alt, set_minusE. apply set_subset_inter_r. split.
    { apply sim_clos_exec_tls; auto. rewrite S_DOM.
      rewrite exec_tls_cip_alt. basic_solver. }
    unfold sim_clos. repeat (apply set_subset_union_l; split).
    2, 3: unfold rmw_clos, rel_clos; iord_dom_solver.
    rewrite S_DOM, exec_tls_cip_alt. basic_solver.
  Qed.

  Lemma sim_traversal_inf_full WF CONS
        (FAIR: mem_fair G)
        (IMM_FAIR: imm_s_fair G sc)
        (TB: fin_threads G) :
    exists (sim_enum: nat -> (trav_label -> Prop)),
      ⟪INIT: sim_enum 0 ≡₁ init_tls G ⟫ /\
      ⟪COH: forall i (DOMi: NOmega.le (NOnum i) (set_size (exec_tls G))),
          tls_coherent G (sim_enum i)⟫ /\
      ⟪STEPS: forall i (DOMi: NOmega.lt_nat_l i (set_size (exec_tls G))),
          (sim_clos_step G sc)^* (sim_enum i) (sim_enum (1 + i)) ⟫ /\
       ⟪ENUM: forall e (Ee: (E \₁ is_init) e), exists i,
           NOmega.le (NOnum i) (set_size (exec_tls G)) /\
             (sim_enum i) (mkTL ta_cover e)⟫.
  Proof using.
    forward eapply sim_traversal_inf with (dom := exec_tls G) as TRAV; eauto.
    { rewrite iord_exec_tls. basic_solver. }
    { unfold exec_tls. basic_solver. }
    { ins. apply sim_clos_exec_tls; auto. }
    desc. eexists. splits; eauto.
  Qed.

End IordTraversal.


(*
  This file is part of the verified smart contract project of SECBIT Labs.

  Copyright 2018 SECBIT Labs

  This program is free software: you can redistribute it and/or
  modify it under the terms of the GNU Lesser General Public License
  as published by the Free Software Foundation, either version 3 of
  the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public License
  along with this program.  If not, see <https://www.gnu.org/licenses/>.
*)

Require Export Lists.List.
Require Import Model.
Require Import Spec.
Require Export Arith.

(*
  High-level properties implied by the ERC20 spec in Spec.v.

  1) Fixed total supply: in any step of any execution, the sum of all balances
     always equal to totalSupply:

Theorem Property_totalSupply_fixed :
  forall env0 env msg ml C E C' E',
    create env0 msg C E
    -> env_step env0 env
    -> run env C ml C' E'
    -> Sum (st_balances (w_st C')) (st_totalSupply (w_st C')).

 *)

(* Definition of sum of mapping *)
Inductive Sum : (@tmap address value) -> value -> Prop :=
 | Sum_emp : Sum tmap_emp 0
 | Sum_add : forall m v a' v',
     Sum m v
     -> m a' = 0
     -> Sum (m $+ {a' <- v'}) (v + v')
 | Sum_del : forall m v a',
     Sum m v
     -> Sum (m $+ {a' <- 0}) (v - (m a')).

Fixpoint sum (m: @tmap address value) (al: list address) : value :=
  match al with
  | nil => 0
  | cons a al' => (m a) + sum m al'
  end.

Open Scope list_scope.

Section List.

  Context  `{A: Type}.

  Context `{BEq A}.

  Fixpoint list_in (a: A) (al: list A) : bool :=
    match al with
    | nil => false
    | cons a' al' => if beq a a' then true
                     else list_in a al'
  end.

Fixpoint no_repeat (al: list A) : bool :=
  match al with
  | nil => true
  | cons a' al' => andb (negb (list_in a' al')) (no_repeat al')
  end.

End List.
Opaque beq.

Lemma sum_emp : forall al,
    sum $0 al  = 0.
Proof.
  intros.
  induction al.
  simpl. trivial.
  simpl. apply IHal.
Qed.

Lemma sum_del_none : forall al m a,
    list_in a al = false
    -> no_repeat al = true
    -> sum (m $+ {a <- 0}) al  = sum m al.
Proof.
  induction al.
    intros m a Hin Hnr.
    simpl.
    trivial.
  intros m a' Hin' Hnr.
  simpl in Hin'.
  simpl.
  decbeq a a'; tmap_simpl.
  simpl in Hnr.
  desb Hnr as [Hnr1 Hnr2].
  rewrite (IHal m a' Hin' Hnr2).
  trivial.
Qed.

Lemma sum_del_any : forall al m a,
    list_in a al = true
    -> no_repeat al = true
    -> m a + sum (m $+ {a <- 0}) al  = sum m al.
Proof.
  induction al.
    intros m a Hin Hnr.
    simpl in Hin.
    discriminate.
  intros m a' Hin' Hnr.
  simpl in Hin'.
  destruct (beq_dec a a').
    simplbeq.
    simpl.
    simpl in Hnr.
    desb Hnr as [Hnr1 Hnr2].
    simpltm.
    assert (a = a').
      beq_elimH H.
      trivial.
    subst a'.
    simplb.
    rewrite sum_del_none; trivial.
  simpl.
  simplbeq.
  tmap_simpl.
  simpl in Hnr.
  desb Hnr as [Hnr1 Hnr2].
  rewrite <- (IHal m a' Hin' Hnr2).
  omega.
Qed.

Lemma minus_minus: forall t a b,
      t - a - b = t - (a + b).
Proof.
  intros.
  omega.
Qed.

Lemma sum_add_not_in : forall al m a v,
    list_in a al = false
    -> no_repeat al = true
    -> sum (m $+ {a <- v}) al  = sum m al.
Proof.
  induction al.
    intros m a v Hin Hnr.
    simpl.
    trivial.
  intros m a' v' Hin' Hnr.
  simpl in Hin'.
  simpl in Hnr.
  desb Hnr as [Hnr1 Hnr2].
  simplb.
  decbeq a a'; tmap_simpl.
  simpl.
  simpltm.
Qed.

Lemma sum_add_in : forall al m a v,
    list_in a al = true
    -> no_repeat al = true
    -> m a = 0
    -> sum (m $+ {a <- v}) al  = sum m al + v.
Proof.
  induction al.
    intros m a v Hin Hnr Hma.
    simpl in Hin.
    discriminate.
  intros m a' v' Hin' Hnr Hma.
  simpl in Hin'.
  simpl in Hnr.
  desb Hnr as [Hnr1 Hnr2].
  decbeq a a'; simpl; simpltm.
    simplb.
    beq_elimH Hb.
    subst a'.
    rewrite sum_add_not_in; auto.
    rewrite Hma; simpl; trivial.
    auto with arith.
  simplb.
  rewrite (IHal m a' v' Hin' Hnr2 Hma).
  auto with arith.
Qed.

Lemma Sum_ge_strong : forall m t,
    Sum m t
    -> forall a al,
      list_in a al = false
      -> no_repeat al = true
      -> t >= m a + sum m al.
Proof.
  intros m t H.
  induction H.
  - intros a al Hal Hnr.
    simpltm.
    rewrite sum_emp.
    auto with arith.
  - intros a al Hal Hnr.
    decbeq a a'.
      simpltm.
      substH IHSum with (IHSum a al Hal Hnr).
      beq_elimH Hb.
      subst a'.
      rewrite H0 in IHSum.
      rewrite (sum_add_not_in _ _ _ _ Hal Hnr).
      omega.
    simpltm.
    substH IHSum with (IHSum a al Hal Hnr).
    assert (Hx: list_in a' al = true \/ list_in a' al = false).
      destruct (list_in a' al); [left | right]; trivial.
    destruct Hx as [Hx | Hx].
      rewrite (sum_add_in _ _ _ _ Hx Hnr H0).
      omega.
    rewrite (sum_add_not_in _ _ _ _ Hx Hnr).
    omega.
  - intros a al' Hnin Hnr.
    decbeq a a'.
      tmap_simpl.
      beq_elimH Hb.
      subst a'.
      rewrite (sum_add_not_in _ _ _ _ Hnin Hnr).
      substH IHSum with (IHSum a al' Hnin Hnr).
      omega.
    assert (Hx: list_in a' al' = true \/ list_in a' al' = false).
      destruct (list_in a' al'); [left | right]; trivial.
    destruct Hx as [Hx | Hx].
      tmap_simpl.
      assert (Hy:=sum_del_any al' m a' Hx Hnr).
      substH IHSum with (IHSum a al' Hnin Hnr).
      rewrite <- Hy in IHSum.
      assert (Hxx: forall a b c d,
          a >= b + (c + d)
          -> a - c >=  b + d).
        clear.
        intros.
        omega.
      apply Hxx; trivial.
    tmap_simpl.
    rewrite sum_del_none; auto.
    assert (Hy: v >= m a + sum m (a' :: al')).
      apply IHSum; trivial.
        simpl.
        simplbeq.
        trivial.
      simpl.
      rewrite Hx.
      simpl.
      trivial.
    simpl in Hy.
    omega.
Qed.

Lemma Sum_ge : forall m a t,
        Sum m t
        -> t >= m a.
Proof.
  intros.
  assert (Hx:= Sum_ge_strong _ _ H a nil).
  simpl in Hx.
  substH Hx with (Hx (eq_refl _) (eq_refl _)).
  omega.
Qed.

Lemma Sum_ge_2 : forall m a a' t,
        Sum m t
        -> beq a a' = false
        -> t >= m a + m a'.
Proof.
  intros.
  assert (Hx:= Sum_ge_strong _ _ H a (a'::nil)).
  simpl in Hx.
  rewrite H0 in Hx.
  assert (m a + m a' =m a + (m a' + 0)). omega.
  rewrite <- H1 in Hx.
  apply Hx.
  trivial. trivial.
Qed.

Lemma Sum_sig :
  forall m a t,
    m = $0 $+ { a <- t }
    -> Sum m t.
Proof.
  intros m a t Hm.
  rewrite Hm.
  assert (t = 0 + t).
    auto with arith.
  rewrite H at 2.
  constructor 2.
    constructor 1.
  simpltm.
  trivial.
Qed.

Ltac arith_rewrite t :=
  let H := fresh "Harith" in
  match t with
  | ?x = ?y => assert (H: t); [auto with arith; try omega | rewrite H; clear H]
  end.

Lemma Sum_dec : forall m t a (v: value),
        Sum m t
        -> m a >= v
        -> Sum  (m $+ {a <- -= v}) (t - v).
Proof.
  unfold a2v_upd_dec.
  intros m t a v H.
  generalize dependent v.
  generalize dependent a.
  induction H.
  + intros.
    simpl in H.
    assert (v = 0).
      unfold value in * .
      omega.
    simpl.
    assert ($0 $+ {a <- (0:value)} = $0).
      simpl.
      apply tmap_extensionality.
      intro a'.
      decbeq a a'.
      rewrite (tmap_get_upd_eq2 $0 a a' (0:value)); auto.
      tmap_simpl.
      assert(Ht: minus_with_underflow 0 v = 0 - v).
      apply minus_safe; trivial.
      rewrite Ht.
      rewrite H0.
      assert(Hm: 0 - 0 = 0);auto.
      rewrite Hm.
    rewrite H1.
    constructor 1.
  + intros a v2 H1.
    decbeq a a'.
      tmap_simpl.
      beq_elimH Hb.
      subst a'.
      assert(Ht: minus_with_underflow v' v2 = v' - v2).
      apply minus_safe; trivial.
      rewrite Ht.
      arith_rewrite (v + v' - v2 = v + (v' - v2)).
      constructor 2; trivial.
    simpltm.
    rewrite (tmap_upd_upd_ne); simplbeq; auto.
    assert (Hx : v + v' - v2 = v - v2 + v').
       assert (v >= m a). apply Sum_ge. apply H.
       assert (v >= v2). omega.
       unfold value in *. omega.
    rewrite Hx.
    constructor; trivial.
      apply IHSum; trivial.
    simpltm.
  + intros a v0 H1.
    decbeq a a'.
      simpltm.
      assert (v0 = 0).
        unfold value in *. omega.
      subst v0.
      simpl.
      simpltm.
      beq_elimH Hb.
      subst a'.
      assert (Hx: v - m a - 0 = v - m a).
        unfold value in *. omega.
      rewrite Hx.
      constructor; trivial.
    simpltm.
    rewrite (tmap_upd_upd_ne); simplbeq; auto.
    assert (Hx: v - m a' - v0 = v - v0 - m a').
       unfold value in *. omega.
    rewrite Hx.
    assert (Hm: m a' = (m $+ {a <- minus_with_underflow (m a) v0}) a').
    simpltm.
    rewrite Hm.
    constructor 3.
    apply IHSum; trivial.
Qed.

Lemma Sum_inc : forall m t a (v: value),
        Sum m t
        -> m a <= MAX_UINT256 - v
        -> Sum  (m $+ {a <- += v}) (t + v).
Proof.
  unfold a2v_upd_inc.
  intros m t a v H Hlt.
  generalize dependent v.
  generalize dependent a.
  induction H.
  +  intros.
     simpltm.
     assert (plus_with_overflow TMap.zero v = v).
     apply plus_safe_lhs0; auto.
     rewrite H.
     constructor 2; auto; try constructor.
  + intros a v2 Hlt.
    decbeq a a'.
      tmap_simpl.
      beq_elimH Hb.
      subst a'.
      arith_rewrite (v + v' + v2 = v + (v' + v2)).
      rewrite (plus_safe_lt v' v2); trivial.
      constructor 2; trivial.
    simpltm.
    substH IHSum with (IHSum a v2).
    rewrite (tmap_upd_upd_ne); simplbeq; auto.
    arith_rewrite (v + v' + v2 = v + v2 + v').
    constructor 2; auto.
    simpltm.
  + intros a v0.
    decbeq a a'.
      beq_elimH Hb.
      subst a'.
      assert (plus_with_overflow ((m $+ {a <- 0}) a)  v0 = v0).
        rewrite tmap_get_upd_eq.
        rewrite plus_safe_lhs0; trivial.
      rewrite H0.
      constructor 2.
      constructor 3.
      trivial.
      simpltm.
  simpltm.
  rewrite (tmap_upd_upd_ne); simplbeq; auto.
  assert (Hx: v - m a' + v0 = v + v0 - m a').
    assert (Hy: v >= m a').
      apply (Sum_ge m a' v); trivial.
    omega.
  rewrite Hx.
  assert (m a' = m $+ {a <- plus_with_overflow (m a) v0} a').
    simpltm.
  rewrite H0.
  constructor 3.
  apply IHSum; trivial.
Qed.

Lemma a2v_upd_inc_zero : forall m a,
        m $+ {a <- += 0} = m.
Proof.
  unfold a2v_upd_inc.
  intros.
  rewrite(plus_safe_rhs0 (m a) 0); trivial.
  assert (Hx : m a + 0 = m a).
    unfold value in *. omega.
  rewrite Hx.
  tmap_simpl.
Qed.

Lemma a2v_upd_dec_zero : forall m a,
        m $+ {a <- -= 0} = m.
Proof.
  unfold a2v_upd_dec.
  intros.
  rewrite(minus_safe (m a) 0).
  assert (Hx : m a - 0 = m a).
    unfold value in *. omega.
  rewrite Hx.
  tmap_simpl.
  omega.
Qed.

Lemma ge_sub_inc: forall a b,
    a >= b -> a = a - b + b.
Proof.
  intros.
  omega.
Qed.

Lemma Sum_transfer : forall m t a1 a2 v m',
        Sum m t
        -> m a1 >= v
        -> m a2 <= MAX_UINT256 - v
        -> m' = m $+{a1 <- -= v} $+{a2 <- += v}
        -> Sum m' t.
Proof.
  intros.
  decbeq a1 a2.
  + beq_elimH Hb.
    subst a2.
    rewrite H2.
    assert (Ht: t = t - v + v).
      assert (Ht1 : t >= m a1).
        apply Sum_ge; trivial.
      assert (Ht2 : t >= v).
        omega.
      clear - Ht2.
      unfold value in t.
      eapply ge_sub_inc; eauto.
    rewrite Ht.
    eapply Sum_inc; eauto.
    eapply Sum_dec; eauto.
    unfold a2v_upd_dec.
    rewrite (tmap_get_upd_eq m a1 _).
    rewrite(minus_safe (m a1) v); auto.
    omega.
  + remember (m a1) as Ha1.
    remember (m a2) as Ha2.
    rewrite HeqHa1 in H0.
    destruct Ha1.
      assert (Hv : v = 0).
        rewrite <- HeqHa1 in H0.
        auto with arith.
      subst v.
      rewrite a2v_upd_dec_zero in H2.
      rewrite a2v_upd_inc_zero in H2.
      rewrite H2; trivial.
    assert (Hx := Sum_ge _ a1 _ H).
    assert (Ht : t = t - v - (m $+ {a1 <- -= v} a2) + (m $+ {a1 <- -= v} a2) + v).
      unfold a2v_upd_dec.
      simpltm.
      assert (Ht2 : t >= v).
        omega.
      assert (Ht3: t >= m a1 + m a2).
        apply Sum_ge_2; trivial.
      rewrite minus_minus.
      arith_rewrite (t - (v + m a2) + m a2 + v = t - (v + m a2) + (v + m a2)).
      rewrite <- ge_sub_inc; trivial.
      omega.
    rewrite Ht.
    rewrite H2.
    unfold a2v_upd_dec in * .
    unfold a2v_upd_inc in * .
    apply Sum_inc.
    simpltm.
    assert (Ht3: t >= m a1 + m a2).
      apply Sum_ge_2; trivial.
    arith_rewrite (t - v - m a2 + m a2 = t - v).
    apply Sum_dec; trivial.
    simpltm.
    omega.
Qed.

Definition assert_genesis_event (e: event) (E: eventlist) : Prop :=
  match E with
    | nil => False
    | cons e' E => e = e'
  end.

Lemma assert_genesis_event_app : forall e E E',
        assert_genesis_event e E
        -> assert_genesis_event e (E ++ E').
Proof.
  intros.
  destruct E.
  + simpl in H.  inversion H.
  + simpl in H. auto.
Qed.

(* Invariant *)
Definition INV (env: env) (S: state) (E: eventlist) : Prop :=
  let blncs := st_balances S in
  (* balances not overflow *)
  (forall a, blncs a <= MAX_UINT256) /\
  (* totalSupply preserves *)
  exists total,
    total = st_totalSupply S
    /\ Sum blncs total
    /\ exists creator,
              assert_genesis_event (ev_constructor creator) E.

(* step evaluation maintains invariant *)
Theorem step_INV: forall this env msg S E env' S' E',
    step env (mk_contract this S) msg (mk_contract this S') E'
    -> env_step env env'
    -> INV env S E
    -> INV env' S' (E ++ E').
Proof.
  intros this env msg S E env' S' E'.
  intros Hstep Henv' HI.
  destruct HI as [Hblncs [total [Htotal [Htv [creator Hassert]]]]].
  inversion_clear Hstep.

  (* case: totalSupply *)
  - unfold funcspec_totalSupply in H1.
    subst spec preP evP postP.
    simpl in *.
    destruct H5 as [Hx1 [Hx2 Hx3]].
    subst S.
    split; auto.
    exists total.
    split; auto.
    split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

  (* case: transfer *)
  - unfold funcspec_transfer in H1.
    subst spec preP evP postP.
    simpl in *.
    subst msg.
    simpl in H5.
    destruct H5 as [[Hx1a Hx1b] [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    destruct Hx1b as [ Hsender [Hx1b2 Hof]].
    split.
    + rewrite Hx7. intros.
      destruct (beq_dec to sender).
      * rewrite Nat.eqb_eq in H0. rewrite H0.
        rewrite <- (a2v_dec_inc_id _ _ _ (Hblncs sender) Hx1b2).
        auto.
      * destruct (beq_dec a to).
        {
          (* a == to *)
          rewrite Nat.eqb_eq in H1.
          subst a.
          unfold a2v_upd_inc, a2v_upd_dec.
          apply beq_sym in H0.
          rewrite (tmap_upd_upd_ne _ _ _ _ _ H0).
          rewrite (tmap_get_upd_ne _ _ _ _ H0).
          rewrite (tmap_get_upd_eq _ _ _).
          rewrite (tmap_get_upd_ne _ _ _ _ H0).
          rewrite (plus_safe_lt _ _ Hof).
          generalize(Hblncs sender). intros. omega.
        }
        {
          (* a <> to *)
          unfold a2v_upd_inc, a2v_upd_dec.
          apply beq_sym in H1.
          rewrite (tmap_get_upd_ne _ _ _ _ H1).
          destruct (beq_dec a sender).
          - (* a == sender *)
            rewrite Nat.eqb_eq in H2.
            subst a.
            rewrite (tmap_get_upd_eq _ _ _).
            rewrite (minus_safe _ _ Hx1b2).
            generalize (Hblncs sender). intros. omega.
          - (* a <> sender *)
            apply beq_sym in H2.
            rewrite (tmap_get_upd_ne _ _ _ _ H2).
            generalize (Hblncs a). intros. omega.
        }
    + exists total. split.
      *  rewrite Htotal. auto.
      *  split.
         {
           apply (Sum_transfer (st_balances S) total
                               sender to v (st_balances S'));
           auto with arith.
         }
         {
           exists creator. apply assert_genesis_event_app; auto.
         }

  (* case: balanceOf *)
  - unfold funcspec_balanceOf in H1.
    subst spec. simpl in *.
    destruct H2 as [Hx1 [Hx2 Hx3]].
    subst S.
    split; auto.
    exists total.
    simpl.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

  (* case: transferFrom *)
  - unfold funcspec_transferFrom in H1.
    subst spec.
    simpl in *.
    destruct H2 as [[Hx1a [Hx1b [Hx1c [Hx1d Hx1e]]]] [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    split.
    + rewrite Hx7. intros.
      destruct (beq_dec to from).
      * rewrite Nat.eqb_eq in H1. rewrite H1.
        rewrite <- (a2v_dec_inc_id _ _ _ (Hblncs from) Hx1c).
        auto.
      * destruct (beq_dec a to).
        {
          (* a == to *)
          rewrite Nat.eqb_eq in H2. rewrite H2.
          subst a.
          unfold a2v_upd_inc, a2v_upd_dec.
          apply beq_sym in H1.
          rewrite (tmap_upd_upd_ne _ _ _ _ _ H1).
          rewrite (tmap_get_upd_ne _ _ _ _ H1).
          rewrite (tmap_get_upd_eq _ _ _).
          rewrite (tmap_get_upd_ne _ _ _ _ H1).
          rewrite (plus_safe_lt _ _ Hx1d).
          generalize(Hblncs from). intros. omega.
        }
        {
          (* a <> to *)
          unfold a2v_upd_inc, a2v_upd_dec.
          apply beq_sym in H2.
          rewrite (tmap_get_upd_ne _ _ _ _ H2).
          destruct (beq_dec a from).
          - (* a == from *)
            rewrite Nat.eqb_eq in H3.
            subst a.
            rewrite (tmap_get_upd_eq _ _ _).
            rewrite (minus_safe _ _ Hx1c).
            generalize (Hblncs from). intros. omega.
          - (* a <> from *)
            apply beq_sym in H3.
            rewrite (tmap_get_upd_ne _ _ _ _ H3).
            generalize (Hblncs a). intros. omega.
        }
     + exists total. split.
      *  rewrite Htotal. auto.
      *  split.
         {
           apply (Sum_transfer (st_balances S) total
                               from to v (st_balances S'));
           auto with arith.
         }
         {
           exists creator. apply assert_genesis_event_app; auto.
         }

  (* case: approve *)
  - unfold funcspec_approve in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    rewrite <- Hx7 in *.
    split; auto.
    exists total.
    rewrite Hx3 in *.
    rewrite Hx7 in *.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

  (* case: allowance *)
  - unfold funcspec_allowance in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 Hx3]].
    subst S'.
    split; auto.
    exists total.
    simpl.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

  (* case: increaseApproval *)
  - unfold funcspec_increaseApproval in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    rewrite <- Hx7 in *.
    split; auto.
    exists total.
    rewrite Hx3 in *.
    rewrite Hx7 in *.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

   (* case: decreaseApproval_1 *)
  - unfold funcspec_decreaseApproval_1 in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    rewrite <- Hx7 in *.
    split; auto.
    exists total.
    rewrite Hx3 in *.
    rewrite Hx7 in *.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

    (* case: decreaseApprova_2 *)
  - unfold funcspec_decreaseApproval_2 in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 Hx8]]]]]]].
    rewrite <- Hx7 in *.
    split; auto.
    exists total.
    rewrite Hx3 in *.
    rewrite Hx7 in *.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

    (* case: transferOwnership *)
  - unfold funcspec_transferOwnership in H1.
    subst spec.
    simpl in *.
    destruct H2 as [[Hx1 Hx2] [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 [Hx8 [Hx9 [Hx10 Hx11]]]]]]]]].
    rewrite <- Hx8 in *.
    split; auto.
    exists total.
    rewrite Hx4.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

    (* case: renounceOwnership *)
  - unfold funcspec_renounceOwnership in H1.
    subst spec.
    simpl in *.
    destruct H2 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 [Hx8 [Hx9 Hx10]]]]]]]]].
    split; auto.
    rewrite Hx7. auto.
    exists total.
    rewrite Hx3.  rewrite Hx7.
    repeat split; auto.
    exists creator.
    apply assert_genesis_event_app; auto.

    (* case: pause*)
  -  unfold funcspec_pause in H1.
     subst spec.
     simpl in *.
     destruct H2 as [[Hx1 Hx2] [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 [Hx8 [Hx9 [Hx10 Hx11]]]]]]]]].
     rewrite <- Hx8 in *.
     split; auto.
     exists total.
     rewrite Hx4.
     repeat split; auto.
     exists creator.
     apply assert_genesis_event_app; auto.

    (* case: unpause*)
  -  unfold funcspec_unpause in H1.
     subst spec.
     simpl in *.
     destruct H2 as [[Hx1 Hx2] [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 [Hx8 [Hx9 [Hx10 Hx11]]]]]]]]].
     rewrite <- Hx8 in *.
     split; auto.
     exists total.
     rewrite Hx4.
     repeat split; auto.
     exists creator.
     apply assert_genesis_event_app; auto.

Qed.

(* create evaluation maintains invariant *)
Theorem create_INV : forall env0 env msg C E,
    create env0 msg C E
    -> INITIAL_SUPPLY <= MAX_UINT256
    -> env_step env0 env
    -> INV env (w_st C) E.
Proof.
  intros.
  inversion_clear H.
  subst spec preP evP postP; simpl.
  unfold funcspec_constructor in H7.
  simpl in H7.
  destruct H7 as [Hx1 [Hx2 [Hx3 [Hx4 [Hx5 [Hx6 [Hx7 [Hx8 Hx9]]]]]]]].
  unfold INV.
  split.

  - (* no overflow initially *)
    subst.
    rewrite Hx6. clear Hx6. simpl.
    intros a.
    destruct (beq_dec sender a).
    + (* a = sender *)
      apply Nat.eqb_eq in H. subst a.
      rewrite (tmap_get_upd_eq _ _ _).
      auto.
    + (* a <> sender *)
      rewrite (tmap_get_upd_ne _ _ _ _ H).
      rewrite (tmap_emp_zero _).
      unfold TMap.zero.
      unfold value_Range.
      omega.
  - (* totalSupply preserves *)
    exists INITIAL_SUPPLY.
    repeat split; auto.
    + apply Sum_sig in Hx6.
      trivial.
    + exists sender.
      unfold assert_genesis_event.
      rewrite Hx1.
      rewrite H2.
      simpl.
      trivial.
Qed.

Lemma step_contract_address_constant : forall env C msg C' E',
      step env C msg C' E'
      -> w_a C = w_a C'.
Proof.
  intros.
  destruct C as [a S].
  destruct C' as [a' S'].
  induction H; simpl; auto; intuition.
Qed.

Lemma steps_INV: forall ml env C E,
    INV env (w_st C) E
    -> forall env' C' E', steps env C ml env' C' E'
    -> INV env' (w_st C') (E ++ E').
Proof.
  induction ml.

  - (* nil *)
    intros.
    inversion_clear H0.
    destruct H2.
    subst.
    rewrite app_nil_r.
    trivial.

  - (* a :: ml *)
    intros.
    inversion_clear H0.
    rename x into envx.
    rename a into msg.
    destruct H1 as [Cx [Ex [Ey [H1 [H2 [H3 H4]]]]]].
    subst E'.
    assert (Hx : INV envx (w_st Cx) (E ++ Ex)).
    {
      assert (w_a C = w_a Cx).
      {
        apply step_contract_address_constant with env msg Ex. apply H1.
      }
      destruct C as [C_a C_st].
      destruct Cx as [Cx_a Cx_st].
      simpl. simpl in H. simpl in H0. generalize H. generalize H4.
      apply step_INV with C_a msg.
      subst Cx_a. apply H1.
    }
    substH IHml with (IHml envx Cx (E ++ Ex) Hx).
    rewrite app_assoc.
    apply IHml; trivial.
Qed.

Lemma INV_implies_totalSupply_fixed :
  forall env S E,
    INV env S E
    -> Sum (st_balances S) (st_totalSupply S).
Proof.
  intros env S E HI.
  unfold INV in HI.
  destruct HI as [_ [total [Ht [HT HI]]]].
  rewrite Ht in HT.
  trivial.
Qed.

(* Prop #1: total supply is equal to sum of balances *)
Theorem Property_totalSupply_equal_to_sum_balances :
  forall env0 env msg ml C E C' E',
    create env0 msg C E
    -> INITIAL_SUPPLY <= MAX_UINT256
    -> env_step env0 env
    -> run env C ml C' E'
    -> Sum (st_balances (w_st C')) (st_totalSupply (w_st C')).
Proof.
  intros env0 env msg il C E C' E' Hc Hi Hs Hr.
  unfold run in Hr.
  destruct Hr as [env' Hsteps].
  apply INV_implies_totalSupply_fixed with env' (E++E').
  substH Hc with (create_INV _ _ _ _ _ Hc Hi Hs).
  eapply steps_INV; eauto.
Qed.

(* Prop #2: total supply is fixed with transfer *)
Theorem Property_totalSupply_fixed_transfer:
  forall env C C' E'  msg to v spec preP evP postP,
    spec = funcspec_transfer to v (w_a C) env msg
    -> preP = spec_require spec
    -> evP = spec_events spec
    -> postP = spec_trans spec
    -> preP (w_st C) /\ evP (w_st C) E' /\ postP (w_st C) (w_st C')
    -> (st_totalSupply (w_st C)) =  (st_totalSupply (w_st C')).
Proof.
  intros.
  rewrite H in H2. simpl in H2.
  destruct H3 as [H31 [H32 H33]].
  rewrite H2 in H33.
  destruct H33.
  auto.
Qed.

Lemma INV_step_total_Supply_fixed:
   forall env C C' E'  msg ,
    step env C msg C' E'
    -> (st_totalSupply (w_st C)) =  (st_totalSupply (w_st C')).
Proof.
  intros.
  inversion H.
  - subst spec.
    destruct H6 as [H61 [H62 H63]].
    rewrite H5 in H63.
    destruct H63.  auto.
  - subst spec.
    destruct H6 as [H61 [H62 H63]].
    rewrite H5 in H63.
    destruct H63.  auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    rewrite H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
  - subst spec.
    destruct H3 as [H31 [H32 H33]].
    rewrite H1 in H33. simpl in H33.
    destruct H33. auto.
Qed.

(* Prop #3: total supply is fixed after initialization *)
Theorem Property_totalSupply_fixed_after_initialization:
  forall env0 env msg C E C' E',
    create env0 msg C E
    -> step env C msg C' E'
    -> (st_totalSupply (w_st C)) =  (st_totalSupply (w_st C')).
Proof.
  intros.
  apply INV_step_total_Supply_fixed with env E' msg.
  auto.
Qed.

Lemma  INV_steps_total_supply_fixed:
forall ml env0 C0 C E env,
  steps env0 C0 ml env C E
  -> (st_totalSupply (w_st C0)) =  (st_totalSupply (w_st C)).
Proof.
  intros ml.
  induction ml.
  + intros. unfold steps in H. destruct H.
    rewrite H. trivial.
  + intros.
    inversion_clear H.
    rename x into envx.
    inversion H0 as [C'' [E'' [E' [Hs1 [Hs2 [Hs3 Hs4]]]]]].
    apply INV_step_total_Supply_fixed in Hs1.
    apply IHml in Hs2.
    rewrite Hs1. auto.
 Qed.

Theorem Property_totalSupply_fixed_after_initialization1:
   forall env0 env msg ml C E C' E',
    create env0 msg C E
    -> run env C ml C' E'
    -> (st_totalSupply (w_st C)) =  (st_totalSupply (w_st C')).
Proof.
  intros.
  unfold run in H0.
  inversion H0 as [env' H0'].
  apply INV_steps_total_supply_fixed in H0'.
  auto.
Qed.

(* Prop #4: total supply is fixed with delegate transfer *)
Theorem Property_totalSupply_fixed_delegate_transfer:
   forall env C C' E' from  msg to v spec,
    spec = funcspec_transferFrom from to v (w_a C) env msg
    -> (spec_require spec) (w_st C) /\ (spec_events spec) (w_st C) E' /\ (spec_trans spec) (w_st C) (w_st C')
    -> (st_totalSupply (w_st C)) =  (st_totalSupply (w_st C')).
Proof.
  intros.
  destruct H0 as [H01 [H02 H03]]. rewrite H in H03. simpl in H03.
  destruct H03.
  auto.
Qed.

(* Prop #5: balances of from and to changed by transfer*)
Theorem Property_from_to_balances_change:
  forall env C C' E' to addr msg v spec,
    spec = funcspec_transfer to v (w_a C) env msg
    -> (spec_require spec) (w_st C) /\
       (spec_events spec) (w_st C) E' /\
       (spec_trans spec) (w_st C) (w_st C')
    -> m_sender msg <> to
    -> m_sender msg <> addr
    -> to <> addr
    -> (st_balances (w_st C') to = (st_balances (w_st C) to) + v)
       /\ (st_balances (w_st C') (m_sender msg) = (st_balances (w_st C) (m_sender msg)) - v)
       /\ st_balances (w_st C') addr = st_balances (w_st C) addr.
Proof.
  intros env C C' E' to addr  msg v spec Hspec_def Hspec Hsender HsenderA HtoA.
  unfold funcspec_transfer in Hspec_def.
  subst spec. simpl in Hspec.
  destruct Hspec as [Hof [_ [_ [_ [_ [_ [Hblncs _]]]]]]].
  rewrite Hblncs in *. clear Hblncs.
  apply neq_beq_false in Hsender.
  apply neq_beq_false in HsenderA.
  apply neq_beq_false in HtoA.
  unfold a2v_upd_dec. unfold a2v_upd_inc.
  destruct Hof as [Hlo [Hs [Hhi Hm]]].

  split.

  - rewrite (tmap_get_upd_eq _ _ _).
    rewrite (tmap_get_upd_ne _ _ _ _ Hsender).
    apply plus_safe_lt; auto.

  - split.
    + apply beq_sym in Hsender.
      rewrite (tmap_get_upd_ne _ _ _ _ Hsender).
      rewrite (tmap_get_upd_eq _ _ _).
      apply minus_safe; auto.

    + apply beq_sym in Hsender.
      rewrite (tmap_get_upd_ne _ _ _ _ HtoA).
      rewrite (tmap_get_upd_ne _ _ _ _ HsenderA).
      auto.
Qed.

(* Prop #6: only owner can pause *)
Theorem Property_pause_only_by_owner:
  forall this env msg spec C C' E',
    spec = funcspec_pause this env msg
    -> (spec_require spec) (w_st C) /\
       (spec_events spec) (w_st C) E' /\
       (spec_trans spec) (w_st C) (w_st C')
    -> m_sender msg = st_owner (w_st C).
Proof.
  intros this env msg spec C C' E' Hspec H0.
  destruct H0 as [Hreq [Henv Htrans]].
  unfold funcspec_pause in Hspec.
  rewrite Hspec in *.
  simpl in *.
  destruct Hreq as [Hmsg Hpause].
  auto.
Qed.

(* Prop #7: only owner can unpause *)
Theorem Property_unpause_only_by_owner:
  forall this env msg spec C C' E',
    spec = funcspec_unpause this env msg
    -> (spec_require spec) (w_st C) /\
       (spec_events spec) (w_st C) E' /\
       (spec_trans spec) (w_st C) (w_st C')
    -> m_sender msg = st_owner (w_st C).
Proof.
  intros this env msg spec C C' E' Hspec H0.
  destruct H0 as [Hreq [Henv Htrans]].
  unfold funcspec_unpause in Hspec.
  rewrite Hspec in *.
  simpl in *.
  destruct Hreq as [Hmsg Hpause].
  auto.
Qed.

(* Prop #8: owner cannot transfer tokens in arbitrary account *)
Theorem Property_restricted_owner_for_transfer:
  forall to value this env msg spec C C' E' owner,
    spec = funcspec_transfer to value this env msg
    -> (spec_require spec) (w_st C) /\
       (spec_events spec) (w_st C) E' /\
       (spec_trans spec) (w_st C) (w_st C')
    -> owner = st_owner (w_st C)
    -> m_sender msg = owner
    -> (forall acct,
           acct <> owner /\ acct <> to
           -> st_balances (w_st C) acct = st_balances (w_st C') acct).
Proof.
  intros to value this env msg spec C C' E' owner Hspec H0 Hw Hmw acct Ha.
  destruct H0 as [Hreq [Henv Htrans]].
  unfold funcspec_transfer in Hspec.
  rewrite Hspec in *.
  simpl in *.
  destruct Htrans as [Hto [Hna [Hdec [Hsym [Hblns [Halw [How Hpa]]]]]]].
  rewrite Hblns.
  destruct Ha as [Hao Hat].
  apply neq_beq_false in Hao.
  apply neq_beq_false in Hat.
  unfold a2v_upd_dec. unfold a2v_upd_inc.

  apply beq_sym in Hat.
  rewrite (tmap_get_upd_ne _ _ _ _ Hat).
  apply beq_sym in Hao.
  rewrite Hmw.
  rewrite (tmap_get_upd_ne _ _ _ _ Hao).
  auto.
Qed.

(* Prop #9: owner cannot delegating transfer tokens in arbitrary account *)
Theorem Property_restricted_owner_for_transferFrom:
  forall from to value this env msg spec C C' E' owner,
    spec = funcspec_transferFrom from to value this env msg
    -> (spec_require spec) (w_st C) /\
       (spec_events spec) (w_st C) E' /\
       (spec_trans spec) (w_st C) (w_st C')
    -> owner = st_owner (w_st C)
    -> m_sender msg = owner
    -> (forall acct,
           acct <> owner /\ acct <> from /\ acct <> to
           -> st_balances (w_st C) acct = st_balances (w_st C') acct).
Proof.
  intros from to value this env msg spec C C' E' owner Hspec H0 Hw Hmw acct Ha.
  unfold funcspec_transferFrom in Hspec.
  rewrite Hspec in *. simpl in *.
  destruct H0 as [H1 [Hev [Hto [Hna [Hdec [Hsym [Hblns [Halw [How Hpa]]]]]]]]].
  rewrite Hblns.
  destruct Ha as [Hao [Haf Hat]].
  apply neq_beq_false in Hao.
  apply neq_beq_false in Hat.
  apply neq_beq_false in Haf.
  unfold a2v_upd_dec. unfold a2v_upd_inc.
  apply beq_sym in Hat.
  rewrite (tmap_get_upd_ne _ _ _ _ Hat).
  apply beq_sym in Haf.
  rewrite (tmap_get_upd_ne _ _ _ _ Haf).
  auto.
Qed.