(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** Blocks: Blocks are given by headers and deltas.
    We define types of block chains and block header chains.
    We leave the reward function, how 'hits' are checked and how targets are calculated as parameters.
    The block contains a ctree corresponding to sufficient information about the previous ledger
    to process the block (ctree_of_Block) obtained by grafting the information in the block delta
    to the information in the block header. All the transactions in the block (including the
    coinstake in the header) can be combined to give one large transaction (tx_of_Block).
    If the block is valid (valid_Block), then the combined transaction will be valid and supported.
    If we start from a valid genesis ledger and a block chain is built from valid blocks (valid_BlockChain),
    then we are guaranteed that the ending ledger is also valid (lastledgerroot_valid).
    Furthermore, we know precisely how many currency units are in the ledger as of
    a certain block height (lastledgerroot_sum_correct).
 **)

Require Export CTreeGrafting.

(*** Idea: keep up with how fast the past N blocks and use this to determine the current target. I'll use 6 blocks just as a concrete option here. ***)
Definition targetinfo : Type := prod nat (list nat).
Definition nexttargetinfo (ti : targetinfo) (tm : nat) : targetinfo :=
match ti with
| (prevtm,nil) => (tm,(tm - prevtm)::nil)
| (prevtm,c1::nil) => (tm,c1::(tm - prevtm)::nil)
| (prevtm,c2::c1::nil) => (tm,c2::c1::(tm - prevtm)::nil)
| (prevtm,c3::c2::c1::nil) => (tm,c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c4::c3::c2::c1::nil) => (tm,c4::c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c5::c4::c3::c2::c1::nil) => (tm,c5::c4::c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c6::c5::c4::c3::c2::c1::_) => (tm,c5::c4::c3::c2::c1::(tm - prevtm)::nil)
end.

Definition hashtargetinfo (ti:targetinfo) : hashval :=
let (n,ml) := ti in
hashpair (hashnat n) (hashlist (map hashnat ml)).

Definition targetinfo_timestamp (ti:targetinfo) : nat := fst ti.

Record BlockHeader : Type :=
  mkBlockHeader
    {
      prevblockhash : option hashval;
      newledgerroot : hashval;
      targetinfohash : hashval;
      timestamp : nat;
      stake : nat;
      stakeaddr : addr;
      stakeassetid : hashval;
      blocksignat : signat;
      prevledger : ctree 160
    }.

Record BlockDelta : Type :=
  mkBlockDelta
    {
      totalfees : nat;
      stakeoutput : list addr_preasset;
      prevledgergraft : cgraft;
      blockdelta_stxl : list sTx
    }.

Definition Block : Type :=
  prod BlockHeader BlockDelta.

Definition coinstake (b:Block) : Tx :=
  let (bh,bd) := b in
  ((stakeaddr bh,stakeassetid bh)::nil,stakeoutput bd).

Definition hitfun : Type  := option hashval -> nat -> nat -> nat -> addr -> Prop.

Definition targetfun : Type := targetinfo -> nat.

Definition hash_BlockHeader (bh:BlockHeader) : hashval :=
hashopair2 (prevblockhash bh) (hashlist (newledgerroot bh::targetinfohash bh::hashnat (timestamp bh)::hashnat (stake bh)::hashaddr (stakeaddr bh)::(stakeassetid bh)::nil)).

(*** A currency asset can be used to stake as long as it will not mature in the next 1000 blocks. (1000 is arbitrary, of course.) ***)
Definition not_close_to_mature : nat := 1000.

(*** The output from staking cannot be spent until 1000 blocks later. Again, 1000 is arbitrary here. ***)
Definition maturation_post_staking : nat := 1000.

Definition valid_BlockHeader (blockheight:nat) (check_hit : hitfun) (targetf : targetfun) (plr:hashval) (ti:targetinfo) (bh:BlockHeader) : Prop :=
  (timestamp bh > targetinfo_timestamp ti /\ hashtargetinfo ti = targetinfohash bh)
  /\
  check_signat (hash_BlockHeader bh) (blocksignat bh) (stakeaddr bh)
  /\
  check_hit (prevblockhash bh) (timestamp bh) (targetf ti) (stake bh) (stakeaddr bh)
  /\
  ctree_hashroot (prevledger bh) = plr
  /\
  (exists al m n,
     ctree_supports_asset (stakeassetid bh,((al,(m,n)),currency (stake bh))) (prevledger bh) (stakeaddr bh)
     /\
     n > blockheight + not_close_to_mature)
.

Fixpoint sTxs_allinputs (stxl : list sTx) : list addr_assetid :=
  match stxl with
    | ((inpl,_),s)::stxr => inpl ++ sTxs_allinputs stxr
    | nil => nil
  end.

Fixpoint sTxs_alloutputs (stxl : list sTx) : list addr_preasset :=
  match stxl with
    | ((_,outpl),s)::stxr => outpl ++ sTxs_alloutputs stxr
    | nil => nil
  end.

Lemma sTxs_allinputs_iff stxl alpha h :
  In (alpha,h) (sTxs_allinputs stxl) <-> exists tx, In_dom tx stxl /\ In (alpha,h) (tx_inputs tx).
induction stxl as [|[[inpl outpl] s] stxr IH]; split.
- simpl. tauto.
- intros [tx [H1 _]]. contradiction H1.
- simpl. intros H1. apply in_app_or in H1. destruct H1 as [H1|H1].
  + exists (inpl,outpl). simpl. tauto.
  + apply IH in H1. destruct H1 as [tx H2]. exists tx. tauto.
- intros [tx [[H1|H1] H2]].
  + simpl. apply in_or_app. left. rewrite H1 in H2. exact H2.
  + simpl. apply in_or_app. right. apply IH. exists tx. tauto.
Qed.

Lemma sTxs_alloutputs_iff stxl alpha u :
  In (alpha,u) (sTxs_alloutputs stxl) <-> exists tx, In_dom tx stxl /\ In (alpha,u) (tx_outputs tx).
induction stxl as [|[[inpl outpl] s] stxr IH]; split.
- simpl. tauto.
- intros [tx [H1 _]]. contradiction H1.
- simpl. intros H1. apply in_app_or in H1. destruct H1 as [H1|H1].
  + exists (inpl,outpl). simpl. tauto.
  + apply IH in H1. destruct H1 as [tx H2]. exists tx. tauto.
- intros [tx [[H1|H1] H2]].
  + simpl. apply in_or_app. left. rewrite H1 in H2. exact H2.
  + simpl. apply in_or_app. right. apply IH. exists tx. tauto.
Qed.

Definition ctree_of_Header (b:Block) : ctree 160 :=
  let (bh,bd) := b in
  prevledger bh.

Definition ctree_of_Block (b:Block) : ctree 160 :=
  let (bh,bd) := b in
  ctree_cgraft (prevledgergraft bd) (prevledger bh).

Definition timestamp_of_Block (b:Block) : nat :=
  let (bh,bd) := b in
  timestamp bh.

(*** One Tx combining all the Txs in the block, including the coinstake. ***)
Definition tx_of_Block (b:Block) : Tx :=
  let (bh,bd) := b in
  ((stakeaddr bh,stakeassetid bh)::sTxs_allinputs (blockdelta_stxl bd),stakeoutput bd ++ sTxs_alloutputs (blockdelta_stxl bd)).

Definition valid_Block (blockheight:nat) (rew:nat) (check_hit : hitfun) (targetf : targetfun) plr ti (b:Block) : Prop :=
  let (bh,bd) := b in
  (*** The header is valid. ***)
  valid_BlockHeader blockheight check_hit targetf plr ti bh
  /\
  (*** The asset staked must be one of the outputs. This is especially important if it's been loaned for staking.
        The other stake outputs must explicitly say that they cannot be spent until at least blockheight + maturation_post_staking. ***)
  (exists obl:obligation, exists i:nat,
     ctree_supports_asset (stakeassetid bh,(obl,currency (stake bh))) (prevledger bh) (stakeaddr bh)
     /\
     nth_error (stakeoutput bd) i = value (stakeaddr bh,(obl,currency (stake bh)))
     /\
     (forall alpha al m n u j, j <> i /\ nth_error (stakeoutput bd) j = value (alpha,((al,(m,n)),u)) -> n > blockheight + maturation_post_staking))
  /\
  (*** The addresses of the coinstake output are supported by the grafted ctree. ***)
  ((forall alpha ou, In (alpha,ou) (stakeoutput bd) -> ctree_supports_addr (ctree_of_Block (bh,bd)) alpha)
   /\
   (*** and the total output values match the declared stake and reward and fees ***)
   (asset_value_out (stakeoutput bd) = stake bh + rew + totalfees bd))
  /\
  (*** There are no duplicate transactions. ***)
  no_dups (blockdelta_stxl bd)
  /\
  (*** Each transaction in the delta has supported elaborated assets and has valid signatures. ***)
  (forall tx sl, In (tx,sl) (blockdelta_stxl bd) ->
                 exists einpl:list asset,
                   tx_signatures_valid blockheight einpl (tx,sl)
                   /\
                   (forall beta h, In (beta,h) (tx_inputs tx) -> exists a, In a einpl /\ assetid a = h /\ ctree_supports_asset a (ctree_of_Block (bh,bd)) beta))
  /\
  (*** Each transaction in the delta is valid. ***)
  (forall stx, In stx (blockdelta_stxl bd) -> tx_valid (fst stx))
  /\
  (*** No transaction has the stake asset as an input. ***)
  (forall tx, In_dom tx (blockdelta_stxl bd) -> ~ In (stakeaddr bh,stakeassetid bh) (tx_inputs tx))
  /\
  (*** No distinct transactions try to spend the same asset. ***)
  (forall tx1 sl1 tx2 sl2 alpha h,
     In (tx1,sl1) (blockdelta_stxl bd) ->
     In (tx2,sl2) (blockdelta_stxl bd) ->
     In (alpha,h) (tx_inputs tx1) ->
     In (alpha,h) (tx_inputs tx2) ->
     tx1 = tx2 /\ sl1 = sl2)
  /\
  (*** The cgraft is valid. ***)
  cgraft_valid (prevledgergraft bd)
  /\
  (*** Every transaction is supported by the grafted ctree with 0 reward. ***)
  (forall tx, In_dom tx (blockdelta_stxl bd)
              -> exists fee, ctree_supports_tx tx (ctree_of_Block (bh,bd)) fee 0)
  (*** The total inputs and outputs match up with the declared fee. ***)
  /\
  (exists utot:nat,
     ctree_asset_value_in (ctree_of_Block (bh,bd)) (sTxs_allinputs (blockdelta_stxl bd)) utot
     /\
     asset_value_out (sTxs_alloutputs (blockdelta_stxl bd)) + (totalfees bd) = utot)
  /\
  exists T:ctree 160,
    ctree_hashroot T = newledgerroot bh
    /\ tx_octree_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) = Some T.

