├── CODE_OF_CONDUCT.md ├── .github └── workflows │ └── main.yml ├── _CoqProject ├── Makefile ├── librachain.opam ├── .gitignore ├── CONTRIBUTING.md ├── README.md ├── Structures ├── BFTFacts.v ├── Chains.v ├── Blocks.v ├── HashSign.v ├── SeqFacts.v ├── BlockTree.v └── ConsensusState.v ├── LICENSE └── Properties └── Safety.v /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | Facebook has adopted a Code of Conduct that we expect project participants to adhere to. 4 | Please read the [full text](https://code.fb.com/codeofconduct/) 5 | so that you can understand what actions will and will not be tolerated. 6 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | 8 | runs-on: ubuntu-latest 9 | 10 | steps: 11 | - uses: actions/checkout@v1 12 | - name: opam install & build 13 | uses: huitseeker/opam-coq-action@master 14 | with: 15 | args: make clean && make 16 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -Q Structures LibraChain 2 | 3 | -arg -w -arg -notation-overridden 4 | -arg -w -arg -local-declaration 5 | -arg -w -arg -redundant-canonical-projection 6 | -arg -w -arg -projection-no-head-constant 7 | 8 | Structures/SeqFacts.v 9 | Structures/Chains.v 10 | Structures/Blocks.v 11 | Structures/ConsensusState.v 12 | Structures/HashSign.v 13 | Structures/BlockTree.v 14 | Structures/BFTFacts.v 15 | Properties/Safety.v -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: default 2 | 3 | default: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | quick: Makefile.coq 7 | $(MAKE) -f Makefile.coq quick 8 | 9 | install: Makefile.coq 10 | $(MAKE) -f Makefile.coq install 11 | 12 | clean: Makefile.coq 13 | $(MAKE) -f Makefile.coq cleanall 14 | rm -f Makefile.coq Makefile.coq.conf 15 | 16 | Makefile.coq: _CoqProject 17 | coq_makefile -f _CoqProject -o Makefile.coq 18 | 19 | .PHONY: all default quick install clean 20 | -------------------------------------------------------------------------------- /librachain.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "dev" 3 | maintainer: "fga@fb.com" 4 | 5 | license: "Apache-2.0" 6 | synopsis: "Coq formalization of LibraBFT" 7 | 8 | build: [ make "-j%{jobs}%" ] 9 | install: [ make "install" ] 10 | depends: [ 11 | "ocaml" {>= "4.05.0" & < "4.10"} 12 | "coq" {(> "8.10" & < "8.12~") | (= "dev")} 13 | "coq-mathcomp-ssreflect" {(>= "1.7" & < "1.11~") | (= "dev")} 14 | "coq-fcsl-pcm" 15 | ] 16 | 17 | tags: [ 18 | "category:Computer Science/Concurrent Systems and Protocols/Theory of concurrent systems" 19 | "keyword:program verification" 20 | "keyword:distributed algorithms" 21 | ] 22 | authors: [ 23 | "François Garillot" 24 | ] 25 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # Generic generated file patterns 3 | # ----------------------------------------------------------------------------- 4 | 5 | Thumbs.db 6 | .DS_Store 7 | .svn 8 | 9 | *~ 10 | #*# 11 | *.bak 12 | *.BAK 13 | *.orig 14 | *.prof 15 | *.rej 16 | 17 | *.hi 18 | *.hi-boot 19 | *.o-boot 20 | *.p_o 21 | *.t_o 22 | *.debug_o 23 | *.thr_o 24 | *.thr_p_o 25 | *.thr_debug_o 26 | *.o 27 | *.vo 28 | *.vio 29 | *.a 30 | *.o.cmd 31 | *.depend* 32 | .#* 33 | log 34 | tags 35 | 36 | # ----------------------------------------------------------------------------- 37 | # Coq-generated stuff 38 | # ----------------------------------------------------------------------------- 39 | 40 | \#*\# 41 | *.vo 42 | *.v.d 43 | *.glob 44 | .coq-native 45 | Makefile.coq 46 | *.aux 47 | CoqMakefile.conf 48 | Makefile.coq.conf 49 | .coqdeps.d 50 | awk.Makefile 51 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to LibraChain 2 | We want to make contributing to this project as easy and transparent as 3 | possible. 4 | 5 | ## Our Development Process 6 | 7 | A TODO comment should include the number of an issue that describes the outstanding work in greater detail. 8 | 9 | A pull request that is a work in progress that has been published to get help and feedback from the community should be tagged with WIP. 10 | 11 | The person approving a pull request will also merge it into master. 12 | 13 | ## Pull Requests 14 | We actively welcome your pull requests. 15 | 16 | 1. Fork the repo and create your branch from `master`. 17 | 2. Ensure the build passes. 18 | 3. If you haven't already, complete the Contributor License Agreement ("CLA"). 19 | 20 | ## Contributor License Agreement ("CLA") 21 | In order to accept your pull request, we need you to submit a CLA. You only need 22 | to do this once to work on any of Facebook's open source projects. 23 | 24 | Complete your CLA here: 25 | 26 | ## Issues 27 | We use GitHub issues to track public bugs. Please ensure your description is 28 | clear and has sufficient instructions to be able to reproduce the issue. 29 | 30 | Facebook has a [bounty program](https://www.facebook.com/whitehat/) for the safe 31 | disclosure of security bugs. In those cases, please go through the process 32 | outlined on that page and do not file a public issue. 33 | 34 | ## Coding Style 35 | 36 | We use the [SSReflect proof language](https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html). 37 | 38 | ## License 39 | By contributing to LibraChain, you agree that your contributions will be licensed 40 | under the [`LICENSE`](LICENSE) file in the root directory of this source tree. 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # LibraChain 2 | 3 | A library providing mechanized proofs of the LibraBFT consensus using the [Coq 4 | theorem prover](https://coq.inria.fr/). 5 | 6 | 7 | ## Architecture & Evolution 8 | 9 | This library uses the [SSreflect proof language](https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html) and [mathematical components libraries](https://github.com/math-comp/math-comp) for Coq. 10 | 11 | It is compatible with, inspired by, and extends, the [ToyChain 12 | library](https://github.com/certichain/toychain) by George Pirlea, Ilya Sergey 13 | et al. 14 | 15 | This library is at an experimental stage and its contents may know significant 16 | evolutions in the future. 17 | 18 | 19 | ## References 20 | 21 | ### Libra Technical Papers 22 | * [The Libra Blockchain](https://developers.libra.org/docs/the-libra-blockchain-paper) 23 | * [State Machine Replication in the Libra Blockchain](https://developers.libra.org/docs/state-machine-replication-paper) 24 | 25 | ### HotStuff technical Papers 26 | 27 | LibraBFT, studied here, is a Hotstuff-inspired protocol. 28 | 29 | * [PODC paper](https://dl.acm.org/doi/abs/10.1145/3293611.3331591) 30 | * [ArXiV full version](https://arxiv.org/abs/1803.05069) 31 | 32 | ### Versions of the Libra Consensus Papers 33 | 34 | Due to the high level of precision requires for a formalized proof, 35 | consultation of both LibraBFT v2 & v3 is recommended: 36 | 37 | * [LibraBFT v2](https://developers.libra.org/docs/assets/papers/libra-consensus-state-machine-replication-in-the-libra-blockchain/2019-10-24.pdf) 38 | * [LibraBFT v3](https://developers.libra.org/docs/assets/papers/libra-consensus-state-machine-replication-in-the-libra-blockchain/2020-04-09.pdf) 39 | 40 | ### Coq libraries used in this development 41 | 42 | * [SSReflect](https://hal.inria.fr/inria-00258384) 43 | * [ToyChain master's thesis of George 44 | Pirlea](https://pirlea.net/papers/toychain-thesis.pdf) 45 | * [Mechanizing BlockChain consensus](https://ilyasergey.net/papers/toychain-cpp18.pdf) 46 | 47 | ## Contributing 48 | 49 | See the [CONTRIBUTING](CONTRIBUTING.md) file for how to help out. 50 | 51 | ## LICENSE 52 | LibraChain is Apache-2.0 licensed, as found in the [LICENSE](https://github.com/calibra/LibraChain/blob/master/LICENSE) file. 53 | -------------------------------------------------------------------------------- /Structures/BFTFacts.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq choice fintype finset. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | 22 | Set Implicit Arguments. 23 | 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | 27 | (***************************************************) 28 | (* Some useful facts about sets *) 29 | (***************************************************) 30 | 31 | Section BFTFacts. 32 | 33 | Variable T: choiceType. 34 | 35 | Variable validators: seq T. 36 | Hypothesis Huniq_val: uniq validators. 37 | 38 | (* Validators is the small subType defined by their enumeration validators.*) 39 | Definition Validators := seq_sub validators. 40 | 41 | (* In this context, honest is a predicate on validators.*) 42 | Variable honest: pred Validators. 43 | Variable f: nat. 44 | 45 | Hypothesis BFT: 46 | (#|[set x : Validators|honest x]| >= (2*f).+1) && 47 | (size validators == (3*f).+1). 48 | 49 | Lemma cards_dishonest: 50 | #|~: [set x| honest x]| <= f. 51 | Proof. 52 | move: (cardsCs [set x| honest x]); move/andP: BFT=> [Hhon Hsv]. 53 | move: (Hsv); rewrite (card_seq_sub Huniq_val) /=; move/eqP=>-> Hdh. 54 | move: (Hhon); rewrite {}Hdh ltn_subRL. 55 | have: 2 * f < (3 * f).+1; first by rewrite ltnS leq_mul2r ltnS (ltn_trans (ltnSn _) (ltnSn _)) orbT. 56 | move/(@ltn_sub2r (2*f) _ _ )=>H; move/H. 57 | rewrite {H}addnK -[(_ * f).+1]addn1 -addnBAC; last by rewrite leq_mul2r ltnS (ltn_trans (ltnSn _) (ltnSn _)) orbT. 58 | by rewrite -mulnBl subSnn mul1n addn1 ltnS. 59 | Qed. 60 | 61 | Lemma card_S2f_gt (C: {set Validators}): 62 | #|C| == (2*f).+1 -> 63 | #|C :&: [set x | honest x]| >= f.+1. 64 | Proof. 65 | move=> Hc; rewrite (cardsCs (_ :&: [set x|honest x])). 66 | move/andP: BFT=> [Hhon /eqP Hsv]. 67 | rewrite (card_seq_sub Huniq_val) Hsv setCI. 68 | have Hi: f < (3 * f).+1 - (2 * f). 69 | - rewrite -[(3*f).+1]addn1 mulnC mulnS mulnC -addnA. 70 | by rewrite [_ + 1]addnC addnA addn1 addnK. 71 | have H: #|(~: C) :|: ~: [set x | honest x]| <= 2*f. 72 | - apply: (leq_trans (leq_card_setU (~:C) (~: [set x|honest x]))). 73 | rewrite mulnC mulnS muln1; move: cards_dishonest. 74 | rewrite -(leq_add2l #|~: C|); move/leq_trans; apply. 75 | rewrite leq_add2r cardsCs (card_seq_sub Huniq_val) Hsv. 76 | rewrite setCK (eqP Hc) mulnC mulnS -addn1 mulnC -addnA addn1. 77 | by rewrite addnK leqnn. 78 | apply: (leq_trans Hi). 79 | by apply: (leq_sub _ H). 80 | Qed. 81 | 82 | Lemma intersection (A B: {set Validators}): 83 | (#|A| == (2*f).+1) && (#|B| == (2*f).+1) -> 84 | #|[set x in A:&:B | honest x]| > 0. 85 | Proof. 86 | move/andP=>[HA HB]; move/andP: BFT=> [Hhon Hsv]. 87 | have H: #|A:&:B| >= f+1. 88 | - rewrite cardsI (eqP HA) (eqP HB). 89 | apply: (leq_trans _ (leq_sub2l _ (subset_leq_card (subsetT (A:|:B))))). 90 | rewrite cardsT (card_seq_sub Huniq_val) (eqP Hsv). 91 | have I: (2 * f).+1 + (2 * f).+1 = f.+1 + (3*f).+1. 92 | - rewrite [3*_]mulnC mulnS [_*2]mulnC -addnS addnA [f.+1 + f]addSnnS. 93 | by rewrite [f+f.+1]addnS -{4}[f]muln1 -mulnS [f*2]mulnC. 94 | by rewrite I addnK addn1. 95 | move: H; rewrite -{1}[A:&:B]setIT -{1}(setUCr [set x|honest x]). 96 | rewrite setIUr cardsU setICA -!setIA setICr !setI0 cards0 subn0 2!setIA. 97 | move/subset_leq_card: (subsetIr (A :&: B) (~: [set x| honest x])). 98 | rewrite -(leq_add2l #|A :&: B :&: [set x|honest x]|)=> H2 H1. 99 | move: {H1 H2}(leq_trans H1 H2); rewrite [_ + #|~: _|]addnC -leq_subLR=>H. 100 | move: (leq_trans (leq_sub2l (f+1) cards_dishonest) H). 101 | by rewrite addnC addnK setIdE. 102 | Qed. 103 | 104 | Lemma intersectionP (A B: {set Validators}): 105 | (#|A| == (2*f).+1) && (#|B| == (2*f).+1) -> 106 | exists x, x \in [set x in A:&:B|honest x]. 107 | Proof. 108 | by move=> H; apply/set0Pn; rewrite -card_gt0 (intersection H). 109 | Qed. 110 | 111 | End BFTFacts. 112 | -------------------------------------------------------------------------------- /Structures/Chains.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq. 18 | From mathcomp 19 | Require Import path. 20 | Require Import Eqdep. 21 | Set Implicit Arguments. 22 | Unset Strict Implicit. 23 | Unset Printing Implicit Defensive. 24 | 25 | Open Scope seq_scope. 26 | Section Prefixes. 27 | 28 | Variable T : eqType. 29 | 30 | Implicit Type bc : seq T. 31 | 32 | (* Strict version of the prefix *) 33 | Definition is_strict_prefix bc bc':= 34 | exists b bc1, bc' = bc ++ (b :: bc1). 35 | 36 | Lemma isp_mt bc : ~ is_strict_prefix bc [::]. 37 | Proof. by case=>b[bc1]; case: bc. Qed. 38 | 39 | (* The corresponding checker *) 40 | Fixpoint sprefixb {T: eqType} (s1 s2 : seq T) := 41 | if s2 is y :: s2' then 42 | if s1 is x :: s1' then (x == y) && (sprefixb s1' s2') 43 | else true 44 | else false. 45 | 46 | Notation "'[' bc1 '<<<' bc2 ']'" := (sprefixb bc1 bc2). 47 | 48 | Lemma sprefixP bc1 bc2: 49 | reflect (is_strict_prefix bc1 bc2) [bc1 <<< bc2]. 50 | Proof. 51 | elim: bc2 bc1=>//=[|b2 bc2 Hi/=]bc1. 52 | - case:bc1=>//=[|b1 bc1]; constructor 2=>//; apply: isp_mt. 53 | case: bc1=>//[|b1 bc1]/=; first by constructor 1; exists b2, bc2. 54 | case X: (b1 == b2)=>/=; last first. 55 | - constructor 2=>[[p]][bc']; rewrite cat_cons; case=>Z; subst b2. 56 | by rewrite eqxx in X. 57 | - move/eqP: X=>X; subst b2. 58 | case: Hi=>H; [constructor 1|constructor 2]. 59 | - by case:H=>x[xs]->; exists x, xs; rewrite cat_cons. 60 | case=>x[xs]; rewrite cat_cons; case=>Z; subst bc2; apply: H. 61 | by exists x, xs. 62 | Qed. 63 | 64 | Lemma bc_spre_nrefl bc : [bc <<< bc] = false. 65 | Proof. 66 | by elim: bc=>[|x xs H] //=; rewrite eqxx H. 67 | Qed. 68 | 69 | (* Non-strict prefix *) 70 | Fixpoint prefixb bc1 bc2 := 71 | if bc2 is y :: bc2' then 72 | if bc1 is x :: bc1' then (x == y) && (prefixb bc1' bc2') 73 | else true 74 | else bc1 == [::]. 75 | 76 | Definition is_prefix bc bc' := 77 | exists bc1, bc' = bc ++ bc1. 78 | 79 | Notation "'[' bc1 '<<=' bc2 ']'" := (prefixb bc1 bc2). 80 | 81 | Lemma prefixb0seq bc : [[::] <<= bc]. Proof. by case: bc. Qed. 82 | 83 | Lemma prefixbseq0 bc: [bc <<= [::]] = (bc == [::]). Proof. by case bc. Qed. 84 | 85 | Lemma bc_pre_refl bc : [bc <<= bc]. 86 | Proof. 87 | by elim bc => [|x s IHs] //=; rewrite eqxx IHs. 88 | Qed. 89 | 90 | Lemma prefixb_belast bc1 b bc2: [bc1 <<= b :: bc2] = [bc1 <<= (belast b bc2)] || (bc1 == b :: bc2). 91 | Proof. 92 | move: bc1 b bc2; elim=> [b bc2|x s IH b]; first by rewrite 2!prefixb0seq. 93 | elim; first by rewrite prefixbseq0 //= prefixbseq0 eqseq_cons. 94 | by move => x' s' H; rewrite eqseq_cons //= (IH x' s') andb_orr. 95 | Qed. 96 | 97 | Lemma prefixP bc1 bc2: 98 | reflect (is_prefix bc1 bc2) [bc1 <<= bc2]. 99 | Proof. 100 | move: bc2 bc1; elim => [|b2 bc2 IH/=] bc1. 101 | - rewrite prefixbseq0 ; apply: (iffP eqP) => [->|] //=; first by exists [::]. 102 | case => [s H]; move: (size_cat bc1 s); rewrite -{}H /=; move/eqP. 103 | by rewrite eq_sym addn_eq0; move /andP =>[H _]; move/nilP: H. 104 | - move: bc1; case. 105 | - rewrite prefixb0seq //; apply/(iffP idP)=>//; exists (b2::bc2). 106 | by rewrite cat0s. 107 | - move => s l; apply/(iffP idP) => /= [|]. 108 | - move/andP => [Heq]; move/(IH l) => [ss Hss]; exists ss. 109 | by move/eqP: Heq->; move:Hss ->; rewrite cat_cons. 110 | - move=> [ss]; rewrite cat_cons; move/eqP; rewrite eqseq_cons eq_sym. 111 | move/andP => [H H']; rewrite H /=; apply/(IH l). 112 | by exists ss; move/eqP: H'. 113 | Qed. 114 | 115 | Lemma sprefixbseq0 bc: [bc <<< [::]] = false. 116 | Proof. by case bc =>// x s. Qed. 117 | 118 | Lemma sprefixb0seq b bc: [[::] <<< b :: bc]. 119 | Proof. by []. Qed. 120 | 121 | Lemma sprefix_prefix_belast bc1 b bc2: [bc1 <<< b :: bc2] = [bc1 <<= (belast b bc2)]. 122 | Proof. 123 | move: bc2 bc1 b ; elim=>[bc1 b |x s IH bc1 b] /=. 124 | - rewrite prefixbseq0; case bc1 => //[b' s']/=. 125 | by rewrite (sprefixbseq0 s') andbF eq_sym; apply/negP. 126 | - case bc1 => [|b' s']; first by rewrite prefixb0seq sprefixb0seq. 127 | by rewrite //=; move: (IH s' x)->. 128 | Qed. 129 | 130 | Lemma bc_spre_trans bc1 bc2 bc3: 131 | [bc1 <<< bc2] -> [bc2 <<< bc3] -> [bc1 <<< bc3]. 132 | Proof. 133 | move/sprefixP => [x][xs] ->; move/sprefixP => [x'][xs']->. 134 | by apply/sprefixP; exists x; exists (xs ++ x' :: xs'); rewrite -catA. 135 | Qed. 136 | 137 | Lemma bc_spre_pre bc bc': 138 | [bc <<< bc'] -> [bc <<= bc']. 139 | Proof. by move/sprefixP=>[] x [] xs=>->; apply/prefixP; exists (x :: xs). Qed. 140 | 141 | Lemma bc_pre_spre bc bc': 142 | [bc <<= bc'] = [bc <<< bc'] || (bc == bc'). 143 | Proof. 144 | case bc' => [|x' s']; first by rewrite prefixbseq0 sprefixbseq0. 145 | by rewrite prefixb_belast sprefix_prefix_belast. 146 | Qed. 147 | 148 | Lemma bc_spre_irrefl bc1 bc2 : 149 | [bc1 <<< bc2] && [bc2 <<< bc1] = false. 150 | Proof. 151 | case H: [bc1 <<< bc2]=>//=; case H': [bc2 <<< bc1] =>//=. 152 | move: (@bc_spre_trans _ _ _ H H'); rewrite bc_spre_nrefl //. 153 | Qed. 154 | 155 | (* Decidable fork *) 156 | Definition fork bc1 bc2 := 157 | ~~([bc1 <<< bc2] || [bc2 <<< bc1] || (bc1 == bc2)). 158 | 159 | Definition fork_rel bc1 bc2 := 160 | ~ ((is_prefix bc1 bc2) \/ (is_prefix bc2 bc1)). 161 | 162 | Lemma forkP bc1 bc2 : 163 | reflect (fork_rel bc1 bc2) (fork bc1 bc2). 164 | Proof. 165 | apply/introP; rewrite /fork_rel /fork. 166 | - rewrite orbC; move/norP => [H]; move/norP => [H1 H2]. 167 | case; move/prefixP; rewrite bc_pre_spre; apply/negPn; 168 | apply/norP; rewrite ?H1 ?H2 ?H; rewrite eq_sym in H; rewrite ?H=> //. 169 | by move/negPn; move/orP =>[|H]; first move/orP=> [H|H]; 170 | case; [left|right|left]; apply/prefixP; rewrite bc_pre_spre H // orbC //. 171 | Qed. 172 | 173 | Lemma bc_fork_neq bc bc' : 174 | fork bc bc' -> bc != bc'. 175 | Proof. 176 | move=>H; apply/negbT/negP=>Z; move/eqP:Z=>Z; subst bc'. 177 | by move: H; rewrite /fork eqxx orbC //=. 178 | Qed. 179 | 180 | Inductive bc_rel bc bc' : bool-> bool-> bool-> bool-> Set := 181 | | CmpBcEq of bc == bc' : bc_rel bc bc' true false false false 182 | | CmpBcFork of fork bc bc' : bc_rel bc bc' false true false false 183 | | CmpBcPre12 of sprefixb bc bc' : bc_rel bc bc' false false true false 184 | | CmpBcPre21 of sprefixb bc' bc: bc_rel bc bc' false false false true. 185 | 186 | Lemma bc_relP bc bc' : 187 | bc_rel bc bc' (bc == bc') (fork bc bc') (sprefixb bc bc') (sprefixb bc' bc). 188 | Proof. 189 | case Eq: (bc == bc'); case F: (fork bc bc'); 190 | case S12: [bc <<< bc']; case S21: [bc' <<< bc]; 191 | try by [constructor| 192 | contradict Eq; move: (bc_fork_neq F)=>/eqP=>A B; apply A; move/eqP in B | 193 | contradict F; rewrite /fork Eq S12 S21 //=| 194 | by move: (bc_spre_irrefl bc bc'); rewrite S12 S21 //= 195 | ]. 196 | - by move/idP: S12; move/eqP: Eq=>->; rewrite bc_spre_nrefl. 197 | - by move/idP: S21; move/eqP: Eq=>->; rewrite bc_spre_nrefl. 198 | Qed. 199 | 200 | End Prefixes. 201 | -------------------------------------------------------------------------------- /Structures/Blocks.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype fintype ssrfun seq path choice. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | From LibraChain 22 | Require Import SeqFacts Chains HashSign. 23 | 24 | Set Implicit Arguments. 25 | Unset Strict Implicit. 26 | Unset Printing Implicit Defensive. 27 | 28 | (* We now define VoteData, which is something we know how to hash and sign*) 29 | 30 | Open Scope sign_scope. 31 | Section BlockType. 32 | 33 | Variable Hash: countType. 34 | 35 | (*we establish an ordering on Hashes through the pickle function given by *) 36 | (*their countability (countType). We recall pickle is an injection in ℕ.*) 37 | Definition pickle_ordering: rel [eqType of Hash] := 38 | fun h1 h2 => (pickle h1) < (pickle h2). 39 | 40 | Lemma pickle_irref: irreflexive pickle_ordering. 41 | Proof. by move => x; rewrite /pickle_ordering ltnn. Qed. 42 | Lemma pickle_trans: transitive pickle_ordering. 43 | Proof. by move => x y z; rewrite /pickle_ordering; apply ltn_trans. Qed. 44 | Lemma pickle_spec: forall x y, [|| pickle_ordering x y, x == y | pickle_ordering y x]. 45 | Proof. move => x y; rewrite /pickle_ordering. 46 | case H: (pickle x == pickle y). 47 | - move/pcan_inj: (@pickleK Hash); move/(_ _ _ (eqP H))/eqP=>->. 48 | by rewrite orbT. 49 | by move/negbT: H; rewrite neq_ltn orbCA=>->; rewrite orbT. 50 | Qed. 51 | 52 | Definition hash_ordMixin := OrdMixin pickle_irref pickle_trans pickle_spec. 53 | Definition hash_ordType := OrdType _ hash_ordMixin. 54 | Canonical hash_ordType. 55 | 56 | Record VoteData := mkVD { 57 | block_hash: Hash; 58 | executed_hash: Hash; 59 | block_round: nat; 60 | parent_block_hash: Hash; 61 | parent_block_round: nat; 62 | }. 63 | 64 | 65 | Definition vote2nats (vd: VoteData) := 66 | (block_hash vd, executed_hash vd, block_round vd, parent_block_hash vd, parent_block_round vd). 67 | Definition nats2vote (nats: Hash * Hash * nat * Hash * nat) := 68 | let: (bh, eh, br, ph, pr) := nats in mkVD bh eh br ph pr. 69 | Lemma vote_nats_cancel: ssrfun.cancel vote2nats nats2vote. 70 | Proof. by move => []. Qed. 71 | 72 | Definition vote_data_eqMixin := CanEqMixin vote_nats_cancel. 73 | Canonical vote_data_eqType := 74 | Eval hnf in EqType _ vote_data_eqMixin. 75 | 76 | Definition vote_data_choiceMixin := CanChoiceMixin vote_nats_cancel. 77 | Canonical vote_data_choiceType := 78 | Eval hnf in ChoiceType _ vote_data_choiceMixin. 79 | 80 | Definition vote_data_countMixin := CanCountMixin vote_nats_cancel. 81 | Canonical vote_data_countType := 82 | Eval hnf in CountType VoteData vote_data_countMixin. 83 | 84 | (* The VoteMsg assumes there's a way to hash and sign VoteData*) 85 | (* The Pubkey, SignType are countTypes, reflecting they are serializable*) 86 | Variables (PublicKey: countType) (Signature: countType) 87 | (HashV: signType VoteData PublicKey Signature). 88 | 89 | Variable Address: hashType PublicKey. 90 | 91 | Record VoteMsg (phA: phant Address) := mkVM { 92 | vote_data: VoteData; 93 | vote: (PublicKey * Signature); 94 | }. 95 | 96 | Definition vm2triple (v: VoteMsg (Phant Address)) := 97 | let: mkVM vd pks := v in (vd, pks). 98 | 99 | Definition triple2vm (triple: VoteData * (PublicKey * Signature)) := 100 | let: (vd, pks) := triple in mkVM (Phant Address) vd pks. 101 | 102 | Lemma can_vm_triple: ssrfun.cancel vm2triple triple2vm. 103 | Proof. by move => []. Qed. 104 | 105 | Definition vm_eqMixin := CanEqMixin can_vm_triple. 106 | Canonical vm_eqType := EqType _ vm_eqMixin. 107 | 108 | Definition vm_choiceMixin := CanChoiceMixin can_vm_triple. 109 | Canonical vm_choiceType := ChoiceType _ vm_choiceMixin. 110 | 111 | Definition vm_countMixin := CanCountMixin can_vm_triple. 112 | Canonical vm_countType := 113 | Eval hnf in CountType _ vm_countMixin. 114 | 115 | Record QuorumCert (phA: phant Address) := mkQC { 116 | qc_vote_data: VoteData; 117 | qc_votes: seq (PublicKey * Signature); 118 | }. 119 | 120 | Definition qc2votes (qc: QuorumCert (Phant Address)) := 121 | let: mkQC vd votes := qc in (vd, votes). 122 | Definition votes2qc (vs: VoteData * seq (PublicKey * Signature)) := 123 | let: (vd, votes) := vs in mkQC (Phant Address) vd votes. 124 | Lemma can_qc_votes: ssrfun.cancel qc2votes votes2qc. 125 | Proof. by move => []. Qed. 126 | 127 | Definition qc_eqMixin := CanEqMixin can_qc_votes. 128 | Canonical qc_eqType := EqType _ qc_eqMixin. 129 | 130 | Definition qc_choiceMixin := CanChoiceMixin can_qc_votes. 131 | Canonical qc_choiceType := ChoiceType _ qc_choiceMixin. 132 | 133 | Definition qc_countMixin := CanCountMixin can_qc_votes. 134 | Canonical qc_countType := 135 | Eval hnf in CountType _ qc_countMixin. 136 | 137 | (* We can finally define the block type *) 138 | 139 | (* The hashability would imply the eqType, but we need serializability -> *) 140 | (* countType *) 141 | Variable Command: countType. 142 | Variable NodeTime: countType. 143 | 144 | Record BlockData := mkBD { 145 | (* Parent's hash pointer is in the QC *) 146 | (* Payload *) 147 | txs : seq Command; 148 | (* UnixTime (see liveness) *) 149 | time: NodeTime; 150 | round: nat; 151 | (* Parent's QC information *) 152 | proof : QuorumCert (Phant Address); 153 | }. 154 | 155 | Definition bd2qudruplet (bd: BlockData) := 156 | (txs bd, time bd, round bd, proof bd). 157 | Definition quadruplet2bd (q: seq Command * NodeTime * nat * QuorumCert(Phant Address)) := 158 | let: (tx, nt, r, pf) := q in mkBD tx nt r pf. 159 | Lemma cancel_bd_quadruplet: ssrfun.cancel bd2qudruplet quadruplet2bd. 160 | Proof. by move =>[]. Qed. 161 | 162 | Definition bd_eqMixin := CanEqMixin cancel_bd_quadruplet. 163 | Canonical bd_eqType := EqType _ bd_eqMixin. 164 | 165 | Definition bd_choiceMixin := CanChoiceMixin cancel_bd_quadruplet. 166 | Canonical bd_choiceType := ChoiceType _ bd_choiceMixin. 167 | 168 | Definition bd_countMixin := CanCountMixin cancel_bd_quadruplet. 169 | Canonical bd_countType := 170 | Eval hnf in CountType _ bd_countMixin. 171 | 172 | Record BlockType (hashB: BlockData -> Hash)(inj_hashB: injective hashB) (verifyB: Hash -> PublicKey -> Signature -> bool) := mkB { 173 | block_data: BlockData; 174 | block_source: PublicKey * Signature; 175 | }. 176 | 177 | Coercion block_data: BlockType >-> BlockData. 178 | 179 | Section BlockStructures. 180 | 181 | Variable hashB: BlockData -> Hash. 182 | Hypothesis hashB_inj: injective hashB. 183 | 184 | Definition Block_hashMixin := 185 | Eval hnf in HashMixin hashB_inj. 186 | 187 | Canonical Block_hashType := 188 | Eval hnf in HashType BlockData [ordType of Hash] Block_hashMixin. 189 | 190 | Variable verifB: Hash -> PublicKey -> Signature -> bool. 191 | 192 | Definition Block_signMixin := 193 | Eval hnf in SignMixin verifB. 194 | 195 | Canonical Block_signType := 196 | Eval hnf in SignType BlockData PublicKey Signature [ordType of Hash] Block_signMixin. 197 | 198 | Definition BD_eqMixin := 199 | Eval hnf in (InjEqMixin (@hash_inj _ Block_hashType)). 200 | Canonical BD_eqType := 201 | Eval hnf in EqType _ BD_eqMixin. 202 | 203 | Definition bt2bdnsource (bt: BlockType hashB_inj verifB) := 204 | let: mkB bd source := bt in (bd, source). 205 | Definition bdnsource2bt (bdnsource: BlockData * (PublicKey * Signature)) := 206 | let: (bd, source) := bdnsource in mkB hashB_inj verifB bd source. 207 | Lemma can_bt_bdnsource: ssrfun.cancel bt2bdnsource bdnsource2bt. 208 | Proof. by move => []. Qed. 209 | 210 | Definition bt_eqMixin := CanEqMixin can_bt_bdnsource. 211 | Canonical bt_eqType := EqType _ bt_eqMixin. 212 | Definition bt_choiceMixin := CanChoiceMixin can_bt_bdnsource. 213 | Canonical bt_choiceType := ChoiceType _ bt_choiceMixin. 214 | Definition bt_countMixin := CanCountMixin can_bt_bdnsource. 215 | Canonical bt_countType := CountType _ bt_countMixin. 216 | 217 | 218 | End BlockStructures. 219 | 220 | End BlockType. 221 | -------------------------------------------------------------------------------- /Structures/HashSign.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype fintype ssrfun seq path. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | From LibraChain 22 | Require Import SeqFacts Chains. 23 | 24 | Set Implicit Arguments. 25 | Unset Strict Implicit. 26 | Unset Printing Implicit Defensive. 27 | 28 | Module Hash. 29 | 30 | (* We start with hashable types, which are just codomains of a canonical *) 31 | (* injection into an ordType. *) 32 | 33 | Section RawMixin. 34 | 35 | (* Surprisingly, we do not need constraints on T: the mixin gives us an eqType *) 36 | (* structure on T, through being precisely eqType's InjEqMixin*) 37 | Variable T: Type. 38 | 39 | (* Note the definition of H as an ordtype allows usign them as union_map 40 | keys. *) 41 | 42 | Record mixin_of (H: Type) := Mixin { 43 | hash: T -> H; 44 | _ : injective hash 45 | }. 46 | 47 | End RawMixin. 48 | 49 | (* the class takes a naked type H and returns all the *) 50 | (* relatex mixins; the inherited ones and the added ones *) 51 | Section ClassDef. 52 | 53 | Variable T: Type. 54 | 55 | Record class_of (H: Type) := Class { 56 | base: Ordered.class_of H; 57 | mixin: mixin_of T (Ordered.Pack base) 58 | }. 59 | 60 | Local Coercion base : class_of >-> Ordered.class_of. 61 | 62 | Structure type (phH: phant T) := Pack { 63 | sort : Type; 64 | _ : class_of sort 65 | }. 66 | 67 | Local Coercion sort: type >-> Sortclass. 68 | 69 | Variables (phT: phant T) (H: ordType) (cH: type phT). 70 | Definition class := let: Pack _ c as cH' := cH return class_of cH' in c. 71 | Definition clone c of phant_id class c := @Pack phT H c. 72 | Let xH := let: @Pack _ H _ := cH in H. 73 | Definition xclass := (class: class_of xH). 74 | 75 | (* produce a hash type out of the inherited mixins *) 76 | (* equalize m0 and m by means of a phantom; will be exploited *) 77 | (* further down in the definition of HashType *) 78 | Definition pack b0 (m0 : mixin_of T (@Ordered.Pack H b0)) := 79 | fun bT b & phant_id (Ordered.class bT) b => 80 | fun m & phant_id m0 m => Pack phT (@Class H b m). 81 | 82 | (* FCSL bug?: not declaring its mixin/base coercions *) 83 | Local Coercion Ordered.base : Ordered.class_of >-> Equality.class_of. 84 | 85 | Definition eqType := Eval hnf in @Equality.Pack xH xclass. 86 | Definition ordType := Eval hnf in @Ordered.Pack xH xclass. 87 | End ClassDef. 88 | 89 | Module Import Exports. 90 | (* FCSL bug fixing*) 91 | Coercion Ordered.base : Ordered.class_of >-> Equality.class_of. 92 | 93 | (* Those are the liens analogous to the ones missing in FCSL *) 94 | Coercion base : class_of >-> Ordered.class_of. 95 | Coercion mixin : class_of >-> mixin_of. 96 | Coercion sort : type >-> Sortclass. 97 | Coercion eqType : type >-> Equality.type. 98 | Canonical eqType. 99 | Notation hashType T := (type (Phant T)). 100 | Notation HashType T H m := (@pack _ (Phant T) H _ m _ _ id _ id). 101 | Notation HashMixin := Mixin. 102 | Notation "[ 'hashType' T 'of' H 'for' cH ]" := (@clone _ (Phant T) H cH _ idfun) 103 | (at level 0, format "[ 'hashType' T 'of' H 'for' cH ]") : form_scope. 104 | Notation "[ 'hashType' T 'of' H ]" := (@clone _ (Phant T) H _ _ id) 105 | (at level 0, format "[ 'hashType' T 'of' H ]") : form_scope. 106 | End Exports. 107 | 108 | End Hash. 109 | 110 | Export Hash.Exports. 111 | 112 | Definition hash_op (T: Type) (H: hashType T) := 113 | Hash.hash (Hash.class H). 114 | 115 | Lemma hash_inj (T: Type) (H: hashType T) : injective (@hash_op T H). 116 | Proof. by case: H=> ?[b []]. Qed. 117 | 118 | Declare Scope hash_scope. 119 | Delimit Scope hash_scope with H. 120 | Open Scope hash_scope. 121 | 122 | (*******************************************************************************) 123 | (* The signatures in our case are really tuples composed of a public key and a *) 124 | (* signature. The public key injectively maps to an address, and the signature *) 125 | (* tuple is verifiable w.r.t a message. *) 126 | (*******************************************************************************) 127 | Module Signable. 128 | 129 | Section RawMixin. 130 | 131 | Variable T: Type. 132 | 133 | (* Public keys can canonically be hashed to an address *) 134 | Variable PublicKey: Type. 135 | (* In most practical cases, we expect to be able to hash the PublicKey to an *) 136 | (* eqType Address, which will be used as a finType or through a set *) 137 | Variable Address: hashType PublicKey. 138 | 139 | Variable Signature: eqType. 140 | 141 | Record mixin_of (H: Type) := Mixin { 142 | verify: H -> PublicKey -> Signature -> bool; 143 | }. 144 | 145 | End RawMixin. 146 | 147 | Section ClassDef. 148 | 149 | Variables (T: Type) (PublicKey: Type) (Signature : eqType). 150 | 151 | Structure class_of (H: Type) := Class { 152 | base : Hash.class_of T H; 153 | mixin : mixin_of PublicKey Signature (Hash.Pack (Phant T) base) 154 | }. 155 | 156 | Local Coercion base : class_of >-> Hash.class_of. 157 | 158 | Structure type (phT: phant T)(phP : phant PublicKey)(phS: phant Signature) := Pack {sort; _ : class_of sort}. 159 | 160 | Local Coercion sort : type >-> Sortclass. 161 | Variable (phT: phant T) (phP : phant PublicKey) (phS: phant Signature) (H: Type) (cH : type phT phP phS). 162 | Definition class := let: Pack _ c as cH' := cH return class_of cH' in c. 163 | Definition clone c of phant_id class c := @Pack phT phP phS H c. 164 | Let xH := let: @Pack _ _ _ H _ := cH in H. 165 | Notation xclass := (class : class_of xH). 166 | 167 | Definition pack b0 (m0 : mixin_of PublicKey Signature (@Hash.Pack _ (Phant T) H b0)) := 168 | fun bH b & phant_id (@Hash.class T (Phant T) bH) b => 169 | fun m & phant_id m0 m => @Pack phT phP phS _ (@Class H b m). 170 | 171 | (* Same FCSL "bug"*) 172 | (* if we had not re-exported that coercion above, we would need *) 173 | (* Local Coercion Ordered.base : Ordered.class_of >-> Equality.class_of. *) 174 | 175 | Definition eqType := Eval hnf in @Equality.Pack cH xclass. 176 | Definition ordType := Eval hnf in @Ordered.Pack cH xclass. 177 | Definition hashType := Eval hnf in @Hash.Pack _ (Phant T) cH xclass. 178 | 179 | End ClassDef. 180 | 181 | Module Import Exports. 182 | Coercion base : class_of >-> Hash.class_of. 183 | Coercion mixin : class_of >-> mixin_of. 184 | Coercion sort : type >-> Sortclass. 185 | Declare Scope signable_scope. 186 | Bind Scope signable_scope with sort. 187 | Coercion eqType : type >-> Equality.type. 188 | Canonical eqType. 189 | Coercion ordType : type >-> Ordered.type. 190 | Canonical ordType. 191 | Coercion hashType : type >-> Hash.type. 192 | Canonical hashType. 193 | 194 | Notation signType T P S := (type (Phant T) (Phant P) (Phant S)). 195 | 196 | Notation SignType T P S H m := (@pack _ _ _ (Phant T) (Phant P) (Phant S) H _ m _ _ id _ id). 197 | Notation SignMixin := Mixin. 198 | Notation "[ 'signType' P 'with' S 'of' H 'for' cH ]" := (@clone _ (Phant P) _ (Phant S) H cH _ idfun) 199 | (at level 0, format "[ 'signType' P 'with' S 'of' H 'for' cH ]") : form_scope. 200 | Notation "[ 'signType' P 'with' S 'of' H ]" := (@clone _ (Phant P) _ (Phant S) H _ _ id) 201 | (at level 0, format "[ 'signType' P 'with' S 'of' H ]") : form_scope. 202 | End Exports. 203 | 204 | End Signable. 205 | Export Signable.Exports. 206 | 207 | Declare Scope sign_scope. 208 | Delimit Scope sign_scope with S. 209 | Open Scope sign_scope. 210 | 211 | Definition verify_op (T P: Type) (S: eqType) (H: signType T P S) := 212 | Signable.verify (Signable.mixin (Signable.class H)). 213 | 214 | Section HonestNodes. 215 | 216 | Variable PublicKey: Type. 217 | (* PublicKey-s hash to Addresses*) 218 | Variable Address: hashType PublicKey. 219 | (* TODO: we may want to make PublicKey & Signature mutually dependent, *) 220 | (* i.e. have structure on a triplet of Private, Public keys and Signature *) 221 | Variable Signature: eqType. 222 | 223 | Variable T: Type. 224 | Variable H: signType T PublicKey Signature. 225 | 226 | (* Honest nodes are nodes that conditionally sign things*) 227 | Definition honest (condition: pred H)(a: Address) := 228 | fun (h:H)(p: PublicKey)(s: Signature) => 229 | (hash_op Address p) == a -> 230 | verify_op (h) p s -> condition h. 231 | 232 | End HonestNodes. 233 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /Structures/SeqFacts.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | 22 | Set Implicit Arguments. 23 | 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | 27 | (***************************************************) 28 | (* Some useful facts about lists *) 29 | (***************************************************) 30 | 31 | Section SeqFacts. 32 | 33 | Variable T: eqType. 34 | 35 | Implicit Types (x y :T). 36 | 37 | Lemma head_rcons x y (s: seq T): 38 | head x (rcons s y) = head y s. 39 | Proof. 40 | by case: s. 41 | Qed. 42 | 43 | Lemma subseq_re_cons x (s1 s:seq T): 44 | uniq s -> 45 | subseq (x::s1) s -> 46 | subseq s1 (drop (index x s).+1 s). 47 | Proof. 48 | elim: s x s1=>[|y ys IHs] x s1 //=. 49 | case Hxy: (y == x); move/andP=>[Hnin Huniq]; 50 | rewrite fun_if eq_sym Hxy ?drop0 //. 51 | by apply IHs. 52 | Qed. 53 | 54 | Lemma mask_rcons b m x s : 55 | size s = size m -> 56 | mask (rcons m b) (rcons s x) = mask m s ++ nseq b x. 57 | Proof. 58 | move: s m; apply seq_ind2; first by case b. 59 | move=> x0 y s t Hst; rewrite 2!rcons_cons mask_cons=>->. 60 | by rewrite mask_cons catA. 61 | Qed. 62 | 63 | Lemma subseq_rconsE x y s1 s: 64 | subseq (rcons s1 x) (rcons s y) = 65 | subseq (rcons s1 x) s || (subseq s1 s && (x == y)). 66 | Proof. 67 | apply/subseqP/orP. 68 | - case; case; first by move/eqP; rewrite eq_sym ?eqn0Ngt size_rcons. 69 | move=> a l; rewrite lastI; move/eqP; rewrite 2!size_rcons eqSS. 70 | move/eqP=> Hsz; rewrite mask_rcons ?Hsz //. 71 | case Hlast: (last a l)=> /= Hcons; [right|left]; last 72 | by rewrite cats0 in Hcons; apply/subseqP; exists (belast a l). 73 | move/eqP: Hcons; rewrite cats1 eqseq_rcons; move/andP=>[H ->]. 74 | by rewrite andbT; apply/subseqP; exists (belast a l); last apply/eqP. 75 | case=>[H|]. 76 | - by apply/subseqP; apply (subseq_trans H); apply subseq_rcons. 77 | move/andP=> [/subseqP[m Hsz Hm] Hxy]; exists (rcons m true). 78 | - by rewrite 2!size_rcons; apply/eqP; rewrite eqSS Hsz. 79 | rewrite mask_rcons //= cats1; apply/eqP; rewrite eqseq_rcons Hxy. 80 | by rewrite andbT Hm. 81 | Qed. 82 | 83 | Lemma take_index x s: 84 | take (index x s).+1 s = 85 | if (x \in s) then 86 | rcons (take (index x s) s) x 87 | else s. 88 | Proof. 89 | case H: (x \in s); move/idP: (H); rewrite -index_mem. 90 | - by move/(take_nth x); rewrite (nth_index _ (idP H)). 91 | by move/negP; rewrite -ltnNge; move/ltnW; move/take_oversize. 92 | Qed. 93 | 94 | Lemma subseq_re_rcons x s1 s: 95 | uniq s -> 96 | subseq (rcons s1 x) s -> 97 | subseq (rcons s1 x) (take (index x s).+1 s). 98 | Proof. 99 | elim/last_ind: s s1 x=> [|ys y IHs] s1 x Huniq; first by rewrite subseq0. 100 | rewrite rcons_uniq in Huniq; move/andP: Huniq=> [Hnin Huniq]. 101 | rewrite subseq_rconsE; case H: (subseq (rcons s1 x) ys). 102 | - have Hx: (x \in ys). 103 | - move: (cat_subseq (sub0seq s1) (subseq_refl [::x])). 104 | by rewrite cat0s cats1; move/subseq_trans/(_ H); rewrite sub1seq. 105 | have Hxs: (x \in (rcons ys y)); first by rewrite mem_rcons inE Hx orbT. 106 | move: (IHs s1 x Huniq H); rewrite 2!take_index Hx Hxs /=. 107 | by rewrite -[rcons ys y]cats1 index_cat Hx take_cat index_mem Hx. 108 | rewrite orFb; move/andP=> [Hsub Hxy]. 109 | rewrite take_oversize ?orFb ?subseq_rconsE. 110 | - by rewrite Hsub Hxy orbT. 111 | move: (Hnin); rewrite -{1}(eqP Hxy)=> Hxnin. 112 | rewrite -{2}[rcons ys y]cats1 index_cat (negbTE Hxnin). 113 | by rewrite leq_eqVlt; apply/orP; left; rewrite size_rcons (eqP Hxy) /= eq_refl addn0. 114 | Qed. 115 | 116 | Lemma subseq_stitch x (s1 s2 s: seq T): 117 | uniq s -> 118 | subseq (rcons s1 x) s -> 119 | subseq (x::s2) s -> 120 | subseq (s1 ++ x :: s2) s. 121 | Proof. 122 | move=> Huniq Hpref Hsuf. 123 | rewrite -(cat_take_drop (index x s).+1 s) -cat_rcons. 124 | apply: cat_subseq; first by apply: subseq_re_rcons. 125 | by apply: subseq_re_cons. 126 | Qed. 127 | 128 | Lemma rem_neq x y ls : 129 | x != y -> x \in ls -> x \in seq.rem y ls. 130 | Proof. 131 | move=>N; elim: ls=>//h ls Hi. 132 | rewrite inE; case/orP=>//=. 133 | - by move/eqP=>Z; subst h; move/negbTE: N=>->; rewrite inE eqxx. 134 | by case: ifP=>//=N' /Hi; rewrite inE orbC=>->. 135 | Qed. 136 | 137 | Lemma rem_neq_notin x y ls: 138 | x != y -> x \notin ls -> x \notin seq.rem y ls. 139 | Proof. 140 | move=>N; elim: ls=>//h ls Hi. 141 | rewrite inE; case/norP=>//=. 142 | move=>Neq Ni; specialize (Hi Ni); case: ifP=>//=. 143 | by move=>Hy; rewrite inE; apply/norP; rewrite Hi. 144 | Qed. 145 | 146 | Lemma in_seq x xs: 147 | x \in xs -> exists fs ls, xs = fs ++ x :: ls. 148 | Proof. 149 | move=>H. elim: xs H; first done. 150 | move=>h t Hi; rewrite in_cons; move/orP; case. 151 | by move/eqP=>->; exists [::], t. 152 | by move=>H; move: (Hi H); move=>[fs] [ls]=>->; exists (h :: fs), ls. 153 | Qed. 154 | 155 | Lemma in_seq_neq x xs : 156 | x \in xs -> exists fs ls, xs = fs ++ x :: ls /\ x \notin fs. 157 | Proof. 158 | move=>H. elim: xs H; first done. 159 | move=>h t Hi; rewrite in_cons; move/orP; case. 160 | by move/eqP=>->; exists [::], t. 161 | move=>H; move: (Hi H); move=>[fs][ls][->]G. 162 | case E: (x == h); last first. 163 | - by exists (h :: fs), ls; split; rewrite ?cat_cons// inE E G. 164 | by exists [::], (fs ++ x :: ls); split; move/eqP:E=>->. 165 | Qed. 166 | 167 | Lemma in_seq_excl x y (xs: seq T): 168 | x \in xs -> y \notin xs -> x != y. 169 | Proof. 170 | elim: xs=>[|h tl Hi]//. 171 | rewrite !in_cons; case/orP=> H; case/norP=>H0. 172 | by move/eqP in H; subst h=>_; rewrite eq_sym. 173 | by move=> H'; apply (Hi H H'). 174 | Qed. 175 | 176 | Lemma nth_in_default_irrel x0 y0 s (i: nat): 177 | i < size s -> 178 | nth x0 s i = nth y0 s i. 179 | Proof. 180 | elim: i s => [|n IHn] s; case: s => [| q qs] /=; first by rewrite ltn0. 181 | - by []. 182 | - by rewrite ltn0. 183 | - by rewrite ltnS => HH; rewrite IHn. 184 | Qed. 185 | 186 | Lemma not_in_filter_predC1 x s : 187 | x \notin filter (predC1 x) s. 188 | Proof. 189 | elim: s=> [|y ys IHs] //=; case H: (y == x)=> /=; first by apply IHs. 190 | by rewrite in_cons eq_sym H orFb IHs. 191 | Qed. 192 | 193 | Lemma not_in_all_predC1 x s: 194 | all (predC1 x) s = (x \notin s). 195 | Proof. 196 | elim: s => [|y s IHs] //. 197 | rewrite in_cons /all -/(all (predC1 x)) {1}/predC1 negb_or eq_sym /=. 198 | by apply: andb_id2l. 199 | Qed. 200 | 201 | Fixpoint rundup (s: seq T) := 202 | if s is x :: s' then x :: (filter (predC1 x) (rundup s')) else [::]. 203 | 204 | Lemma size_rundup s : size (rundup s) <= size s. 205 | Proof. elim: s => //= x s IHs; rewrite size_filter. 206 | by apply: (leq_ltn_trans (count_size _ _)). 207 | Qed. 208 | 209 | Lemma mem_rundup s : rundup s =i s. 210 | Proof. 211 | move=> x; elim: s => //= y s IHs; rewrite 2!inE -IHs. 212 | by case H:(x == y) => //=; rewrite mem_filter /= H. 213 | Qed. 214 | 215 | Lemma rundup_uniq s : uniq (rundup s). 216 | Proof. 217 | elim: s => //= x s IHs; rewrite mem_filter /= eq_refl /=. 218 | by rewrite filter_uniq. 219 | Qed. 220 | 221 | Lemma rundup_id s : uniq s -> rundup s = s. 222 | Proof. 223 | elim: s => //= x s IHs /andP [H /IHs->]. 224 | have/all_filterP: (all (predC1 x) s)=>[|->] //. 225 | rewrite all_predC; apply/hasP=> [[x1 Hx1]]; move/eqP=> eqxx1. 226 | by move: H; rewrite -eqxx1; move/negP. 227 | Qed. 228 | 229 | Lemma predC_pred1 x : pred1 x =1 [eta predC [pred x0 | x0 != x]]. 230 | Proof. 231 | move=> x0; apply/eqP. 232 | rewrite /predC /=; case H: (x0 == x)=> /=; by apply/eqP; rewrite ?H. 233 | Qed. 234 | 235 | Lemma count_predC1Pn x s : (count (predC1 x) s == size s) = (x \notin s). 236 | Proof. 237 | rewrite /predC1 -(count_predC [pred x0| x0 != x]) -{1}[count _ s]addn0 -has_pred1 has_filter. 238 | rewrite eqn_add2l -size_filter eq_sym; apply/nilP; rewrite if_neg -(eq_filter (predC_pred1 x)). 239 | case H: ([seq x0 <- s| (pred1 x) x0] == [::])=> /=; apply/eqP; first by []. 240 | by rewrite H. 241 | Qed. 242 | 243 | Lemma all_filter (a: pred T) (s: seq T): (filter a s == s) = all a s. 244 | Proof. 245 | by apply/eqP; case H: (all a s); apply/all_filterP; [|rewrite H]. 246 | Qed. 247 | 248 | Lemma all_notin (s: seq T) x: (all (predC1 x) s) = (x \notin s). 249 | Proof. 250 | elim: s =>[| x0 s IHs] //; rewrite in_cons /= negb_or IHs. 251 | by apply andb_id2r; rewrite eq_sym. 252 | Qed. 253 | 254 | Lemma ltn_size_rundup s : (size (rundup s) < size s) = ~~ uniq s. 255 | Proof. 256 | case Huniq: (uniq s) =>/=; first by move/rundup_id: Huniq=>->; rewrite ltnn. 257 | apply: idP; move/negP: Huniq; elim: s => [| x s IHs] //=; rewrite ltnS. 258 | move/negP; rewrite negb_and; move/orP=> [Hnin|Hnuniq]. 259 | - move: Hnin; rewrite -mem_rundup -count_predC1Pn=> Hnin. 260 | move: (count_size (predC1 x) (rundup s)); rewrite leq_eqVlt; move/negbTE: Hnin=>->. 261 | rewrite orFb size_filter; move/leq_trans; apply; exact: size_rundup. 262 | rewrite size_filter; apply: (leq_ltn_trans (count_size (predC1 x) (rundup s))). 263 | by rewrite IHs //; apply/negP. 264 | Qed. 265 | 266 | Lemma rundup_nil s : rundup s = [::] -> s = [::]. 267 | Proof. by case: s => //= x s; rewrite -mem_rundup; case: ifP; case: rundup. Qed. 268 | 269 | Lemma predIC (p q: pred T) : predI p q =1 predI q p. 270 | Proof. 271 | by move => x /=; rewrite andbC. 272 | Qed. 273 | 274 | Lemma filter_rundup p s : filter p (rundup s) = rundup (filter p s). 275 | Proof. 276 | elim: s => //= x s IHs; rewrite (fun_if rundup) /= fun_if -filter_predI. 277 | rewrite (eq_filter (predIC p _)) filter_predI IHs; case H: (p x) => //=. 278 | apply/eqP; rewrite all_filter all_notin. 279 | by rewrite -IHs mem_filter H andFb. 280 | Qed. 281 | 282 | Lemma predC1_eq s x: x::s =i x::(filter (predC1 x) s). 283 | Proof. 284 | move=> y; rewrite 2!in_cons; case Hyx: (y == x); first by []. 285 | by rewrite 2!orFb mem_filter /= Hyx andTb. 286 | Qed. 287 | 288 | Lemma predC1_split s x: x \in s -> s =i x::(filter (predC1 x) s). 289 | Proof. 290 | elim: s=> [|y s IHs] Hx //. 291 | move: Hx; rewrite in_cons; case Hxy: (x == y). 292 | - by move/eqP: Hxy=>-> _; rewrite /filter {1}/predC1 /= eq_refl; apply: predC1_eq. 293 | rewrite orFb; move/IHs=> Hs; rewrite /filter {1}/predC1 /= eq_sym Hxy /=. 294 | move=> z; rewrite 3!in_cons; case Hx: (z == y); first by rewrite orbT. 295 | rewrite 2!orFb -in_cons; move: z {Hx}; apply Hs. 296 | Qed. 297 | 298 | Lemma cat_take_drop_in s x: 299 | x \in s -> 300 | take (index x s) s ++ x :: drop (index x s).+1 s == s. 301 | Proof. 302 | move=> Hx; rewrite -{2}(nth_index x Hx). 303 | rewrite -cat_rcons -take_nth; last by rewrite index_mem. 304 | by rewrite cat_take_drop. 305 | Qed. 306 | 307 | Lemma rem_elem (p : T) xs ys : 308 | p \notin xs-> seq.rem p (xs ++ p :: ys) = xs ++ ys. 309 | Proof. 310 | elim: xs=>//=; first by rewrite eqxx. 311 | move=>x xs Hi; rewrite inE=>/norP[H1 H2]. 312 | by move/negbTE: H1; rewrite eq_sym=>->; rewrite (Hi H2). 313 | Qed. 314 | 315 | Lemma dom_ord1 {K: ordType} (j : K) (w : T) m : 316 | valid (j \\-> w \+ m) -> 317 | path ord j (dom m) -> 318 | dom (j \\-> w \+ m) = j :: (dom m). 319 | Proof. 320 | elim/um_indf: m=>/=[||k v m Hi V' P' V P]. 321 | - by case: validUn=>//=_; rewrite valid_undef. 322 | - by rewrite unitR dom0 domPtK. 323 | rewrite -joinCA in V; move: Hi; move/(_ (validR V))=> Hi. 324 | have A: antisymmetric ord by move=>???/andP[]H1 H2; move: (nsym H1 H2). 325 | apply: (eq_sorted (@trans K) (A K))=>//=. 326 | rewrite joinCA in V. 327 | apply: uniq_perm=>/=; rewrite ?dom_uniq ?[_&&true]andbC//=. 328 | - case: validUn V=>//_ _/(_ j). 329 | by rewrite domPtK inE eqxx uniq_dom=>/(_ is_true_true) ? ?; apply/andP. 330 | move=>z; rewrite !inE !domUn !inE V domPtK inE (eq_sym z k). 331 | by rewrite (validR V)/= domPtUn V'/= domPtK !inE. 332 | Qed. 333 | 334 | Lemma path_ord_sorted {K: ordType} z j (l : seq K) : 335 | sorted ord l -> path ord j l -> z \in l -> ord j z. 336 | Proof. 337 | elim: l z=>//h l Hi z/=P/andP[O _]. 338 | rewrite inE; case/orP; first by move/eqP=>->. 339 | move=>I; apply: Hi=>//; first by apply:(path_sorted P). 340 | clear I z; case: l O P=>//=x xs O/andP[O' ->]; rewrite andbC/=. 341 | by apply: (@trans K _ _ _ O O'). 342 | Qed. 343 | 344 | Lemma dom_ord2 {K: ordType} (j k : K) (w v : T) m: 345 | valid (k \\-> v \+ (j \\-> w \+ m)) -> 346 | path ord j (dom m) -> 347 | dom (pts j w \+ (k \\-> v \+ m)) = 348 | if ord j k then j :: dom (k \\-> v \+ m) else k :: j :: (dom m). 349 | Proof. 350 | have A: antisymmetric ord by move=>???/andP[]H1 H2; move: (nsym H1 H2). 351 | case: ifP=>X V P; rewrite joinCA in V. 352 | - apply: (eq_sorted (@trans K) (A K))=>//=. 353 | + rewrite path_min_sorted //. 354 | apply/allP=> z; rewrite domUn inE (validR V) domPtK inE /=. 355 | case/orP; first by move/eqP=>->. 356 | by move/(path_ord_sorted (sorted_dom m) P). 357 | apply: uniq_perm=>/=; rewrite ?dom_uniq ?[_&&true]andbC//=. 358 | + by case: validUn V=>//_ _/(_ j); 359 | rewrite domPtK inE eqxx=>/(_ is_true_true) ? ?; apply/andP. 360 | move=>z; rewrite !inE !domUn !inE V domPtK inE /=. 361 | by rewrite (validR V)/= domPtUn /= domPtK !inE (validR V) (eq_sym z k). 362 | apply: (eq_sorted (@trans K) (A K))=>//=. 363 | - rewrite P andbC/=; case/orP: (total k j) X=>///orP[]; last by move=>->. 364 | move/eqP=>Z; subst j. 365 | case: validUn (V)=>//_ _/(_ k); rewrite domPtK inE eqxx=>/(_ is_true_true). 366 | by rewrite domUn inE domPtK inE eqxx/= andbC(validR V). 367 | apply: uniq_perm=>/=; rewrite ?dom_uniq ?[_&&true]andbC//=. 368 | - rewrite joinCA in V; case: validUn (V)=>//_ _/(_ k). 369 | rewrite domPtK inE eqxx=>/(_ is_true_true)=>/negP N _. 370 | apply/andP; split; last first. 371 | + case: validUn (validR V)=>//_ _/(_ j). 372 | by rewrite domPtK inE eqxx=>/(_ is_true_true) ? ?; apply/andP. 373 | rewrite inE; apply/negP=>M; apply: N. 374 | by rewrite domUn inE (validR V) domPtK inE. 375 | move=>z; rewrite !inE !domUn !inE V domPtK inE eq_sym/=. 376 | rewrite domUn inE (validR V)/= domPtK inE. 377 | by case: (j == z)=>//; case: (z == k). 378 | Qed. 379 | 380 | Lemma dom_insert {K: ordType} (k : K) (v : T) m : 381 | valid (k \\-> v \+ m) -> 382 | exists ks1 ks2, dom m = ks1 ++ ks2 /\ 383 | dom (k \\-> v \+ m) = ks1 ++ k :: ks2. 384 | Proof. 385 | move=>V; elim/um_indf: m V=>//[||j w m' Hi V' P V]. 386 | - by case: validUn=>//=_; rewrite valid_undef. 387 | - by rewrite unitR dom0 domPtK; exists [::], [::]. 388 | move: (V); rewrite -joinCA=>/validR/Hi[ks1][ks2][E1]E2. 389 | (* So, j < (dom m'), hence it goes at the head *) 390 | rewrite (dom_ord1 V' P) E1 (dom_ord2 V P) !E1 E2. 391 | case: ifP=>_; first by exists (j :: ks1), ks2. 392 | by exists [::], (j :: ks1 ++ ks2). 393 | Qed. 394 | 395 | End SeqFacts. 396 | -------------------------------------------------------------------------------- /Properties/Safety.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq choice fintype path finset. 18 | Require Import Eqdep. 19 | Set Implicit Arguments. 20 | Unset Strict Implicit. 21 | Unset Printing Implicit Defensive. 22 | 23 | Section SeqSubMissing. 24 | Variables (T : choiceType) (s : seq T). 25 | Local Notation sT := (seq_sub s). 26 | 27 | Variable (D: pred T). 28 | 29 | Lemma card_seq_sub : uniq s -> #|[set x:sT| D (val x)]| = size (filter D s). 30 | Proof. 31 | move=> Us; case: (pickP (fun x: sT => D(val x)))=> [x Px |P0]. 32 | - rewrite -(card_seq_sub (filter_uniq D Us)). 33 | move/valP: (x)=> Hx. 34 | have: (val x \in filter D s); first by rewrite mem_filter Px Hx. 35 | rewrite -(codom_val (seq_sub_subFinType (filter D s))). 36 | move/codomP=> [x0 Hxx0]; pose f := fun (x:sT) => insubd x0 (val x). 37 | rewrite -(@card_in_imset _ _ f); first apply eq_card. 38 | - move=> x1; rewrite inE; apply/idP; apply/imsetP. 39 | move/valP: (x1); rewrite mem_filter; move/andP=> [Dx1 Hx1]. 40 | exists (insubd x (val x1)); last by rewrite /f /= insubdK; [rewrite valKd| rewrite Hx1 ]. 41 | by rewrite /insubd (insubT _) inE /= Dx1. 42 | move=> y2 y1 Hy2 Hy1; rewrite in_set in Hy1; rewrite in_set in Hy2. 43 | rewrite /f /insubd (insubT _) /=; first by rewrite mem_filter (valP y2) Hy2. 44 | rewrite (insubT _) /=; first by rewrite mem_filter (valP y1) Hy1. 45 | move=> Hyp1 Hyp2; case; apply val_inj. 46 | rewrite cardsE; move/eq_card0: (P0)=>->; rewrite size_filter. 47 | apply/eqP/negPn; rewrite eq_sym -lt0n -has_count. 48 | rewrite negbT //; apply/hasP; move => [x Hx Dx]. 49 | move: Hx; rewrite -(codom_val (seq_sub_subFinType s))=> Hcd. 50 | by move/codomP: Hcd=> [x0 Hxx0]; move: (P0 x0); rewrite -Hxx0 Dx. 51 | Qed. 52 | 53 | End SeqSubMissing. 54 | 55 | From fcsl 56 | Require Import pred prelude ordtype pcm finmap unionmap heap. 57 | From LibraChain 58 | Require Import SeqFacts Chains HashSign Blocks ConsensusState BlockTree BFTFacts. 59 | 60 | Section Safety. 61 | (* We require Hashes, Addresses, Signatures and PublicKeys to be numbers in *) 62 | (* some fashion, i.e. to have an injective embedding in ints *) 63 | Variable Hash : countType. 64 | 65 | Variables (PublicKey: countType) (Signature: countType). 66 | Variable Address: hashType PublicKey. 67 | 68 | (* The Block Data (w/o signatures) *) 69 | Notation BDataType := (BlockData Hash Signature Address Command NodeTime). 70 | 71 | Variable hashB: BDataType -> Hash. 72 | Hypothesis inj_hashB: injective hashB. 73 | 74 | Variable verifB: Hash -> PublicKey -> Signature -> bool. 75 | 76 | (* Block Type : block data with signatures *) 77 | Notation BType := (BlockType inj_hashB verifB). 78 | Notation QC := (QuorumCert Hash Signature (Phant Address)). 79 | 80 | Canonical BDHType := Eval hnf in (Block_hashType inj_hashB). 81 | Canonical BSType := Eval hnf in (Block_signType inj_hashB verifB). 82 | 83 | Implicit Type b: BDataType. 84 | 85 | Notation "# b" := (hashB b) (at level 20). 86 | 87 | Parameter peers : seq Address. 88 | 89 | (* f is the byzantine fraction (see below) *) 90 | Variable f: nat. 91 | 92 | (* boolean predicate for all signatures in a sequence to be valid *) 93 | Definition all_valid (h: Hash) (s: seq (PublicKey * Signature)) := 94 | all (fun ps => (@verify_op _ _ _ BSType h (fst ps) (snd ps))) s. 95 | 96 | (* a valid qc only contains distinct and valid signatures *) 97 | Definition qc_valid (qc: QC) := 98 | all_valid (block_hash (qc_vote_data qc)) (qc_votes qc) && (uniq (qc_votes qc)). 99 | 100 | (* a valid block is properly signed by its emitter *) 101 | Definition source_valid (block: BType) := 102 | let: (p, s) := (block_source block) in 103 | (@verify_op _ _ _ BSType (#block) p s). 104 | 105 | Notation BlockStore := (BlockTree inj_hashB verifB). 106 | 107 | (* Nodes have a public key, log of processed blocks and block store*) 108 | Record NodeState := mkNode { 109 | public_key: PublicKey; 110 | block_log: seq BType; 111 | }. 112 | 113 | Definition node_state2components (ns: NodeState) := 114 | let: mkNode pk bl := ns in (pk, bl). 115 | 116 | Definition components2node_state (tuple: PublicKey * seq BType) := 117 | let: (pk, bl) := tuple in mkNode pk bl. 118 | 119 | Lemma can_ns_components: ssrfun.cancel node_state2components components2node_state. 120 | Proof. by move => []. Qed. 121 | 122 | (* There are a half-dozen wrong things that have turned wrong for me to do this by hands, TODO: *) 123 | (* diagnose & fix*) 124 | Canonical BlockTree_eqType := (union_map_eqType [ordType of Hash] [eqType of BType]). 125 | 126 | Definition ns_eqMixin := CanEqMixin can_ns_components. 127 | Canonical ns_eqType := EqType _ ns_eqMixin. 128 | 129 | Definition ns_choiceMixin := CanChoiceMixin can_ns_components. 130 | Canonical ns_choiceType := ChoiceType _ ns_choiceMixin. 131 | 132 | Definition ns_countMixin := CanCountMixin can_ns_components. 133 | Canonical ns_countType := CountType _ ns_countMixin. 134 | 135 | Notation GenesisState := (genesis_state inj_hashB verifB ). 136 | 137 | Definition addr_of(n: NodeState) := (hash_op Address (public_key n)). 138 | 139 | Definition qc_keys(qc: QC) := 140 | unzip1 (qc_votes qc). 141 | 142 | Definition qc_addresses(qc: QC) := 143 | map (hash_op Address) (qc_keys qc). 144 | 145 | Variable validator_nodes: seq NodeState. 146 | Hypothesis Huniq: uniq validator_nodes. 147 | Hypothesis inj_keys: {in validator_nodes, injective public_key}. 148 | 149 | Definition Validator:= seq_sub validator_nodes. 150 | 151 | Definition node_keys := 152 | map public_key validator_nodes. 153 | 154 | Definition NodeKey := seq_sub node_keys. 155 | 156 | Lemma mem_node_keys (v: Validator): 157 | (public_key (val v)) \in node_keys. 158 | Proof. 159 | rewrite /node_keys; apply/mapP; exists (val v)=> //. 160 | by move/valP: (v). 161 | Qed. 162 | 163 | Definition to_pk (v: Validator): NodeKey := 164 | Sub (public_key (val v)) (mem_node_keys v). 165 | 166 | Lemma inj_to_pk : injective to_pk. 167 | Proof. 168 | move=> x1 x2; case; by move/(inj_keys (valP x1))/val_inj. 169 | Qed. 170 | 171 | Definition qc_relevant(qc: QC):= 172 | filter (fun pk => pk \in node_keys) (undup (qc_keys qc)). 173 | 174 | (* There is a finite number of blocks at any given time *) 175 | 176 | Definition all_blocks := 177 | flatten [seq block_log n | n <- validator_nodes]. 178 | 179 | Definition BlockFinType := seq_sub all_blocks. 180 | 181 | Section ValidBlocks. 182 | 183 | Definition valid_pred (block: BType) := 184 | source_valid block && qc_valid (qc_of block) && (size (qc_relevant (qc_of block)) == 2*f+1) && (qc_hash block != #block). 185 | 186 | (* Valid blocks are the small subType which presents with enough valid *) 187 | (* signatures *) 188 | Record valid_block : Type := mkValid { 189 | block :> BlockFinType; 190 | _: valid_pred (val block); 191 | }. 192 | 193 | Canonical valid_block_subType := Eval hnf in [subType for block]. 194 | Definition valid_block_eqMixin := Eval hnf in [eqMixin of valid_block by <:]. 195 | Canonical valid_block_eqType := Eval hnf in EqType _ valid_block_eqMixin. 196 | Definition valid_block_choiceMixin := [choiceMixin of valid_block by <:]. 197 | Canonical valid_block_choiceType := Eval hnf in ChoiceType valid_block valid_block_choiceMixin. 198 | Definition valid_block_countMixin := [countMixin of valid_block by <:]. 199 | Canonical valid_block_countType := Eval hnf in CountType valid_block valid_block_countMixin. 200 | Canonical valid_block_subCountType := Eval hnf in [subCountType of valid_block]. 201 | Definition valid_block_finMixin := [finMixin of valid_block by <:]. 202 | Canonical valid_block_finType := Eval hnf in FinType valid_block valid_block_finMixin. 203 | Canonical valid_block_subFinType := Eval hnf in [subFinType of valid_block]. 204 | 205 | Implicit Type vb : valid_block. 206 | 207 | Definition type_val (vb: valid_block) : BType := 208 | ((val \o val) vb). 209 | Coercion type_val: valid_block >-> BType. 210 | 211 | Definition data_val (vb: valid_block) : BDataType := 212 | ((val \o val) vb). 213 | Coercion data_val: valid_block >-> BDataType. 214 | 215 | Definition valid vb mkB : valid_block := 216 | mkB (let: mkValid _ vbP := vb return (source_valid vb) && qc_valid (qc_of vb) && (size (qc_relevant (qc_of vb)) == 2*f+1) && (qc_hash vb != #vb) in vbP). 217 | 218 | Lemma valid_blockE vb : valid (fun sP => @mkValid vb sP) = vb. 219 | Proof. by case: vb. Qed. 220 | 221 | Parameter GenesisBlock : valid_block. 222 | 223 | (* node_in_votes captures the inclusion of this node in the block's signatures *) 224 | Definition node_in_votes(n: NodeState): pred valid_block := 225 | fun vb => addr_of n \in (qc_addresses (qc_of vb)). 226 | 227 | Notation "'qc#' vb" := (qc_hash vb) (at level 40). 228 | 229 | (* The parenthood relationship over valid blocks *) 230 | Definition vb_parent := 231 | [eta (parent hashB): rel valid_block]. 232 | 233 | (* The chaining relationship — parents with consecutive round — over valid blocks *) 234 | Definition vb_direct_parent (vb1 vb2: valid_block) := 235 | direct_parent vb1 vb2. 236 | 237 | Definition voted_by_node(n: NodeState): seq BType := 238 | [ seq b <- block_log n | ((block_data b) \in voted_in_processing GenesisState [seq block_data i | i <- block_log n]) && (valid_pred b)]. 239 | 240 | (* block_in_voting captures the inclusion of the valid block in the node's *) 241 | (* voting log *) 242 | Definition block_in_voting(n: NodeState): pred valid_block := 243 | fun (vb:valid_block) => has (fun b:BType => parent hashB b vb) (voted_by_node n). 244 | 245 | (* This captures that the only blocks one can find this node's signatures are *) 246 | (* those in its voting log => the node only votes according to the procedure *) 247 | (* we describe in voted_by_node. *) 248 | Definition honest : pred NodeState := fun n => 249 | [set vb |node_in_votes n vb] \subset [set vb|block_in_voting n vb]. 250 | 251 | Hypothesis BFT: 252 | (#|[set x : Validator |honest (val x)]| >= (2*f).+1) && 253 | (size validator_nodes == (3*f).+1). 254 | 255 | (* the definition of node_in_votes through the injective hashes (addresses) of *) 256 | (* public keys is the same as enumerating the public keys *) 257 | Lemma nodes_in_votes_relevantE vb: 258 | [set v: Validator| node_in_votes (val v) vb] = 259 | [set v: Validator| (public_key (val v)) \in (qc_keys (qc_of vb))]. 260 | Proof. 261 | apply eq_finset=> x/=. 262 | rewrite /node_in_votes /qc_addresses /addr_of mem_map //. 263 | by apply hash_inj. 264 | Qed. 265 | 266 | Lemma validators_in_votes vb: 267 | #|[set v: Validator| node_in_votes (val v) vb]| == (2*f).+1. 268 | Proof. 269 | rewrite -addn1. 270 | move/valP/andP: (vb)=> [/andP[_ H] _]; move/eqP: H=><-; rewrite nodes_in_votes_relevantE. 271 | rewrite (@card_seq_sub _ _ (fun (v:NodeState) => (public_key v) \in _) Huniq). 272 | rewrite -(size_map public_key) -uniq_size_uniq. 273 | - rewrite map_inj_in_uniq ?filter_uniq //. 274 | move=> x y; rewrite 2!mem_filter; move/andP=>[_ Hx]; move/andP=>[_ Hy]. 275 | by apply (inj_keys Hx). 276 | - by rewrite /qc_relevant filter_uniq // undup_uniq. 277 | move=> x; rewrite /qc_relevant /node_keys mem_filter mem_undup. 278 | by rewrite -filter_map mem_filter /= andbC. 279 | Qed. 280 | 281 | Lemma honest_in_one_block (vb: valid_block): 282 | exists (x: Validator), (node_in_votes (val x) vb) && honest (val x). 283 | Proof. 284 | move/card_S2f_gt: (validators_in_votes vb); move/(_ Huniq)=> Hcard. 285 | move: (Hcard _ BFT). 286 | move/(leq_ltn_trans (leq0n f)); rewrite card_gt0; move/set0Pn=>[x]. 287 | rewrite !inE; move/andP=> [Hn Hh]; by exists x; apply/andP. 288 | Qed. 289 | 290 | (* The intersection lemma implies a honest validator voted for any pair of blocks*) 291 | Lemma honest_in_two_blocks (vb1 vb2: valid_block): 292 | exists (x:Validator), (node_in_votes (val x) vb1 && node_in_votes (val x) vb2 && honest (val x)). 293 | Proof. 294 | move: (validators_in_votes vb1) (validators_in_votes vb2)=> Hvb1 Hvb2. 295 | move/andP: (conj Hvb1 Hvb2)=> H12; move: {Hvb1 Hvb2 H12}(intersectionP Huniq BFT H12). 296 | move=>[x]; rewrite 4!inE; move/andP => [H12 Hhx]; move/andP: {H12}H12=>[H1 H2]. 297 | by exists x; rewrite Hhx H1 H2. 298 | Qed. 299 | 300 | (* That node has both blocks in its logs *) 301 | Lemma honest_voted_two_blocks (vb1 vb2: valid_block): 302 | exists (n: Validator), (block_in_voting (val n) vb1) && (block_in_voting (val n) vb2 && honest(val n)). 303 | Proof. 304 | move: (honest_in_two_blocks vb1 vb2)=> [x]; move/andP=> [H12 Hh]. 305 | move/andP: H12=> [H1 H2]; exists x; rewrite Hh. 306 | move/subsetP: (Hh); move/(_ vb1); rewrite inE H1 inE=> -> //. 307 | by move/subsetP: Hh; move/(_ vb2); rewrite inE H2 inE=> -> //. 308 | Qed. 309 | 310 | (* This is the off-by one difference between most formalisms of LibraBFT and *) 311 | (* the present Coq formalization. LibraBFT often speaks of confirmed / QC'ed blocks and *) 312 | (* focuses on the blocks, treating the downward blocks which QC confirms them *) 313 | (* implicitly. We can't afford to do this in Coq — since we chose to not have *) 314 | (* an entire separate relation and type for "dangling" QCs — hence we have to *) 315 | (* be very explicit with naming these confirming blocks. Hence note that here, *) 316 | (* we express that if vb is in the vote log of n, its parent is voted for. *) 317 | Lemma block_in_voting_processingP (n:NodeState) vb: 318 | (block_in_voting n vb) -> 319 | exists b, (parent hashB b vb) && 320 | (b \in (voted_in_processing GenesisState [seq block_data i | i <- block_log n])). 321 | Proof. 322 | move/hasP=> [b Hvb Hhb]; exists b; rewrite Hhb andTb. 323 | by move: Hvb; rewrite mem_filter; move/andP=> [/andP[-> Hval] Hlog]. 324 | Qed. 325 | 326 | (* This is S2 in LibraBFT v2. The statement on state hashes is trivial *) 327 | (* editing block_in_voting *) 328 | Lemma valid_blocks_same_round_equal (vb1 vb2: valid_block): 329 | (qc_round vb1 == qc_round vb2) -> qc# vb1 == qc# vb2. 330 | Proof. 331 | move=> Hr. 332 | move: (honest_voted_two_blocks vb1 vb2)=> [n]; move/andP=> [H1 /andP[H2 Hh]]. 333 | move/block_in_voting_processingP: H1=> [b1 /andP [Hb1 Hproc1]]. 334 | move/block_in_voting_processingP: H2=> [b2 /andP [Hb2 Hproc2]]. 335 | case H12: (b1 == b2). 336 | - by move/andP: Hb1=>[/andP[/andP[/eqP[<-] _] _] _]; move/andP: Hb2=>[/andP[/andP[/eqP[<-] _] _] _]; move/eqP: H12=>->. 337 | case/orP: (leq_total (round b1) (round b2)). 338 | - move/(voted_in_processing_ltn (negbT H12) Hproc1 Hproc2); move/ltn_eqF. 339 | by move/andP: Hb1=>[/andP[/andP[_ /eqP[->]] _] _]; move/andP: Hb2=>[/andP[/andP[_ /eqP[->]] _] _]; rewrite Hr. 340 | rewrite eq_sym in H12. 341 | move/(voted_in_processing_ltn (negbT H12) Hproc2 Hproc1); move/ltn_eqF. 342 | by move/andP: Hb1=>[/andP[/andP[_ /eqP[->]] _] _]; move/andP: Hb2=>[/andP[/andP[_ /eqP[->]] _] _]; rewrite eq_sym Hr. 343 | Qed. 344 | 345 | Lemma valid_qc_ancestor_is_parent (n: NodeState) (block: BType) vb: 346 | parent hashB block vb -> 347 | block_in_voting n vb -> 348 | (block_data block \in (voted_in_processing GenesisState [seq block_data i | i<- block_log n])). 349 | Proof. 350 | move=> Hpar. 351 | move/block_in_voting_processingP=> [b0 /andP[/andP [/andP [/andP [Hb0 Hrd0] Hqc0] Hqcr0] Hproc0]]. 352 | move: (Hb0); move/andP: Hpar=> [/andP[/andP [/eqP[<-] _] _] _]; move/eqP/inj_hashB=> Hbb0. 353 | by rewrite -Hbb0. 354 | Qed. 355 | 356 | (* Lemma S3 in LibraBFT v2, ported to v3 formalization *) 357 | (* See comment of block_in_voting_processingP to understand why it takes us 4 *) 358 | (* blocks to form a 3-chain *) 359 | Lemma three_chain_higher (b0 b1 b2 c2 b c : valid_block): 360 | (path vb_direct_parent b0 [:: b1 ; b2 ]) && (vb_parent b2 c2) && 361 | (vb_parent b c) -> 362 | (round b > round b2) -> 363 | (* a.k.a. previous_round b > round b0 in this presentation*) 364 | (qc_round b >= round b0). 365 | Proof. 366 | move/andP=> [/andP[Hpath Hpar23] Hparbc]. 367 | move: (honest_voted_two_blocks c2 c)=> [n /andP[Hvot3 /andP[Hvotc Hh]] Hqc]. 368 | move: (valid_qc_ancestor_is_parent Hparbc Hvotc) => Hbvot. 369 | move: Hpath; rewrite /vb_direct_parent. 370 | rewrite -cat1s cat_path; move/andP=>[Hb0b1]; rewrite /= andbT; move/andP=> [Hpar12 Hrd12]. 371 | move: Hb0b1; rewrite /= andbT; move/andP=> [Hpar01 Hrd01]. 372 | move: (valid_qc_ancestor_is_parent Hpar23 Hvot3) => H2vot. 373 | move/andP: Hparbc=> [/andP[/andP[Hb /eqP[Hrd]] Hparent] Hparent_rd]. 374 | move/andP: (Hpar01)=> [/andP[/andP[H0 /eqP[Hrd0]] Hparent0] Hparent_rd0]. 375 | move/andP: (Hpar12)=> [/andP[/andP[H1 /eqP[Hrd1]] Hparent1] Hparent_rd1]. 376 | rewrite Hrd0 (eqP Hparent_rd1). 377 | (* TODO : clean up type inference in this imbricated subtype*) 378 | apply: (@voted_in_processing_subseq_qc_parent_rel _ _ _ _ _ _ 379 | GenesisState [seq block_data i | i <- block_log (val n)]). 380 | apply: voted_in_processing_both => //=. 381 | - by apply/negPn=> H; move:Hqc; rewrite (eqP H) ltnn. 382 | by rewrite ltnW. 383 | Qed. 384 | 385 | Lemma lt_wf_ind : forall (n : nat) (P : nat -> Prop), 386 | (forall n0 : nat, (forall m : nat, (m < n0) -> P m) -> P n0) -> 387 | P n. 388 | Proof. 389 | move=>n P H; apply: Wf_nat.lt_wf_ind=> [m mn]. 390 | by apply: (H m)=>[m0 m0m]; apply: mn; apply/ltP. 391 | Qed. 392 | 393 | Lemma logged_in_all_blocks (v: Validator) (b: BType): 394 | b \in block_log (val v) -> b \in all_blocks. 395 | Proof. 396 | move=> Hlog. 397 | have H: (block_log (val v)) \in [seq block_log i | i <- validator_nodes]. 398 | - by apply/mapP; exists (val v)=> //; move/valP: (v). 399 | by apply/flattenP; exists (block_log (val v)). 400 | Qed. 401 | 402 | Lemma valid_block_in_voting_processingP (v: Validator) vb: 403 | let n := val v in 404 | (block_in_voting n vb) -> 405 | exists b: valid_block, (vb_parent b vb) && 406 | ((block_data b) \in (voted_in_processing GenesisState [seq block_data i | i <- block_log n])). 407 | Proof. 408 | rewrite /=; move/hasP=> [b Hvb Hhb]. 409 | move: Hvb; rewrite mem_filter; move/andP=> [/andP[Hvot Hval] Hlog]. 410 | move/logged_in_all_blocks: Hlog=>Hball; pose bb : BlockFinType := (Sub b Hball). 411 | pose bv : valid_block := (Sub bb Hval). 412 | exists bv; rewrite /= /vb_parent {1}/bv /parent. 413 | by rewrite /type_val /comp !SubK -/(parent hashB b vb) Hhb andTb. 414 | Qed. 415 | 416 | (* Property S4 in LibraBFT v2, ported to v3 formalization *) 417 | 418 | (* This includes a pretty strong variation in introducing d, the "lagging" *) 419 | (* element in the blocks in comparison with the earlier three-chain. 'd' serves *) 420 | (* exclusively to introduce a voted block carrying a QC for c, ensuring *) 421 | (* qc_parent_round c < qc_round c, i.e. qc_round b < round b, which is essential *) 422 | (* to the use of the induction hypothesis. *) 423 | (* We are therefore proving a weaker property than S4 — which is *) 424 | (* incorrect as stated, though this technical error is of no consequence, since *) 425 | (* the lemma yields the final theorem S5 anyway. *) 426 | Lemma three_chain_linked (b0 b1 b2 c2 : valid_block): 427 | (path vb_direct_parent b0 [:: b1 ; b2 ]) && (vb_parent b2 c2) -> 428 | forall n: nat, 429 | (forall b c d: valid_block, (round b == n) && (path vb_parent b [:: c ; d]) && (round b >= round b0) -> 430 | (exists bs: seq valid_block, (path vb_parent b0 bs) && (block_data (last b0 bs) == b))). 431 | Proof. 432 | move=>Hchain; elim/lt_wf_ind=> n IHn b c d; move/andP=>[/andP[Hn /andP[Hparbc /andP[Hparcd _]]] Hbb0]. 433 | case Hbb2: (round b > round b2). 434 | - have Hqcb: (qc_round b >= round b0); first by apply: (@three_chain_higher b0 b1 b2 c2 b c); rewrite // Hparbc andbT Hchain. 435 | (* qc_round b <= round b — this is the only part that uses d *) 436 | have Hqc_cd: qc_parent_round c <= qc_round c. 437 | - move: (honest_in_one_block d)=> [nd /andP[Hvotd]]. 438 | move/subsetP; move/(_ d); rewrite 2!inE; move/(_ Hvotd)=> Hvotingd. 439 | move: (valid_qc_ancestor_is_parent Hparcd Hvotingd). 440 | by move/voted_in_processing_exists=>[sb /andP[/andP[_ Hd] _]]; move: (voted_br_gt_qcr Hd). 441 | move: (Hparbc) Hqc_cd; rewrite {1}/vb_parent /parent; move/andP=>[/andP[/andP[_ /eqP[<-]] _] /eqP[<-]]. 442 | (* set parb and prove round parb = qc_round b *) 443 | move: (honest_in_two_blocks b c)=> [node /andP[/andP[Hvotb Hvotc] Hhon]]; move/subsetP: (Hhon); move/(_ b). 444 | rewrite 2!inE; move/(_ Hvotb); move/valid_block_in_voting_processingP=> [parb /andP[Hparbb Hvotparb]]. 445 | move: (Hparbb); rewrite {1}/vb_parent {1}/parent; move/andP=> [/andP[/andP[Hparb_h /eqP[Hrb]] _] _]. 446 | rewrite -Hrb=> Hrd_parbb. 447 | (* establish parb != b & the prelude for voted_in_processing_ltn *) 448 | have Hrounds_parb_b : round parb < round b. 449 | - move/subsetP: Hhon; move/(_ c); rewrite 2!inE; move/(_ Hvotc). 450 | move/valid_block_in_voting_processingP=> [parc /andP[Hparc Hvotparc]]. 451 | move: (Hparc) (Hparbc); rewrite {1 2}/vb_parent {1 2}/parent. 452 | move/andP=>[/andP[/andP[Hparc_h _] _] _]; move/andP=>[/andP[/andP[Hb_h _] _] _]. 453 | move: Hb_h; rewrite -(eqP Hparc_h); move/eqP/inj_hashB=>Heqparcb; rewrite -Heqparcb in Hvotparc Hparc. 454 | apply: (voted_in_processing_ltn _ Hvotparb Hvotparc Hrd_parbb). 455 | move/valP: (b); move/andP=>[_]; rewrite -(eqP Hparb_h). 456 | by apply/contra=> HH; apply/eqP; congr hashB; rewrite (eqP HH) /=. 457 | rewrite (eqP Hn) in Hrounds_parb_b; move: (IHn (round parb) Hrounds_parb_b parb b c); rewrite eqxx andTb. 458 | rewrite -Hrb in Hqcb; rewrite Hqcb /= 2!andbT Hparbb Hparbc /=. 459 | move/(_ is_true_true)=> [bs Hbs]; exists (rcons bs b). 460 | rewrite rcons_path last_rcons eqxx andbT; move/andP: Hbs=>[->] /=. 461 | by case bs=>[|x xs] /=; rewrite /vb_parent; move/eqP=>->. 462 | (* Prequel: unzip the vb_direct_parent assumption *) 463 | move/andP: Hchain=> [Hchain Hb2c2]; have Hpar_chain: vb_parent b0 b1 && vb_parent b1 b2. 464 | by move: Hchain; rewrite /= andbT /vb_direct_parent /direct_parent /vb_parent; move/andP=> [/andP[-> _] /andP[-> _]]. 465 | have Hrd_chain: (round b1 == (round b0).+1) && (round b2 == (round b1).+1). 466 | by move: Hchain; rewrite /= andbT /vb_direct_parent /direct_parent; move/andP=> [/andP[_ ->] /andP[_ ->]]. 467 | (* Prequel : establish round b = qc_round c *) 468 | move/andP: (Hparbc)=> [/andP[/andP[Hqch_c Hqc_c] _ ] _]. 469 | move/negbT: Hbb2; rewrite -leqNgt leq_eqVlt; move/orP=>[Hbb2|Hbb2]. 470 | - move: Hb2c2; rewrite {1}/vb_parent {1}/parent; move/andP=>[/andP[/andP[Hqch_c2 Hqc_c2] _] _]. 471 | move: Hbb2; rewrite (eqP Hqc_c2) (eqP Hqc_c); move/valid_blocks_same_round_equal. 472 | rewrite -(eqP Hqch_c) -(eqP Hqch_c2); move/eqP/inj_hashB=> Heq_bb2. 473 | by exists [:: b1; b2]; rewrite /= andbT Hpar_chain andTb eq_sym; apply/eqP. 474 | move: Hbb2; move/andP: (Hrd_chain)=>[_ /eqP[->]]; rewrite ltnS leq_eqVlt; move/orP=> [Hbb1|Hbb1]. 475 | - move: Hbb1; rewrite (eqP Hqc_c); move/andP: (Hpar_chain)=>[_]; rewrite {1}/vb_parent {1}/parent. 476 | move/andP=> [/andP[/andP[Hqch_b1 /eqP[->]] _] _]; move/valid_blocks_same_round_equal. 477 | rewrite -(eqP Hqch_c) -(eqP Hqch_b1); move/eqP/inj_hashB=> Heq_bb1. 478 | by exists [:: b1]; rewrite /= Heq_bb1 eqxx 2!andbT; move/andP: Hpar_chain=> [-> _]. 479 | move: Hbb1; move/andP: Hrd_chain=> [/eqP[->] _]; rewrite ltnS=> Hbb1. 480 | move: (eqn_leq (round b0) (round b)); rewrite {}Hbb0 {}Hbb1 andbT; move/idP. 481 | move: Hpar_chain; rewrite andbC; move/andP=>[_]; rewrite {1}/vb_parent {1}/parent. 482 | move/andP=> [/andP[/andP[Hqch_b0 /eqP[->]] _] _]; rewrite (eqP Hqc_c). 483 | move/valid_blocks_same_round_equal; rewrite -(eqP Hqch_b0) -(eqP Hqch_c). 484 | move/eqP/inj_hashB=> Hbb0. 485 | by exists [::]=>/=; apply/eqP. 486 | Qed. 487 | 488 | 489 | Theorem safety (b0 b1 b2 c2: valid_block) (d0 d1 d2 e2: valid_block): 490 | (path vb_direct_parent b0 [:: b1 ; b2 ]) && (vb_parent b2 c2) -> 491 | (path vb_direct_parent d0 [:: d1 ; d2 ]) && (vb_parent d2 e2) -> 492 | (exists bs: seq valid_block, (path vb_parent b0 bs) && (block_data (last b0 bs) == d0)) \/ 493 | (exists ds: seq valid_block, (path vb_parent d0 ds) && (block_data (last d0 ds) == b0)). 494 | Proof. 495 | wlog: b0 b1 b2 c2 d0 d1 d2 e2 / (round b0 <= round d0)=> H Hb0 Hd0. 496 | - move/orP: (leq_total (round b0) (round d0))=>[H1|H1]; 497 | [move: (H b0 b1 b2 c2 _ d1 d2 e2 H1 Hb0 Hd0) | move: (H d0 d1 d2 e2 _ b1 b2 c2 H1 Hd0 Hb0) ]; try by apply. 498 | by case; [right|left]. 499 | left; apply: (@three_chain_linked _ _ _ _ Hb0 (round d0) d0 d1 d2). 500 | rewrite eq_refl andTb H andbT /= andbT; move/andP: Hd0=>[/andP[H1 /andP[H2 _]] _]. 501 | by rewrite /vb_parent; move/andP: H1=>[-> _]; move/andP: H2=>[-> _]. 502 | Qed. 503 | 504 | End ValidBlocks. 505 | 506 | End Safety. 507 | -------------------------------------------------------------------------------- /Structures/BlockTree.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path choice. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | From LibraChain 22 | Require Import SeqFacts Chains HashSign Blocks. 23 | Set Implicit Arguments. 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | Require Import Recdef. 27 | 28 | (* A formalization of a block forests *) 29 | (*Some bits and pieces (btExtend relation properties) taken from *) 30 | (*https://github.com/certichain/toychain *) 31 | 32 | (************************************************************) 33 | (******************* ***************************) 34 | (************************************************************) 35 | Section Forests. 36 | 37 | Variable Hash : countType. 38 | Variables (PublicKey: countType) (Signature: countType) (Address: hashType PublicKey). 39 | 40 | Parameters (Command NodeTime: countType). 41 | 42 | (* The Block Data (w/o signatures) *) 43 | Notation BDataType := (BlockData Hash Signature Address Command NodeTime). 44 | 45 | Variable hashB: BDataType -> Hash. 46 | Hypothesis inj_hashB: injective hashB. 47 | 48 | Variable verifB: Hash -> PublicKey -> Signature -> bool. 49 | 50 | (* Block Type : block data with signatures *) 51 | Notation BType := (BlockType inj_hashB verifB). 52 | Notation QC := (QuorumCert Hash Signature (Phant Address)). 53 | 54 | Implicit Type bd: BDataType. 55 | 56 | Notation "# b" := (hashB b) (at level 20). 57 | 58 | Parameter peers : seq Address. 59 | Parameter GenesisBlock : BType. 60 | 61 | Definition genesis_round := (round GenesisBlock). 62 | 63 | (* In fact, it's a forest, as it also keeps orphan blocks *) 64 | Definition BlockTree := union_map [ordType of Hash] BType. 65 | 66 | Implicit Type bt : BlockTree. 67 | 68 | Definition btHasBlock bt (b: BType) := 69 | (#b \in dom bt) && (find (#b) bt == Some b). 70 | 71 | Notation "b ∈ bt" := (btHasBlock bt b) (at level 70). 72 | Notation "b ∉ bt" := (~~ btHasBlock bt b) (at level 70). 73 | 74 | Definition btExtend bt (b: BType) := 75 | (* We only add fresh blocks which qc is in bt *) 76 | if #b \in dom bt then 77 | if find (#b) bt == Some b then 78 | bt 79 | (* A hash collision makes the blocktree undefined *) 80 | else um_undef 81 | else 82 | (#b \\-> b \+ bt). 83 | 84 | Definition Blockchain := seq BType. 85 | 86 | Definition qc_of bd := (proof bd). 87 | Definition qc_hash bd := (block_hash (qc_vote_data (qc_of bd))). 88 | Definition qc_round bd := (block_round (qc_vote_data (qc_of bd))). 89 | Definition qc_parent_hash bd := (parent_block_hash (qc_vote_data (qc_of bd))). 90 | Definition qc_parent_round bd := (parent_block_round (qc_vote_data (qc_of bd))). 91 | 92 | Definition parent b1 b2 := (hashB b1 == qc_hash b2) && (round b1 == qc_round b2) && (qc_hash b1 == qc_parent_hash b2) && (qc_round b1 == qc_parent_round b2). 93 | Definition chained (bc: seq BType):= path [eta parent: rel BType] GenesisBlock bc. 94 | 95 | Definition bcLast (bc : Blockchain) := last GenesisBlock bc. 96 | 97 | Definition subchain (bc1 bc2 : Blockchain) := exists p q, bc2 = p ++ bc1 ++ q. 98 | 99 | Implicit Type (b: BType). 100 | 101 | Definition has_init_block (bt : BlockTree) := 102 | find (# GenesisBlock) bt = Some GenesisBlock. 103 | 104 | Lemma has_init_block_free bt hb : 105 | has_init_block bt -> # GenesisBlock != hb -> 106 | has_init_block (free hb bt). 107 | Proof. move=>Ib /eqP Ng; rewrite/has_init_block findF; case: ifP=>/eqP//=. Qed. 108 | 109 | Definition validH (bt : BlockTree) := 110 | forall h (b:BType), find h bt = Some b -> h = hashB b. 111 | 112 | Lemma validH_free bt b : 113 | validH bt -> validH (free (# b) bt). 114 | Proof. by move=>Vh h c; rewrite findF;case: ifP=>//_ /Vh. Qed. 115 | 116 | Lemma validH_undef : validH um_undef. 117 | Proof. by rewrite/validH=>h b; rewrite find_undef. Qed. 118 | 119 | Lemma btExtendV bt (b:BType) : 120 | valid (btExtend bt b) -> valid bt. 121 | Proof. 122 | rewrite/btExtend; case: ifP. 123 | by case: ifP=>//=; rewrite valid_undef. 124 | by move=>Nd; rewrite validPtUn Nd //==>[/andP] []. 125 | Qed. 126 | 127 | Lemma btExtendV_comm bt a b : 128 | valid (btExtend (btExtend bt a) b) = 129 | valid (btExtend (btExtend bt b) a). 130 | Proof. 131 | rewrite/btExtend; case: ifP; case: ifP; case: ifP; case: ifP; 132 | move=>A B C D. 133 | by rewrite D C B. 134 | by rewrite D dom_undef in_nil validPtUn valid_undef. 135 | by rewrite dom_undef in D. 136 | by rewrite dom_undef in D. 137 | - case: ifP; case: ifP. 138 | case: ifP=>X Y Z. 139 | by rewrite Y X in A; rewrite A in C. 140 | by rewrite find_undef in Z. 141 | by move=>X; move: D; rewrite domPtUn inE X Bool.orb_false_r=>/andP [] _; 142 | move/eqP=>->_ ; rewrite !validPtUn !inE. 143 | case: ifP=>X Y Z. 144 | by rewrite Y X in A; rewrite A in C. 145 | by rewrite Y X dom_undef in A. 146 | move=>X; move: D; rewrite domPtUn inE X Bool.orb_false_r=>/andP[]->. 147 | move/eqP=>E; move: A; rewrite X domPtUn inE=>/andP[]V _. 148 | move: B; rewrite E findUnR; last by move: V; rewrite !validPtUn. 149 | rewrite X findPt //==>/eqP []E'; subst b; 150 | by rewrite findUnR ?V //= X findPt //==>/eqP []. 151 | - case: ifP. 152 | case: ifP=>X Y //=. 153 | by move: D; rewrite domPtUn inE Y=>/andP[] V _; 154 | move: B; rewrite findUnR ?V //= Y X. 155 | by move=>X; move: D; rewrite domPtUn inE X Bool.orb_false_r=>/andP [] V; 156 | move/eqP=>E; move: A; rewrite X E domPtUn inE eq_refl Bool.orb_true_l; 157 | move: V; rewrite !validPtUn C X !Bool.andb_true_r//==>->. 158 | - case: ifP; case: ifP=>//=. 159 | case: ifP=>X Y Z=>//=. 160 | by rewrite Y X in A; rewrite A in C. 161 | move=>X; move: D; rewrite domPtUn inE X Bool.orb_false_r=>/andP [] V. 162 | move/eqP=>E; move: B; rewrite E !findUnR; 163 | do? by move:V; rewrite !validPtUn C X //=. 164 | by rewrite X !findPt //= eq_sym=>->. 165 | - case: ifP. 166 | case: ifP=>X Y; move: B; rewrite findUnR. 167 | by case: ifP; [rewrite X | rewrite Y]. 168 | by move: D; rewrite domPtUn inE validPtUn Y C //==>/andP[]. 169 | by case: ifP; rewrite join_undefR. 170 | by move: D; rewrite domPtUn inE validPtUn Y C //==>/andP[]. 171 | by rewrite joinA (joinC (#a \\-> _) (#b \\-> _)) -joinA; 172 | rewrite validPtUn inE D //= Bool.andb_false_r valid_undef. 173 | - rewrite D in A *; case: ifP=>//=. 174 | rewrite findUnR. by rewrite C B. 175 | by move: A; rewrite domPtUn inE=>/andP[]. 176 | - rewrite D in A *. 177 | by rewrite validPtUn D !validPtUn A D //= !Bool.andb_true_r. 178 | - case: ifP; case: ifP; do? by rewrite join_undefR. 179 | case: ifP=>X Y Z. 180 | by rewrite Z in B. 181 | by rewrite find_undef in Z. 182 | move=>X; rewrite findUnR. by rewrite C B. 183 | by move: A; rewrite X domPtUn validPtUn inE X C //=; 184 | rewrite Bool.orb_true_r !Bool.andb_true_r. 185 | - case: ifP. 186 | case: ifP=>X Y; first by rewrite Y X C in A. 187 | by rewrite !join_undefR. 188 | rewrite joinA (joinC (#a \\-> _) (#b \\-> _)) -joinA. 189 | suff: (# a \\-> a \+ bt) = um_undef by move=>->. 190 | by apply invalidE; rewrite validPtUn C Bool.andb_false_r. 191 | - case: ifP; case: ifP=>X Y; do? by rewrite X C in B. 192 | by rewrite find_undef in Y. 193 | by rewrite X dom_undef in_nil in B. 194 | - case: ifP; first by rewrite !validPtUn A C D //= !Bool.andb_true_r. 195 | move: B; rewrite domPtUn inE C Bool.orb_false_r=>/andP[]V /eqP E. 196 | contradict D. 197 | rewrite domPtUn inE E eq_refl Bool.orb_true_l Bool.andb_true_r. 198 | by move: V; rewrite !validPtUn C //= Bool.andb_true_r=>/andP[]->. 199 | - case: ifP=>X. 200 | contradict D. 201 | rewrite domPtUn inE A Bool.orb_true_r validPtUn C //=. 202 | case V: (valid bt)=>//=. 203 | move: (invalidE bt); rewrite V //=; case=>Z _. 204 | have T: true by []. specialize (Z T). 205 | by move: Z A=>->; rewrite dom_undef in_nil. 206 | by rewrite joinA (joinC (#b \\-> _)) -joinA !validPtUn //=; 207 | rewrite A //= Bool.andb_false_r valid_undef !Bool.andb_false_l. 208 | by rewrite !joinA (joinC (#b \\-> _) (#a \\-> _)). 209 | Qed. 210 | 211 | Lemma btExtendV_fold1 bt bs b : 212 | valid (foldl btExtend bt (rcons bs b)) -> valid (foldl btExtend bt bs). 213 | Proof. 214 | rewrite -cats1 foldl_cat /= {1}/btExtend; case: ifP. 215 | case: ifP=>_ _ =>//=; last by rewrite valid_undef. 216 | by move=>_; rewrite validPtUn /= =>/andP[H _]. 217 | Qed. 218 | 219 | Lemma btExtendV_fold bt xs ys : 220 | valid (foldl btExtend bt (xs ++ ys)) -> valid (foldl btExtend bt xs). 221 | Proof. 222 | elim/last_ind: ys=>[|ys y Hi]; first by rewrite cats0. 223 | by rewrite foldl_cat; move/btExtendV_fold1; rewrite -foldl_cat; apply Hi. 224 | Qed. 225 | 226 | Lemma btExtendV_fold_xs bt xs : 227 | valid (foldl btExtend bt xs) -> valid bt. 228 | Proof. 229 | have X: xs = ([::] ++ xs) by rewrite cat0s. 230 | by rewrite X; move/btExtendV_fold. 231 | Qed. 232 | 233 | Lemma btExtendV_fold_dup bt xs a b : 234 | valid (foldl btExtend bt (rcons xs a)) -> 235 | b \in xs -> #a = #b -> a = b. 236 | Proof. 237 | elim/last_ind: xs=>[|xs x H]//=. 238 | rewrite -!cats1 !foldl_cat //=. 239 | have E: (btExtend (btExtend (foldl btExtend bt xs) a) x) = 240 | foldl btExtend bt (rcons (rcons xs a) x) 241 | by rewrite -!cats1 -catA !foldl_cat //=. 242 | rewrite btExtendV_comm E=>V; move: (btExtendV_fold1 V)=>V0. 243 | specialize (H V0); rewrite mem_cat inE=>/orP; case=>//=. 244 | move/eqP=>Eq; subst x; move=>Hh. 245 | case X: (a == b); first by move/eqP: X. 246 | contradict V. 247 | rewrite -!cats1 !foldl_cat //=. 248 | move: (btExtendV_fold1 V0)=>V1. 249 | rewrite{1}/btExtend; case: ifP. 250 | - case: ifP. 251 | rewrite{5}/btExtend; case: ifP. 252 | case: ifP; last by rewrite valid_undef. 253 | rewrite -Hh. 254 | move=>A B C _; contradict C. 255 | by rewrite{1}/btExtend B A; move/eqP: A=>-> /eqP [] Y; 256 | rewrite Y eq_refl in X. 257 | move=>A B C D; move: B. 258 | by rewrite{1}/btExtend A -Hh findPtUn ?D //==>/eqP [] Y; 259 | rewrite Y eq_refl in X. 260 | by rewrite valid_undef. 261 | move=>D; rewrite{1}/btExtend. 262 | case: ifP. 263 | case: ifP; last by rewrite join_undefR valid_undef. 264 | by move=>B A; rewrite -Hh validPtUn A //= Bool.andb_false_r. 265 | by rewrite -Hh joinA (joinC _ (foldl btExtend _ _)); 266 | move=>_; apply/negP; apply invalidE; rewrite pts_undef join_undefR. 267 | Qed. 268 | 269 | Lemma btExtendH bt b : valid bt -> validH bt -> validH (btExtend bt b). 270 | Proof. 271 | move=>V H z c; rewrite /btExtend. 272 | case: ifP=>X. 273 | - case: ifP=>_; by [move/H | rewrite find_undef]. 274 | rewrite findUnL ?validPtUn ?V ?X//. 275 | case: ifP=>Y; last by move/H. 276 | rewrite domPtK inE in Y; move/eqP: Y=>Y; subst z. 277 | by rewrite findPt; case=>->. 278 | Qed. 279 | 280 | Lemma btExtendH_fold bt bs : 281 | validH bt -> valid (foldl btExtend bt bs) -> 282 | validH (foldl btExtend bt bs). 283 | Proof. 284 | move=>Vh V'; elim/last_ind: bs V' =>[|xs x Hi] V'; first done. 285 | move: (btExtendV_fold1 V')=>V; move: (Hi V). 286 | rewrite -cats1 foldl_cat /= {2}/btExtend; case: ifP. 287 | case: ifP=>//=; by move: validH_undef. 288 | move=>D H; rewrite/validH=>h b; rewrite findUnR ?validPtUn ?V ?D //=. 289 | case: ifP; first by move: (H h b). 290 | by rewrite findPt2; case: ifP=>//= /andP[/eqP ->] _ _ [] ->. 291 | Qed. 292 | 293 | Lemma btExtendIB bt b : 294 | validH bt -> valid (btExtend bt b) -> has_init_block bt -> 295 | has_init_block (btExtend bt b). 296 | Proof. 297 | move=>Vh V'; rewrite /btExtend/has_init_block=>Ib. 298 | move: (btExtendV V')=>V; case: ifP=>X; last first. 299 | by move: (find_some Ib)=>G; rewrite findUnR ?validPtUn ?X ?V //= G Ib. 300 | case: ifP=>//=. 301 | case: (um_eta X)=>v [F _]. 302 | rewrite F=>/eqP; move: (Vh _ _ F)=>H Neq. 303 | contradict V'; rewrite/btExtend X; case: ifP. 304 | by rewrite F=>/eqP [] E; subst v. 305 | by rewrite valid_undef. 306 | Qed. 307 | 308 | Lemma btExtendIB_fold bt bs : 309 | validH bt -> valid (foldl btExtend bt bs) -> has_init_block bt -> 310 | has_init_block (foldl btExtend bt bs). 311 | Proof. 312 | move=>Vh V'; rewrite/has_init_block=>iB. 313 | elim/last_ind: bs V'=>[|xs x Hi]; first done. 314 | rewrite -cats1 foldl_cat /= {1}/btExtend; case: ifP. 315 | - case: ifP; last by rewrite valid_undef. 316 | by move=>F D V; rewrite{1}/btExtend D F; apply Hi. 317 | move=>Nd; rewrite validPtUn Nd /==>/andP[V _]. 318 | rewrite{1}/btExtend Nd findUnR ?validPtUn ?V ?Nd //=. 319 | by move: (find_some (Hi V)) (Hi V)=>-> ->. 320 | Qed. 321 | 322 | Lemma in_ext bt b : valid (btExtend bt b) -> validH bt -> b ∈ btExtend bt b. 323 | Proof. 324 | move=>V' Vh; rewrite/btHasBlock/btExtend; 325 | move: (btExtendV V')=>V; case: ifP=>//=; last first. 326 | - rewrite domUn inE ?validPtUn ?V //==>D; rewrite D domPt inE/=. 327 | apply/andP; split. 328 | by apply/orP; left. 329 | by rewrite findUnL ?validPtUn ?V ?D //; rewrite domPt inE /=; 330 | case: ifP=>/eqP//= _; rewrite findPt /=. 331 | move=>D; case: ifP. 332 | by rewrite D=>/eqP ->; apply /andP; split=>//=. 333 | case: (um_eta D)=>b' [] F' _; move: (Vh _ _ F')=>H F. 334 | rewrite F' in F; contradict V'. 335 | rewrite/btExtend D; case: ifP; last by rewrite valid_undef. 336 | by rewrite F' F. 337 | Qed. 338 | 339 | Lemma btExtend_dom bt b : 340 | valid (btExtend bt b) -> {subset dom bt <= dom (btExtend bt b)}. 341 | Proof. 342 | move=>V' z; rewrite/btExtend; case:ifP=>C//=D. 343 | case: ifP=>//= F. 344 | by contradict V'; rewrite/btExtend C F valid_undef. 345 | move: (btExtendV V')=>V. 346 | by rewrite domUn inE andbC/= validPtUn/= V D/= C orbC. 347 | Qed. 348 | 349 | Lemma btExtend_dom_fold bt bs : 350 | valid (foldl btExtend bt bs) -> {subset dom bt <= dom (foldl btExtend bt bs)}. 351 | Proof. 352 | move=>V z; elim/last_ind: bs V=>[|xs x Hi]=>//. 353 | move=>V'; move: (btExtendV_fold1 V')=>V D; specialize (Hi V D). 354 | rewrite -cats1 foldl_cat /=; apply btExtend_dom=>//=. 355 | by move: V'; rewrite -cats1 foldl_cat /=. 356 | Qed. 357 | 358 | Lemma btExtend_find bt z h b : 359 | valid (btExtend bt z) -> 360 | h \in dom bt -> 361 | find h (btExtend bt z) = Some b -> 362 | find h bt = Some b. 363 | Proof. 364 | move=>V' D; move: (btExtendV V')=>V. 365 | rewrite/btExtend; case:ifP=>C. 366 | case: ifP=>//=C'; first by rewrite find_undef. 367 | rewrite findUnR ?validPtUn ?V ?C //; case: ifP=>//=. 368 | by rewrite D. 369 | Qed. 370 | 371 | Lemma btExtend_find_fold bt h b bs : 372 | valid (foldl btExtend bt bs) -> 373 | h \in dom bt -> 374 | find h (foldl btExtend bt bs) = Some b -> 375 | find h bt = Some b. 376 | Proof. 377 | move=>V' D. 378 | elim/last_ind: bs V'=>[|xs x Hi]=>//. 379 | move=>V'; move: (btExtendV_fold1 V')=>V; move: V'. 380 | rewrite -cats1 foldl_cat /= =>X. 381 | specialize (Hi V); rewrite{1}/btExtend. 382 | case: ifP. 383 | case: ifP; last by rewrite find_undef. 384 | by move=>_ _ ; apply Hi. 385 | move=>Nd; rewrite findUnR ?validPtUn ?Nd ?V //. 386 | case: ifP; first by move=>_; apply Hi. 387 | move=>Nd'; rewrite findPt2 //=; case: ifP=>//=. 388 | by move: (btExtend_dom_fold V D); rewrite Nd'. 389 | Qed. 390 | 391 | Lemma btExtend_fold_in_either bt xs b : 392 | b ∈ (foldl btExtend bt xs) -> 393 | b ∈ bt \/ b \in xs. 394 | Proof. 395 | elim/last_ind: xs=>[|xs x H]; first by left. 396 | rewrite -cats1 foldl_cat //= {1}/btExtend. 397 | case: ifP; last first. 398 | - move=>D; rewrite/btHasBlock=>/andP []. 399 | rewrite domPtUn inE=>/andP[]Z/orP; case. 400 | * move/eqP=>Hh; rewrite Hh findPtUn; last by rewrite -Hh. 401 | move/eqP=>[]E; subst x; right. 402 | by rewrite mem_cat inE eq_refl Bool.orb_true_r. 403 | move=>A; rewrite findPtUn2 ?Z //=; case: ifP. 404 | by move=>_ /eqP[]->; right; rewrite mem_cat inE eq_refl Bool.orb_true_r. 405 | move=>_ B; have X: (b ∈ foldl btExtend bt xs) by rewrite/btHasBlock A B. 406 | move: (H X); case; first by rewrite/btHasBlock=>->; left. 407 | by move=>M; right; rewrite mem_cat M Bool.orb_true_l. 408 | case: ifP. 409 | move=>_ _ M; case: (H M); first by left. 410 | by move=>X; right; rewrite mem_cat X Bool.orb_true_l. 411 | by move=> _ _; rewrite/btHasBlock dom_undef in_nil Bool.andb_false_l. 412 | Qed. 413 | 414 | Lemma btExtend_in_either bt b b' : 415 | b ∈ btExtend bt b' -> b ∈ bt \/ b == b'. 416 | Proof. 417 | move=>X0; have X: (b ∈ (foldl btExtend bt [:: b'])) by []. 418 | case: (btExtend_fold_in_either X); first by left. 419 | by rewrite inE=>->; right. 420 | Qed. 421 | 422 | Lemma btExtend_fold_in bt xs b : 423 | valid (foldl btExtend bt xs) -> b ∈ bt \/ b \in xs -> 424 | b ∈ (foldl btExtend bt xs). 425 | Proof. 426 | elim/last_ind: xs=>[|xs x H]; first by move=>_; case=>//=. 427 | move=>V'; move: (btExtendV_fold1 V')=>V; specialize (H V). 428 | rewrite -cats1 foldl_cat //= {1}/btExtend. 429 | case: ifP; last first. 430 | - move=>D; case. 431 | * move=>Hv; have X: (b ∈ bt \/ b \in xs) by left. 432 | move: (H X); rewrite/btHasBlock=>/andP[] A B; 433 | rewrite domPtUn inE validPtUn V D A Bool.orb_true_r //=; 434 | (rewrite findPtUn2; last by rewrite validPtUn V D); 435 | case: ifP=>//=; by move/eqP=>E; move: D A; rewrite E=>->. 436 | 437 | * rewrite mem_cat inE=>/orP; case=>Hv. 438 | have X: (b ∈ bt \/ b \in xs) by right. 439 | move: (H X); rewrite/btHasBlock=>/andP[] A B; 440 | rewrite domPtUn inE validPtUn V D A Bool.orb_true_r //=; 441 | (rewrite findPtUn2; last by rewrite validPtUn V D); 442 | case: ifP=>//=; by move/eqP=>E; move: D A; rewrite E=>->. 443 | 444 | * by move/eqP in Hv; rewrite/btHasBlock domPtUn Hv inE eq_refl D; 445 | rewrite validPtUn V D findPtUn ?validPtUn ?V ?D //=. 446 | case:ifP. 447 | * move=>F D; case=>Hv. 448 | by (have X: (b ∈ bt \/ b \in xs) by left); move: (H X). 449 | move: Hv; rewrite mem_cat inE=>/orP; case=>Hv. 450 | by (have X: (b ∈ bt \/ b \in xs) by right); move: (H X). 451 | by move/eqP in Hv; subst x; rewrite/btHasBlock D F. 452 | move=>F D; contradict V'. 453 | by rewrite -cats1 foldl_cat //= {1}/btExtend D F valid_undef. 454 | Qed. 455 | 456 | Lemma btExtend_idemp bt b : 457 | valid (btExtend bt b) -> btExtend bt b = btExtend (btExtend bt b) b. 458 | Proof. 459 | move=>V'; move: (btExtendV V')=>V; rewrite{2}/btExtend; case: ifP. 460 | case: ifP=>//=. 461 | move=>X; rewrite{1}/btExtend; case: ifP=>D. 462 | case: ifP=>F; last by rewrite dom_undef. 463 | by move=>_; contradict X; rewrite/btExtend D F F. 464 | by contradict X; rewrite/btExtend D; rewrite findPtUn ?validPtUn ?V ?D //= eq_refl. 465 | move=>X; contradict X. 466 | rewrite/btExtend; case: ifP=>D. 467 | case: ifP=>F; first by rewrite D. 468 | by contradict V'; rewrite/btExtend D F valid_undef. 469 | by rewrite domPtUn inE validPtUn V D //= eq_refl. 470 | Qed. 471 | 472 | (* Just a reformulation *) 473 | Lemma btExtend_preserve (bt : BlockTree) ob b : 474 | valid (btExtend bt b) -> 475 | ob ∈ bt -> ob ∈ btExtend bt b. 476 | Proof. 477 | move=>V'; move: (btExtendV V')=>V; rewrite/btHasBlock=>/andP [H0 H1]. 478 | rewrite/btExtend; case: ifP=>D. 479 | - case: ifP=>F. 480 | by rewrite H0 H1. 481 | by contradict V'; rewrite/btExtend D F valid_undef. 482 | have Vu: (valid (# b \\-> b \+ bt)) by rewrite validPtUn V D. 483 | rewrite findUnR // H0 H1 domUn inE Vu H0 /=. 484 | by apply/andP; split=>//=; apply/orP; right. 485 | Qed. 486 | 487 | Lemma btExtend_withDup_noEffect (bt : BlockTree) b: 488 | b ∈ bt -> bt = (btExtend bt b). 489 | Proof. by rewrite/btHasBlock/btExtend=>/andP[]->->. Qed. 490 | 491 | (* There must be a better way to prove this. *) 492 | Lemma btExtend_comm bt b1 b2 : 493 | valid (btExtend (btExtend bt b1) b2) -> 494 | btExtend (btExtend bt b1) b2 = btExtend (btExtend bt b2) b1. 495 | Proof. 496 | move=>V2; move: (btExtendV V2)=>V1; move: (btExtendV V1)=>V0. 497 | have V1': valid (btExtend bt b2). 498 | rewrite/btExtend; case: ifP. 499 | - case: ifP=>//= F D. 500 | contradict V2; rewrite{2}/btExtend; case: ifP. 501 | case: ifP=>_ _; rewrite/btExtend. 502 | by rewrite D F valid_undef. 503 | by rewrite dom_undef validPtUn //= dom_undef valid_undef //=. 504 | move=>Nd; 505 | by rewrite/btExtend domPtUn validPtUn inE Nd V0 D Bool.orb_true_r //=; 506 | rewrite findUnR ?validPtUn ?V0 ?Nd //= D F valid_undef. 507 | by move=>Nd; rewrite validPtUn V0 Nd. 508 | (* Now have V1' *) 509 | case A: (b1 ∈ bt). 510 | - move/andP: A=>[A0 A1]. 511 | rewrite ![btExtend _ b1]/btExtend A0 A1 (btExtend_dom V1' A0). 512 | case: ifP=>//=; rewrite{1}/btExtend; case: ifP. 513 | case: ifP; first by rewrite A1. 514 | by move=>F D; contradict V1'; rewrite/btExtend D F valid_undef. 515 | by move=>Nd; move: V1'; rewrite{1}/btExtend Nd=>V; 516 | rewrite findUnR ?V1' //= A0 A1. 517 | case B: (b2 ∈ bt). 518 | - move/andP: B=>[B0 B1]. 519 | rewrite ![btExtend _ b2]/btExtend B0 (btExtend_dom V1 B0). 520 | case: ifP; first by rewrite B1. 521 | rewrite{1}/btExtend; move/nandP: A=>[A0|A1]. 522 | case: ifP; first by move=>D; rewrite D in A0. 523 | by clear A0; move=>A0; rewrite findUnR ?validPtUn ?V0 ?A0 //= B0 B1. 524 | rewrite B1; case: ifP. 525 | case: ifP; first by move/eqP=>F; rewrite F in A1; move/eqP: A1. 526 | by clear A1; move=>A1 A0 _; rewrite/btExtend A0 A1. 527 | by move=>Nd; rewrite findUnR ?validPtUn ?V0 ?A0 ?Nd //= B0 B1. 528 | move/nandP: A=>[A0|A1]; move/nandP: B=>[B0|B1]. 529 | - have VPt1: (forall a, valid (# b1 \\-> a \+ bt)). by move=>a; rewrite validPtUn V0 A0. 530 | apply Bool.negb_true_iff in A0; apply Bool.negb_true_iff in B0. 531 | rewrite/btExtend A0 B0; case: ifP. 532 | + rewrite domPtUn VPt1 inE B0 //= =>/orP [] //==>/eqP H. 533 | rewrite -H findUnR //= A0 domPtUn inE eq_refl VPt1 A0 findUnR //= A0 !findPt /=. 534 | case: ifP; rewrite eq_sym=>/eqP; case: ifP=>/eqP=>//=. 535 | by case=>->. 536 | have VPt2: (forall a, valid (# b2 \\-> a \+ bt)). by move=>a; rewrite validPtUn V0 B0. 537 | move=>X; have H: ((# b1 == # b2) = false) 538 | by move: X; rewrite domPtUn inE VPt1 B0 //==>/norP [/eqP H _]; apply/eqP. 539 | rewrite findUnR //= A0 domPtUn inE VPt2 A0 findPt2 eq_sym H //=. 540 | by rewrite (joinC (#b1 \\-> _)) (joinC (#b2 \\-> _)); 541 | rewrite (joinC (#b2 \\-> _)) joinA (joinC bt). 542 | - have VPt1: (forall a, valid (# b1 \\-> a \+ bt)). by move=>a; rewrite validPtUn V0 A0. 543 | apply Bool.negb_true_iff in A0; 544 | rewrite/btExtend A0. 545 | rewrite domPtUn VPt1 inE //=; case: ifP. 546 | + move=>/orP []. 547 | by move/eqP=>H; rewrite -H findUnR //= A0 findPt domUn VPt1 !inE domPt A0 inE eq_refl //=; 548 | rewrite findUnR //= A0 findPt //= eq_sym; case: ifP=>//= /eqP[]->. 549 | move=>D; rewrite findUnR //= D; case: ifP. 550 | by move/eqP=>E; rewrite E in B1; move/eqP: B1. 551 | by rewrite dom_undef //= join_undefR. 552 | move/norP=>[Nh Nd]; case: ifP; case: ifP. 553 | case: ifP; do? by move=>_ D; rewrite D in Nd. 554 | by rewrite domPtUn inE A0=>Nd' /andP [] VPt2 /orP []=>//=; 555 | move/eqP=>H; rewrite H in Nh; move/eqP: Nh. 556 | by move=>D; rewrite D in Nd. 557 | move=>_ _; 558 | by rewrite (joinC (#b1 \\-> _)) (joinC (#b2 \\-> _)); 559 | rewrite (joinC (#b2 \\-> _)) joinA (joinC bt). 560 | - have VPt2: (forall a, valid (# b2 \\-> a \+ bt)). by move=>a; rewrite validPtUn V0 B0. 561 | apply Bool.negb_true_iff in B0. 562 | rewrite/btExtend B0 domPtUn VPt2 inE //=. 563 | case: ifP; case: ifP; case: ifP; 564 | do? by [ 565 | move/eqP=>A; rewrite A in A1; move/eqP: A1 | 566 | rewrite dom_undef 567 | ]. case: ifP. 568 | move=>/orP [] //= /eqP H; rewrite H findUnL; last by rewrite -H; apply VPt2. 569 | rewrite domPt inE eq_refl //= findUnR; last by rewrite -H; apply VPt2. 570 | move=>F ->; rewrite findPt //=; case: ifP=>/eqP; first by case=>E; subst b2. 571 | by move: F; rewrite findPt //= eq_sym=>/eqP. 572 | by move/norP=>[]Nh _ F Nd; 573 | rewrite domPtUn inE B0 //==>/andP [] _ /orP[]=>//= /eqP H; 574 | rewrite H in Nh; move/eqP: Nh. 575 | move=>X Y; rewrite domPtUn inE B0=>/andP [] _ /orP []=>//=/eqP H. 576 | rewrite -H eq_refl //= findUnL; last by rewrite H; apply VPt2. 577 | rewrite domPt inE eq_refl //= findPt //=; case: ifP=>//=. 578 | move/eqP=>[E]; subst b2; contradict X. 579 | by rewrite findUnR ?validPtUn ?V0 ?B0 //= findPt //==>/eqP. 580 | move=>_ D; rewrite findUnR ?VPt2 //= D -(Bool.if_negb _ (find (# b1) bt == Some b1) _) A1. 581 | case: ifP=>_ _; first by rewrite join_undefR. 582 | have X: (# b1 \\-> b1 \+ bt = um_undef) by 583 | apply invalidE; rewrite validPtUn V0 D. 584 | by rewrite joinA (joinC (#b1 \\-> _)) -X joinA. 585 | by move/orP=>[] //= /eqP H; rewrite H=>D; rewrite H in VPt2; 586 | rewrite domPtUn inE D eq_refl VPt2. 587 | by rewrite (joinC (#b1 \\-> _)) (joinC (#b2 \\-> _)); 588 | rewrite (joinC (#b2 \\-> _)) joinA (joinC bt). 589 | (* Nastiest case - 16 subcases to be handled one-by-one *) 590 | rewrite/btExtend; case: ifP; case: ifP; case: ifP; case: ifP. 591 | by move/eqP=>B; rewrite B in B1; move/eqP: B1. 592 | by move=>_ /eqP A; rewrite A in A1; move/eqP: A1. 593 | by rewrite dom_undef. 594 | by rewrite dom_undef. 595 | case: ifP; case: ifP. 596 | by move/eqP=>B; rewrite B in B1; move/eqP: B1. 597 | by rewrite dom_undef. 598 | move=>_ D; rewrite domPtUn inE=>/andP[] _ /orP[]. 599 | by move/eqP=>H F Nd; move: F; rewrite H findUnL ?validPtUn ?V0 ?Nd //=; 600 | rewrite domPt inE eq_refl findPt //==>/eqP[]->. 601 | by move=>->. 602 | move=>Nf Nd2 _ F Nd1. rewrite domPtUn inE Nd2 //==>/andP[]_ /orP[]=>//= /eqP H. 603 | move: F; rewrite -H findUnL ?validPtUn ?V0 ?Nd1 //= domPt inE eq_refl //= findPt //=. 604 | move/eqP=>[]E; subst b2; contradict Nf. 605 | by rewrite findUnL ?validPtUn ?V0 ?Nd1 //= domPt inE eq_refl //= findPt //==>/eqP []. 606 | case: ifP. 607 | case: ifP=>//=. 608 | move=>_ D; contradict V1'; 609 | rewrite/btExtend D; case: ifP=>/eqP E; 610 | by [rewrite E in B1; move/eqP: B1|rewrite valid_undef]. 611 | move=>D A F B; rewrite domPtUn inE D=>/andP []_/orP[] //= /eqP H; rewrite H. 612 | by contradict A; rewrite domPtUn inE eq_sym H eq_refl D validPtUn V0 D. 613 | case: ifP; case: ifP=>//=. 614 | by move/eqP=>B; rewrite B in B1; move/eqP: B1. 615 | by rewrite dom_undef. 616 | move=>F D _ Nf D'; move: F Nf; rewrite !findUnL ?validPtUn ?V0 ?D ?D' //=. 617 | rewrite !domPt !inE //= inE (eq_sym (#b2)); case: ifP. 618 | by move/eqP=>->; rewrite !findPt //==>/eqP []-> /eqP. 619 | by move=>_ /eqP F; move: (find_some F)=>Nd'; rewrite Nd' in D'. 620 | case: ifP. 621 | case: ifP; first by move/eqP=> B; move/eqP: B1; rewrite B. 622 | by rewrite join_undefR. 623 | move=>D _ _ _. rewrite domUn inE D domPt //= inE=>/andP []_/orP[]//=. 624 | by move/eqP=><-; rewrite joinA pts_undef join_undefL. 625 | by move=>_/eqP A; rewrite A in A1; move/eqP: A1. 626 | by move=>_/eqP A; rewrite A in A1; move/eqP: A1. 627 | case: ifP; case: ifP. 628 | by move/eqP=>B; rewrite B in B1; move/eqP: B1. 629 | by rewrite dom_undef. 630 | by move=>F D' _ _ D; move: F; rewrite findUnR ?validPtUn ?V0 ?D' //= D; 631 | move/eqP=>A; rewrite A in A1; move/eqP: A1. 632 | by rewrite join_undefR. 633 | case: ifP. 634 | case: ifP; last by rewrite !join_undefR. 635 | by move/eqP=> B; rewrite B in B1; move/eqP: B1. 636 | rewrite join_undefR=>_ _ _ D _; rewrite joinA (joinC (#b1 \\-> _)). 637 | suff: ~~ valid(#b1 \\-> b1 \+ bt) by move/invalidE; rewrite -joinA=>->; rewrite join_undefR. 638 | by rewrite validPtUn V0 D. 639 | by case: ifP; [move=>_ _ -> | rewrite dom_undef]. 640 | rewrite domPtUn inE=>_ /andP[]_/orP []; last by move=>->. 641 | by move/eqP=>-> D; rewrite domPtUn inE eq_refl //= validPtUn V0 D. 642 | case: ifP. 643 | by move/eqP=>B; rewrite B in B1; move/eqP: B1. 644 | by move=>_D D' _; rewrite domPtUn validPtUn V0 inE D' //==>-> //= /norP[]. 645 | by move=>_ _ _ _; rewrite !joinA (joinC (#b2 \\-> _)). 646 | Qed. 647 | 648 | Definition no_collisions (bt : BlockTree) (xs : seq BType) := 649 | valid bt /\ 650 | forall a, a \in xs -> 651 | (forall b, b \in xs -> # a = # b -> a = b) /\ 652 | (forall b, b ∈ bt -> # a = # b -> a = b). 653 | 654 | Lemma btExtendV_valid_no_collisions bt xs : 655 | valid (foldl btExtend bt xs) -> no_collisions bt xs. 656 | Proof. 657 | elim/last_ind: xs=>[|xs x H0] //=. 658 | - move=>V; move: (btExtendV_fold1 V)=>V1; specialize (H0 V1). 659 | move: H0; rewrite/no_collisions. 660 | move=>[] V0 N; split=>//=. 661 | move=>a; rewrite -cats1 mem_cat inE=>/orP; case; last first. 662 | * move/eqP=>E; subst a; split. 663 | move=>b; rewrite mem_cat inE=>/orP; case; last first. 664 | by rewrite eq_sym=>/eqP. 665 | by apply (btExtendV_fold_dup V). 666 | move=>b; rewrite/btHasBlock=>/andP[D F] Hh. 667 | move: V; rewrite -cats1 foldl_cat //= {1}/btExtend. 668 | move: (btExtend_dom_fold V1 D)=>D'; rewrite Hh D'. 669 | case: ifP; last by rewrite valid_undef. 670 | move=>F' _; move/eqP in F'. 671 | by move: (btExtend_find_fold V1 D F'); move/eqP: F=>-> []->. 672 | move=>X; specialize (N a X); case: N=>N0 N1; split=>b; last by apply N1. 673 | rewrite mem_cat inE=>/orP; case; first by apply N0. 674 | move/eqP=>E; subst b=>/eqP Hh; rewrite eq_sym in Hh; move/eqP in Hh. 675 | by move: (btExtendV_fold_dup V X Hh)=>->. 676 | Qed. 677 | 678 | Lemma btExtendV_no_collisions_valid bt xs : 679 | validH bt -> no_collisions bt xs -> valid (foldl btExtend bt xs). 680 | Proof. 681 | elim/last_ind: xs=>[|xs x H1] //=. 682 | by rewrite/no_collisions=>_; case. 683 | rewrite/no_collisions=>Vh; case=>V N. 684 | have N0: no_collisions bt xs. 685 | rewrite/no_collisions; split=>//=. 686 | move=>a X; have X0: a \in rcons xs x 687 | by rewrite mem_rcons inE X Bool.orb_true_r. 688 | specialize (N a X0); move: N=>[]N0 N1; split=>b; last by apply N1. 689 | move=>X1; have X2: b \in rcons xs x. 690 | by rewrite mem_rcons inE X1 Bool.orb_true_r. 691 | by apply N0. 692 | specialize (H1 Vh N0); rewrite -cats1 foldl_cat //= {1}/btExtend. 693 | case: ifP; last by move=>D; rewrite validPtUn H1 D. 694 | case: ifP=>//= F D; contradict H1. 695 | (* Hmm *) 696 | have X: (x \in rcons xs x) by rewrite mem_rcons mem_head. 697 | specialize (N x X); move: N0=>N'; case: N=>N0 N1. 698 | move: (um_eta D)=>[b] [F'] zz; rewrite F' in F. 699 | specialize (N0 b); specialize (N1 b). 700 | move: (btExtendH_fold Vh (dom_valid D) F')=>Hh. 701 | rewrite Hh in D F'; have H: b ∈ (foldl btExtend bt xs). 702 | by rewrite/btHasBlock D F' eq_refl. 703 | case Z: (x == b); first by move/eqP: Z F=>->; rewrite eq_refl. 704 | case: (btExtend_fold_in_either H). 705 | by move=>Q; move: (N1 Q Hh) Z=>->; rewrite eq_refl. 706 | move=>R; have Q: (b \in rcons xs x) 707 | by rewrite -cats1 mem_cat inE R Bool.orb_true_l. 708 | by move: (N0 Q Hh) Z=>->; rewrite eq_refl. 709 | Qed. 710 | 711 | Lemma btExtendV_fold_comm' bt xs ys : 712 | validH bt -> 713 | valid (foldl btExtend (foldl btExtend bt xs) ys) -> 714 | valid (foldl btExtend (foldl btExtend bt ys) xs). 715 | Proof. 716 | move=>Vh. 717 | elim/last_ind: ys=>[|ys y V1]//= V. 718 | move: (btExtendV_fold1 V)=>V0; specialize (V1 V0). 719 | rewrite -foldl_cat; apply btExtendV_no_collisions_valid=>//=. 720 | rewrite/no_collisions; split. 721 | have X: (xs = [::] ++ xs) by []. 722 | by move: V0; rewrite -foldl_cat X; move/btExtendV_fold/btExtendV_fold. 723 | move: V; rewrite -foldl_cat; move/btExtendV_valid_no_collisions. 724 | rewrite/no_collisions; case=>V H. 725 | move=>a; rewrite mem_cat Bool.orb_comm=>X. 726 | specialize (H a); rewrite mem_cat in H; specialize (H X). 727 | case: H=>H0 H1; split=>//=. 728 | move=>b; rewrite mem_cat Bool.orb_comm -mem_cat; apply H0. 729 | Qed. 730 | 731 | Lemma btExtendV_fold_comm bt xs ys : 732 | validH bt -> 733 | valid (foldl btExtend (foldl btExtend bt xs) ys) = 734 | valid (foldl btExtend (foldl btExtend bt ys) xs). 735 | Proof. 736 | move=>Vh. 737 | have T: true by []. 738 | have X: forall (a b : bool), a <-> b -> a = b. 739 | by move=>a b []; case: a; case: b=>//= A B; 740 | [specialize (A T) | specialize (B T)]. 741 | by apply X; split; apply btExtendV_fold_comm'. 742 | Qed. 743 | 744 | Lemma btExtendV_fold' bt xs ys : 745 | validH bt-> valid (foldl btExtend bt (xs ++ ys)) -> valid (foldl btExtend bt ys). 746 | Proof. by move=>Vh; rewrite foldl_cat btExtendV_fold_comm //= -foldl_cat=>/btExtendV_fold. Qed. 747 | 748 | (**************************************************) 749 | (** The chain computed following parent pointers **) 750 | (**************************************************) 751 | 752 | Function compute_chain_up_to (bound: BType) bt b {measure round b} : Blockchain := 753 | if b ∈ bt then 754 | match find (qc_hash b) bt with 755 | | None => [::] 756 | | Some prev => 757 | if prev == bound then [:: b] else 758 | if (round prev < round b) && parent prev b then 759 | rcons (nosimpl (compute_chain_up_to bound (free (# b) bt) prev)) b 760 | else 761 | [::] 762 | end 763 | else [::]. 764 | Proof. 765 | move=> bound bt b Hb prev Hprev Hgen. 766 | move/andP=>[H _]. 767 | by apply/ltP. 768 | Qed. 769 | 770 | Definition compute_chain bt b := 771 | let: l := compute_chain_up_to GenesisBlock bt b in 772 | if parent GenesisBlock (head GenesisBlock l) then 773 | compute_chain_up_to GenesisBlock bt b 774 | else 775 | [::]. 776 | 777 | Lemma last_compute_chain_up_to (bound: BType) bt b: 778 | let: l := (compute_chain_up_to bound bt b) in 779 | last (head bound l) (behead l) = if l is [::] then bound else b. 780 | Proof. 781 | apply compute_chain_up_to_rec=>//=; move=> {b} bt b Hb prev Hprev. 782 | case =>[|Hgenesis _] //; move/andP=>[Hround Hpar] _ /=. 783 | set l:= (compute_chain_up_to bound (free (# b) bt) prev). 784 | move=> H; rewrite -(last_cons GenesisBlock) head_rcons -headI. 785 | by rewrite last_rcons; case l=>//. 786 | Qed. 787 | 788 | Lemma compute_chain_up_to_is_chained (bound: BType) bt b: 789 | validH bt -> 790 | let: l := (compute_chain_up_to bound bt b) in 791 | path [eta parent: rel BType] (head bound l) (behead l). 792 | Proof. 793 | apply compute_chain_up_to_rec=>//=; move=> {b} bt b Hb prev Hprev. 794 | case =>[|Hgenesis _] //; move/andP=> [Hround Hpar] _ /=. 795 | move: (last_compute_chain_up_to bound (free (#b) bt) prev). 796 | set l:= (compute_chain_up_to bound (free (# b) bt) prev). 797 | case H: l=> [| x xs] /= Hlast IH Hvalid //=. 798 | rewrite rcons_path (IH (validH_free Hvalid)) andTb. 799 | rewrite /parent Hlast (Hvalid _ _ Hprev). 800 | by move/andP: Hpar=>[/andP[/andP[_ ->] ->] ->]; rewrite eq_refl. 801 | Qed. 802 | 803 | Lemma compute_chain_is_chained bt b: 804 | validH bt -> 805 | chained (compute_chain bt b). 806 | Proof. 807 | rewrite /chained /compute_chain. 808 | apply compute_chain_up_to_ind=> //=; move=> {b} bt b Hb prev Hprev; try by case (parent GenesisBlock GenesisBlock) => //=. 809 | - by move/eqP => HprevG Hvalid; case H: (parent GenesisBlock b)=> //=; rewrite H. 810 | - case =>[|Hgen] _ //; move/andP=> [Hrds Hpar] _ . 811 | move: (last_compute_chain_up_to GenesisBlock (free (#b) bt) prev). 812 | set l:= (compute_chain_up_to GenesisBlock (free (# b) bt) prev). 813 | case H: l=> [| x xs] /= Hlast //=. 814 | - by case HGb: (parent GenesisBlock b) => //=; rewrite andbT. 815 | - case HGx: (parent GenesisBlock x)=> /= IH Hvalid //=; rewrite rcons_path Hlast {3}/parent (Hvalid _ _ Hprev) eq_refl . 816 | move/andP: Hpar=>[/andP[/andP[_ ->] ->] ->]; rewrite !andbT. 817 | by apply (IH (validH_free Hvalid)). 818 | Qed. 819 | 820 | Definition get_block (bt : BlockTree) k : BType := 821 | if find k bt is Some b then b else GenesisBlock. 822 | Definition all_blocks (bt : BlockTree) := [seq get_block bt k | k <- dom bt]. 823 | Definition all_chains bt := [seq compute_chain bt b | b <- all_blocks bt]. 824 | 825 | Definition direct_parent b1 b2 := 826 | (parent b1 b2) && (round b2 == (round b1).+1). 827 | 828 | Definition chain b bseq:= 829 | path direct_parent b bseq. 830 | 831 | Lemma chain_to_parent b bseq: 832 | (path direct_parent b bseq) -> 833 | (path [eta parent: rel BType] b bseq). 834 | Proof. 835 | elim: bseq b=>[|x xs IHs] b //=. 836 | by move/andP=>[/andP [Hpar _] Hpath]; rewrite Hpar (IHs _ Hpath). 837 | Qed. 838 | 839 | Notation "chain [ :: x1 ; x2 ; .. ; xn ]" := (chain x1 ( x2 :: .. [:: xn] ..)) 840 | (at level 0, format "chain [ :: '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]" 841 | ). 842 | 843 | Fixpoint three_slide (xs: seq BType) := 844 | match xs with 845 | | x :: (y :: z :: ts as l) => (x, y , z) :: (three_slide l) 846 | | _ => [::] 847 | end. 848 | 849 | Fixpoint highest_3_chain_aux (s: seq (BType * BType * BType)) n := 850 | match s with 851 | | (b1, b2, b3) :: bs => if ((round b1).+1 == (round b2)) && ((round b2).+1 == (round b3)) then 852 | (highest_3_chain_aux bs (round b3)) 853 | else 854 | (highest_3_chain_aux bs n) 855 | | _ => n 856 | end. 857 | 858 | Definition highest_3_chain (s: seq BType) := 859 | highest_3_chain_aux (three_slide s) genesis_round. 860 | 861 | Definition take_better_bc bc2 bc1 := 862 | if ((highest_3_chain bc2) > (highest_3_chain bc1)) then bc2 else bc1. 863 | 864 | Definition btChain bt : Blockchain := 865 | foldr take_better_bc ([::]) (all_chains bt). 866 | 867 | 868 | End Forests. 869 | -------------------------------------------------------------------------------- /Structures/ConsensusState.v: -------------------------------------------------------------------------------- 1 | (****************************************************************************) 2 | (* Copyright (c) Facebook, Inc. and its affiliates. *) 3 | (* *) 4 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 5 | (* you may not use this file except in compliance with the License. *) 6 | (* You may obtain a copy of the License at *) 7 | (* *) 8 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 9 | (* *) 10 | (* Unless required by applicable law or agreed to in writing, software *) 11 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 12 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 13 | (* See the License for the specific language governing permissions and *) 14 | (* limitations under the License. *) 15 | (****************************************************************************) 16 | From mathcomp.ssreflect 17 | Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path choice. 18 | Require Import Eqdep. 19 | From fcsl 20 | Require Import pred prelude ordtype pcm finmap unionmap heap. 21 | From LibraChain 22 | Require Import SeqFacts Chains HashSign Blocks. 23 | Set Implicit Arguments. 24 | Unset Strict Implicit. 25 | Unset Printing Implicit Defensive. 26 | 27 | (* A formalization of a block forests *) 28 | 29 | (************************************************************) 30 | (******************* ***************************) 31 | (************************************************************) 32 | Section State. 33 | 34 | Variable Hash : countType. 35 | Variables (PublicKey: countType) (Signature: countType) (Address: hashType PublicKey). 36 | 37 | Variables (Command NodeTime: countType). 38 | 39 | (* The Block Data (w/o signatures) *) 40 | Notation BDataType := (BlockData Hash Signature Address Command NodeTime). 41 | 42 | Variable hashB: BDataType -> Hash. 43 | Hypothesis inj_hashB: injective hashB. 44 | 45 | Variable verifB: Hash -> PublicKey -> Signature -> bool. 46 | 47 | (* Block Type : block data with signatures *) 48 | Notation BType := (BlockType inj_hashB verifB). 49 | Notation QC := (QuorumCert Hash Signature (Phant Address)). 50 | 51 | Implicit Type b: BDataType. 52 | 53 | Parameter GenesisBlock : BType. 54 | 55 | Definition genesis_round := (round GenesisBlock). 56 | 57 | Implicit Type (bd: BDataType). 58 | 59 | Definition qc_of bd := (proof bd). 60 | Definition qc_hash bd := (block_hash (qc_vote_data (qc_of bd))). 61 | Definition qc_round bd := (block_round (qc_vote_data (qc_of bd))). 62 | Definition qc_parent_hash bd := (parent_block_hash (qc_vote_data (qc_of bd))). 63 | Definition qc_parent_round bd := (parent_block_round (qc_vote_data (qc_of bd))). 64 | 65 | Definition parent b1 b2 := (hashB b1 == qc_hash b2) && (round b1 == qc_round b2) && (qc_hash b1 == qc_parent_hash b2) && (qc_round b1 == qc_parent_round b2). 66 | Definition chained (bc: seq BType):= path [eta parent: rel BType] GenesisBlock bc. 67 | 68 | Lemma rounds_transitive: 69 | transitive (fun b1 b2 => (round b1) < (round b2)). 70 | Proof. 71 | by move=> b1 b2 b3; apply ltn_trans. 72 | Qed. 73 | 74 | Lemma rounds_irreflexive: 75 | irreflexive (fun b1 b2 => (round b1) < (round b2)). 76 | Proof. by move=> b; rewrite ltnn. Qed. 77 | 78 | (************************************************************) 79 | (** Consensus State **) 80 | (************************************************************) 81 | 82 | Record ConsensusState := mkConsensusState { 83 | last_vote_round: nat; 84 | preferred_block_round: nat; 85 | }. 86 | 87 | Definition consensusstate2nats (cs: ConsensusState) := 88 | let: mkConsensusState lvr pvr := cs in (lvr, pvr). 89 | 90 | Definition nats2consensusstate (nats: nat * nat) := 91 | let: (lvr, pbr) := nats in mkConsensusState lvr pbr. 92 | 93 | Lemma can_cs_nats: ssrfun.cancel consensusstate2nats nats2consensusstate. 94 | Proof. by move => []. Qed. 95 | 96 | Definition cs_eqMixin := CanEqMixin can_cs_nats. 97 | Canonical cs_eqType := EqType _ cs_eqMixin. 98 | Definition cs_choiceMixin := CanChoiceMixin can_cs_nats. 99 | Canonical cs_choiceType := ChoiceType _ cs_choiceMixin. 100 | Definition cs_countMixin := CanCountMixin can_cs_nats. 101 | Canonical cs_countType := CountType _ cs_countMixin. 102 | 103 | Definition genesis_state := mkConsensusState genesis_round genesis_round. 104 | 105 | Implicit Type state: ConsensusState. 106 | 107 | Definition update state (qc: QC) := 108 | let: round := (parent_block_round (qc_vote_data qc)) in 109 | if (round > preferred_block_round state) then 110 | mkConsensusState (last_vote_round state) (round) 111 | else 112 | state. 113 | 114 | Lemma update_eq_lvr state qc : 115 | last_vote_round (update state qc) = last_vote_round state. 116 | Proof. 117 | rewrite /update. 118 | by case (parent_block_round (qc_vote_data qc) > preferred_block_round state). 119 | Qed. 120 | 121 | Lemma update_pbr_geq state qc : 122 | preferred_block_round state <= preferred_block_round (update state qc). 123 | Proof. 124 | rewrite /update. 125 | case H: (parent_block_round (qc_vote_data qc) > preferred_block_round state) => //. 126 | by move/ltnW: H => ->. 127 | Qed. 128 | 129 | Lemma update_qc_gt state qc : 130 | parent_block_round (qc_vote_data qc) <= preferred_block_round (update state qc). 131 | Proof. 132 | rewrite /update; case H: (preferred_block_round state < (parent_block_round (qc_vote_data qc))) => //. 133 | by rewrite leqNgt H. 134 | Qed. 135 | 136 | Lemma update_pbr_P state qc: 137 | reflect (preferred_block_round (update state qc) = parent_block_round (qc_vote_data qc)) 138 | (preferred_block_round state <= parent_block_round (qc_vote_data qc)). 139 | Proof. 140 | apply: (iffP idP); rewrite /update; 141 | case H: (parent_block_round (qc_vote_data qc) > preferred_block_round state); 142 | rewrite leq_eqVlt H ?orbF ?orbT //; move/eqP=> //. 143 | Qed. 144 | 145 | Lemma update_maxn state qc: 146 | update state qc = 147 | mkConsensusState (last_vote_round state) 148 | (maxn (preferred_block_round state) (parent_block_round (qc_vote_data qc))). 149 | Proof. 150 | rewrite /update /maxn; case: ((preferred_block_round state) < (parent_block_round (qc_vote_data qc))) => //=. 151 | by case state. 152 | Qed. 153 | 154 | (************************************************************) 155 | (** Voting after update with the QC **) 156 | (************************************************************) 157 | 158 | Definition votable state b := 159 | let: (rd, qcr, lvr, pbr) := 160 | ((round b), (qc_round b), 161 | (last_vote_round state), 162 | (preferred_block_round state)) in [&& rd > lvr & qcr >= pbr]. 163 | 164 | Lemma votable_updateP state b: 165 | reflect (votable (update state (qc_of b)) b) 166 | (votable state b && (qc_round b >= qc_parent_round b)). 167 | Proof. 168 | apply: (iffP andP); rewrite /votable update_eq_lvr. 169 | - rewrite /update; case (preferred_block_round state < parent_block_round (qc_vote_data (qc_of b))); 170 | move=> [H1 H2]; move/andP: H1=> [-> H1] //; rewrite ltnW //. 171 | - move/andP => [->] //= H. 172 | apply/andP; rewrite (leq_trans (update_pbr_geq _ _) H) //=. 173 | by apply: (leq_trans (update_qc_gt state _)). 174 | Qed. 175 | 176 | Lemma votable_update_round_geq state b: 177 | (votable (update state (qc_of b)) b) = 178 | (votable state b && (qc_round b >= qc_parent_round b)). 179 | Proof. 180 | by apply/(sameP idP); apply: votable_updateP. 181 | Qed. 182 | 183 | Definition voting_rule state (b: BDataType) := 184 | let after_update := update state (qc_of b) in 185 | if votable (after_update) b then 186 | let newState := 187 | mkConsensusState (round b) (preferred_block_round after_update) 188 | in 189 | (newState, true) 190 | else (after_update, false). 191 | 192 | Definition voted_on state b := (voting_rule state b).2. 193 | 194 | Lemma voted_on_votable state b: 195 | voted_on state b = votable (update state (qc_of b)) b. 196 | Proof. 197 | rewrite /voted_on /voting_rule. 198 | by case: (votable (update state (qc_of b)) b) => //. 199 | Qed. 200 | 201 | Lemma voted_br_gt_qcr state b: 202 | voted_on state b -> 203 | qc_round b >= qc_parent_round b. 204 | Proof. 205 | rewrite /voted_on /voting_rule. 206 | case H: (votable (update state (qc_of b)) b). 207 | - by move/votable_updateP: H; move/andP => [_ ->]. 208 | - by rewrite /update; case (preferred_block_round state < _). 209 | Qed. 210 | 211 | Lemma voted_pr_gt_qcr state b: 212 | voted_on state b -> 213 | qc_round b >= preferred_block_round state. 214 | Proof. 215 | rewrite /voted_on /voting_rule. 216 | case H: (votable (update state (qc_of b)) b). 217 | - by move/votable_updateP: H; rewrite andbC /=; move/andP=>[_]; move/andP=>[_ ->]. 218 | - by rewrite /update; case (preferred_block_round state < _). 219 | Qed. 220 | 221 | Lemma ineq_voted_on state b: 222 | (voted_on state b) = [&& (round b > last_vote_round state), 223 | (qc_round b >= preferred_block_round state) & 224 | (qc_round b >= qc_parent_round b)]. 225 | Proof. 226 | by rewrite voted_on_votable votable_update_round_geq /votable -andbA. 227 | Qed. 228 | 229 | 230 | Lemma vote_genesis_N: voted_on genesis_state GenesisBlock = false. 231 | Proof. 232 | by rewrite voted_on_votable /votable update_eq_lvr /= /genesis_round ltnn. 233 | Qed. 234 | 235 | Definition next_state state b := (voting_rule state b).1. 236 | 237 | Lemma next_state_pbr_update state b : 238 | preferred_block_round (next_state state b) = preferred_block_round (update state (qc_of b)). 239 | Proof. 240 | by rewrite /next_state /voting_rule; case (votable (update state (qc_of b)) b). 241 | Qed. 242 | 243 | Lemma next_state_pbr_geq state b: 244 | preferred_block_round state <= preferred_block_round (next_state state b). 245 | Proof. 246 | by rewrite next_state_pbr_update update_pbr_geq. 247 | Qed. 248 | 249 | Lemma next_state_lvr_voted state b : 250 | reflect (last_vote_round state < last_vote_round (next_state state b)) (voted_on state b). 251 | Proof. 252 | rewrite /next_state /voting_rule -voted_on_votable; apply: (iffP idP). 253 | - move=>H; rewrite (H)=>//=; move:H; rewrite ineq_voted_on. 254 | by move/andP=>[-> _]. 255 | - by case: (voted_on state b); rewrite // update_eq_lvr ltnn. 256 | Qed. 257 | 258 | Lemma next_state_lvr_round state b: 259 | voted_on state b -> last_vote_round (next_state state b) = round b. 260 | Proof. 261 | by rewrite voted_on_votable /next_state /voting_rule=>-> /=. 262 | Qed. 263 | 264 | Lemma next_state_lvr_static state b: 265 | ~~ voted_on state b -> last_vote_round (next_state state b) = last_vote_round state. 266 | Proof. 267 | rewrite voted_on_votable /next_state /voting_rule. 268 | by move/negbTE=>->; rewrite update_eq_lvr. 269 | Qed. 270 | 271 | Lemma next_state_lvr_if state b: 272 | next_state state b = 273 | let: pbr:= preferred_block_round (update state (qc_of b)) in 274 | if (voted_on state b) then 275 | mkConsensusState (round b) pbr 276 | else 277 | mkConsensusState (last_vote_round state) pbr. 278 | Proof. 279 | rewrite /next_state /voting_rule -voted_on_votable /=; case H: (voted_on state b)=> //=. 280 | by rewrite update_maxn /=. 281 | Qed. 282 | 283 | Lemma next_state_lvr_leq state b: 284 | last_vote_round state <= last_vote_round (next_state state b). 285 | Proof. 286 | case H: (voted_on state b). 287 | - by rewrite leq_eqVlt; move/next_state_lvr_voted: H=>->; rewrite orbT. 288 | - by rewrite /next_state /voting_rule -voted_on_votable H update_eq_lvr. 289 | Qed. 290 | 291 | Lemma next_state_maxn state b: 292 | (next_state state b) = 293 | let: u_pbr := (maxn (preferred_block_round state) (qc_parent_round b)) in 294 | mkConsensusState 295 | (if (round b >= (last_vote_round state).+1) && (qc_round b >= u_pbr) then round b else last_vote_round state) 296 | u_pbr. 297 | Proof. 298 | rewrite /next_state /voting_rule update_maxn. 299 | set pbr:= (maxn (preferred_block_round state) (qc_parent_round b)). 300 | rewrite /votable /=. 301 | by case H: ((last_vote_round state < round b) && (pbr <= qc_round b)). 302 | Qed. 303 | 304 | Lemma pbr_next_stateC state b c: 305 | preferred_block_round (next_state (next_state state b) c) = 306 | preferred_block_round (next_state (next_state state c) b). 307 | Proof. 308 | rewrite (next_state_maxn (next_state state c) b) next_state_maxn /=. 309 | by rewrite !next_state_maxn /= maxnAC. 310 | Qed. 311 | 312 | Lemma voting_next_voted state b : 313 | voting_rule state b = (next_state state b, voted_on state b). 314 | Proof. 315 | by apply surjective_pairing. 316 | Qed. 317 | 318 | Lemma voting_next_N state b: voted_on (next_state state b) b = false. 319 | Proof. 320 | rewrite voted_on_votable votable_update_round_geq /votable. 321 | rewrite {1}/next_state /voting_rule. 322 | case H:(votable (update state (qc_of b)) b) => /=; first by rewrite ltnn. 323 | rewrite /votable -next_state_pbr_update in H. 324 | by rewrite H andFb. 325 | Qed. 326 | 327 | Lemma voting_update_progress state qc x: 328 | voted_on (update state qc) x -> voted_on state x. 329 | Proof. 330 | rewrite 2!ineq_voted_on update_maxn /= geq_max. 331 | by move/andP=>[->]; move/andP =>[H ->]; move/andP: H=>[-> _]. 332 | Qed. 333 | 334 | Lemma voting_progress state b x: 335 | voted_on (next_state state b) x -> voted_on state x. 336 | Proof. 337 | rewrite 2!ineq_voted_on; move/andP=> [Hlvr]; move/andP=> [Hpbr Hbr]. 338 | rewrite (leq_ltn_trans (next_state_lvr_leq _ _) Hlvr). 339 | by rewrite (leq_trans (next_state_pbr_geq _ _) Hpbr) /=. 340 | Qed. 341 | 342 | Lemma voting_gt state b x: 343 | voted_on (next_state state b) x -> 344 | ~~ voted_on state b || (round b < round x). 345 | Proof. 346 | move=> H; move: (H); rewrite ineq_voted_on; move/andP=> [Hlvr _]. 347 | case I: (voted_on state b)=> //. 348 | by rewrite (next_state_lvr_round I) in Hlvr. 349 | Qed. 350 | 351 | Lemma non_voted_on_update state b x: 352 | ~~ voted_on state b -> 353 | voted_on (next_state state b) x = voted_on (update state (qc_of b)) x. 354 | Proof. 355 | rewrite next_state_lvr_if; move/negbTE=>->. 356 | by rewrite update_maxn. 357 | Qed. 358 | 359 | Lemma pbr_update_next state b x: 360 | preferred_block_round (update (next_state state b) (qc_of x)) = 361 | preferred_block_round (update (update state (qc_of b)) (qc_of x)). 362 | Proof. 363 | by rewrite next_state_maxn !update_maxn /=. 364 | Qed. 365 | 366 | Lemma voted_next_update state b x: 367 | voted_on (next_state state b) x -> 368 | voted_on (update state (qc_of b)) x. 369 | Proof. 370 | move=> H; move/voting_progress: (H); rewrite ineq_voted_on; move/andP=> [Hs _]. 371 | move: H; rewrite ineq_voted_on next_state_pbr_update. 372 | move/andP=>[Hlvr]; move/andP=> [H1 H2]. 373 | by rewrite ineq_voted_on update_eq_lvr Hs H1 H2. 374 | Qed. 375 | 376 | Lemma next_state_updateC state qc x: 377 | voted_on (update state qc) x -> 378 | next_state (update state (qc)) x = 379 | update (next_state state x) qc. 380 | Proof. 381 | move => H; rewrite /next_state /voting_rule -2!voted_on_votable H. 382 | by move/voting_update_progress: H=> -> /=; rewrite !update_maxn /= maxnAC. 383 | Qed. 384 | 385 | Lemma voted_on_maxn state b: 386 | (voted_on state b) = 387 | (round b >= (last_vote_round state).+1) && (qc_round b >= maxn (preferred_block_round state) 388 | (qc_parent_round b)). 389 | Proof. 390 | by rewrite !geq_max ineq_voted_on. 391 | Qed. 392 | 393 | (************************************************************) 394 | (** Voting in Sequence **) 395 | (************************************************************) 396 | 397 | Implicit Type bseq: seq BDataType. 398 | 399 | (* node_processing is a slight modification on a scanleft of the voting rules 400 | over a seq of block *) 401 | Fixpoint process_aux state bseq res := 402 | if bseq is x::s then 403 | let: (new_state, vote) := (voting_rule state x) in 404 | process_aux new_state s ((state, vote) :: res) 405 | else 406 | (state, rev res). 407 | 408 | Definition node_processing state bseq := process_aux state bseq [::]. 409 | 410 | Lemma size_process_aux state bseq res: size (process_aux state bseq res).2 = size bseq + size res. 411 | Proof. 412 | elim:bseq res state => [|x xs IHs] res state. 413 | - by rewrite size_rev add0n. 414 | - by rewrite /= voting_next_voted IHs /= addSnnS. 415 | Qed. 416 | 417 | Lemma size_processing state bseq : size (node_processing state bseq).2 = size bseq. 418 | Proof. 419 | by rewrite /node_processing size_process_aux addn0. 420 | Qed. 421 | 422 | Lemma processing_aux_state_res_irrel state bseq rs1 rs2: 423 | (process_aux state bseq rs1).1 = (process_aux state bseq rs2).1. 424 | Proof. 425 | elim: bseq state rs1 rs2 => [|b bs IHb] state rs1 rs2 //=; rewrite voting_next_voted. 426 | by apply:IHb. 427 | Qed. 428 | 429 | Lemma processing_aux_rcons state bseq r rs: 430 | (process_aux state bseq (rcons rs r)).2 = 431 | r :: (process_aux state bseq rs).2. 432 | Proof. 433 | elim: bseq r rs state =>[| b bs IHb] r rs state => /=. 434 | - by rewrite rev_rcons. 435 | - by rewrite voting_next_voted -IHb -rcons_cons. 436 | Qed. 437 | 438 | Lemma processing_aux_rev state bseq res: 439 | (process_aux state bseq res).2 = 440 | rev res ++ (process_aux state bseq [::]).2. 441 | Proof. 442 | move: res bseq state; apply: last_ind=> [|rs r IHr] bseq state. 443 | - by []. 444 | - by rewrite processing_aux_rcons IHr rev_rcons. 445 | Qed. 446 | 447 | Lemma processing_aux_cons state b bs: 448 | (process_aux state (b::bs) [::]).2 = 449 | (state, voted_on state b) :: (process_aux (next_state state b) bs [::]).2. 450 | Proof. 451 | rewrite /= voting_next_voted -[[:: (state, voted_on _ _)]]cat0s cats1. 452 | by rewrite processing_aux_rcons. 453 | Qed. 454 | 455 | Lemma processing_aux_cons2 state b bs: 456 | (process_aux state (b::bs) [::]) = 457 | let: (f_state, vbs) := (process_aux (next_state state b) bs [::]) in 458 | (f_state, (state, voted_on state b) ::vbs). 459 | Proof. 460 | rewrite /= voting_next_voted -[[:: (state, voted_on _ _)]]cat0s cats1. 461 | rewrite [process_aux _ bs [::]]surjective_pairing -processing_aux_cons /=. 462 | rewrite (processing_aux_state_res_irrel _ _ [::] [:: (state, voted_on state b)]). 463 | by rewrite voting_next_voted -surjective_pairing. 464 | Qed. 465 | 466 | Lemma node_processing_cons state b bs: 467 | (node_processing state (b::bs)).2 = 468 | (state, voted_on state b) :: (node_processing (next_state state b) bs).2. 469 | Proof. 470 | by rewrite processing_aux_cons. 471 | Qed. 472 | 473 | Lemma node_processing_cons2 state b bs: 474 | (node_processing state (b::bs)) = 475 | let: (final_state, bsvotes) := node_processing (next_state state b) bs in 476 | (final_state, (state, voted_on state b)::bsvotes). 477 | Proof. 478 | by rewrite /node_processing processing_aux_cons2. 479 | Qed. 480 | 481 | Lemma node_processing_cons1 state b bs: 482 | (node_processing state (b::bs)).1 = 483 | (node_processing (next_state state b) bs).1. 484 | Proof. 485 | case: bs state b=>[|x s ]=>state b; rewrite node_processing_cons2 //=. 486 | by rewrite [node_processing _ _]surjective_pairing /=. 487 | Qed. 488 | 489 | Lemma node_processing_cat_cps state bs1 bs2 : 490 | (node_processing state (bs1 ++ bs2)) = 491 | let: (state1, seq1) := (node_processing state bs1) in 492 | let: (state2, seq2) := (node_processing state1 bs2) in 493 | (state2, seq1 ++ seq2). 494 | Proof. 495 | elim: bs1 state =>[| b bs IHb] state /=. 496 | - by rewrite {2}[node_processing _ _]surjective_pairing -surjective_pairing. 497 | rewrite 2!node_processing_cons2 IHb [node_processing (next_state _ _) _]surjective_pairing /=. 498 | by rewrite [node_processing _ _]surjective_pairing. 499 | Qed. 500 | 501 | Lemma node_processing_rcons state bs b: 502 | (next_state (node_processing state bs).1 b) = 503 | (node_processing state (rcons bs b)).1. 504 | Proof. 505 | rewrite -cats1 node_processing_cat_cps /=. 506 | rewrite {2}[node_processing _ _]surjective_pairing /=. 507 | rewrite [node_processing _ [::b]]surjective_pairing /=. 508 | by rewrite node_processing_cons1 /=. 509 | Qed. 510 | 511 | Lemma voting_progress_seq state bs b: 512 | voted_on (node_processing state bs).1 b -> voted_on state b. 513 | Proof. 514 | elim: bs state b => [|x s IHs] state b //=. 515 | rewrite node_processing_cons1. 516 | move/IHs; apply voting_progress. 517 | Qed. 518 | 519 | (************************************************************) 520 | (** Consensus State Comparators **) 521 | (************************************************************) 522 | 523 | Definition comparator state1 := 524 | ((last_vote_round state1).+1, (preferred_block_round state1)). 525 | 526 | Definition state_compare state1 state2 := 527 | ((comparator state1).1 <= (comparator state2).1) && ((comparator state1).2 <= (comparator state2).2). 528 | 529 | Declare Scope state_scope. 530 | Delimit Scope state_scope with STATE. 531 | Open Scope state_scope. 532 | 533 | Notation "state1 <% state2" := (state_compare state1 state2) (at level 40) :state_scope. 534 | 535 | Lemma comparators_reflexive: 536 | reflexive state_compare. 537 | Proof. 538 | by move => x; rewrite /state_compare 2!leqnn. 539 | Qed. 540 | 541 | Lemma comparators_transitive: 542 | transitive state_compare. 543 | Proof. 544 | move => s2 s1 s3 H12 H23; move/andP: H12=> [H12fst H12snd]. 545 | move/andP: H23=> [H23fst H23snd]; rewrite /state_compare (leq_trans H12fst H23fst). 546 | by rewrite (leq_trans H12snd). 547 | Qed. 548 | 549 | Lemma voting_comparator state x: 550 | (voted_on state x) -> 551 | (comparator (next_state state x) = ((round x).+1, (maxn (comparator state).2 (qc_parent_round x)))). 552 | Proof. 553 | rewrite next_state_lvr_if fun_if /comparator /= =>H. 554 | by rewrite H update_maxn /= maxnC. 555 | Qed. 556 | 557 | Lemma non_voting_comparator state x: 558 | ~~ voted_on state x -> 559 | comparator (next_state state x) = ((comparator state).1, (maxn (comparator state).2 (qc_parent_round x))). 560 | Proof. 561 | move=>Hnv; rewrite next_state_lvr_if; move/negbTE: (Hnv)=>->. 562 | by rewrite /comparator update_maxn /=. 563 | Qed. 564 | 565 | Lemma voting_comparatorE state x: 566 | comparator (next_state state x) = 567 | if (voted_on state x) then 568 | ((round x).+1, (maxn (comparator state).2 (qc_parent_round x))) 569 | else 570 | ((comparator state).1, (maxn (comparator state).2 (qc_parent_round x))). 571 | Proof. 572 | by case H:(voted_on state x); [rewrite (voting_comparator H)| rewrite (non_voting_comparator (negbT H))]. 573 | Qed. 574 | 575 | Lemma voting_comparator_eq state b: 576 | (voted_on state b) = 577 | ((comparator state).1 <= round b) && ((comparator state).2 <= (qc_round b)) && ((qc_parent_round b) <= qc_round b). 578 | Proof. 579 | by rewrite /comparator ineq_voted_on /= andbA. 580 | Qed. 581 | 582 | Lemma voting_gt_compare state1 state2 x: 583 | state1 <% state2 -> voted_on state2 x -> voted_on state1 x. 584 | Proof. 585 | move=> H; rewrite 2!voted_on_maxn. 586 | move/andP=> [Hlv2 Hpr2]; move/andP: H=> [Hlv12 Hpr12]. 587 | rewrite (leq_trans Hlv12 Hlv2) /=; move:Hpr2; rewrite 2!geq_max. 588 | by move/andP=> [Hpr2 ->]; rewrite (leq_trans Hpr12 Hpr2). 589 | Qed. 590 | 591 | Lemma voting_gt_compareN state1 state2 x: 592 | state1 <% state2 -> ~~ voted_on state1 x -> ~~ voted_on state2 x. 593 | Proof. 594 | by move=>H; apply: contra; apply: voting_gt_compare. 595 | Qed. 596 | 597 | Lemma voting_next_gt state x: 598 | state <% (next_state state x). 599 | Proof. 600 | rewrite next_state_lvr_if. 601 | case Hx:(voted_on state x); rewrite /state_compare /=. 602 | - move/idP: Hx; rewrite voted_on_maxn. 603 | rewrite geq_max; move/andP=> [Hlv Hpr]. 604 | by rewrite update_maxn /= leq_max leqnn orTb andbT ltnW. 605 | by rewrite update_maxn /= leq_max 2!leqnn orTb andTb. 606 | Qed. 607 | 608 | Lemma node_processing_sorted state bs: 609 | sorted (fun s1 s2 => s1 <% s2) (unzip1 (node_processing state bs).2). 610 | Proof. 611 | move: state; elim: bs=>[| b bs IHb] state //. 612 | rewrite node_processing_cons; move:(IHb (next_state state b)); rewrite /path /sorted /=. 613 | case H: (unzip1 (node_processing (next_state state b) bs).2) =>// [x xs]. 614 | rewrite /path -/(path _ _ _)=>-> /=; move:H; case bs=> [|y ys]//=. 615 | rewrite andbT node_processing_cons /=; move/eqP; rewrite eqseq_cons. 616 | by move/andP=>[/eqP<- _]; apply: voting_next_gt. 617 | Qed. 618 | 619 | Lemma node_processing_head state bs: 620 | unzip1 (node_processing state bs).2 = (if bs is x::xs then state :: unzip1 (node_processing (next_state state x) xs).2 else [::]). 621 | Proof. 622 | by case: bs=> [|x xs]//=; rewrite node_processing_cons /=. 623 | Qed. 624 | 625 | Lemma node_processing_path state bs: 626 | path (fun s1 s2 => s1 <% s2) state (unzip1 (node_processing state bs).2). 627 | Proof. 628 | move: (node_processing_sorted state bs); rewrite node_processing_head. 629 | rewrite /sorted; case: bs=>[|b bs] //=; by rewrite comparators_reflexive. 630 | Qed. 631 | 632 | Lemma node_processing_last s0 state bs b: 633 | last s0 (unzip1 (node_processing state (rcons bs b)).2) = (node_processing state bs).1. 634 | Proof. 635 | elim: bs state s0 =>[| x s IHs] state s0 //=; first by rewrite node_processing_cons. 636 | rewrite node_processing_cons node_processing_cons1 /unzip1 map_cons /= -/unzip1. 637 | by rewrite (IHs (next_state state x)). 638 | Qed. 639 | 640 | (************************************************************) 641 | (** Sequence of blocks which a node voted on **) 642 | (************************************************************) 643 | 644 | Definition voted_in_processing state bseq := 645 | mask (unzip2 (node_processing state bseq).2) bseq. 646 | 647 | Lemma voted_in_processing_cat_cps state bs1 bs2: 648 | (voted_in_processing state (bs1 ++ bs2)) = 649 | let: b1 := (voted_in_processing state bs1) in 650 | let: b2 := (voted_in_processing (node_processing state bs1).1 bs2) in 651 | b1 ++ b2. 652 | Proof. 653 | rewrite /voted_in_processing node_processing_cat_cps /=. 654 | rewrite 2![node_processing _ _]surjective_pairing /=. 655 | rewrite -mask_cat; last by rewrite size_map size_processing. 656 | by rewrite -map_cat /unzip2. 657 | Qed. 658 | 659 | Lemma voted_in_processing_cons state b bs: 660 | (voted_in_processing state (b::bs)) = 661 | (nseq (voted_on state b) b ++ (voted_in_processing (next_state state b) bs)). 662 | Proof. 663 | by rewrite /voted_in_processing node_processing_cons mask_cons. 664 | Qed. 665 | 666 | Lemma comparator_next state1 state2 b: 667 | comparator state1 = comparator state2 668 | -> comparator (next_state state1 b) = comparator (next_state state2 b). 669 | Proof. 670 | move=> H12; case H1: (voted_on state1 b); move: (H1); rewrite voting_comparator_eq H12 -voting_comparator_eq=> H2. 671 | - by rewrite (voting_comparator H1) (voting_comparator H2) /=; move/eqP: H12; rewrite xpair_eqE; move/andP =>[_]; move/eqP=>->. 672 | by rewrite (non_voting_comparator (negbT H1)) (non_voting_comparator (negbT H2)) H12. 673 | Qed. 674 | 675 | Lemma comparator_processing state1 state2 bseq: 676 | comparator state1 = comparator state2 677 | -> comparator (node_processing state1 bseq).1 = comparator (node_processing state2 bseq).1. 678 | Proof. 679 | elim: bseq state1 state2 =>[| x s IHs] state1 state2 H12 //. 680 | by rewrite 2!node_processing_cons1 (IHs _ _ (comparator_next x H12)). 681 | Qed. 682 | 683 | Lemma next_state_repeat state b: 684 | (next_state (next_state state b) b) = (next_state state b). 685 | Proof. 686 | rewrite next_state_lvr_if voting_next_N update_maxn next_state_pbr_update update_maxn /= -maxnA maxnn. 687 | move: (next_state_pbr_update state b); rewrite update_maxn {2}/preferred_block_round=><-. 688 | have H: forall s, s = {| last_vote_round := (last_vote_round s); 689 | preferred_block_round:= (preferred_block_round s)|}; first by case. 690 | by rewrite {3}(H (next_state state b)). 691 | Qed. 692 | 693 | Lemma voted_on_already state bs1 b: 694 | b \in bs1 -> 695 | voted_on (node_processing state bs1).1 b = false. 696 | Proof. 697 | elim/last_ind: bs1 state b => [|s x IHs] state b //=. 698 | rewrite mem_rcons inE -node_processing_rcons; move/orP=>[Hb|Hb]. 699 | - by rewrite (eqP Hb) voting_next_N. 700 | - apply/negbTE; rewrite (voting_gt_compareN (voting_next_gt _ x) _) //. 701 | by apply/negbT; apply: IHs. 702 | Qed. 703 | 704 | Lemma updated_already state bs1 b: 705 | b \in bs1 -> 706 | update (node_processing state bs1).1 (qc_of b) = (node_processing state bs1).1. 707 | Proof. 708 | have H: forall s, s = {| last_vote_round := (last_vote_round s); 709 | preferred_block_round:= (preferred_block_round s)|}; first by case. 710 | rewrite update_maxn=> Hb. 711 | have Hpr: (preferred_block_round (node_processing state bs1).1 >= qc_parent_round b); 712 | last by move/maxn_idPl: Hpr=>->; symmetry; exact:H. 713 | move: {H} Hb; elim/last_ind: bs1 state b => [|s x IHs] state b //. 714 | rewrite mem_rcons inE -node_processing_rcons next_state_pbr_update update_maxn leq_max. 715 | move/orP=>[Hb|Hb]; rewrite -/(qc_parent_round _) ?(eqP Hb) ?leqnn ?orbT //. 716 | by rewrite IHs. 717 | Qed. 718 | 719 | Lemma next_state_already state bs1 b: 720 | b \in bs1 -> 721 | (next_state (node_processing state bs1).1 b) = (node_processing state bs1).1. 722 | Proof. 723 | move=> Hb; rewrite next_state_lvr_if (voted_on_already _ Hb) updated_already //; symmetry. 724 | have H: forall s, s = {| last_vote_round := (last_vote_round s); 725 | preferred_block_round:= (preferred_block_round s)|}; first by case. 726 | by apply H. 727 | Qed. 728 | 729 | Lemma comparator_repeat state b: 730 | comparator (next_state (next_state state b) b) = 731 | comparator (next_state state b). 732 | Proof. 733 | by rewrite next_state_repeat. 734 | Qed. 735 | 736 | Lemma voted_in_processing_comparison state1 state2 bs: 737 | comparator state1 = comparator state2 -> 738 | voted_in_processing state1 bs = voted_in_processing state2 bs. 739 | Proof. 740 | elim: bs state1 state2=>[| x s IHs] state1 state2 H12 //. 741 | rewrite /voted_in_processing 2!node_processing_cons 2!mask_cons. 742 | rewrite -/(map snd) -/unzip2 -2!/(voted_in_processing (next_state _ x) s). 743 | rewrite (IHs _ _ (comparator_next x H12)) /=. 744 | by rewrite 2!voting_comparator_eq H12. 745 | Qed. 746 | 747 | Lemma voted_in_processing_repeat state b bs: 748 | voted_in_processing (next_state state b) (b:: bs) = 749 | voted_in_processing (next_state state b) (bs). 750 | Proof. 751 | rewrite /voted_in_processing !node_processing_cons !mask_cons. 752 | by rewrite voting_next_N next_state_repeat. 753 | Qed. 754 | 755 | Lemma voted_in_processing_already_cat state b bs1 bs2: 756 | b \in bs1 -> 757 | voted_in_processing state (bs1 ++ b::bs2) = 758 | voted_in_processing state (bs1 ++ bs2). 759 | Proof. 760 | rewrite voted_in_processing_cat_cps voted_in_processing_cons=> Hb. 761 | by rewrite (next_state_already _ Hb) (voted_on_already _ Hb) /= voted_in_processing_cat_cps. 762 | Qed. 763 | 764 | Lemma voted_in_processing_already state b bs1 bs2: 765 | b \in bs1 -> 766 | voted_in_processing (node_processing state bs1).1 (b::bs2) = 767 | voted_in_processing (node_processing state bs1).1 bs2. 768 | rewrite voted_in_processing_cons=> Hb. 769 | by rewrite (next_state_already _ Hb) (voted_on_already _ Hb) /=. 770 | Qed. 771 | 772 | Lemma voted_in_pred_cat state bs1 bs2 b: 773 | b \in bs1 -> 774 | voted_in_processing (node_processing state bs1).1 bs2 = 775 | voted_in_processing (node_processing state bs1).1 (filter (predC1 b) bs2). 776 | Proof. 777 | elim: bs2 state bs1 b =>[|x xs IHs] state bs1 b Hbin //=. 778 | case Hbx: (x == b)=>/=. 779 | - by rewrite (voted_in_processing_already _ _ ) ?(IHs _ _ b) // (eqP Hbx). 780 | rewrite 2!voted_in_processing_cons; apply/eqP; rewrite eqseq_cat; last by []. 781 | rewrite eq_refl node_processing_rcons andTb; apply/eqP/IHs. 782 | by rewrite mem_rcons inE Hbin orbT. 783 | Qed. 784 | 785 | Lemma voted_in_predC1 state b bs: 786 | voted_in_processing (next_state state b) (bs) = 787 | voted_in_processing (next_state state b) (filter (predC1 b) bs). 788 | Proof. 789 | have H: (next_state state b) = ((node_processing state [:: b]).1). 790 | - by rewrite -[[:: b]]cat0s cats1 -node_processing_rcons /=. 791 | rewrite H; apply: voted_in_pred_cat. 792 | by rewrite inE. 793 | Qed. 794 | 795 | Lemma voted_in_rundup state bs: 796 | voted_in_processing state bs = voted_in_processing state (rundup bs). 797 | Proof. 798 | elim: bs state =>[| x s IHs] state //=. 799 | rewrite /voted_in_processing 2!node_processing_cons /unzip2 map_cons mask_cons. 800 | rewrite -/(voted_in_processing (next_state state x) s) IHs . 801 | rewrite mask_cons -/(map snd) -/unzip2 -/(voted_in_processing (next_state state x) _). 802 | by rewrite -voted_in_predC1. 803 | Qed. 804 | 805 | Lemma voted_in_processing_idx state bseq b: 806 | (b \in (voted_in_processing state bseq)) = 807 | (voted_on (nth state (unzip1 (node_processing state bseq).2) (index b bseq) ) b && (b \in bseq)). 808 | Proof. 809 | rewrite voted_in_rundup. 810 | elim: bseq b state =>[| bb bbs IHbb] b state /=. 811 | - by rewrite in_nil andbF. 812 | rewrite /voted_in_processing /= 2!node_processing_cons /unzip2 mask_cons -/(map snd) /=. 813 | case H: (bb == b). 814 | - move/eqP: H=> ->; rewrite in_cons eqxx. 815 | case H2: (voted_on state b); first by rewrite in_cons eqxx orTb andbT. 816 | rewrite /=; apply: negbTE; apply: contraT; move/negPn=>H. 817 | by move: (mem_mask H); rewrite mem_filter /= eq_refl. 818 | rewrite mem_cat mem_nseq in_cons eq_sym H andbF 2!orFb. 819 | rewrite -/unzip2 -/(voted_in_processing (next_state state bb) _). 820 | rewrite -voted_in_predC1 IHbb /=; case Hbbs: (b\in bbs); last by rewrite 2!andbF. 821 | rewrite (nth_in_default_irrel (next_state state bb) state _); first by []. 822 | by rewrite size_map size_processing index_mem. 823 | Qed. 824 | 825 | Lemma voted_in_processing_exists state bseq b: 826 | (b \in voted_in_processing state bseq) -> 827 | exists s, (s \in (unzip1 (node_processing state bseq).2)) && (voted_on s b) && (b \in bseq). 828 | Proof. 829 | rewrite voted_in_processing_idx. 830 | move/andP => [H Hb]; exists (nth state (unzip1 (node_processing state bseq).2) (index b bseq)). 831 | rewrite H Hb 2!andbT; apply/(nthP state); exists (index b bseq)=> //. 832 | by rewrite size_map size_processing index_mem. 833 | Qed. 834 | 835 | Lemma voted_in_processing_sorted state bseq: 836 | (sorted (fun b1 b2 => round b1 < round b2) (voted_in_processing state bseq)). 837 | Proof. 838 | move: state; elim bseq => [| b bs] //; rewrite /sorted=> IHs state //. 839 | rewrite voted_in_processing_cons. 840 | case Hv: (voted_on state b)=> //=. 841 | move: (IHs (next_state state b)). 842 | case H:((voted_in_processing (next_state state b) bs))=> //= [x xs]->. 843 | rewrite andbT (@leq_trans (last_vote_round (next_state state b)).+1)=> //. 844 | - by rewrite next_state_lvr_if Hv ltnS. 845 | move: (mem_head x xs); rewrite -H; move/voted_in_processing_exists=> [s]. 846 | move/andP=> [Hs]; move/andP: Hs=> [Hs]; rewrite voting_comparator_eq; move/andP => [Hlt Hbr] Hx. 847 | move/andP:(Hlt)=> [Hlt1 _]; apply: (leq_trans _ Hlt1); move: (node_processing_sorted (next_state state b) (bs)); rewrite /sorted. 848 | case Hunz1: (unzip1 (node_processing (next_state state b) bs).2) => [|y ys]; first by move: Hs; rewrite Hunz1 in_nil. 849 | move: (Hunz1); rewrite node_processing_head; case Hbs: bs => [|z zs]; first by move: Hx; rewrite Hbs in_nil. 850 | move/eqP; rewrite eqseq_cons; move/andP=>[Hy Hys]; rewrite -(eqP Hy). 851 | move/(order_path_min comparators_transitive); move/allP; rewrite Hunz1 in Hs. 852 | move: Hs; rewrite in_cons; case Hsy: (s == y). 853 | by move/eqP: Hsy=>->; move/eqP: Hy=><-. 854 | by move/orP=>[//|] Hin Hcomp; move/andP: (Hcomp _ Hin)=>[-> _]. 855 | Qed. 856 | 857 | Lemma voted_in_processing_qc_parent_sorted state bseq: 858 | (sorted (fun b1 b2 => qc_parent_round b1 <= qc_round b2)) (voted_in_processing state bseq). 859 | Proof. 860 | move: state; elim bseq => [| b bs] //; rewrite /sorted=> IHs state //. 861 | rewrite voted_in_processing_cons. 862 | case Hv: (voted_on state b)=> //=. 863 | move: (IHs (next_state state b)). 864 | case H:((voted_in_processing (next_state state b) bs))=> //= [x xs]->. 865 | rewrite andbT (@leq_trans (preferred_block_round (next_state state b)))=> //. 866 | - by rewrite next_state_pbr_update update_maxn leq_maxr. 867 | move: (mem_head x xs); rewrite -H; move/voted_in_processing_exists=> [s]. 868 | move/andP=> [Hs]; move/andP: Hs=> [Hs]; rewrite voting_comparator_eq; move/andP => [Hlt Hbr] Hx. 869 | move/andP:(Hlt)=> [_ Hleq1]; apply: (leq_trans _ Hleq1); move: (node_processing_sorted (next_state state b) (bs)); rewrite /sorted. 870 | case Hunz1: (unzip1 (node_processing (next_state state b) bs).2) => [|y ys]; first by move: Hs; rewrite Hunz1 in_nil. 871 | move: (Hunz1); rewrite node_processing_head; case Hbs: bs => [|z zs]; first by move: Hx; rewrite Hbs in_nil. 872 | move/eqP; rewrite eqseq_cons; move/andP=>[Hy Hys]; rewrite -(eqP Hy). 873 | move/(order_path_min comparators_transitive); move/allP; rewrite Hunz1 in Hs. 874 | move: Hs; rewrite in_cons; case Hsy: (s == y). 875 | by move/eqP: Hsy=>->; move/eqP: Hy=><-. 876 | by move/orP=>[//|] Hin Hcomp; move/andP: (Hcomp _ Hin)=>[_ ->]. 877 | Qed. 878 | 879 | Lemma voted_in_processing_subseq_qc_parent_rel state bseq b1 b2: 880 | subseq [:: b1; b2] (voted_in_processing state bseq) -> 881 | qc_parent_round b1 <= qc_round b2. 882 | Proof. 883 | move: state b1 b2; elim: bseq => [|b bs Hbs] //= state b1 b2; rewrite voted_in_processing_cons. 884 | case Hvotb: (voted_on state b)=>/=; last by move/Hbs. 885 | case Hb1b: (b1 == b); last by move/Hbs. 886 | rewrite sub1seq (eqP Hb1b). 887 | move/voted_in_processing_exists => [s /andP[/andP[Hs Hvotsb2] Hb2]]. 888 | move: (order_path_min comparators_transitive (node_processing_path (next_state state b) bs)). 889 | move/allP; move/(_ _ Hs); move/andP=>[_]; rewrite (voting_comparator Hvotb) /= geq_max; move/andP=>[_]. 890 | move: Hvotsb2; rewrite ineq_voted_on; move/andP=>[_]; move/andP=> [H _] Hb. 891 | apply:(leq_trans Hb H). 892 | Qed. 893 | 894 | Lemma voted_in_processing_uniq state bseq: 895 | uniq (voted_in_processing state bseq). 896 | Proof. 897 | apply (sorted_uniq rounds_transitive rounds_irreflexive). 898 | apply voted_in_processing_sorted. 899 | Qed. 900 | 901 | Lemma voted_in_processing_both state bseq b1 b2: 902 | (b1 != b2) -> 903 | (b1 \in (voted_in_processing state bseq)) -> 904 | (b2 \in (voted_in_processing state bseq)) -> 905 | (round b1 <= round b2) -> 906 | subseq ([:: b1; b2]) (voted_in_processing state bseq). 907 | Proof. 908 | move => Hneq H1 H2 H12; move: (cat_take_drop_in H1); move/eqP=> Hsplit. 909 | move: (H2); rewrite -{1}Hsplit; rewrite mem_cat in_cons eq_sym. 910 | move/negbTE: Hneq=>->; rewrite orFb; move/orP=>[|]. 911 | - rewrite -sub1seq=> H13; move: (subseq_refl [:: b1])=> H24; move: {H13 H24}(cat_subseq H13 H24)=> Hpref. 912 | move: (subseq_trans Hpref (prefix_subseq _ (drop (index b1 (voted_in_processing state bseq)).+1 (voted_in_processing state bseq)))). 913 | rewrite cat1s -catA cat1s Hsplit=> Hsub; move/subseq_sorted: Hsub; move/(_ _ _ (voted_in_processing_sorted state bseq)). 914 | by move/(_ rounds_transitive); rewrite /= ltnNge H12. 915 | rewrite -sub1seq=> H24; move: (subseq_refl [::b1])=> H13; move: {H13 H24}(cat_subseq H13 H24)=> Hpref. 916 | move: (subseq_trans Hpref (suffix_subseq (take (index b1 (voted_in_processing state bseq)) (voted_in_processing state bseq)) _)). 917 | by rewrite 2!cat1s Hsplit. 918 | Qed. 919 | 920 | Lemma voted_in_processing_ltn state bseq b1 b2: 921 | (b1 != b2) -> 922 | (b1 \in (voted_in_processing state bseq)) -> 923 | (b2 \in (voted_in_processing state bseq)) -> 924 | (round b1 <= round b2) -> 925 | round b1 < round b2. 926 | Proof. 927 | move => Hneq Hb1 Hb2 Hb12; move:(voted_in_processing_both Hneq Hb1 Hb2 Hb12)=> Hsub. 928 | move/subseq_sorted: Hsub; move/(_ _ _ (voted_in_processing_sorted state bseq)). 929 | by move/(_ rounds_transitive) => /=; rewrite andbT. 930 | Qed. 931 | 932 | 933 | (************************************************************) 934 | (** Node Aggregation **) 935 | (************************************************************) 936 | 937 | 938 | Definition node_aggregator bseq := 939 | (foldl (fun stateNvote => voting_rule stateNvote.1) (genesis_state,false) bseq).1. 940 | 941 | Definition commit_rule state (qc: QC)(bround: nat) := 942 | let: potential_commit_round := (parent_block_round (qc_vote_data qc)) in 943 | if (potential_commit_round.+1 == (block_round (qc_vote_data qc))) && 944 | ((block_round (qc_vote_data qc)).+1 == bround) then 945 | Some(potential_commit_round) 946 | else None. 947 | 948 | End State. 949 | --------------------------------------------------------------------------------