From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
From Heaps
Require Import pred prelude idynamic ordtype pcm finmap unionmap heap coding.
From Contracts
Require Import Automata2.
Require Import Arith Bool Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Crowdfunding.
(* Encoding of the Crowdfunding contract from the Scilla whitepaper *)

(******************************************************
contract Crowdfunding
 (owner     : address,
  max_block : uint,
  goal      : uint)

(* Mutable state description *)
{
  backers : address => uint = [];
  funded  : boolean = false;
}

(* Transition 1: Donating money *)
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)

(* Transition 2: Sending the funds to the owner *)
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block >= blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)

(* Transition 3: Reclaim funds by a backer *)
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)

 *******************************************************)

Record crowdState := CS {
   owner_mb_goal : address * nat * value;
   backers : seq (address * value);
   funded : bool;
}.

(* Administrative setters/getters *)
Definition get_owner cs : address := (owner_mb_goal cs).1.1.
Definition get_goal cs : value := (owner_mb_goal cs).2.
Definition get_max_block cs : nat := (owner_mb_goal cs).1.2.

Definition set_backers cs bs : crowdState :=
  CS (owner_mb_goal cs) bs (funded cs).

Definition set_funded cs f : crowdState :=
  CS (owner_mb_goal cs) (backers cs) f.

(* Defining three layers of initial states *)
(* Parameters *)
Variable init_owner : address.
Variable init_max_block : nat.
Variable init_goal : value.
Variable init_address : address.
(* Initial crowdfunding state *)
Definition init_state : crowdState :=
  CS (init_owner, init_max_block, init_max_block) [::] false.
(* Initial contract state *)
Definition init_cstate : cstate crowdState :=
  CState init_address 0 init_state.
(* Initial world *)
Definition init_world : world crowdState :=
mkW emptymsg init_cstate b0 None.

Definition pred := world crowdState -> Prop.

(*********************************************************)
(********************* Transitions ***********************)
(*********************************************************)

(* Transition 1 *)
(*
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)
 *)

(* Definition of the protocol *)
Variable crowd_addr : address.

Notation tft := (trans_fun_type crowdState).
Definition ok_msg := [:: (0, [:: 1])].
Definition no_msg := [:: (0, [:: 0])].