Inductive BlockChain : nat -> Type :=
| BlockChainGen : Block -> BlockChain 0
| BlockChainSucc n : BlockChain n -> Block -> BlockChain (S n).

Inductive BlockHeaderChain : nat -> Type :=
| BlockHeaderChainGen : BlockHeader -> BlockHeaderChain 0
| BlockHeaderChainSucc n : BlockHeaderChain n -> BlockHeader -> BlockHeaderChain (S n).

Fixpoint BlockChain_headers {n} (bc : BlockChain n) : BlockHeaderChain n :=
match bc with
| BlockChainGen (bh,_) => BlockHeaderChainGen bh
| BlockChainSucc n bc (bh,_) => BlockHeaderChainSucc n (BlockChain_headers bc) bh
end.

Definition lastledgerroot_of_BlockChain {n} (bc:BlockChain n) : hashval :=
match bc with
| BlockChainGen (bh,_) => newledgerroot bh
| BlockChainSucc n bc (bh,_) => newledgerroot bh
end.

Definition lastledgerroot_of_BlockHeaderChain {n} (bc:BlockHeaderChain n) : hashval :=
match bc with
| BlockHeaderChainGen bh => newledgerroot bh
| BlockHeaderChainSucc n bc bh => newledgerroot bh
end.

Fixpoint valid_BlockChain (rewfn:nat -> nat) (check_hit:hitfun) (targetf:targetfun) genlr genti ti {n} (bc : BlockChain n) : Prop :=
match bc with
| BlockChainGen b => valid_Block 0 (rewfn 0) check_hit targetf genlr genti b /\ ti = nexttargetinfo genti (timestamp_of_Block b)
| BlockChainSucc n bc b => exists ti', valid_BlockChain rewfn check_hit targetf genlr genti ti' bc /\ valid_Block (S n) (rewfn (S n)) check_hit targetf (lastledgerroot_of_BlockChain bc) ti' b /\ ti = nexttargetinfo ti' (timestamp_of_Block b)
end.

Fixpoint valid_BlockHeaderChain (check_hit:hitfun) (targetf:targetfun) genlr genti ti {n} (bc : BlockHeaderChain n) : Prop :=
match bc with
| BlockHeaderChainGen bh => valid_BlockHeader 0 check_hit targetf genlr genti bh /\ ti = nexttargetinfo genti (timestamp bh)
| BlockHeaderChainSucc n bc bh => exists ti', valid_BlockHeaderChain check_hit targetf genlr genti ti' bc /\ valid_BlockHeader (S n) check_hit targetf (lastledgerroot_of_BlockHeaderChain bc) ti' bh /\ ti = nexttargetinfo ti' (timestamp bh)
end.

Lemma tx_of_Block_valid blockheight rew check_hit targetf plr ti (b:Block) :
  valid_Block blockheight rew check_hit targetf plr ti b ->
  tx_valid (tx_of_Block b).
destruct b as [bh bd].
intros HvB. generalize HvB.
intros [[HvBaa [HvBab [HvBac [HvBad [HvBae HvBaf]]]]] [HvBag [HvBah [HvBb [HvBc [HvBd [HvBe [HvBf [HvBg [HvBh [HvBi HvBj]]]]]]]]]]].
split.
- simpl. discriminate.
- simpl. apply no_dups_cons.
  + intros H1. apply sTxs_allinputs_iff in H1.
    destruct H1 as [[inpl outpl] [H2 H3]].
    revert H2 H3. apply HvBe.
  + revert HvBb HvBd HvBf. unfold sTxs_allinputs. generalize (blockdelta_stxl bd).
    clear.
    (*** This could be made into a reasonable lemma instead of giving a double induction in a subproof. ***)
    induction l as [|[[inpl outpl] sl] txl IH].
    * simpl. intros H0 H1 H2. apply no_dups_nil.
    * { simpl. intros H0 H1 H2. apply no_dups_app.
        - assert (L1: (inpl, outpl, sl) = (inpl, outpl, sl) \/ In (inpl, outpl, sl) txl) by now left.
          destruct (H1 ((inpl,outpl),sl) L1) as [_ H1b].
          exact H1b.
        - apply IH.
          + inversion H0. assumption.
          + intros stx H3. apply H1. now right.
          + intros tx1 sl1 tx2 sl2 alpha h H3 H4. apply H2; now right.
        - revert H0 H2. clear.
          induction txl as [|[[inpl2 outpl2] sl2] txr IH]; intros H0 H2 [alpha h] H3.
          + simpl. tauto.
          + intros H4. apply in_app_or in H4.
            destruct H4 as [H4|H4].
            * inversion H0. apply H5. left.
              assert (L1: (inpl,outpl) = (inpl2,outpl2) /\ sl = sl2).
              { apply (H2 (inpl,outpl) sl (inpl2,outpl2) sl2 alpha h).
                - now left.
                - right. now left.
                - exact H3.
                - exact H4.
              }
              destruct L1 as [L1a L1b].
              rewrite L1a. rewrite L1b.
              reflexivity.
            * { revert H4. apply IH.
                - inversion H0. apply no_dups_cons.
                  + intros H6. apply H4. now right.
                  + inversion H5. assumption.
                - intros tx3 sl3 tx4 sl4 beta k H6 H7. apply H2.
                  + simpl. tauto.
                  + simpl. tauto.
                - exact H3.
              }
      }
Qed.

Lemma tx_of_Block_input_iff alpha h (b : Block) :
  In (alpha,h) (tx_inputs (tx_of_Block b))
  <->
  ((alpha = stakeaddr (fst b) /\ h = stakeassetid (fst b))
   \/
   exists tx sl, In (tx,sl) (blockdelta_stxl (snd b)) /\ In (alpha,h) (tx_inputs tx)).
destruct b as [bh bd]. simpl. split; intros [H1|H1].
- left. inversion H1. tauto.
- right. apply sTxs_allinputs_iff in H1.
  destruct H1 as [tx [H1 H2]]. apply In_In_dom_lem in H1.
  destruct H1 as [sl H1]. exists tx. exists sl. tauto.
- left. destruct H1 as [H2 H3]. congruence.
- right. apply sTxs_allinputs_iff. destruct H1 as [tx [sl [H1 H2]]].
  exists tx. split.
  + revert H1. apply In_In_dom_lem_2.
  + exact H2.
Qed.

Lemma tx_of_Block_output_iff alpha obju (b : Block) :
 In (alpha, obju) (tx_outputs (tx_of_Block b))
 <->
 (In (alpha, obju) (stakeoutput (snd b))
  \/
   exists tx sl, In (tx,sl) (blockdelta_stxl (snd b)) /\ In (alpha,obju) (tx_outputs tx)).
destruct b as [bh bd]. simpl. split; intros H1.
- apply in_app_or in H1. destruct H1 as [H1|H1].
  + now left.
  + right. apply sTxs_alloutputs_iff in H1.
    destruct H1 as [tx [H1 H2]]. apply In_In_dom_lem in H1.
    destruct H1 as [sl H1]. exists tx. exists sl. tauto.
- apply in_or_app. destruct H1 as [H1|H1].
  + now left.
  + right. apply sTxs_alloutputs_iff. destruct H1 as [tx [sl [H1 H2]]].
    exists tx. split.
    * revert H1. apply In_In_dom_lem_2.
    * exact H2.
Qed.

Opaque ctree_supports_addr.

(*** This lemma was pulled out from the main proof to help Coq process the main proof. ***)
Lemma tx_of_Block_supported_lem_1 blockheight rew (bh:BlockHeader) (bd:BlockDelta) utot :
  ctree_valid (ctree_of_Block (bh, bd)) ->
  subqc (prevledger bh) (ctree_of_Block (bh, bd)) ->
  (exists (al : list addr) (m n : nat),
     ctree_supports_asset
       (stakeassetid bh, (al, (m, n), currency (stake bh)))
       (prevledger bh) (stakeaddr bh) /\
     n > blockheight + not_close_to_mature) ->
  asset_value_out (stakeoutput bd) = stake bh + rew + totalfees bd ->
  asset_value_out (sTxs_alloutputs (blockdelta_stxl bd)) + totalfees bd = utot ->
  asset_value_out (tx_outputs (tx_of_Block (bh, bd))) + 0 =
  stake bh + utot + rew.
  intros HT Lsubqc HvBae H5 H3.
  simpl. rewrite asset_value_out_app.
  omega.
Qed.

Theorem tx_of_Block_supported blockheight rew check_hit targetf plr ti (b:Block) :
  ctree_valid (ctree_of_Block b) ->
  valid_Block blockheight rew check_hit targetf plr ti b ->
  ctree_supports_tx (tx_of_Block b) (ctree_of_Block b) 0 rew.