Definition donate_tag := 1.
Definition donate_fun : tft := fun id bal s m bc =>
  if method m == donate_tag then
    let bs := backers s in
    let nxt_block := block_num bc + 1 in
    let from := sender m in
    if get_max_block s <= nxt_block
    then (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else if all [pred e | e.1 != from] bs
         (* new backer *)
         then let bs' := (from, val m) :: bs in
              let s'  := set_backers s bs' in
              (s', Some (Msg 0 crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition donate := CTrans donate_tag donate_fun.

(* Transition 2: Sending the funds to the owner *)
(*
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block < blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)
 *)

Definition getfunds_tag := 2.
Definition getfunds_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if (method m == getfunds_tag) && (from == (get_owner s)) then
    let blk := block_num bc + 1 in
    if (get_max_block s < blk)
    then if get_goal s <= bal
         then let s' := set_funded s true in
              (s', Some (Msg bal crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition get_funds := CTrans getfunds_tag getfunds_fun.

(* Transition 3: Reclaim funds by a backer *)
(*
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)
*)

Definition claim_tag := 3.
Definition claim_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if method m == claim_tag then
    let blk := block_num bc in
    if blk <= get_max_block s
    then
      (* Too early! *)
      (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else let bs := backers s in
         if [|| funded s | get_goal s <= bal]
         (* Cannot reimburse: campaign suceeded *)
         then (s, Some (Msg 0 crowd_addr from 0 no_msg))
         else let n := seq.find [pred e | e.1 == from] bs in
              if n < size bs
              then let v := nth 0 (map snd bs) n in
                   let bs' := filter [pred e | e.1 != from] bs in
                   let s'  := set_backers s bs' in
                   (s', Some (Msg v crowd_addr from 0 ok_msg))
              else
                (* Didn't back or already claimed *)
                (s, None)
  else (s, None).

Definition claim := CTrans claim_tag claim_fun.

Program Definition crowd_prot : Protocol crowdState :=
@CProt _ crowd_addr 0 init_state [:: donate; get_funds; claim] _.

Lemma crowd_tags : tags crowd_prot = [:: 1; 2; 3].
Proof. by []. Qed.

Program Definition prot : Protocol crowdState :=
@CProt _ crowd_addr 0 init_state [:: donate; get_funds; claim] _.

Definition reachability w1 w2 := step_world prot w1 = w2.

Check reachability.

(* Path definitions *)
Definition path := nat -> world crowdState.
Definition firstp (p : path) : world crowdState := p 0.
Definition path_predicate (p : path) := forall n, reachability (p n) (p (S n)).
(* Good path sigma-type definitions *)
Definition gpath : Type := {p : path & path_predicate p}.
(* Projection functions for sigma type good paths *)
Definition gpath_proj1 : gpath -> (nat -> world crowdState) :=
  fun gp => match gp with
            | existT a _ => a
            end.
Coercion gpath_proj1 : gpath >-> Funclass.
Definition gpath_proj2 (gp : gpath) : (path_predicate (gpath_proj1 gp)) :=
  match gp with
  | existT _ b => b
  end.
Definition first (gp : gpath) : world crowdState := (gpath_proj1 gp 0).

(* A cacophany of path constructions *)
(* Constructing a random path *)
Fixpoint step_n_times (w : world crowdState) (n : nat) :=
  match n with
  | 0 => w
  | S n' => step_world prot (step_n_times w n')
  end.

Print step_world.

Definition make_path (w : world crowdState) : path :=
  step_n_times w.

Lemma rewrite_step_world_S :
  forall (n : nat) (w : world crowdState),
    step_n_times w (S n) = step_world prot (step_n_times w n).
Proof. reflexivity. Qed.

Lemma step_world_swap_helper :
  forall (n : nat) (w : world crowdState),
    step_world prot (step_n_times w n) =
    step_n_times (step_world prot w) n.
Proof.
  intros n w.
  induction n.
  - reflexivity.
  - rewrite rewrite_step_world_S.
    rewrite IHn.
    rewrite rewrite_step_world_S.
    reflexivity.
Qed.

Lemma step_world_swap :
  forall n : nat,
    step_world prot (step_n_times (step_world prot init_world) n) =
    step_n_times (step_world prot (step_world prot init_world)) n.
Proof.
  induction n.
  - reflexivity.
  - rewrite step_world_swap_helper.
    reflexivity.
Qed.

Lemma step_world_ind :
  forall n : nat,
    step_world prot (step_n_times init_world n) = step_n_times init_world (S n).
Proof.
  induction n.
  - simpl; reflexivity.
  - simpl. reflexivity.
Qed.

Lemma about_p : path_predicate (make_path init_world).
Proof.
  unfold path_predicate.
  induction n.
  - simpl. unfold reachability. reflexivity.
  - unfold reachability in *.
    unfold make_path in *.
    rewrite <- IHn.
    simpl. reflexivity.
Qed.

Lemma about_p_hole :
  forall w : world crowdState,
    path_predicate (make_path w).
Proof.
  unfold path_predicate.
  induction n.
  - simpl. unfold reachability. reflexivity.
  - unfold reachability in *.
    unfold make_path in *.
    rewrite <- IHn.
    simpl. reflexivity.
Qed.

Definition gp : gpath := (existT _ (make_path init_world) about_p).
(* Can you make a sigma type with a dependent type? *)
Parameter generic_world : world crowdState.
Check (about_p_hole generic_world).
Definition gp_hole (w : world crowdState) : gpath := (existT _ (make_path w) (about_p_hole w)).
(* The answer is yes *)

(* Constructing an offset path *)
Definition make_offset_path (p : path) : path := fun n => p (S n).
Definition make_offset_path' (gp : gpath) : path := fun n => gpath_proj1 gp (S n).
Lemma about_offset_path :
  forall p : path,
    path_predicate p ->
    path_predicate (make_offset_path p).
Proof.
  intros p H_p.
  unfold make_offset_path.
  unfold path_predicate in *.
  intro n.
  exact (H_p (S n)).
Qed.
Lemma about_offset_path' :
  forall gp : gpath,
    path_predicate (make_offset_path' gp).
Proof.
  intro gp.
  destruct gp. unfold path_predicate in p.
  unfold make_offset_path'.
  unfold gpath_proj1.
  unfold path_predicate.
  intros n.
  exact (p (S n)).
Qed.

Definition gp_offset (p : path) (pred : path_predicate p) : gpath :=
  (existT _ (make_offset_path p) (about_offset_path pred)).
Definition gp_offset' (gp : gpath) : gpath :=
  (existT _ (make_offset_path' gp) (about_offset_path' gp)).

(* Constructing a backwards offset path *)
Definition make_backwards_offset_path (w0 : world crowdState) (p : path) : path :=
  fun n => match n with 0 => w0 | _ => (p (n.-1)) end.
Definition make_backwards_offset_path' (w0 : world crowdState) (gp : gpath) : path :=
  fun n => match n with 0 => w0 | _ => (gpath_proj1 gp (n.-1)) end.
Lemma about_backwards_offset_path :
  forall (p : path) (w0 : world crowdState),
    path_predicate p ->
    reachability w0 (p 0) ->
    path_predicate (make_backwards_offset_path w0 p).
Proof.
  intros p w0 H_p.
  unfold make_backwards_offset_path.
  unfold path_predicate in *.
  destruct n.
  simpl. exact H.
  simpl. replace (n-0) with n.
  Focus 2. rewrite subn0. reflexivity.
  apply (H_p n).
Qed.
Lemma about_backwards_offset_path' :
  forall (gp : gpath) (w0 : world crowdState),
    reachability w0 (gpath_proj1 gp 0) ->
    path_predicate (make_backwards_offset_path' w0 gp).
Proof.
  intros gp w0 H_0.
  destruct gp. unfold path_predicate in p.
  unfold make_backwards_offset_path'.
  unfold gpath_proj1.
  unfold path_predicate.
  destruct n.
  simpl. exact H_0.
  simpl. replace (n-0) with n. Focus 2. rewrite subn0. reflexivity.
  apply (p n).
Qed.
Definition gp_backwards_offset
           (w0 : world crowdState) (p : path)
           (pred : path_predicate p)
           (r : reachability w0 (p 0)) : gpath :=
  (existT _ (make_backwards_offset_path w0 p) (about_backwards_offset_path pred r)).
Definition gp_backwards_offset'
           (w0 : world crowdState) (gp : gpath)
           (r : reachability w0 (gpath_proj1 gp 0)) : gpath :=
  (existT _ (make_backwards_offset_path' w0 gp) (about_backwards_offset_path' r)).
(* Satisfaction definition *)
Definition satisfies (w : world crowdState) (p : pred) : Prop := p w.
(* I'm not sure that the following metalogic entail is necessary *)
Definition entails (p q : pred) : Prop :=
  forall w, (satisfies w p) -> (satisfies w q).
Definition equiv (p q : pred) : Prop := entails p q /\ entails q p.

Axiom LEM : forall P : Prop, P \/ ~ P.
Notation "w '|=' p" := (satisfies w p) (at level 80, no associativity).

(* Temporal operator definitions *)
Parameter Top : pred.
Parameter Bottom : pred.
Axiom about_top : forall w, Top w.
Axiom about_bottom : forall w, Bottom w -> False.
Definition Neg p : pred := fun w => (w |= p) -> False.
Definition Conj p q : pred := fun w => (w |= p) /\ (w |= q).
Definition Disj p q : pred := fun w => (w |= p) \/ (w |= q).
Definition Impl p q : pred := fun w => ~ (w |= p) \/ (w |= q).

(* Temporal operator definitions *)
(* AX says 'in every next state', all gpaths beginning with w next satisfy p. *)
Definition AllNext (p : pred) := fun w =>
  forall gp : gpath, first gp = w -> gp 1 |= p.
(* EX says 'in some next state', all gpaths beginning with w next satisfy p. *)
Definition ExistsNext (p : pred) := fun w =>
  exists gp : gpath, first gp = w /\ gp 1 |= p.
(* AG says all states along all paths beginning with  w satisfy p, including w. *)
Definition AllBox (p : pred) := fun w =>
  forall gp : gpath, first gp = w -> forall n, gp n |= p.
(* EG says that there exists a path beginning with w along which all states satisfy p. *)
Definition ExistsBox (p : pred) := fun w =>
  exists gp : gpath, first gp = w /\ forall n, gp n |= p.
(* AF says all paths beginning with w contain a future state which satisfies p. *)
Definition AllFuture (p : pred) := fun w =>
  forall gp : gpath, first gp = w -> exists n, gp n |= p.
(* EF says that there exists a path beginning with a future state which satisfies p. *)
Definition ExistsFuture (p : pred) := fun w =>
  exists gp : gpath, first gp = w /\  exists n, gp n |= p.
(* AU says that all paths beginning with w satisfy p Until q. *)
Definition AllUntil (p q : pred) := fun w =>
  forall gp : gpath, first gp = w -> exists n, gp n |= q /\ forall m, m < n -> gp m |= p.
(* EU says that there exists a path beginning with w that satifies p Until q. *)
Definition ExistsUntil (p q : pred) := fun w =>
  exists gp : gpath, first gp = w /\ exists n, gp n |= q /\ forall m, m < n -> gp m |= p.

(* Extended temporal operator definitions *)
Definition AllRelease (p q : pred) := fun w =>
  Neg (ExistsUntil (Neg p) (Neg q)) w.
Definition ExistsRelease (p q : pred) := fun w =>
  Neg (AllUntil (Neg p) (Neg q)) w.
Definition AllWait (p q : pred) := fun w =>
  AllRelease q (Disj p q) w.
Definition ExistsWait (p q : pred) := fun w =>
  ExistsRelease q (Disj p q) w.

(* Notation definitions *)
Notation "p <=> q" := (equiv p q) (at level 35, no associativity).
Notation "! p" := (Neg p) (at level 60, right associativity).
Notation "p && q" := (Conj p q) (at level 40, left associativity).
Notation "p || q" := (Disj p q).
Notation "p --> q" := (Impl p q) (at level 35, no associativity).
Notation "'AG' p" := (AllBox p) (at level 35, no associativity).
Notation "'EG' p" := (ExistsBox p) (at level 35, no associativity).
Notation "'AX' p" := (AllNext p) (at level 35, no associativity).
Notation "'EX' p" := (ExistsNext p) (at level 35, no associativity).
Notation "'AF' p" := (AllFuture p) (at level 35, no associativity).
Notation "'EF' p" := (ExistsFuture p) (at level 35, no associativity).
Notation "'A' '[' p 'U' q ']'" := (AllUntil p q) (at level 35, no associativity).
Notation "'E' '[' p 'U' q ']'" := (ExistsUntil p q) (at level 35, no associativity).
Notation "'A' '[' p 'R' q ']'" := (AllRelease p q) (at level 35, no associativity).
Notation "'E' '[' p 'R' q ']'" := (ExistsRelease p q) (at level 35, no associativity).
Notation "'A' '[' p 'W' q ']'" := (AllWait p q) (at level 35, no associativity).
Notation "'E' '[' p 'W' q ']'" := (ExistsWait p q) (at level 35, no associativity).

Theorem ctl_1 : forall (P : pred),
    AG P <=> (P && AX (AG P)).
Proof. Admitted.
Theorem ctl_2 : forall (P : pred),
    (P && AX (AG P)) <=> AG P.
Proof. Admitted.
Theorem ctl_3 : forall (P : pred),
    EG P <=> (P && EX (EG P)).
Proof. Admitted.
Theorem ctl_4 : forall (P : pred),
    (P && EX (EG P)) <=> EG P.
Proof. Admitted.
Theorem equiv_1 : forall (P : pred),
    AX P <=> ! (EX (! P)).
Proof. Admitted.
Theorem equiv_2 : forall (P : pred),
    AF P <=> ! (EG (! P)).
Proof. Admitted.
Theorem equiv_3 : forall (P : pred),
    AG P <=> ! (EF (!P)).
Proof. Admitted.
Theorem equiv_4 : forall (P : pred),
    AF P <=> A [Top U P].
Proof. Admitted.
Theorem equiv_5 : forall (P : pred),
    EF P <=> E [Top U P].
Proof. Admitted.
Theorem equiv_6 : forall (P Q : pred),
    A [P U Q] <=> E [!P U (!P && !Q)] && AF Q.
Proof. Admitted.

(*
Lemma find_leq {A : eqType} (p : pred (A * nat)) (bs : seq (A * nat)) :
  nth 0 [seq i.2 | i <- bs] (seq.find p bs) <= sumn [seq i.2 | i <- bs].
Proof.
elim: bs=>//[[a w]]bs/=Gi; case:ifP=>_/=; first by rewrite leq_addr.
by rewrite (leq_trans Gi (leq_addl w _)).
Qed.
*)

(***********************************************************)
(**             Correctness properties                    **)
(***********************************************************)

(************************************************************************

1. The contract always has sufficient balance to reimburse everyone,
unless it's successfully finished its campaign:

The "funded" flag is set only if the campaign goals were reached, then
all money goes to owner. Otherwise, the contract keeps all its money
intact.

Perhaps, we should make it stronger, adding a temporal property that
one's reimbursement doesn't change.

************************************************************************)

Definition notfunded : pred :=
  fun w => funded (state (st w)) = false.
Definition balance_sufficient s :=
  sumn (map snd (backers (state (st s)))) <= balance (st s).

Lemma temporal_balance_backed :
    init_world |= AG (notfunded --> balance_sufficient).
Proof.
  rewrite /satisfies/AllBox=>gp H_first n/=.
  rewrite /satisfies/Impl.
  case: gp H_first=>p r/= H0.
  elim: n=>[|n Hi].
  - by rewrite H0/satisfies; right. (* Hurray! *)
  move: (r n); case: Hi=>H Ri;
  rewrite /reachability in Ri; rewrite -Ri.
  - remember (step_world prot (p n)) as w. clear Ri.
    move: Heqw H.
    case: (p n)=>inFlight st b out/=.
    case: st=>id bal st/=.
    case: inFlight=>val from to tg body/=?; subst w=>/=.
    rewrite/step_world/=.
    case: ifP=>[/eqP Zi|_]/=.
    + subst tg=>/=; left; rewrite /donate_fun/=.
      case:ifP=>_/=.
      by rewrite /satisfies/=/notfunded/= in H *.

    (* NOW we have a real mess. *)
    (* How to get a clean case distinction on the three transitions? *)
Abort.

(* Ilya's proof for non-temporal model:
apply: safe_ind=>[|[id bal s]bc m M Hi]//.
rewrite crowd_tags !inE in M.
(* Get the exact transitions and start struggling... *)
rewrite /= /apply_prot; case/orP: M; [|case/orP]=>/eqP M; rewrite M/=.

(* Donate transition *)
rewrite /donate_fun M eqxx.
case: ifP=>/=_; [move/Hi=>{Hi}Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>/=_; move/Hi=>{Hi}Hi; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
by rewrite subn0 /balance_backed/= in Hi *; rewrite addnC leq_add2r.

(* Get funds transition. *)
rewrite /getfunds_fun M eqxx.
case: ifP=>//=_; case:ifP=>//=_;[|move/Hi=>{Hi}Hi]; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=_; move/Hi=>{Hi}Hi.
by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).

(* Claim funds back *)
rewrite /claim_fun M eqxx.
case: ifP=>//=_; [move/Hi=>{Hi}Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=X.
- case/orP: X; first by rewrite /balance_backed/==>->.
  by move=>_/Hi Z; rewrite subn0; apply: (leq_trans Z (leq_addr (val m) bal)).
case: ifP=>//=G/=; move/Hi=>/={Hi}Hi.
rewrite addnC.
have H1: nth 0 [seq i.2 | i <- backers s]
             (seq.find [pred e | e.1 == sender m] (backers s)) <=
         sumn [seq i.2 | i <- backers s] by apply: find_leq.
move: (leq_trans H1 Hi)=> H2.
rewrite -(addnBA _ H2); clear H2.
suff H3: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         bal - nth 0 [seq i.2 | i <- backers s]
                   (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H3 (leq_addl (val m) _ )).
clear M.
suff H2: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         sumn [seq i.2 | i <- backers s] -
         nth 0 [seq i.2 | i <- backers s] (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H2); apply: leq_sub.
clear Hi H1 X G bc bal id crowd_addr init_goal init_max_block init_owner.
move: (backers s)=>bs{s}.
elim:bs=>//[[a v]] bs/= Hi/=; case:ifP; last first.
- move/negbT; case: ifP=>//= _ _; rewrite addnC -addnBA//subnn addn0.
  clear Hi; elim: bs=>//={a v}[[a v]]bs/=.
  case:ifP=>//=_ H; first by rewrite leq_add2l.
  by rewrite (leq_trans H (leq_addl _ _)).
move/negbTE=>->/={a}; rewrite -(leq_add2l v) in Hi.
by rewrite addnBA in Hi; last by apply: find_leq.
Qed. *)

(***********************************************************************)
(******           Proving temporal properties                     ******)
(***********************************************************************)

(* Contribution of backer b is d is recorded in the `backers` *)
Definition donated b (d : value) st :=
  (filter [pred e | e.1 == b] (backers (state st))) == [:: (b, d)].

(* b doesn't claim its funding back *)
Definition no_claims_from b (q : bstate * message) := sender q.2 != b.

(************************************************************************

2. The following lemma shows that the donation record is going to be
preserved by the protocol since the moment it's been contributed, as
long, as no messages from the corresponding backer b is sent to the
contract. This guarantees that the contract doesn't "drop" the record
about someone's donations.

In conjunctions with sufficient_funds_safe (proved above) this
guarantees that, if the campaign isn't funded, there is always a
necessary amount on the balance to reimburse each backer, in the case
of failure of the campaign.

************************************************************************)
(*
Lemma donation_preserved (b : address) (d : value):
  since_as_long crowd_prot (donated b d)
                (fun _ s' => donated b d s') (no_claims_from b).
Proof.
(* This is where we would need a temporal logic, but, well.. *)
(* Let's prove it out of the definition. *)
elim=>[|[bc m] sc Hi]st st' P R; first by rewrite /reachable'=>/=Z; subst st'.
rewrite /reachable'/==>E.
apply: (Hi (post (step_prot crowd_prot st bc m))); last 2 first; clear Hi.
- by move=>q; move:(R q)=>{R}R G; apply: R; apply/In_cons; right.
- rewrite E; set st1 := (step_prot crowd_prot st bc m); clear E R P.
  by case: sc st1=>//=[[bc' m']] sc st1/=.
clear E.
have N: sender m != b.
- suff B: no_claims_from b (bc, m) by [].
  by apply: R; apply/In_cons; left.
case M: (method m \in tags crowd_prot); last first.
- by move/negbT: M=>M; rewrite (bad_tag_step bc st M).
case: st P=>id a s; rewrite /donated/==>D.
case/orP: M; [|case/orP;[| rewrite orbC]]=>/eqP T;
rewrite /apply_prot T/=.
- rewrite /donate_fun T/=; case: ifP=>//_; case: ifP=>//_/=.
  by move/negbTE: N=>->.
- by rewrite /getfunds_fun T/=; case: ifP=>//_; case: ifP=>//_; case:ifP.
rewrite /claim_fun T/=; case:ifP=>//_; case: ifP=>//_; case: ifP=>//=X.
rewrite -filter_predI/=; move/eqP:D=><-; apply/eqP.
elim: (backers s)=>//=x xs Hi; rewrite Hi; clear Hi.
case B: (x.1 == b)=>//=.
by move/eqP: B=>?; subst b; move/negbTE: N; rewrite eq_sym=>/negbT=>->.
Qed. *)

(************************************************************************

3. The final property: if the campaign has failed (goal hasn't been
reached and the deadline has passed), every registered backer can get
its donation back.

TODO: formulate and prove it.

************************************************************************)
(*
Lemma can_claim_back b d st bc:
  (* We have donated, so the contract holds that state *)
  donated b d st ->
  (* Not funded *)
  ~~(funded (state st)) ->
  (* Balance is small: not reached the goal *)
  balance st < (get_goal (state st)) ->
  (* Block number exceeds the set number *)
  get_max_block (state st) < block_num bc ->
  (* Can emit message from b *)
  exists (m : message),
    sender m == b /\
    out (step_prot crowd_prot st bc m) = Some (Msg d crowd_addr b 0 ok_msg).
Proof.
move=>D Nf Nb Nm.
exists (Msg 0 b crowd_addr claim_tag [::]); split=>//.
rewrite /step_prot.
case: st D Nf Nb Nm =>id bal s/= D Nf Nb Nm.
rewrite /apply_prot/=/claim_fun/=leqNgt Nm/= leqNgt Nb/=.
rewrite /donated/= in D.
move/negbTE: Nf=>->/=; rewrite -(has_find [pred e | e.1 == b]) has_filter.
move/eqP: D=>D; rewrite D/=.
congr (Some _); congr (Msg _ _ _ _ _).
elim: (backers s) D=>//[[a w]]bs/=; case:ifP; first by move/eqP=>->{a}/=_; case.
by move=>X Hi H; move/Hi: H=><-.
Qed.
*)

(************************************************************************

4. Can we have a logic that allows to express all these properties
declaratively? Perhaps, we could do it in TLA?

(This is going to be our future work.)

************************************************************************)

End Crowdfunding.


Require Export Structure.

Section Dual.
Universe U.

Section CoTop.
Context (C: BotCategory: Type@{U}).

Definition CoTop_mixin: TopCategory.mixin_of (co C) :=
  TopCategory.Mixin (co C) 0 (@from_zero C) (@from_zero_unique C).

Canonical CoTop: TopCategory: Type@{U} :=
  TopCategory.Pack (co C) CoTop_mixin.
End CoTop.

Section CoBot.
Context (C: TopCategory: Type@{U}).

Definition CoBot_mixin: BotCategory.mixin_of (co C) :=
  BotCategory.Mixin (co C) 1 (@to_one C) (@to_one_unique C).

Canonical CoBot: BotCategory: Type@{U} :=
  BotCategory.Pack (co C) CoBot_mixin.
End CoBot.

Section CoProd.
Context (C: CoprodCategory: Type@{U}).

Program Definition CoProd_mixin: ProdCategory.mixin_of (co C) :=
  ProdCategory.Mixin (co C) coprod (fun a b c => @merge C b c a) (@in1 C) (@in2 C) (fun a b c f g h => @merge_in C b c a f g h).

Canonical CoProd: ProdCategory: Type@{U} :=
  ProdCategory.Pack (co C) CoProd_mixin.
End CoProd.

Section CoCoprod.
Context (C: ProdCategory: Type@{U}).

Program Definition CoCoprod_mixin: CoprodCategory.mixin_of (co C) :=
  CoprodCategory.Mixin (co C) prod (fun a b c => @fork C c a b) (@π₁ C) (@π₂ C) (fun a b c f g h => @fork_pi C c a b f g h).

Canonical CoCoprod: CoprodCategory: Type@{U} :=
  CoprodCategory.Pack (co C) CoCoprod_mixin.
End CoCoprod.

Section TopCo.
Context (C: Category: Type@{U}) (m: BotCategory.mixin_of (co C): Type@{U}).
Let C' := BotCategory.Pack (co C) m.

Definition TopCo_mixin: TopCategory.mixin_of C :=
  TopCategory.Mixin C (0: C') (@from_zero C') (@from_zero_unique C').

Definition TopCo: TopCategory: Type@{U} :=
  TopCategory.Pack C TopCo_mixin.
End TopCo.

Section BotCo.
Context (C: Category: Type@{U}) (m: TopCategory.mixin_of (co C): Type@{U}).
Let C' := TopCategory.Pack (co C) m.

Definition BotCo_mixin: BotCategory.mixin_of C :=
  BotCategory.Mixin C (1: C') (@to_one C') (@to_one_unique C').

Definition BotCo: BotCategory: Type@{U} :=
  BotCategory.Pack C BotCo_mixin.
End BotCo.

Section ProdCo.
Context (C: Category: Type@{U}) (m: CoprodCategory.mixin_of (co C): Type@{U}).
Let C' := CoprodCategory.Pack (co C) m.

Program Definition ProdCo_mixin: ProdCategory.mixin_of C :=
  ProdCategory.Mixin C (@coprod C') (fun a b c => @merge C' b c a) (@in1 C') (@in2 C') (fun a b c f g h => @merge_in C' b c a f g h).

Definition ProdCo: ProdCategory: Type@{U} :=
  ProdCategory.Pack C ProdCo_mixin.
End ProdCo.

Section CoprodCo.
Context (C: Category: Type@{U}) (m: ProdCategory.mixin_of (co C): Type@{U}).
Let C' := ProdCategory.Pack (co C) m.

Program Definition CoprodCo_mixin: CoprodCategory.mixin_of C :=
  CoprodCategory.Mixin C (@prod C') (fun a b c => @fork C' c a b) (@π₁ C') (@π₂ C') (fun a b c f g h => @fork_pi C' c a b f g h).

Definition CoprodCo: CoprodCategory: Type@{U} :=
  CoprodCategory.Pack C CoprodCo_mixin.
End CoprodCo.

End Dual.


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

Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.micromega.Lia.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.BitArithmeticProperties.
Require Import Cava.Util.Byte.
Require Import Cava.Util.If.
Require Import Cava.Util.List.
Require Import Cava.Util.Nat.
Require Import Cava.Util.Tactics.
Require Import Cava.Types.
Require Import Cava.Expr.
Require Import Cava.ExprProperties.
Require Import Cava.Invariant.
Require Import Cava.Primitives.
Require Import Cava.Semantics.
Require Import HmacSpec.SHA256Properties.
Require Import HmacHardware.Sha256.
Require HmacSpec.SHA256.
Import ListNotations.

Require Import coqutil.Tactics.autoforward.
Ltac autoforward_in db H ::=
  let tmp := fresh H in
  rename H into tmp;
  let A := type of tmp in
  pose proof ((ltac:(typeclasses eauto with db) : autoforward A _) tmp) as H;
  (* Recently, this `move` was added in coqutil, which breaks this proof script,
     because through destruct_one_match_hyp, it depends on the hypotheses order,
     and the most straightforward way to fix the broken proofs requires too
     much memory to work on CI *)
  (* move H after tmp; *)
  clear tmp.

Lemma step_rotr n (x : denote_type sha_word) :
  step (rotr n) tt (x,tt) = (tt, SHA256.ROTR (N.of_nat n) x).
Proof.
  cbv [rotr]. stepsimpl.
  cbv [SHA256.ROTR SHA256.truncating_shiftl SHA256.w].
  repeat (f_equal; try lia).
Qed.
Hint Rewrite @step_rotr using solve [eauto] : stepsimpl.

Lemma step_sha256_compress
      (H : denote_type sha_digest)
      (k w : denote_type sha_word) (t : nat) (W : list N) :
  k = nth t SHA256.K 0%N ->
  w = nth t W 0%N ->
  step sha256_compress tt (H,(k,(w,tt)))
  = (tt, SHA256.sha256_compress W (List.resize 0%N 8 H) t).
Proof.
  intros. rewrite resize_map_nth. cbn [List.map seq].
  subst. cbv [sha256_compress]. stepsimpl.
  autorewrite with push_nth. reflexivity.
Qed.
Hint Rewrite @step_sha256_compress using solve [eauto] : stepsimpl.

Lemma step_sha256_message_schedule_update
      (w0 w1 w9 w14 : denote_type sha_word) (t i : nat) msg :
  w0 = nth (t-16) (SHA256Alt.W msg i) 0%N ->
  w1 = nth (t-15) (SHA256Alt.W msg i) 0%N ->
  w9 = nth (t-7) (SHA256Alt.W msg i) 0%N ->
  w14 = nth (t-2) (SHA256Alt.W msg i) 0%N ->
  (16 <= t < 64) ->
  step sha256_message_schedule_update tt (w0, (w1, (w9, (w14, tt))))
  = (tt, nth t (SHA256Alt.W msg i) 0%N).
Proof.
  intros. cbv [sha256_message_schedule_update]. stepsimpl.
  rewrite nth_W_alt by lia. destruct_one_match; [ lia | ].
  repeat match goal with H : _ = nth ?n _ _ |- _ =>
                         rewrite <-H end.
  cbv [SHA256.add_mod SHA256.w]. apply f_equal.
  cbv [SHA256.sigma1 SHA256.sigma0 SHA256.SHR].
  cbv [N.of_nat Pos.of_succ_nat Pos.succ]. clear.
  (* fully compute moduli *)
  repeat match goal with |- context [(_ mod ?m)%N] =>
                         progress compute_expr m end.
  (* convert to Z, solve with Z.div_mod_to_equations *)
  zify.
  repeat rewrite Z.rem_mod_nonneg; Z.div_mod_to_equations; lia.
Qed.
Hint Rewrite @step_sha256_message_schedule_update using solve [eauto] : stepsimpl.

Lemma step_sha256_round_constants (round : denote_type sha_round) :
  step sha256_round_constants tt (round, tt)
  = (tt, nth (N.to_nat round) SHA256.K 0%N).
Proof. reflexivity. Qed.
Hint Rewrite @step_sha256_round_constants using solve [eauto] : stepsimpl.

(* High-level representation for sha256_inner:
   msg : message seen so far (padded)
   i : block index
   t : round number (compression loop)
   inner_done : whether the computation for the current block is complete
   cleared : boolean indicating whether the circuit has been cleared
 *)
Instance sha256_inner_invariant
  : invariant_for sha256_inner (list N * nat * nat * bool * bool) :=
  fun (state : denote_type (sha_digest ** sha_block ** Bit ** sha_round))
    repr =>
    let '(current_digest, (message_schedule, (done, round))) := state in
    let '(msg, i, t, inner_done, cleared) := repr in
    (* inner_done matches the [done] bit *)
    inner_done = done
    (* ...and if we've been cleared, then we're in the reset state *)
    /\ (if cleared
       then current_digest = SHA256.H0
            /\ done = true
            /\ t = 0
            /\ i = 0
            /\ msg = []
       else
         (* ...if we're not cleared, the current digest is the expected digest *)
         let initial_digest :=
             fold_left (SHA256Alt.sha256_step msg) (seq 0 i) SHA256.H0 in
         current_digest = fold_left (SHA256.sha256_compress (SHA256Alt.W msg i))
                                    (seq 0 t) initial_digest
         (* ...and the message has (S i) blocks (1 block = 16 words) *)
         /\ S i * 16 = length msg
      )
    /\ if done
      then if cleared then t = 0 else t = 64
      else
        (* the round is < 64 *)
        (round < 64)%N
        (* ...and inner_round matches [round] *)
        /\ t = N.to_nat round
        (* ...and the message schedule is the expected slice of the message *)
        /\ message_schedule = List.slice 0%N (SHA256Alt.W msg i) (t - 15) 16.

Instance sha256_inner_specification
  : specification_for sha256_inner (list N * nat * nat * bool * bool) :=
  {| reset_repr := ([], 0%nat, 0%nat, true, true);
     update_repr :=
       fun (input : denote_type [Bit; sha_block; sha_digest; Bit])
         repr =>
         let '(block_valid, (block, (initial_digest, (clear,_)))) := input in
         let '(msg, i, t, inner_done, cleared) := repr in
         let updated_msg := msg ++ block in
         if clear
         then ([], 0%nat, 0%nat, true, true)
         else if inner_done
              then if block_valid
                   then if cleared
                        then
                          (* start with i=0 *)
                          (updated_msg, 0, 0, false, false)
                        else
                          (* starting new block *)
                          (updated_msg, S i, 0, false, false)
                   else
                     (* unchanged *)
                     (msg, i, t, inner_done, cleared)
              else (msg, i, S t, t =? 63, false);
     precondition :=
       fun (input : denote_type [Bit; sha_block; sha_digest; Bit])
         repr =>
         let '(block_valid, (block, (initial_digest, (clear,_)))) := input in
         let '(msg, i, t, inner_done, cleared) := repr in
         if block_valid
         then
           let new_i := if cleared then 0 else S i in
           (* a valid block is passed only if we're not busy *)
           inner_done = true
           (* ...and the initial digest is the digest up to (the new value of) i *)
           /\ initial_digest = fold_left (SHA256Alt.sha256_step (msg ++ block))
                                        (seq 0 new_i) SHA256.H0
           (* and the length of the block is 16 *)
           /\ length block = 16
         else
           if inner_done
           then True (* no requirements; stay in the done state until block is valid *)
           else
             (* the initial digest is the digest up to i *)
             initial_digest = fold_left (SHA256Alt.sha256_step msg)
                                        (seq 0 i) SHA256.H0;
     postcondition :=
       fun (input : denote_type [Bit; sha_block; sha_digest; Bit])
         repr (output : denote_type (sha_digest ** Bit)) =>
         let '(block_valid, (block, (initial_digest, (clear,_)))) := input in
         let '(msg, i, t, inner_done, cleared) := repr in
         let new_done := if clear
                         then true
                         else if block_valid
                              then false
                              else if inner_done
                                   then true
                                   else t =? 63 in
         exists output_value : denote_type sha_digest,
           output = (output_value, new_done)
           /\ (* the output value is only meaningful in the case when we're done and not
                cleared *)
           (if cleared
            then True (* no guarantees *)
            else if clear
                 then True (* no guarantees *)
                 else if new_done
                      then
                        (* if the initial digest is correct, the output value
                           matches the expected digest *)
                        initial_digest = fold_left (SHA256Alt.sha256_step msg) (seq 0 i) SHA256.H0 ->
                        output_value = fold_left (SHA256Alt.sha256_step msg) (seq 0 (S i)) SHA256.H0
                      else True (* no guarantees *))
  |}.

Lemma sha256_inner_invariant_at_reset : invariant_at_reset sha256_inner.
Proof.
  simplify_invariant sha256_inner. repeat split.
Qed.

Local Hint Unfold sha256_inner_state : stepsimpl.

Lemma sha256_inner_invariant_preserved : invariant_preserved sha256_inner.
Proof.
  simplify_invariant sha256_inner. cbn [absorb_any].
  simplify_spec sha256_inner.
  intros (block_valid, (block, (initial_digest, (clear, [])))).
  intros (current_digest, (message_schedule, (done, round))).
  intros ((((msg, i), t), inner_done), cleared).
  intros; logical_simplify; subst.
  cbv [sha256_inner K]. cbn [negb]. stepsimpl.
  repeat (destruct_pair_let; cbn [fst snd]).
  autorewrite with tuple_if; cbn [fst snd].
  (* destruct cases for [clear] *)
  destruct clear; logical_simplify; [ tauto | ].
  (* destruct cases for [block_valid] *)
  destruct block_valid; logical_simplify; subst;
    [ destruct cleared; logical_simplify; subst;
      pull_snoc; natsimpl; push_length;
      rewrite ?slice0_W_alt by length_hammer;
      ssplit; (lia || reflexivity) | ].
  (* destruct cases for [done] *)
  destruct done; logical_simplify; subst; boolsimpl;
    [ ssplit; auto; tauto | ].
  (* destruct cases for [cleared] *)
  destruct cleared; logical_simplify; subst; boolsimpl;
    [ destr (round =? 63)%N;
      ssplit; repeat destruct_one_match; lia | ].
  destr (N.to_nat round =? 63);
    (destr (round =? 63)%N; try lia; [ ]); subst;
      [ ssplit; lazymatch goal with
                | |- context [sha256_compress] => idtac
                | |- _ => lia
                end;
      (* handle case involving last compression step *)
      subst; destruct_one_match; try lia; [ ];
      erewrite step_sha256_compress with (t:=63)
      by (push_resize; push_nth; reflexivity);
      cbn [fst snd]; push_resize;
      rewrite seq_snoc with (len:=63); rewrite fold_left_app;
      reflexivity | ].

  (* For remaining cases, the new [done] is always 0 *)
  cbn [N.lor N.eqb].
  (* destruct case statements *)
  repeat first [ discriminate
               | lia
               | destruct_one_match_hyp
               | destruct_one_match ].
  all:try (rewrite (N.mod_small _ (2 ^ N.of_nat 7))
            by (change (2 ^ N.of_nat 7)%N with 128%N; lia)).
  all:push_resize; push_nth.
  all:repeat match goal with
             | |- context [(?x <? ?y)] =>
               destr (x <? y); try lia; [ ]
             | |- context [(?x =? ?y)] =>
               destr (x =? y); try lia; [ ]
             end.
  all:natsimpl.
  all:ssplit;
    lazymatch goal with
    | |- ?x = ?x => reflexivity
    | |- (_ < _)%N => lia
    | |- @eq nat _ _ => length_hammer
    | |- True => tauto
    | _ => idtac
    end.
  (* solve subgoals about compression *)
  all:
    lazymatch goal with
    | |- context [sha256_compress] =>
      erewrite step_sha256_compress with (t:=N.to_nat round) by (f_equal; lia);
        cbn [fst snd]; pull_snoc; rewrite ?resize_noop by (symmetry; length_hammer);
          try reflexivity
    | |- _ => idtac
    end.

  (* remaining subgoals should all be about message schedule: solve those *)
  all:lazymatch goal with
        | |- context [sha256_message_schedule_update] =>
          erewrite step_sha256_message_schedule_update with (t:=(N.to_nat round+1))
            by lazymatch goal with
               | |- nth _ _ _ = nth _ _ _ => f_equal; lia
               | _ => lia
               end; cbn [fst snd];
            lazymatch goal with
            | |- context [List.slice ?d ?ls ?start ?len ++ [nth ?n ?ls ?d]] =>
              replace n with (start + len) by lia
            end; rewrite slice_snoc, tl_slice; f_equal; lia
      end.
Qed.

Lemma sha256_inner_output_correct : output_correct sha256_inner.
Proof.
  simplify_invariant sha256_inner. cbn [absorb_any].
  simplify_spec sha256_inner.
  intros (block_valid, (block, (initial_digest, (clear, [])))).
  intros (current_digest, (message_schedule, (done, round))).
  intros ((((msg, i), t), inner_done), cleared).
  intros. logical_simplify. subst. cbn [fst snd] in *.
  cbv [sha256_inner K]. stepsimpl.
  repeat (destruct_pair_let; cbn [fst snd]).
  autorewrite with tuple_if; cbn [fst snd].
  stepsimpl. push_resize.
  (* some general-purpose simplification *)
  pull_snoc; natsimpl.
  eexists. ssplit; [ | ].
  { apply f_equal2; [ reflexivity | ].
    (* prove that done bit matches spec *)
    boolsimpl. destr clear;[ reflexivity | ].
    destr block_valid; [ reflexivity | ].
    destr done; boolsimpl; [ reflexivity | ].
    logical_simplify; subst.
    destr (N.to_nat round =? 63); destr (round =? 63)%N; lia. }
  (* destruct cases for [cleared] *)
  destruct cleared; logical_simplify; subst; [ tauto | ].
  (* destruct cases for [clear] *)
  destruct clear; logical_simplify; subst; [ tauto | ].
  (* destruct cases for [block_valid] *)
  destruct block_valid; logical_simplify; subst;
    [ push_resize; rewrite ?resize_noop by (symmetry; length_hammer);
      try reflexivity | ].
  (* destruct cases for [done] *)
  destruct done; logical_simplify; subst; boolsimpl;
    [ intros; subst; rewrite !resize_noop by (symmetry; length_hammer);
      reflexivity | ].
  push_resize; push_nth.
  erewrite step_sha256_compress with (t:=N.to_nat round)
    by (repeat destruct_one_match;
        repeat destruct_one_match_hyp; f_equal; lia).
  cbn [fst snd]. push_resize.
  rewrite ?resize_noop by (symmetry; length_hammer).
  destr (N.to_nat round =? 63); destr (round =? 63)%N; try lia; [ ].
  intros; subst. unfold SHA256Alt.sha256_step.
  rewrite seq_snoc with (len:=63); rewrite fold_left_app.
  reflexivity.
Qed.

Existing Instances sha256_inner_invariant_at_reset sha256_inner_invariant_preserved
         sha256_inner_output_correct.
Global Instance sha256_inner_correctness : correctness_for sha256_inner.
Proof. constructor; typeclasses eauto. Defined.


(* Do not edit this file, it was generated automatically *)
(** Heavily annotated for a tutorial introduction. *)

(** First, import the entire Floyd proof automation system, which includes
 ** the VeriC program logic and the MSL theory of separation logic**)
Require Import VST.floyd.proofauto.

(** Import the [reverse.v] file, which is produced by CompCert's clightgen
 ** from reverse.c.   The file reverse.v defines abbreviations for identifiers
 ** (variable names, etc.) of the C program, such as _head, _reverse.
 ** It also defines "prog", which is the entire abstract syntax tree
 ** of the C program *)
Require Import VST.progs64.reverse.

(* The C programming language has a special namespace for struct
** and union identifiers, e.g., "struct foo {...}".  Some type-based operators
** in the program logic need access to an interpretation of this namespace,
** i.e., the meaning of each struct-identifier such as "foo".  The next
** line (which looks identical for any program) builds this
** interpretation, called "CompSpecs" *)
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.

(** Calculate the "types-of-global-variables" specification
 ** directly from the program *)
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** A convenience definition *)
Definition t_struct_list := Tstruct _list noattr.

(** Inductive definition of linked lists *)
Fixpoint listrep (sigma: list val) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (h,y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

(** Whenever you define a new spatial operator, such as
 ** [listrep] here, it's useful to populate two hint databases.
 ** The [saturate_local] hint is a lemma that extracts
 ** pure propositional facts from a spatial fact.
 ** The [valid_pointer] hint is a lemma that extracts a
 ** valid-pointer fact from a spatial lemma.
 **)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

(** Specification of the [reverse] function.  It characterizes
 ** the precondition required for calling the function,
 ** and the postcondition guaranteed by the function.
 **)
Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list val, p: val
  PRE  [ tptr t_struct_list ]
     PROP ()
     PARAMS (p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP () RETURN (q)
     SEP (listrep(rev sigma) q).

(** The global function spec, characterizing the
 ** preconditions/postconditions of all the functions
 ** that your proved-correct program will call.
 ** Normally you include all the functions here, but
 ** in this tutorial example we include only one. *)
Definition Gprog : funspecs :=[ reverse_spec ].

(** For each function definition in the C program, prove that the
 ** function-body (in this case, f_reverse) satisfies its specification
 ** (in this case, reverse_spec).
 **)
Lemma body_reverse: semax_body Vprog Gprog
                                    f_reverse reverse_spec.
Proof.
(** The start_function tactic "opens up" a semax_body
 ** proof goal into a Hoare triple. *)
start_function.
(** For each assignment statement, "symbolically execute" it
 ** using the forward tactic *)
forward.  (* w = NULL; *)
forward.  (* v = p; *)
(** To prove a while-loop, you must supply a loop invariant,
 ** in this case (EX s1  PROP(...)LOCAL(...)(SEP(...)).  *)
forward_while
   (EX s1: list val, EX s2 : list val,
    EX w: val, EX v: val,
     PROP (sigma = rev s1 ++ s2)
     LOCAL (temp _w w; temp _v v)
     SEP (listrep s1 w; listrep s2 v)).
(** The forward_while tactic leaves four subgoals,
 ** which we mark with * (the Coq "bullet") *)
* (* Prove that precondition implies loop invariant *)
Exists (@nil val) sigma nullval p.
entailer!.
unfold listrep.
entailer!.
* (* Prove that loop invariant implies typechecking of loop condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
destruct s2 as [ | h r].
 - unfold listrep at 2.
   Intros. subst. contradiction.
 - unfold listrep at 2; fold listrep.
   Intros y.
   forward. (* t = v->tail *)
   forward. (* v->tail = w; *)
   forward. (* w = v; *)
   forward. (* v = t; *)
   (* At end of loop body; reestablish invariant *)
   entailer!.
   Exists (h::s1,r,v,y).
   entailer!.
   + simpl. rewrite app_ass. auto.
   + unfold listrep at 3; fold listrep.
     Exists w. entailer!.
* (* after the loop *)
forward.  (* return w; *)
Exists w; entailer!.
rewrite (proj1 H1) by auto.
unfold listrep at 2; fold listrep.
entailer!.
rewrite <- app_nil_end, rev_involutive.
auto.
Qed.

(** See the file [progs/verif_reverse.v] for an alternate
 ** proof of this function, using a general theory of
 ** list segments.  That file also has proofs of the
 ** sumlist function, the main function, and the
 ** [semax_func] theorem that ties all the functions together
 **)


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                    Category ONE                  		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export ONE.
Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

(* !C : C -> One *)

Section Fun_One.

Variable C : Category.

Definition FunOne_ob (a : C) := Obone.

 Section funone_map_def.

 Variable a b : C.

 Definition FunOne_mor (f : a --> b) : FunOne_ob a --> FunOne_ob b :=
   Id_Obone.

 Lemma FunOne_map_law : Map_law FunOne_mor.
 Proof.
 unfold Map_law, FunOne_mor in |- *.
 intros; apply Refl.
 Qed.

 Canonical Structure FunOne_map := Build_Map FunOne_map_law.

 End funone_map_def.

Lemma FunOne_comp_law : Fcomp_law FunOne_map.
Proof.
unfold Fcomp_law in |- *; simpl in |- *.
unfold Equal_One_mor in |- *; auto.
Qed.

Lemma FunOne_id_law : Fid_law FunOne_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
unfold Equal_One_mor in |- *; auto.
Qed.

Canonical Structure FunOne := Build_Functor FunOne_comp_law FunOne_id_law.

End Fun_One.