destruct b as [bh bd]. intros HT HvB. generalize HvB.
intros [[HvBaa [HvBab [HvBac [HvBad HvBae]]]] [HvBaf [HvBag [HvBb [HvBc [HvBd [HvBe [HvBf [HvBg [HvBh [HvBi HvBj]]]]]]]]]]].
generalize HvBag. intros [HvBag1 HvBag2].
assert (Lsubqc: subqc (prevledger bh) (ctree_of_Block (bh,bd))).
{ unfold ctree_of_Block. apply ctree_cgraft_subqc. exact HvBg. }
split.
- intros alpha obju H1.
  apply tx_of_Block_output_iff in H1.
  destruct H1 as [H1|[tx' [sl' [H2 H3]]]].
  + exact (HvBag1 alpha obju H1).
  + apply In_In_dom_lem_2 in H2.
    destruct (HvBh tx' H2) as [fee [H2a _]].
    revert H3. apply H2a.
- destruct HvBi as [utot [H2 H3]].
  exists (stake bh + utot).
  split.
  + change (ctree_asset_value_in (ctree_of_Block (bh, bd))
                                 ((stakeaddr bh, stakeassetid bh)
                                    :: sTxs_allinputs (blockdelta_stxl bd))
                                 (stake bh + utot)).
    destruct HvBae as [al [m [n [H4 H5]]]].
    apply ctree_asset_value_in_cons with (a := (stakeassetid bh,((al,(m,n)),currency (stake bh)))).
    * exact H2.
    * revert H4. apply subqc_supports_asset. exact Lsubqc.
    * reflexivity.
    * reflexivity.
  + revert HT Lsubqc HvBae HvBag2 H3.
    apply tx_of_Block_supported_lem_1.
Qed.

Definition ledgerroot_valid (h:hashval) : Prop :=
  ctree_valid (ctreeH 160 h).

Opaque tx_octree_trans.

Lemma ctree_hashroot_ctree_H {n} (h:hashval) :
  ctree_hashroot (ctreeH n h) = h.
destruct n; simpl; reflexivity.
Qed.

Opaque mtree_approx_fun_p.
Opaque ctree_mtree.
Opaque tx_of_Block.
Opaque mtree_hashroot.
Opaque ctree_hashroot.
Opaque ctree_cgraft.
Opaque cgraft_assoc.
Opaque subqm.

Lemma endledgerroot_plr_valid_lem1 lroot (bh:BlockHeader) bd (f:statefun) :
  mtree_approx_fun_p (ctree_mtree (ctreeH 160 lroot)) f ->
  ctree_hashroot (prevledger bh) = lroot ->
  cgraft_valid (prevledgergraft bd) ->
  mtree_approx_fun_p (ctree_mtree (ctree_of_Block (bh, bd))) f.
intros H1 H2 H3.
apply (mtree_hashroot_mtree_approx_fun_p (ctree_mtree (ctreeH 160 lroot))).
- change (mtree_hashroot (ctree_mtree (ctreeH 160 lroot)) =
          mtree_hashroot (ctree_mtree (ctree_of_Block (bh, bd)))).
  rewrite mtree_hashroot_ctree_hashroot.
  rewrite mtree_hashroot_ctree_hashroot.
  rewrite ctree_hashroot_ctree_H.
  unfold ctree_of_Block.
  assert (L1: subqc (prevledger bh) (ctree_cgraft (prevledgergraft bd) (prevledger bh))).
  { exact (ctree_cgraft_subqc (prevledgergraft bd) (prevledger bh) H3). }
  unfold subqc in L1.
  apply subqm_hashroot_eq in L1.
  rewrite mtree_hashroot_ctree_hashroot in L1.
  rewrite mtree_hashroot_ctree_hashroot in L1.
  rewrite H2 in L1.
  exact L1.
- exact H1.
Qed.

Theorem lastledgerroot_valid rewfn check_hit targetf genlr genti ti {n} (bc : BlockChain n) :
  ledgerroot_valid genlr ->
  valid_BlockChain rewfn check_hit targetf genlr genti ti bc ->
  ledgerroot_valid (lastledgerroot_of_BlockChain bc).
intros H1. revert ti. induction bc as [[bh bd]|n bc IH [bh bd]]; intros ti.
- intros H2. generalize H2. intros [[[H2aa [H2ab [H2ac [H2ad H2ae]]]] [H2af [H2ag [H2b [H2c [H2d [H2e [H2f [H2g [H2h [H2i H2j]]]]]]]]]]] Hti].
  assert (LT: ctree_valid (ctree_of_Block (bh,bd))).
  { unfold ctree_of_Block. apply ctree_valid_cgraft_valid.
    - revert H1. unfold ledgerroot_valid. unfold ctree_valid.
      apply mtree_hashroot_eq_valid.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite ctree_hashroot_ctree_H.
      f_equal. exact H2ad.
    - exact H2g.
  }
  destruct H2j as [T [H2ja H2jb]].
  change (ledgerroot_valid (newledgerroot bh)).
  rewrite <- H2ja.
  unfold ledgerroot_valid.
  unfold ctree_valid.
  assert (L1: octree_supports_tx (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) 0 (rewfn 0)).
  { destruct H2 as [H2x H2y].
    exact (tx_of_Block_supported 0 (rewfn 0) check_hit targetf _ _ (bh,bd) LT H2x).
  }
  apply (mtree_hashroot_eq_valid (ctree_mtree T)).
  + rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  + destruct H1 as [f [H1a H1b]].
    assert (LTf: octree_approx_fun_p (Some (ctree_of_Block (bh,bd))) f).
    { exact (endledgerroot_plr_valid_lem1 genlr bh bd f H1b H2ad H2g). }
    exists (tx_statefun_trans (tx_of_Block (bh,bd)) f). split.
    * { apply sf_tx_valid_thm with (fee := 0) (rew := (rewfn 0)).
        - exact H1a.
        - destruct H2 as [H2x H2y]. revert H2x. apply tx_of_Block_valid.
        - assert (L2: mtree_supports_tx (tx_of_Block (bh, bd))
                                        (octree_mtree (Some (ctree_of_Block (bh, bd)))) 0
                                        (rewfn 0)).
          { revert L1. apply octree_mtree_supports_tx. }
          apply mtree_supports_tx_statefun with (f := f) in L2.
          + exact L2.
          + destruct H1a as [_ [Hf2 _]]. exact Hf2.
          + unfold octree_approx_fun_p in LTf.
            exact LTf.
      }
    * { assert (L4: mtree_approx_fun_p (octree_mtree (Some T)) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
        { rewrite <- H2jb.
          set (tx' := (tx_of_Block (bh,bd))).
          set (T' := (ctree_of_Block (bh,bd))).
          assert (L5: octree_approx_fun_p (tx_octree_trans tx' (Some T')) (tx_statefun_trans tx' f)).
          { apply (octree_approx_trans tx' (Some T') f 0 (rewfn 0)).
            - exact H1a.
            - unfold tx'. unfold T'. destruct H2 as [H2x H2y]. revert H2x. apply tx_of_Block_supported.
              exact LT.
            - unfold T'. exact LTf.
          }
          unfold octree_approx_fun_p in L5.
          exact L5.
        }
        unfold octree_mtree in L4.
        exact L4.
      }
- intros [ti' [H3 [H2 Hti]]].
  generalize H2.
  intros [[H2aa [H2ab [H2ac [H2ad H2ae]]]] [H2af [H2ag [H2b [H2c [H2d [H2e [H2f [H2g [H2h [H2i H2j]]]]]]]]]]].
  assert (LT: ctree_valid (ctree_of_Block (bh,bd))).
  { unfold ctree_of_Block. apply ctree_valid_cgraft_valid.
    - generalize (IH ti' H3). unfold ledgerroot_valid. unfold ctree_valid.
      apply mtree_hashroot_eq_valid.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite ctree_hashroot_ctree_H.
      f_equal. exact H2ad.
    - exact H2g.
  }
  destruct H2j as [T [H2ja H2jb]].
  change (ledgerroot_valid (newledgerroot bh)).
  rewrite <- H2ja.
  unfold ledgerroot_valid.
  unfold ctree_valid.
  assert (L1: octree_supports_tx (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) 0 (rewfn (S n))).
  { exact (tx_of_Block_supported (S n) (rewfn (S n)) check_hit targetf _ _ (bh,bd) LT H2). }
  apply (mtree_hashroot_eq_valid (ctree_mtree T)).
  + rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  + destruct (IH ti' H3) as [f [H1a H1b]].
    assert (LTf: octree_approx_fun_p (Some (ctree_of_Block (bh,bd))) f).
    { exact (endledgerroot_plr_valid_lem1 _ bh bd f H1b H2ad H2g). }
    exists (tx_statefun_trans (tx_of_Block (bh,bd)) f). split.
    * { apply sf_tx_valid_thm with (fee := 0) (rew := (rewfn (S n))).
        - exact H1a.
        - revert H2. apply tx_of_Block_valid.
        - assert (L2: mtree_supports_tx (tx_of_Block (bh, bd))
                                        (octree_mtree (Some (ctree_of_Block (bh, bd)))) 0
                                        (rewfn (S n))).
          { revert L1. apply octree_mtree_supports_tx. }
          apply mtree_supports_tx_statefun with (f := f) in L2.
          + exact L2.
          + destruct H1a as [_ [Hf2 _]]. exact Hf2.
          + unfold octree_approx_fun_p in LTf.
            exact LTf.
      }
    * { assert (L4: mtree_approx_fun_p (octree_mtree (Some T)) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
        { rewrite <- H2jb.
          set (tx' := (tx_of_Block (bh,bd))).
          set (T' := (ctree_of_Block (bh,bd))).
          assert (L5: octree_approx_fun_p (tx_octree_trans tx' (Some T')) (tx_statefun_trans tx' f)).
          { apply (octree_approx_trans tx' (Some T') f 0 (rewfn (S n))).
            - exact H1a.
            - unfold tx'. unfold T'. revert H2. apply tx_of_Block_supported.
              exact LT.
            - unfold T'. exact LTf.
          }
          unfold octree_approx_fun_p in L5.
          exact L5.
        }
        unfold octree_mtree in L4.
        exact L4.
      }
Qed.

Fixpoint units_as_of_block (initdistr:nat) (rewfn:nat -> nat) (blockheight:nat) : nat :=
match blockheight with
| O => initdistr
| S n => units_as_of_block initdistr rewfn n + rewfn n
end.

Opaque sf_valid.
Opaque tx_statefun_trans.
Opaque tx_octree_trans.
Opaque mtree_approx_fun_p.

Theorem lastledgerroot_sum_correct initdistr al bl rewfn check_hit targetf genlr genti ti {n}
      (bc : BlockChain n) :
  ledgerroot_valid genlr ->
  octree_totalassets (Some (ctreeH 160 genlr)) al ->
  asset_value_sum al = initdistr ->
  valid_BlockChain rewfn check_hit targetf genlr genti ti bc ->
  octree_totalassets (Some (ctreeH 160 (lastledgerroot_of_BlockChain bc))) bl ->
  asset_value_sum bl = units_as_of_block initdistr rewfn (S n).
intros H1 H2 H3. revert bl ti.
induction bc as [[bh bd]|n bc IH [bh bd]].
- intros bl ti H4 H5.
  simpl. unfold valid_BlockChain in H4.
  generalize H4.
  intros [[[H4aa [H4ab [H4ac [H4ad H4ae]]]] [H4af [H4ag [H4b [H4c [H4d [H4e [H4f [H4g [H4h [H4i [T [HT1 HT2]]]]]]]]]]]]] Hti].
  assert (L0: ctree_hashroot (ctree_of_Block(bh,bd)) = genlr).
  { transitivity (ctree_hashroot (prevledger bh)).
    - unfold ctree_of_Block. symmetry.
      apply subqc_hashroot_eq. apply ctree_cgraft_subqc. exact H4g.
    - exact H4ad.
  }
  assert (L1: octree_valid (Some (ctree_of_Block (bh, bd)))).
  { unfold octree_valid. revert H1. unfold ledgerroot_valid. unfold ctree_valid.
    apply mtree_hashroot_eq_valid.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L2: tx_valid (tx_of_Block (bh, bd))).
  { destruct H4 as [H4x H4y]. revert H4x. apply tx_of_Block_valid. }
  assert (L3: octree_supports_tx (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd))) 0 (rewfn 0)).
  { unfold octree_supports_tx.
    destruct H4 as [H4x H4y].
    revert L1 H4x. unfold octree_valid. apply tx_of_Block_supported.
  }
  generalize L1. intros [f [Hf HTf]].
  assert (L4: mtree_approx_fun_p (ctree_mtree (ctreeH 160 genlr)) f).
  { revert HTf. apply mtree_hashroot_mtree_approx_fun_p.
    rewrite mtree_hashroot_ctree_hashroot. rewrite L0.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L5: octree_totalassets (Some (ctree_of_Block (bh, bd))) al).
  { unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ HTf).
    revert H2. unfold octree_totalassets. unfold octree_mtree.
    revert L4. clear. apply mtree_approx_fun_p_totalassets.
  }
  assert (L6: octree_approx_fun_p
                (tx_octree_trans (tx_of_Block (bh, bd))
                                 (Some (ctree_of_Block (bh, bd))))
                (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { apply (octree_approx_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) f 0 (rewfn 0) Hf L3).
    unfold octree_approx_fun_p. unfold octree_mtree.
    exact HTf.
  }
  assert (L7: octree_approx_fun_p (Some T) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { unfold octree_approx_fun_p. rewrite <- HT2.
    exact L6.
  }
  assert (L8: octree_totalassets (tx_octree_trans (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd)))) bl).
  { rewrite HT2.
    unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L7).
    revert H5.
    unfold octree_totalassets. unfold octree_mtree.
    apply mtree_approx_fun_p_totalassets.
    revert L7. unfold octree_approx_fun_p.
    apply mtree_hashroot_mtree_approx_fun_p.
    unfold octree_mtree.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    rewrite HT1. reflexivity.
  }
  generalize (octree_tx_asset_value_sum (Some (ctree_of_Block (bh,bd))) (tx_of_Block (bh,bd)) 0 (rewfn 0) al bl L1 L2 L3 L5 L8).
  rewrite H3.
  assert (L9: asset_value_sum bl + 0 = asset_value_sum bl).
  { clear. omega. }
  rewrite L9. exact (fun H => H).
- intros bl ti [ti' [H4 [H5 Hti]]] H6.
  generalize H5.
  intros [[H5aa [H5ab [H5ac [H5ad H5ae]]]] [H5af [H5ag [H5b [H5c [H5d [H5e [H5f [H5g [H5h [H5i [T [HT1 HT2]]]]]]]]]]]]].
  assert (Lplr: ledgerroot_valid (lastledgerroot_of_BlockChain bc)).
  { revert H1 H4. apply lastledgerroot_valid. }
  generalize Lplr. intros [f [Hf Hplrf]].
  assert (LIH: asset_value_sum (totalassets_ f) = units_as_of_block initdistr rewfn (S n)).
  { apply (IH (totalassets_ f) ti').
    - exact H4.
    - unfold octree_totalassets. unfold octree_mtree.
      apply (mtree_approx_fun_p_totalassets _ _ _ Hplrf).
      reflexivity.
  }
  change (asset_value_sum bl = units_as_of_block initdistr rewfn (S n) + rewfn (S n)).
  rewrite <- LIH.
  assert (L0: ctree_hashroot (ctree_of_Block(bh,bd)) = lastledgerroot_of_BlockChain bc).
  { transitivity (ctree_hashroot (prevledger bh)).
    - unfold ctree_of_Block. symmetry.
      apply subqc_hashroot_eq. apply ctree_cgraft_subqc. exact H5g.
    - exact H5ad.
  }
  assert (L1: octree_valid (Some (ctree_of_Block (bh, bd)))).
  { unfold octree_valid. revert Lplr. unfold ledgerroot_valid. unfold ctree_valid.
    apply mtree_hashroot_eq_valid.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L2: tx_valid (tx_of_Block (bh, bd))).
  { revert H5. apply tx_of_Block_valid. }
  assert (L3: octree_supports_tx (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd))) 0 (rewfn (S n))).
  { unfold octree_supports_tx. revert L1 H5. unfold octree_valid. apply tx_of_Block_supported. }
  assert (L4: mtree_approx_fun_p (ctree_mtree (ctree_of_Block (bh,bd))) f).
  { revert Hplrf. apply mtree_hashroot_mtree_approx_fun_p.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot. rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L5: octree_totalassets (Some (ctree_of_Block (bh, bd))) (totalassets_ f)).
  { unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L4).
    reflexivity.
  }
  assert (L6: octree_approx_fun_p
                (tx_octree_trans (tx_of_Block (bh, bd))
                                 (Some (ctree_of_Block (bh, bd))))
                (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { apply (octree_approx_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) f 0 (rewfn (S n)) Hf L3).
    unfold octree_approx_fun_p. unfold octree_mtree.
    exact L4.
  }
  assert (L7: octree_approx_fun_p (Some T) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { unfold octree_approx_fun_p. rewrite <- HT2.
    exact L6.
  }
  assert (L8: octree_totalassets (tx_octree_trans (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd)))) bl).
  { rewrite HT2.
    unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L7).
    revert H6.
    unfold octree_totalassets. unfold octree_mtree.
    apply mtree_approx_fun_p_totalassets.
    revert L7. unfold octree_approx_fun_p.
    apply mtree_hashroot_mtree_approx_fun_p.
    unfold octree_mtree.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    rewrite HT1. reflexivity.
  }
  generalize (octree_tx_asset_value_sum (Some (ctree_of_Block (bh,bd))) (tx_of_Block (bh,bd)) 0 (rewfn (S n)) (totalassets_ f) bl L1 L2 L3 L5 L8).
  assert (L9: asset_value_sum bl + 0 = asset_value_sum bl).
  { clear. omega. }
  rewrite L9. exact (fun H => H).
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e450m2e225m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(*|
###########################################################
How to add variables introduced by set tactic to a Hint DB?
###########################################################

:Link: https://stackoverflow.com/q/48114995
|*)

(*|
Question
********

I want to use a Hint DB with variables introduced by ``set``. For
example,
|*)

Example foo : forall n : nat, n + n = n + n.
Proof.
  intro.
  set (m := n + n).
Abort. (* .none *)
Fail #[local] Hint Unfold m : core. (* .fails .unfold *)

(*| Is there any way to achieve this, or is it impossible? |*)

(*|
Answer
******

It's not possible to do this like you suggested because after you
finish ``foo`` with ``Qed`` the local variable ``m`` will be out of
scope, but hints go straight into some global database.

However, you can use the ``Section`` mechanism, as the hints declared
inside a section are *local* to that section:
|*)

Section LocalHints.
  Variable n : nat.
  Let m := n + n.
  Hint Unfold m.

  Example bar : m = m.
  Proof.
    autounfold with core.
    reflexivity.
  Qed.
End LocalHints.


Require Import compcert.lib.Coqlib.
Require Import Bvector.
Require Import List.
Require Import compcert.lib.Integers.
Require Import BinNums.
Require Import msl.Axioms.
Require Import fcf.Blist.

Require Import sha.ByteBitRelations.
Require Import sha.hmac_pure_lemmas.
Require Import sha.general_lemmas.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_abstract.
Require Import sha.HMAC_equivalence.

(*SHA256-specific Modules*)
Require Import sha.common_lemmas.
Require Import sha.HMAC256_functional_prog.
Require Import sha.sha_padding_lemmas.
Require Import sha.ShaInstantiation.
Require Import sha.hmac_common_lemmas.
Require Import sha.HMAC256_spec_pad.
Require Import sha.HMAC256_spec_concat.
Require Import sha.HMAC256_spec_list. (*for toBlocks*)

(*
Lemma of_length_proof_irrel {A:Set} n (l: list A) M:
      Vector.to_list (@of_list_length _ n l M) = l.
Proof. destruct M. apply Vector.to_list_of_list_opp. Qed.
*)
(*Section EQUIV.*)
(*Definition h_v (iv:Bvector c) (blk:Bvector b): Bvector c :=
  of_list_length _
   (sha_h_length _ _ (VectorToList_length _ iv) (VectorToList_length _ blk)).

Lemma h_eq : forall (block_v : Bvector b) (block_l : Blist)
               (HVL: block_l = Vector.to_list block_v)
               ivA ivB (IV: ivA = Vector.to_list ivB),
               sha_h ivA block_l = Vector.to_list (h_v ivB block_v).
Proof. intros. unfold h_v, of_list_length.
  destruct (sha_h_length (Vector.to_list ivB) (Vector.to_list block_v)
      (VectorToList_length c ivB) (VectorToList_length b block_v)).
  symmetry. subst. apply Vector.to_list_of_list_opp.
Qed.
*)

Definition iv_v : Bvector c := Vector.of_list sha_iv.

Lemma iv_eq : sha_iv = Vector.to_list iv_v.
Proof. unfold iv_v.
  rewrite <- Vector.to_list_of_list_opp.
  reflexivity.
Qed.
(*
Lemma opad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Opad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition opad_v: Bvector b := of_list_length _ opad_length.

Lemma ipad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Ipad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition ipad_v: Bvector b := of_list_length _ ipad_length.
*)
Lemma fpad_length (v:Bvector c): length (fpad (Vector.to_list v)) = p.
Proof. unfold fpad, fpad_inner. rewrite bytesToBits_len.
  repeat rewrite app_length. rewrite length_list_repeat, length_intlist_to_Zlist.
  rewrite (mult_comm 4), plus_comm, Zlength_correct.
  rewrite bitsToBytes_len_gen with (n:=32%nat).
    reflexivity.
    apply VectorToList_length.
Qed.

Definition fpad_v (v:Bvector c): Bvector p := of_list_length _ (fpad_length v).

Lemma fpad_eq : forall (v : Bvector c) (l : Blist),
                  l = Vector.to_list v ->
                  fpad l = Vector.to_list (fpad_v v).
Proof. intros. unfold fpad_v, of_list_length.
  destruct (fpad_length v).
  rewrite Vector.to_list_of_list_opp.
  subst; reflexivity.
Qed.

Fixpoint splitAndPad_aux (m:list Blist) (M: Forall (fun x => length x = 512%nat) m):
           list (Bvector b) :=
(match m as l return (Forall (fun x => length x = 512%nat) l) -> list (Bvector b) with
  nil => fun F => nil
|  cons h t => fun F => cons (of_list_length h (Forall_inv F))
                    (splitAndPad_aux t (Forall_tl _ _ _ _ F))
 end) M.

Lemma splitAndPad_aux_consD h t M:
      splitAndPad_aux (cons h t) M
      = (of_list_length h (Forall_inv M))
         :: (splitAndPad_aux t (Forall_tl _ _ _ _ M)).
Proof. reflexivity. Qed.

Lemma splitAndPad_aux_nil m M: m=nil -> splitAndPad_aux m M= nil.
Proof. intros; subst. reflexivity. Qed.

Lemma length_splitandpad_inner_aux: forall ssm pf,
  Forall2
  (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
  (splitAndPad_aux (toBlocks ssm) pf)
  (toBlocks ssm).
Proof.
  intros ssm. remember (toBlocks ssm). generalize dependent ssm.
  induction l.
  { simpl; intros. constructor. }
  { intros. rewrite toBlocks_equation in Heql.
    destruct ssm. discriminate.
    remember ( Compare_dec.leb (length (b :: ssm)) 511) as d.
    destruct d. exfalso.
           rewrite Heql in pf. apply Forall_inv in pf.  clear Heql.
           rewrite firstn_length in pf.
           symmetry in Heqd. apply leb_complete in Heqd.
           eapply NPeano.Nat.min_l_iff in pf. omega.
    rewrite splitAndPad_aux_consD.
    constructor.
      rewrite of_length_proof_irrel. trivial.
    eapply (IHl (skipn 512 (b :: ssm))).
      remember (firstn 512 (b :: ssm)) as zz.
      remember (toBlocks (skipn 512 (b :: ssm))) as yy.
      clear - Heql. inversion Heql. trivial. }
Qed.

Definition splitAndPad_v (m: Blist): list (Bvector b).
  apply (splitAndPad_aux (sha_splitandpad_blocks m)).
  apply InBlocks_Forall_512. apply sha_splitandpad_inc_InBlocks.
Defined.

Lemma splitAndPad_nil: exists pf,
  splitAndPad_v nil =
  cons (@of_list_length bool 512 (sha_splitandpad_inc nil) pf) nil.
Proof. unfold splitAndPad_v, sha_splitandpad_blocks.
  remember (InBlocks_Forall_512 _ (sha_splitandpad_inc_InBlocks nil)). clear Heqf.
  remember (toBlocks (sha_splitandpad_inc nil)).
  rewrite toBlocks_equation in Heql.
  remember (sha_splitandpad_inc nil) as m.
  destruct m. exfalso. clear Heql f l.
    unfold sha_splitandpad_inc in Heqm.
    assert (@length bool nil = length (bytesToBits (pad_inc (bitsToBytes nil)))).
      rewrite <- Heqm; trivial.
    simpl in H; clear Heqm. omega.
  rewrite leb_correct_conv in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite sublist.firstn_same in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite skipn_short in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite toBlocks_equation in Heql. subst l.
  simpl. eexists. reflexivity.
Qed.

Lemma length_splitandpad_inner m :
   Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (sha_splitandpad_blocks m).
Proof. apply length_splitandpad_inner_aux. Qed.

Lemma C: NPeano.Nat.divide 8 c.
  exists 32%nat. reflexivity.
Qed.

Module EQ256 <: EQUIV_Inst SHA256.
  Definition c := c.
  Definition C := C.
  Definition p := p.
  Definition b := b.
  Definition B := B.
  Definition BS: (SHA256.BlockSize * 8)%nat = b. reflexivity. Qed.
  Definition h := sha_h.
  Definition h_length := sha_h_length.
(*  Definition h_v := h_v.
  Definition h_eq := h_eq.*)
  Definition ir: list int := SHA256.init_registers.
(*  Definition iv:= sha_iv.*)
  Lemma iv_length: length (HMAC_spec_pad.convert ir) = c.
     apply sha_iv_length. Qed.
  (*Definition iv_length := sha_iv_length.*)
  Definition iv_v: Bvector c := iv_v. (*of_list_length _ iv_length.*)
  Lemma iv_eq: HMAC_spec_pad.convert ir  = Vector.to_list iv_v.
  Proof. reflexivity. Qed.
  (*
  Definition ipd:Z := 54.
  Definition opd:Z:=92.
  Lemma isbyteZ_Ipad: isbyteZ ipd.
    unfold ipd. split; omega. Qed.
  Lemma isbyteZ_Opad: isbyteZ opd.
    unfold opd. split; omega. Qed.*)
  Definition fpad_v := fpad_v.
  Definition fpad := fpad.
  Definition fpad_length msg: length msg = c -> length (fpad msg) = p.
  Proof. apply ShaInstantiation.fpad_length. Qed.
  Definition fpad_eq := fpad_eq.
  Definition splitAndPad := sha_splitandpad.
  Definition splitAndPad_v := splitAndPad_v.
  Definition splitandpad_blocks := sha_splitandpad_blocks.
  Definition sap_fpad:=sha_splitandpad_fpad.
  Definition shasplitandpad_blocks_b:= sha_splitandpad_blocks_512.
  Definition sap' m := concat (splitandpad_blocks m).
  Definition sap_app:forall (l m : Blist),
                         length l = b ->
                         splitAndPad (l ++ m) = l ++ sap' m.
  Proof. intros. rewrite sha_splitandpad_app; trivial.
    f_equal. unfold sap', splitandpad_blocks, sha_splitandpad_blocks.
    rewrite concat_toBlocks_id; trivial.
    apply sha_splitandpad_inc_InBlocks.
  Qed.
  Lemma sap'_InBlocks m: InBlocks b (sap' m).
    apply concat_InBlocks. apply sha_splitandpad_blocks_512. Qed.
  Definition hashblock : list int -> list int -> list int := SHA256.hash_block.
  Lemma HHB : h =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).
    reflexivity. Qed.

  Definition hashblocks: list int -> list int -> list int:= SHA256.hash_blocks.
  Definition d := 16%nat.

  Definition HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end := SHA256.hash_blocks_equation.
  Lemma D: (d * 32)%nat = b. reflexivity. Qed.

  Definition gap:list Z -> list int := SHA256.generate_and_pad.
  Lemma GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
    intros. rewrite <- pad_compose_equal. apply gap_divide16. Qed.

  Lemma sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_Zlist (gap (bitsToBytes bits))).
  Proof. apply extensionality. intros l. unfold splitAndPad, sha_splitandpad.
    f_equal. rewrite <- pad_compose_equal. unfold generate_and_pad'.
    rewrite pure_lemmas.Zlist_to_intlist_to_Zlist. trivial.
    destruct (pad_len_64_nat (bitsToBytes l)). rewrite Zlength_correct, H. exists (Z.of_nat(x*16)). do 2 rewrite Nat2Z.inj_mul. rewrite Z.mul_comm, <- Z.mul_assoc. reflexivity.
    apply pad_isbyteZ. eapply bitsToBytes_isbyteZ. reflexivity.
  Qed.

  Lemma HASH m: SHA256.Hash m = intlist_to_Zlist (hashblocks ir (gap m)).
     unfold SHA256.Hash.
     rewrite functional_prog.SHA_256'_eq; reflexivity.
  Qed.

  Lemma FOLD_HB_eq: forall l ls, length l = (c + p)%nat ->
     Forall (fun x => length x = (c + p)%nat) ls ->
     fold_left h (l :: ls) (Vector.to_list iv_v) =
          hash_blocks_bits (HMAC_spec_concat.HMAC_Concat.b c p) B h
          (Vector.to_list iv_v) (l ++ concat ls).
  Proof. intros.
     assert (SH: sha_iv = Vector.to_list iv_v). rewrite <- iv_eq; trivial.
     rewrite <- SH; apply (fold_hash_blocks_eq _ _ H H0).
  Qed.

  Lemma length_splitandpad_inner m:
    Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (splitandpad_blocks m).
  Proof. apply length_splitandpad_inner. Qed.

End EQ256.

Module EQ := HMAC_Equiv SHA256 EQ256.

(* Note we're comparing to HP.HMAC_SHA256.HmacCore, not HMAC. *)
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.Nat.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC EQ.h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v EQ.opad_v EQ.ipad_v kv m) =
      bytesToBits (HMAC_SHA256.HmacCore (Byte.repr EQ.ipd) (Byte.repr EQ.opd)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  specialize (EQ.Equivalence _ HP kv m); intros.
  unfold EQ.h_v in H.
  unfold EQ256.c, EQ256.p, EQ256.splitAndPad_v in H.
  unfold EQ256.fpad_v in H.
  unfold EQ256.b in H. apply H.
Qed.

(* Earlier explicit proof:
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v opad_v ipad_v kv m) =
      bytesToBits (HP.HMAC_SHA256.HmacCore (Integers.Byte.repr 54) (Integers.Byte.repr 92)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  assert (LK : length (Vector.to_list kv) = b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply fpad_eq.
  2: apply length_splitandpad_inner.
  erewrite HMAC256_spec_list.HMAC_list_concat_sap_instantiated. (*; trivial.*)
SearchAbout sha_splitandpad_inc.
(*sap' to be instantiated to sha_splitandpad_inc*)
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply fold_hash_blocks_eq.
  2: apply LK.
(*  rewrite <- sha_splitandpad_inc_eq.*)
  rewrite <- HMAC256_spec_concat.HMAC_concat_pad_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  eapply HMAC256_spec_pad.HMAC_pad_concrete'.

  split; omega.
  split; omega.

  (* key length *)
  { rewrite map_length, bitsToBytes_len_gen with (n:=64%nat).
    reflexivity.
    rewrite LK; reflexivity. }

  (* key length *)
  { rewrite Zlength_map, bitsToBytes_len. reflexivity. apply LK. }

  (* TODO: maybe replace bytes_bits_lists with bytesToBits? Since bytes_bits_comp_ind
     is used a lot *)

  (* key *)
  { rewrite map_unsigned_Brepr_isbyte.
      apply bytes_bits_comp_ind.
      eapply bitsToBytes_isbyteZ; reflexivity.
      rewrite  bits_bytes_bits_id; trivial.
      apply block_8. assumption.
      eapply bitsToBytes_isbyteZ. reflexivity. }

  (* uses fact that message is in blocks of 8 *)
  { apply bytes_bits_comp_ind.
    eapply bitsToBytes_isbyteZ; reflexivity.
    rewrite bits_bytes_bits_id; trivial.
    apply InBlocks_len.
    apply HP. destruct m. simpl; trivial. }

  (* opad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Opad. omega.
    apply of_length_proof_irrel. }

  (* ipad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Ipad. omega.
    apply of_length_proof_irrel. }

Qed.
End EQUIV. *)


Inductive t :=
| C0 : t
| C1 : bool -> t
| C2 : t -> nat -> t
.


(* The input for this one is assumed to be sorted (e.g., using
   the [sort] command). *)

Set Warnings "-extraction-opaque-accessed".

From Coq Require Import
     List Arith NArith ZArith Ascii String
     OrderedTypeEx FSetAVL FMapAVL
     extraction.ExtrOcamlIntConv
     Lia.
Import ListNotations.

From SimpleIO Require SimpleIO.

From ExtLib Require Import
     Structures.Monads.
Import MonadNotation.
Local Open Scope monad.

From advent Require Import lib.

(* Sets indexed by natural numbers. *)
Module NMap := FMapAVL.Make N_as_OT.

(* Minutes since midnight. *)
Definition time : Type := N.

(* We assume shifts happen around midnight. *)
Variant event : Type :=
| Shift (guard : N)
| FallsAsleep
| WakesUp
.

(* A list of 1 in the interval [[n1; n2-1]] *)
Definition interval (n1 n2 : N) : list nat :=
  N.iter n1 (cons 0) (N.iter (n2 - n1) (cons 1) []).

Fixpoint union {A : Type}
         (merge : A -> A -> A) (xs ys : list A) : list A :=
  match xs, ys with
  | [], _ => ys
  | _, [] => xs
  | x :: xs, y :: ys => merge x y :: union merge xs ys
  end.

Definition union1 : list nat -> list nat -> list nat := union plus.

Parameter err : forall {A}, A.
Extract Inlined Constant err => "assert false".

Fixpoint record_sleeps_aux (r : NMap.t (list nat))
         (guard0 : N) (es : list (time * event)) : NMap.t (list nat) :=
  match es with
  | (_, Shift guard) :: es => record_sleeps_aux r guard es
  | (i, FallsAsleep) :: (j, WakesUp) :: es =>
    let gz := match NMap.find guard0 r with
              | None => []
              | Some gz => gz
              end in
    let r' := NMap.add guard0 (union1 (interval i j) gz) r in
    record_sleeps_aux r' guard0 es
  | [] => r
  | _ => err
  end.

Definition record_sleeps
           (es : list (time * event)) : NMap.t (list nat) :=
  record_sleeps_aux (NMap.empty _) 0 es.

Definition sum : list nat -> nat :=
  fun ns => fold_left plus ns 0.

Definition NMap_argmax {A : Type} (f : A -> nat)
           (r : NMap.t A) : nat * list (N * A) :=
  NMap.fold (fun i x best =>
    let y := f x in
    if y <? fst best then
      best
    else if y =? fst best then
      (fst best, (i, x) :: snd best)
    else
      (y, [(i, x)])) r (0, []).

(* Find the maximum of a list and all indices where it is reached. *)

Fixpoint arg_max_aux (best : nat) (arg : list nat) (i : nat)
         (xs : list nat) : nat * list nat :=
  match xs with
  | [] => (best, arg)
  | x :: xs =>
    if x <? best then
      arg_max_aux best arg (S i) xs
    else if x =? best then
      arg_max_aux best (i :: arg) (S i) xs
    else
      arg_max_aux x [i] (S i) xs
  end.

Definition arg_max : list nat -> nat * list nat :=
  arg_max_aux 0 [] 0.

(* Find the laziest guards (there should be only one in the AoC
   input), together with the total time they slept. *)
Definition laziest1 :
  NMap.t (list nat) -> nat * list (N * list nat) :=
  NMap_argmax sum.

Definition laziest2 :
  NMap.t (list nat) -> nat * list (N * (nat * list nat)) :=
  fun r => NMap_argmax (fun '(max_slept, _) => max_slept)
                       (NMap.map arg_max r).

Definition all_laziest1 (es : list (time * event)) :
  nat * list (N * nat * list nat) :=
  let r := record_sleeps es in
  let '(max_sleep, offenders) := laziest1 r in
  let most_slept_minutes := fun '(guard, slept) =>
    let '(m, mns) := arg_max slept in
    (guard, m, mns) in
  (max_sleep, map most_slept_minutes offenders).

Definition all_laziest2 (es : list (time * event)) :
  nat * list (N * list nat) :=
  let r := record_sleeps es in
  let '(max_slept, offenders) := laziest2 r in
  let most_slept_minutes := fun '(guard, (_, mns)) =>
    (guard, mns) in
  (max_slept, map most_slept_minutes offenders).

Section main.

Import SimpleIO.

Context {m : Type -> Type} `{Monad m} `{MonadFix m}
        `{MonadI (time * event) m}
        `{MonadO ocaml_string m}.

Infix "+++" := ostring_app (at level 30).

Definition print_all_laziest1 (a : nat * list (N * nat * list nat)) :=
  let '(max_sleep, offenders) := a in
  print (to_ostring "Total slept:");;
  print (ostring_of_int (int_of_nat max_sleep));;
  let of_n n := ostring_of_int (int_of_n n) in
  let of_nat n := ostring_of_int (int_of_nat n) in
  for' offenders (fun '(guard, max_slept, mns) =>
    print (OString.concat (to_ostring "; ") ([
      of_n guard;
      of_nat max_slept;
      OString.concat (to_ostring ",")
        (map (fun n => OString.concat (to_ostring ":") [
                of_nat n;
                of_n (guard * N.of_nat n)%N])
             mns)]
      ))
  ).

Definition print_all_laziest2 (a : nat * list (N * list nat)) :=
  let '(max_sleep, offenders) := a in
  print (to_ostring "Max slept:");;
  print (ostring_of_int (int_of_nat max_sleep));;
  let of_n n := ostring_of_int (int_of_n n) in
  let of_nat n := ostring_of_int (int_of_nat n) in
  for' offenders (fun '(guard, mns) =>
    print (OString.concat (to_ostring "; ") ([
      of_n guard;
      OString.concat (to_ostring ",")
        (map (fun n => OString.concat (to_ostring ":") [
                of_nat n;
                of_n (guard * N.of_nat n)%N])
             mns)]
      ))
  ).

Definition main1 : m unit :=
  es <- read_all;;
  let a := all_laziest1 es in
  print_all_laziest1 a.

Definition main2 : m unit :=
  es <- read_all;;
  let a := all_laziest2 es in
  print_all_laziest2 a.

End main.

Module io.

Import SimpleIO.
Import IO.Notations.

(* Partial function!? *)
Parameter parse_event : forall {TIME EVENT : Type},
    (int -> TIME) ->
    (int -> EVENT) -> EVENT -> EVENT ->
    ocaml_string -> TIME * EVENT.

Extract Constant parse_event =>
  "fun mk_time mk_shift sleep wakeup s ->
   try
     Scanf.sscanf s ""[1518-%_d-%_d %_d:%d] %[^\n]""
       (fun mn e ->
          (mk_time mn, match e with
               | ""falls asleep"" -> sleep
               | ""wakes up"" -> wakeup
               | _ -> Scanf.sscanf e ""Guard #%d"" mk_shift)
       )
   with End_of_file ->
    failwith (Printf.sprintf ""Parse error: %S"" s)".

Instance MonadI_event_IO : MonadI (time * event) IO := {
  read := catch_eof (
    s <- read_line';;
    ret (parse_event
           n_of_int
           (fun g => Shift (n_of_int g)) FallsAsleep WakesUp
           s));
}.

End io.

Import SimpleIO.

Definition exec1 : io_unit := IO.unsafe_run main1.
Extraction "day04_1.ml" exec1.

Definition exec2 : io_unit := IO.unsafe_run main2.
Extraction "day04_2.ml" exec2.


Require Import List Common
        ADT.ADTSig ADT.Core
        ADTNotation.BuildADTSig ADTNotation.BuildADT
        Common.ilist ADTNotation.StringBound
        ADTRefinement.Core ADTRefinement.SetoidMorphisms
        ADTRefinement.GeneralRefinements
        ADTRefinement.Refinements.HoneRepresentation
        ADTRefinement.BuildADTSetoidMorphisms
        ADTRefinement.Refinements.SimplifyRep.

Section SimplifyRep.

  (* If a representation has extraneous information (perhaps intermediate
     data introduced during refinement), simplifying the representation
     is a valid refinement. *)

  Variable oldRep : Type. (* The old representation type. *)
  Variable newRep : Type. (* The new representation type. *)

  Variable simplifyf : oldRep -> newRep. (* The simplification function. *)
  Variable concretize : newRep -> oldRep. (* A map to the enriched representation. *)

  (* The abstraction relation between old and new representations. *)
  Variable AbsR : oldRep -> newRep -> Prop.
  Notation "ro ≃ rn" := (AbsR ro rn) (at level 70).

  Definition simplifyMethDef
             (Sig : methSig)
             (oldMeth : @methDef oldRep Sig)
  : @methDef newRep Sig :=
    {| methBody := simplifyMethod simplifyf concretize (methBody oldMeth) |}.

  Definition simplifyConstrDef
             (Sig : consSig)
             (oldConstr : @consDef oldRep Sig)
  : @consDef newRep Sig :=
    {| consBody := simplifyConstructor simplifyf (consBody oldConstr) |}.

  Lemma refineADT_BuildADT_Simplify
            (constrSigs : list consSig)
            (methSigs : list methSig)
            (constrDefs : ilist (@consDef oldRep) constrSigs)
            (methDefs : ilist (@methDef oldRep) methSigs) :
    (forall r_o, r_o ≃ simplifyf r_o) ->
    (forall r_n r_o,
       (r_o ≃ r_n) ->
       forall idx n,
         refineEquiv (r_o'' <- getMethDef methDefs idx r_o n;
                      r_n' <- {r_n' | fst r_o'' ≃ r_n'};
                      ret (r_n', snd r_o''))
                     (r_o'' <- getMethDef methDefs idx (concretize r_n) n;
                      ret (simplifyf (fst r_o''), snd r_o''))) ->
    refineADT
      (BuildADT constrDefs methDefs)
      (BuildADT (imap _ simplifyConstrDef constrDefs)
                (imap _ simplifyMethDef methDefs)).
  Proof.
    econstructor 1 with (AbsR := AbsR); simpl in *; eauto; intros.
    - rewrite <- ith_Bounded_imap.
      unfold simplifyConstrDef, simplifyConstructor; simpl.
      intros v Comp_v; inversion_by computes_to_inv;
      repeat econstructor; subst; eauto.
    - rewrite <- ith_Bounded_imap.
      rewrite H0; eauto; reflexivity.
  Qed.

End SimplifyRep.


Require Import HOASLib.
Require Import Denotation.
Require Import TypeChecking.

Open Scope matrix_scope.

(***************************)
(* Approximate Slide Lemma *)
(***************************)

(* How did this get here?
Lemma slide : forall (p q : Pat Qubit) (Γ0 Γ : Ctx) (U V : Unitary Qubit),
  denote_circuit true (let_ p' ← U $ p; let_ q' ← V $ q; (p',q')) Γ0 Γ =
  denote_circuit true (let_ q' ← V $ q; let_ p' ← U $ p; (p',q')) Γ0 Γ.
Proof.
  intros p q Γ0 Γ U V. simpl.
  unfold denote_circuit.
  simpl.
  dependent destruction p.
  dependent destruction q.
  simpl.
  autounfold with den_db. simpl.

  *)

(* ---------------------------------------*)
(*--------- Boxed Circuit Specs ----------*)
(* ---------------------------------------*)

(* TODO: add lemmas to proof_db *)
Lemma id_circ_spec : forall W ρ safe, WF_Matrix ρ ->
  denote_box safe  (@id_circ W) ρ = ρ.
Proof.
  intros W ρ safe H.
  simpl. unfold denote_box. simpl.
  autorewrite with proof_db.
  rewrite add_fresh_split.
  simpl.
  unfold pad.
  simpl.
  rewrite Nat.sub_diag.
  rewrite kron_1_r.
  rewrite subst_pat_fresh_empty.
  rewrite denote_pat_fresh_id.
  rewrite super_I; auto.
Qed.

Lemma X_spec : forall (b safe : bool), denote_box safe (boxed_gate _X) (bool_to_matrix b) =
                               bool_to_matrix (¬ b).
Proof. intros. vector_denote. destruct b; solve_matrix. Qed.

Lemma init0_spec : forall safe, denote_box safe init0 (I (2^0)) = ∣0⟩⟨0∣.
Proof. intros. matrix_denote. Msimpl. reflexivity. Qed.

Lemma init1_spec : forall safe, denote_box safe init1 (I (2^0)) = ∣1⟩⟨1∣.
Proof. intros. matrix_denote. Msimpl. reflexivity. Qed.

Lemma assert0_spec : forall safe, denote_box safe assert0 ∣0⟩⟨0∣ = I 1.
Proof.
  destruct safe.
  - matrix_denote.
    Msimpl.
    solve_matrix.
  - matrix_denote.
    Msimpl.
    solve_matrix.
Qed.

Lemma assert1_spec : forall safe, denote_box safe assert1 ∣1⟩⟨1∣ = I 1.
Proof.
  destruct safe.
  - matrix_denote.
    Msimpl.
    solve_matrix.
  - matrix_denote.
    Msimpl.
    solve_matrix.
Qed.

Lemma init_spec : forall b safe, denote_box safe (init b) (I (2^0)) = bool_to_matrix b.
Proof. destruct b; [apply init1_spec | apply init0_spec]. Qed.

Lemma assert_spec : forall b safe, denote_box safe (assert b) (bool_to_matrix b) = I 1.
Proof. destruct b; [apply assert1_spec | apply assert0_spec]. Qed.

Lemma SWAP_spec : forall ρ safe, denote_box safe SWAP ρ = swap × ρ × swap.
Proof. intros. matrix_denote. Msimpl. setoid_rewrite swap_sa. reflexivity. Qed.

Lemma SWAP_spec_sep : forall (ρ1 ρ2 : Density 2) safe,
  WF_Matrix ρ1 -> WF_Matrix ρ2 ->
  denote_box safe SWAP (ρ1 ⊗ ρ2) = ρ2 ⊗ ρ1.
Proof. intros. rewrite SWAP_spec. solve_matrix. Qed.

(* MOVE THIS! *)
Lemma fresh_wtype : forall (w : WType) (Γ : Ctx), add_fresh_state w Γ = Γ ++ (add_fresh_state w []).
Proof.
  intros. generalize dependent Γ.
  induction w; unfold add_fresh_state; simpl; try reflexivity; intros.
  - induction Γ; simpl; try reflexivity.
    rewrite <- IHΓ. reflexivity.
  - repeat rewrite add_fresh_split. simpl.
    replace (add_fresh_state w2 (add_fresh_state w1 [])) with ((add_fresh_state w1 []) ++ (add_fresh_state w2 [])) by (rewrite <- IHw2; reflexivity).
    rewrite IHw2. rewrite IHw1. rewrite app_assoc. reflexivity.
Qed.

Lemma SWAP_GEN_spec_same_sep : forall W (ρ1 ρ2 : Density (2^⟦W⟧)) safe,
    denote_box safe (@SWAP_GEN W W) (ρ1 ⊗ ρ2) = ρ2 ⊗ ρ1.
Proof.
  matrix_denote.
  repeat rewrite add_fresh_split.
  unfold hoas_to_db. simpl.
  Search subst_pat.
  rewrite subst_pat_fresh.
  rewrite pad_nothing.
  unfold denote_pat. simpl.
  rewrite subst_pat_no_gaps.

  2:{ rewrite fresh_wtype. rewrite app_length.
      Search Bounded_Pat.
      apply bounded_pat_le with (length (add_fresh_state W [])).
      lia.
      rewrite length_fresh_state with (w := W) (Γ' := add_fresh_state W []) (Γ := []) by easy.
      apply add_fresh_pat_bounded.
      constructor.
  }

  all: repeat apply add_fresh_state_no_gaps; try constructor.
  Search pat_to_list add_fresh_pat.
  repeat rewrite swap_fresh_seq. simpl.
  Search length add_fresh_state.
  erewrite length_fresh_state by reflexivity. simpl.
Abort.

(* -----------------------------------------*)
(*--------- Reversible Circuit Specs -------*)
(* -----------------------------------------*)

Lemma CNOT_spec : forall (b1 b2 safe : bool),
  denote_box safe CNOT (bool_to_matrix b1 ⊗ bool_to_matrix b2)
  = (bool_to_matrix b1 ⊗ bool_to_matrix (b1 ⊕ b2)).
Proof.
  vector_denote. destruct b1, b2; unfold bool_to_ket; simpl; Msimpl; solve_matrix.
Qed.

Lemma TRUE_spec : forall z safe,
  denote_box safe TRUE (bool_to_matrix z) = bool_to_matrix (true ⊕ z).
Proof. vector_denote. destruct z; solve_matrix. Qed.

Lemma FALSE_spec : forall z safe,
    denote_box safe FALSE (bool_to_matrix z) = bool_to_matrix (false ⊕ z).
Proof. vector_denote. destruct z; solve_matrix. Qed.

Lemma NOT_spec : forall (x z : bool),
  forall safe, denote_box safe NOT (bool_to_matrix x ⊗ bool_to_matrix z) =
  bool_to_matrix x ⊗ bool_to_matrix ((¬ x) ⊕ z).
Proof.
  vector_denote.
  destruct x, z; unfold bool_to_ket; simpl; Msimpl; solve_matrix.
Qed.

Lemma XOR_spec : forall (x y z safe : bool),
    denote_box safe XOR (bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix z)  =
    bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix (x ⊕ y ⊕ z).
Proof.
  vector_denote. Msimpl.
  destruct x, y, z; simpl; solve_matrix.
Qed.

Lemma AND_spec : forall (x y z safe : bool),
    denote_box safe AND (bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix z)  =
    bool_to_matrix x ⊗ bool_to_matrix y ⊗ bool_to_matrix ((x && y) ⊕ z).
Proof.
  vector_denote. Msimpl.
  destruct x, y, z; simpl; Msimpl; solve_matrix.
Qed.


Require Import IntuitionisticLogic.base.
Import LogicNotation.
Local Open Scope IPC_scope.

Section KripkeSemantic.

Context {venv: Var_env}.

Class Frame : Type := {
  Worlds: Type;
  access: Worlds -> Worlds -> Prop;
  access_refl: forall w, access w w;
  access_trans: forall u v w, access u v -> access v w -> access u w
}.

Class Model: Type := {
  F: Frame;
  eval: Worlds -> Var -> bool;
  hereditary: forall w v: Worlds, access w v -> (forall x: Var, eval w x = true -> eval v x = true)
}.

Existing Instance F.

Class KripkeSem : Type := {
  M: Model;
  Kripke_Sat : Worlds -> Term -> Prop;
  satisfy_ind: forall (w: Worlds) (t: Term),
    Kripke_Sat w t <->
    match t with
    | andp t1 t2 => Kripke_Sat w t1 /\ Kripke_Sat w t2
    | orp t1 t2 => Kripke_Sat w t1 \/ Kripke_Sat w t2
    | impp t1 t2 => forall v, access w v -> Kripke_Sat v t1 -> Kripke_Sat v t2
    | falsep => False
    | varp x => eval w x = true
    end
}.

Lemma Kripke_Sat_mono: forall `{KripkeSem} w v t, access w v -> Kripke_Sat w t -> Kripke_Sat v t.
Proof.
  intros.
  induction t; apply satisfy_ind in H1; apply satisfy_ind.
  + tauto.
  + tauto.
  + intros.
    specialize (H1 v0 (access_trans _ _ _ H0 H2)).
    tauto.
  + tauto.
  + eapply hereditary; eauto.
Qed.

Existing Instance M.

Class PointModel: Type := {
  KS: KripkeSem;
  w: Worlds
}.

Existing Instance KS.

Instance Kripke_sem : Semantic := mk_sem PointModel (fun KM t => Kripke_Sat w t).

End KripkeSemantic.

Lemma sound_Kripke_IPC: sound Kripke_sem IPC.
Proof.
  unfold sound.
  intros.
  induction H; intros M CONTEXT.
  + apply CONTEXT.
    auto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    simpl in IHIPC_derive1; apply satisfy_ind in IHIPC_derive1.
    destruct IHIPC_derive1.
    - assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 a).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive2 M CONTEXT_a).
    - assert (CONTEXT_b: forall t0 : Term, (ctx;; b) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 b).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive3 M CONTEXT_b).
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    apply satisfy_ind in IHIPC_derive2.
    specialize (IHIPC_derive2 w (access_refl _)).
    tauto.
  + simpl.
    apply satisfy_ind.
    intros.
    rename M into M0.
    pose (Build_PointModel KS v) as M1.
    assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M1 |= t0).
    Focus 1. {
      intros.
      unfold ExtendContext in H2.
      destruct (term_eq t0 a).
      + subst; exact H1.
      + specialize (CONTEXT t0 H2).
        simpl.
        apply Kripke_Sat_mono with w; auto.
    } Unfocus.
    specialize (IHIPC_derive M1 CONTEXT_a).
    exact IHIPC_derive.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    apply satisfy_ind in IHIPC_derive.
    tauto.
Qed.

End IPC.

Module IPC_Notation.
Notation "x && y" := (andp x y) (at level 40, left associativity) : IPC_scope.
Notation "x || y" := (orp x y) (at level 50, left associativity) : IPC_scope.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : IPC_scope.
Notation "'FF'" := falsep : IPC_scope.
Notation "ctx ;; t" := (ExtendContext ctx t) (at level 65, left associativity) : IPC_scope.
Notation "M  |=  t" := (satisfy M t) (at level 60, no associativity) : IPC_scope.
Notation "|==  t" := (valid t) (at level 61, no associativity) : IPC_scope.
Notation "ctx  |==  t" := (sem_conseq ctx t) (at level 60, no associativity) : IPC_scope.
Notation "ctx  |--  t" := (derivable ctx t) (at level 60, no associativity) : IPC_scope.
Notation "|--  t" := (provable t) (at level 61, no associativity) : IPC_scope.
End IPC_Notation.

Module CanonicalModel.

Context {venv: Var_env}.

Existing Instance IPC.
Import IPC_Notation.
Local Open Scope IPC_scope.

Context (IPC_classic: forall ctx t, {ctx |-- t} + {~ ctx |-- t}).

Definition W := {w: Context &
                   (forall t, w |-- t -> w t = true) /\
                   (forall t1 t2, w (t1 || t2) = true -> w t1 = true \/ w t2 = true)}.

Definition R (w v: W) := match w, v with existT w _, existT v _ => forall t, w t = true -> v t = true end.

Definition gen (ctx: Context) : Context := fun t => if IPC_classic ctx t then true else false.

Lemma gen_derive: forall ctx t, ctx |-- t <-> gen ctx |-- t.
Proof.
  intros; split; intros.
  + apply assum.
    unfold gen.
    destruct (IPC_classic ctx t); tauto.
  + apply IPC_substitution with (gen ctx); auto.
    clear; intros.
    unfold gen in H.
    destruct (IPC_classic ctx t0); congruence.
Qed.

Definition Gen (ctx: Context) : W.
  exists (gen ctx).
  split.
  + intros.
    apply gen_derive in H.
    unfold gen.
    destruct (IPC_classic ctx t); congruence.
  +

Definition F: Frame.
  apply (Build_Frame W R).
  + intros.
    unfold R.
    destruct w0; simpl.
    intros; auto.
  + unfold R.
    intros u v w.
    destruct u, v, w.
    intros.
    specialize (H t).
    specialize (H0 t).
    tauto.
Defined.

Definition V (w: W) (v: Var) : bool := let (w, _) := w in (w (varp v)).

Definition M: Model.
  apply (Build_Model F V).
  intros w v ? x.
  simpl in H.
  unfold R in H; unfold V; destruct w, v.
  apply H.
Defined.

Instance CanonicalModel: KripkeSem.
  apply (Build_KripkeSem M (fun w t => let (w, _) := w in w t = true)).
  intros w t; revert w; induction t; intros [w Hw].
  + split; intros; [split |]; apply (proj1 Hw).
    - apply and_elim_l with t2.
      apply assum; auto.
    - apply and_elim_r with t1.
      apply assum; auto.
    - apply and_intro; apply assum; tauto.
  + split; [intro | intros [? | ?]].
    - exact (proj2 Hw t1 t2 H).
    - apply (proj1 Hw).
      apply or_intro_l.
      apply assum; auto.
    - apply (proj1 Hw).
      apply or_intro_r.
      apply assum; auto.
  + split; intros.
    - simpl in H0.
      destruct v as [v Hv].
      assert (IPC_derive (w;; t1) t2).
      Focus 1. {
        apply imp_elim with t1.
        + apply assum.
          unfold ExtendContext.
          destruct (term_eq t1 t1); congruence.
        + apply IPC_weakening with w.
          - clear.
            intros.
            unfold ExtendContext.
            destruct (term_eq t0 t1); congruence.
          - apply assum; auto.
      } Unfocus.
      apply (proj1 Hv).
      apply IPC_weakening with (w;; t1); auto.
      clear - H1 H0.
      unfold ExtendContext.
      intros.
      destruct (term_eq t0 t1).
      * subst. auto.
      * apply H0; auto.
    - apply (proj1 Hw).
      simpl in H.
      specialize (

Lemma complete_Kripke_IPC: strong_complete Kripke_sem IPC.
Proof.
  unfold strong_complete.
  intros.
  pose ( (fun w v => match w, v with existT w _, existT v _ => forall t, w t = true -> v t = true end)).  : Type := {
  Worlds: Type;
  access: Worlds -> Worlds -> bool;
  access_refl: forall w, access w w = true;
  access_trans: forall u v w, access u v = true -> access v w = true -> access u w = true
}.


Require Import propInv3.
Require Import verif_cond_5.
Require Import extra5.
Require Import ind_scheme.
Local Open Scope Z.

Theorem proof3_5: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond5 ->
 (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
split.
unfold propInv3.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i (timer1-(11-1)).
intros.
assert (Hstartnewloop : (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1)).
assumption.
apply startnewloop_to_propInv in H0.
elim H0 with i.
intros.
exists x.
split.
apply H8.
split.
apply H8.
split.
intros.
apply H8.
assumption.
apply H8.
split.
apply H5.
split.
inversion_clear Hstartnewloop.
auto with zarith.
apply H5.
(*case i=timer1-(11-1)*)
intros.
(*inductive proof*)
assert (Hdryer_hands : (forall k, (i<=k /\ k<i -> dryer1.[of_Z k]=ON /\ hands1.[of_Z k]=OFF))).
intros.
elimtype False.
auto with zarith.
assert (Hi_in_interval : (i<=i<=i+(11-1))).
auto with zarith.
generalize Hdryer_hands.
generalize Hi_in_interval.
apply generalize_i.

(*induction base *)
assert (Hbase : (ind_prove_pred dryer1 i (i+(11-1)) (i+(11-1)))).
unfold ind_prove_pred.
intros.
exists (i+(11-1)).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
apply Zeq_plus_swap in H7.
rewrite H7.
right.
assumption.
(*apply inductive scheme*)
intro.
intro.
apply natlike_down_bound_ind with (fun z=> (ind_prove_pred dryer1 i (i+(11-1)) z)) (i+(11-1)) i l in Hbase.
apply Hbase.
(*inductive step*)
intros.
unfold ind_prove_pred.
intros.
assert (true_or_false : forall b : bool, b=true \/ b=false).
induction b.
left.
reflexivity.
right.
reflexivity.
(*induction on hands*)
elim true_or_false with hands1.[of_Z (Z.pred y)].
intro.
exists (Z.pred y).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
right.
assumption.
intros.
(*induction on dryer*)
elim true_or_false with dryer1.[of_Z (Z.pred y)].
(*hands=OFF /\ dryer=ON*)
intros.
assert (Hpremise_y : (forall k, (i<=k /\ k<y -> dryer1.[of_Z k]=ON /\ hands1.[of_Z k]=OFF))).
intros.
elim Zle_lt_or_eq with k (Z.pred y).
intros.
apply H11.
split.
apply H14.
assumption.
intros.
rewrite H15.
split; assumption.
auto with zarith.
apply H10 in Hpremise_y.
elim Hpremise_y.
intros.
exists x.
split.
auto with zarith.
apply H14.
(*hands=OFF /\ dryer=OFF*)
intros.
exists (Z.pred y).
split.
auto with zarith.
split.
auto with zarith.
split.
assumption.
left.
assumption.
assumption.
apply H5.

apply extra5.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.