├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.markdown ├── histories ├── huge-scc.edn ├── paper-example.edn ├── si-without-g-single.edn └── small-slow-scc.edn ├── images ├── anomalies.png ├── g1c-example.png ├── list.dot ├── list.png ├── models.png ├── perf.svg ├── plot-example.png ├── register.dot ├── severity.png └── watch.sh ├── paper └── elle.pdf ├── project.clj ├── proof ├── .Traceable-Objects.thy.marks ├── Anomaly.thy ├── DSG.thy ├── FinMap.thy ├── History.thy ├── IDSG.thy ├── InferredAnomaly.thy ├── LocaleTest.thy ├── Object.thy ├── Object2.thy ├── Observation.thy ├── Op.thy ├── Op2.thy ├── PolymorphismTest.thy ├── ProofTest.thy ├── Scratch.thy ├── Traceable-Objects.thy ├── Transaction.thy ├── VersionOrder.thy └── graphs │ ├── Arc_Walk.thy │ ├── Bidirected_Digraph.thy │ ├── Digraph.thy │ ├── Digraph_Component.thy │ ├── Digraph_Component_Vwalk.thy │ ├── Digraph_Isomorphism.thy │ ├── Euler.thy │ ├── Funpow.thy │ ├── Graph_Theory.thy │ ├── Kuratowski.thy │ ├── Pair_Digraph.thy │ ├── ROOT │ ├── Rtrancl_On.thy │ ├── Shortest_Path.thy │ ├── Stuff.thy │ ├── Subdivision.thy │ ├── Vertex_Walk.thy │ ├── Weighted_Graph.thy │ └── document │ ├── root.bib │ └── root.tex ├── src └── elle │ ├── BFSPath.java │ ├── BitRels.java │ ├── bfs.clj │ ├── closed_predicate.clj │ ├── consistency_model.clj │ ├── core.clj │ ├── graph.clj │ ├── list_append.clj │ ├── rels.clj │ ├── rw_register.clj │ ├── txn.clj │ ├── util.clj │ └── viz.clj └── test └── elle ├── bfs_test.clj ├── closed_predicate_test.clj ├── consistency_model_test.clj ├── core_test.clj ├── graph_test.clj ├── list_append_test.clj ├── rels_test.clj ├── rw_register_test.clj ├── txn_test.clj ├── util_test.clj └── viz_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | \#*\# 2 | *.swp 3 | *~ 4 | /G1c.txt 5 | /target 6 | /classes 7 | /checkouts 8 | /plots 9 | /test-output 10 | /proof/**/*.pdf 11 | profiles.clj 12 | pom.xml 13 | pom.xml.asc 14 | *.jar 15 | *.class 16 | /.lein-* 17 | /.nrepl-port 18 | /.clj-kondo 19 | /.lsp 20 | /.vscode 21 | /incompatible-order 22 | .hgignore 23 | .hg/ 24 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/). 3 | 4 | ## [Unreleased] 5 | ### Changed 6 | - Add a new arity to `make-widget-async` to provide a different widget shape. 7 | 8 | ## [0.1.1] - 2020-02-24 9 | ### Changed 10 | - Documentation on how to make the widgets. 11 | 12 | ### Removed 13 | - `make-widget-sync` - we're all async, all the time. 14 | 15 | ### Fixed 16 | - Fixed widget maker to keep working when daylight savings switches over. 17 | 18 | ## 0.1.0 - 2020-02-24 19 | ### Added 20 | - Files from the new template. 21 | - Widget maker public API - `make-widget-sync`. 22 | 23 | [Unreleased]: https://github.com/your-name/elle/compare/0.1.1...HEAD 24 | [0.1.1]: https://github.com/your-name/elle/compare/0.1.0...0.1.1 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 2.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION 5 | OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial content 12 | Distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | i) changes to the Program, and 16 | ii) additions to the Program; 17 | where such changes and/or additions to the Program originate from 18 | and are Distributed by that particular Contributor. A Contribution 19 | "originates" from a Contributor if it was added to the Program by 20 | such Contributor itself or anyone acting on such Contributor's behalf. 21 | Contributions do not include changes or additions to the Program that 22 | are not Modified Works. 23 | 24 | "Contributor" means any person or entity that Distributes the Program. 25 | 26 | "Licensed Patents" mean patent claims licensable by a Contributor which 27 | are necessarily infringed by the use or sale of its Contribution alone 28 | or when combined with the Program. 29 | 30 | "Program" means the Contributions Distributed in accordance with this 31 | Agreement. 32 | 33 | "Recipient" means anyone who receives the Program under this Agreement 34 | or any Secondary License (as applicable), including Contributors. 35 | 36 | "Derivative Works" shall mean any work, whether in Source Code or other 37 | form, that is based on (or derived from) the Program and for which the 38 | editorial revisions, annotations, elaborations, or other modifications 39 | represent, as a whole, an original work of authorship. 40 | 41 | "Modified Works" shall mean any work in Source Code or other form that 42 | results from an addition to, deletion from, or modification of the 43 | contents of the Program, including, for purposes of clarity any new file 44 | in Source Code form that contains any contents of the Program. Modified 45 | Works shall not include works that contain only declarations, 46 | interfaces, types, classes, structures, or files of the Program solely 47 | in each case in order to link to, bind by name, or subclass the Program 48 | or Modified Works thereof. 49 | 50 | "Distribute" means the acts of a) distributing or b) making available 51 | in any manner that enables the transfer of a copy. 52 | 53 | "Source Code" means the form of a Program preferred for making 54 | modifications, including but not limited to software source code, 55 | documentation source, and configuration files. 56 | 57 | "Secondary License" means either the GNU General Public License, 58 | Version 2.0, or any later versions of that license, including any 59 | exceptions or additional permissions as identified by the initial 60 | Contributor. 61 | 62 | 2. GRANT OF RIGHTS 63 | 64 | a) Subject to the terms of this Agreement, each Contributor hereby 65 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 66 | license to reproduce, prepare Derivative Works of, publicly display, 67 | publicly perform, Distribute and sublicense the Contribution of such 68 | Contributor, if any, and such Derivative Works. 69 | 70 | b) Subject to the terms of this Agreement, each Contributor hereby 71 | grants Recipient a non-exclusive, worldwide, royalty-free patent 72 | license under Licensed Patents to make, use, sell, offer to sell, 73 | import and otherwise transfer the Contribution of such Contributor, 74 | if any, in Source Code or other form. This patent license shall 75 | apply to the combination of the Contribution and the Program if, at 76 | the time the Contribution is added by the Contributor, such addition 77 | of the Contribution causes such combination to be covered by the 78 | Licensed Patents. The patent license shall not apply to any other 79 | combinations which include the Contribution. No hardware per se is 80 | licensed hereunder. 81 | 82 | c) Recipient understands that although each Contributor grants the 83 | licenses to its Contributions set forth herein, no assurances are 84 | provided by any Contributor that the Program does not infringe the 85 | patent or other intellectual property rights of any other entity. 86 | Each Contributor disclaims any liability to Recipient for claims 87 | brought by any other entity based on infringement of intellectual 88 | property rights or otherwise. As a condition to exercising the 89 | rights and licenses granted hereunder, each Recipient hereby 90 | assumes sole responsibility to secure any other intellectual 91 | property rights needed, if any. For example, if a third party 92 | patent license is required to allow Recipient to Distribute the 93 | Program, it is Recipient's responsibility to acquire that license 94 | before distributing the Program. 95 | 96 | d) Each Contributor represents that to its knowledge it has 97 | sufficient copyright rights in its Contribution, if any, to grant 98 | the copyright license set forth in this Agreement. 99 | 100 | e) Notwithstanding the terms of any Secondary License, no 101 | Contributor makes additional grants to any Recipient (other than 102 | those set forth in this Agreement) as a result of such Recipient's 103 | receipt of the Program under the terms of a Secondary License 104 | (if permitted under the terms of Section 3). 105 | 106 | 3. REQUIREMENTS 107 | 108 | 3.1 If a Contributor Distributes the Program in any form, then: 109 | 110 | a) the Program must also be made available as Source Code, in 111 | accordance with section 3.2, and the Contributor must accompany 112 | the Program with a statement that the Source Code for the Program 113 | is available under this Agreement, and informs Recipients how to 114 | obtain it in a reasonable manner on or through a medium customarily 115 | used for software exchange; and 116 | 117 | b) the Contributor may Distribute the Program under a license 118 | different than this Agreement, provided that such license: 119 | i) effectively disclaims on behalf of all other Contributors all 120 | warranties and conditions, express and implied, including 121 | warranties or conditions of title and non-infringement, and 122 | implied warranties or conditions of merchantability and fitness 123 | for a particular purpose; 124 | 125 | ii) effectively excludes on behalf of all other Contributors all 126 | liability for damages, including direct, indirect, special, 127 | incidental and consequential damages, such as lost profits; 128 | 129 | iii) does not attempt to limit or alter the recipients' rights 130 | in the Source Code under section 3.2; and 131 | 132 | iv) requires any subsequent distribution of the Program by any 133 | party to be under a license that satisfies the requirements 134 | of this section 3. 135 | 136 | 3.2 When the Program is Distributed as Source Code: 137 | 138 | a) it must be made available under this Agreement, or if the 139 | Program (i) is combined with other material in a separate file or 140 | files made available under a Secondary License, and (ii) the initial 141 | Contributor attached to the Source Code the notice described in 142 | Exhibit A of this Agreement, then the Program may be made available 143 | under the terms of such Secondary Licenses, and 144 | 145 | b) a copy of this Agreement must be included with each copy of 146 | the Program. 147 | 148 | 3.3 Contributors may not remove or alter any copyright, patent, 149 | trademark, attribution notices, disclaimers of warranty, or limitations 150 | of liability ("notices") contained within the Program from any copy of 151 | the Program which they Distribute, provided that Contributors may add 152 | their own appropriate notices. 153 | 154 | 4. COMMERCIAL DISTRIBUTION 155 | 156 | Commercial distributors of software may accept certain responsibilities 157 | with respect to end users, business partners and the like. While this 158 | license is intended to facilitate the commercial use of the Program, 159 | the Contributor who includes the Program in a commercial product 160 | offering should do so in a manner which does not create potential 161 | liability for other Contributors. Therefore, if a Contributor includes 162 | the Program in a commercial product offering, such Contributor 163 | ("Commercial Contributor") hereby agrees to defend and indemnify every 164 | other Contributor ("Indemnified Contributor") against any losses, 165 | damages and costs (collectively "Losses") arising from claims, lawsuits 166 | and other legal actions brought by a third party against the Indemnified 167 | Contributor to the extent caused by the acts or omissions of such 168 | Commercial Contributor in connection with its distribution of the Program 169 | in a commercial product offering. The obligations in this section do not 170 | apply to any claims or Losses relating to any actual or alleged 171 | intellectual property infringement. In order to qualify, an Indemnified 172 | Contributor must: a) promptly notify the Commercial Contributor in 173 | writing of such claim, and b) allow the Commercial Contributor to control, 174 | and cooperate with the Commercial Contributor in, the defense and any 175 | related settlement negotiations. The Indemnified Contributor may 176 | participate in any such claim at its own expense. 177 | 178 | For example, a Contributor might include the Program in a commercial 179 | product offering, Product X. That Contributor is then a Commercial 180 | Contributor. If that Commercial Contributor then makes performance 181 | claims, or offers warranties related to Product X, those performance 182 | claims and warranties are such Commercial Contributor's responsibility 183 | alone. Under this section, the Commercial Contributor would have to 184 | defend claims against the other Contributors related to those performance 185 | claims and warranties, and if a court requires any other Contributor to 186 | pay any damages as a result, the Commercial Contributor must pay 187 | those damages. 188 | 189 | 5. NO WARRANTY 190 | 191 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 192 | PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" 193 | BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 194 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF 195 | TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR 196 | PURPOSE. Each Recipient is solely responsible for determining the 197 | appropriateness of using and distributing the Program and assumes all 198 | risks associated with its exercise of rights under this Agreement, 199 | including but not limited to the risks and costs of program errors, 200 | compliance with applicable laws, damage to or loss of data, programs 201 | or equipment, and unavailability or interruption of operations. 202 | 203 | 6. DISCLAIMER OF LIABILITY 204 | 205 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 206 | PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS 207 | SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 208 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST 209 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 210 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 211 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 212 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE 213 | POSSIBILITY OF SUCH DAMAGES. 214 | 215 | 7. GENERAL 216 | 217 | If any provision of this Agreement is invalid or unenforceable under 218 | applicable law, it shall not affect the validity or enforceability of 219 | the remainder of the terms of this Agreement, and without further 220 | action by the parties hereto, such provision shall be reformed to the 221 | minimum extent necessary to make such provision valid and enforceable. 222 | 223 | If Recipient institutes patent litigation against any entity 224 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 225 | Program itself (excluding combinations of the Program with other software 226 | or hardware) infringes such Recipient's patent(s), then such Recipient's 227 | rights granted under Section 2(b) shall terminate as of the date such 228 | litigation is filed. 229 | 230 | All Recipient's rights under this Agreement shall terminate if it 231 | fails to comply with any of the material terms or conditions of this 232 | Agreement and does not cure such failure in a reasonable period of 233 | time after becoming aware of such noncompliance. If all Recipient's 234 | rights under this Agreement terminate, Recipient agrees to cease use 235 | and distribution of the Program as soon as reasonably practicable. 236 | However, Recipient's obligations under this Agreement and any licenses 237 | granted by Recipient relating to the Program shall continue and survive. 238 | 239 | Everyone is permitted to copy and distribute copies of this Agreement, 240 | but in order to avoid inconsistency the Agreement is copyrighted and 241 | may only be modified in the following manner. The Agreement Steward 242 | reserves the right to publish new versions (including revisions) of 243 | this Agreement from time to time. No one other than the Agreement 244 | Steward has the right to modify this Agreement. The Eclipse Foundation 245 | is the initial Agreement Steward. The Eclipse Foundation may assign the 246 | responsibility to serve as the Agreement Steward to a suitable separate 247 | entity. Each new version of the Agreement will be given a distinguishing 248 | version number. The Program (including Contributions) may always be 249 | Distributed subject to the version of the Agreement under which it was 250 | received. In addition, after a new version of the Agreement is published, 251 | Contributor may elect to Distribute the Program (including its 252 | Contributions) under the new version. 253 | 254 | Except as expressly stated in Sections 2(a) and 2(b) above, Recipient 255 | receives no rights or licenses to the intellectual property of any 256 | Contributor under this Agreement, whether expressly, by implication, 257 | estoppel or otherwise. All rights in the Program not expressly granted 258 | under this Agreement are reserved. Nothing in this Agreement is intended 259 | to be enforceable by any entity that is not a Contributor or Recipient. 260 | No third-party beneficiary rights are created under this Agreement. 261 | 262 | Exhibit A - Form of Secondary Licenses Notice 263 | 264 | "This Source Code may also be made available under the following 265 | Secondary Licenses when the conditions for such availability set forth 266 | in the Eclipse Public License, v. 2.0 are satisfied: {name license(s), 267 | version(s), and exceptions or additional permissions here}." 268 | 269 | Simply including a copy of this Agreement, including this Exhibit A 270 | is not sufficient to license the Source Code under Secondary Licenses. 271 | 272 | If it is not possible or desirable to put the notice in a particular 273 | file, then You may include the notice in a location (such as a LICENSE 274 | file in a relevant directory) where a recipient would be likely to 275 | look for such a notice. 276 | 277 | You may add additional accurate notices of copyright ownership. 278 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Elle 2 | 3 | [![Via Clojars](https://img.shields.io/clojars/v/elle.svg)](https://clojars.org/elle) 4 | 5 | Elle is a transactional consistency checker for black-box databases. Based 6 | purely on client observations of transactions, and given some minimal 7 | constraints on datatypes and operations, it can tell you whether that 8 | observation exhibits a variety of transactional anomalies. Like a clever 9 | lawyer, Elle looks for a sequence of events in a story which couldn't possibly 10 | have happened in that order, and uses that inference to prove the story can't 11 | be consistent. 12 | 13 | In a nutshell, Elle is: 14 | 15 | - _General_: Elle works over a variety of datatypes and places only minimal, practical constraints on transaction structure. 16 | - _Efficient_: Elle is ~linear in history length, and ~constant, rather than exponential, with respect to concurrency. 17 | - _Effective_: Elle has found unexpected anomalies in [every](http://jepsen.io/analyses/yugabyte-db-1.1.9) [database](http://jepsen.io/analyses/tidb-2.1.7) [we've](http://jepsen.io/analyses/yugabyte-db-1.3.1) [checked](https://twitter.com/aphyr/status/1165761686348992513), ranging from internal consistency violations to anti-dependency cycles to dirty read to lost updates to realtime violations. 18 | - _Sound_: Elle can find every (non-predicate) anomaly from Adya, Liskov, & O'Neil's [Generalized Isolation Level Definitions](http://pmg.csail.mit.edu/papers/icde00.pdf). 19 | - _Elucidative_: Elle can point to a minimal set of transactions which witness a consistency violation; its conclusions are easy to understand and verify. 20 | 21 | This repository encompasses a [Clojure implementation](src/elle/) of the Elle 22 | consistency checker and its [accompanying test suite](test/elle/), which you 23 | can use to check your own histories. Our 24 | [paper](https://github.com/jepsen-io/elle/raw/master/paper/elle.pdf) provides 25 | deep insight into the goals and intuition behind Elle, and a rough 26 | formalization of its soundness proof. A nowhere-near-complete formal 27 | [proof](proof/) sketch is written in the 28 | [Isabelle/HOL](https://isabelle.in.tum.de/) proof language. 29 | 30 | If you want to check a database using Elle, see [Jepsen](https://jepsen.io); Elle comes built-in. If you want to use Elle to check your own histories without using Jepsen, you can add Elle as a dependency to any JVM project, and invoke its checker functions directly. If you're working in a non-JVM language, you can write your history to a file or stream, and call a small wrapper program to produce output. 31 | 32 | Elle is still under active development, and we're not 100% confident in its 33 | inference rules yet. Jepsen recommends checking reported anomalies by hand to 34 | make sure they're valid. If you'd like to contribute, we'd especially welcome your help in the [formal proof](proof/), and in [rigorously defining consistency models](src/elle/consistency_model.clj). 35 | 36 | Questions? [Read the paper](https://github.com/jepsen-io/elle/raw/master/paper/elle.pdf)! 37 | 38 | ## Demo 39 | 40 | First, you'll need a copy of Graphviz installed. 41 | 42 | Imagine a database where each object (identified by keys like `:x` or `:y`) is 43 | a list of numbers. Transactions are made up of reads `[:r :x [1 2 3]]`, which 44 | return the current value of the given list, and writes `[:append :y 4]`, which 45 | append a number to the end of the list. 46 | 47 | ```clj 48 | => (require '[elle.list-append :as a] 49 | '[jepsen.history :as h]) 50 | nil 51 | ``` 52 | 53 | We construct a history of three transactions, each of which is known to 54 | have committed (`:type :ok`). The first transaction appends 1 to `:x` and 55 | observes `:y = [1]`. The second appends 2 to `:x` and 1 to `:y`. The third 56 | observes `x`, and sees its value as `[1 2]`. 57 | 58 | ```clj 59 | => (def h (h/history 60 | [{:process 0, :type :ok, :value [[:append :x 1] [:r :y [1]]]} 61 | {:process 1, :type :ok, :value [[:append :x 2] [:append :y 1]]} 62 | {:process 2, :type :ok, :value [[:r :x [1 2]]]}])) 63 | h 64 | ``` 65 | 66 | Now, we ask Elle to check this history, expecting it to be serializable, and 67 | have it dump anomalies to a directory called `out/`. 68 | 69 | ```clj 70 | => (pprint (a/check {:consistency-models [:serializable], :directory "out"} h)) 71 | {:valid? false, 72 | :anomaly-types (:G1c), 73 | :anomalies 74 | {:G1c 75 | [{:cycle 76 | [{:process 1, 77 | :type :ok, 78 | :f nil, 79 | :value [[:append :x 2] [:append :y 1]], 80 | :index 1, 81 | :time -1} 82 | {:process 0, 83 | :type :ok, 84 | :f nil, 85 | :value [[:append :x 1] [:r :y [1]]], 86 | :index 0, 87 | :time -1} 88 | {:process 1, 89 | :type :ok, 90 | :f nil, 91 | :value [[:append :x 2] [:append :y 1]], 92 | :index 1, 93 | :time -1}], 94 | :steps 95 | ({:type :wr, :key :y, :value 1, :a-mop-index 1, :b-mop-index 1} 96 | {:type :ww, 97 | :key :x, 98 | :value 1, 99 | :value' 2, 100 | :a-mop-index 0, 101 | :b-mop-index 0}), 102 | :type :G1c}]}, 103 | :not #{:read-committed}, 104 | :also-not 105 | #{:consistent-view :cursor-stability :forward-consistent-view 106 | :monotonic-atomic-view :monotonic-snapshot-read :monotonic-view 107 | :repeatable-read :serializable :snapshot-isolation :strong-serializable 108 | :strong-session-serializable :strong-session-snapshot-isolation 109 | :strong-snapshot-isolation :update-serializable}} 110 | 111 | ``` 112 | 113 | Here, Elle can infer the write-read relationship between T1 and T2 on the basis 114 | of their respective reads and writes. The write-write relationship between T2 115 | and T1 is inferrable because T3 observed `x = [1,2]`, which constrains the 116 | possible orders of appends. This is a G1c anomaly: cyclic information flow. The 117 | `:cycle` field shows the operations in that cycle, and `:steps` shows the 118 | dependencies between each pair of operations in the cycle. 119 | 120 | On the basis of this anomaly, Elle has concluded that this history is not 121 | read-committed---this is the weakest level Elle can demonstrate is violated. In 122 | addition, several stronger isolation levels, such as consistent-view and 123 | update-serializable, are also violated by this history. 124 | 125 | Let's see the G1c anomaly in text: 126 | 127 | ``` 128 | $ cat out/G1c.txt 129 | G1c #0 130 | Let: 131 | T1 = {:index 1, :time -1, :type :ok, :process 1, :f nil, 132 | :value [[:append :x 2] [:append :y 1]]} 133 | T2 = {:index 0, :time -1, :type :ok, :process 0, :f nil, 134 | :value [[:append :x 1] [:r :y [1]]]} 135 | 136 | 137 | Then: 138 | - T1 < T2, because T2 observed T1's append of 1 to key :y. 139 | - However, T2 < T1, because T1 appended 2 after T2 appended 1 to :x: a contradiction! 140 | ``` 141 | 142 | In the `out/G1c` directory, you'll find a corresponding plot. 143 | 144 | ![A plot showing the G1c dependency](images/g1c-example.png) 145 | 146 | In addition to rendering a graph for each individual cycle, Elle generates a 147 | plot for each strongly-connected component of the dependency graph. This can be 148 | helpful for getting a handle on the *scope* of an anomalous behavior, whereas 149 | cycles show as small a set of transactions as possible. Here's a plot from a 150 | more complex history, involving realtime edges, write-write, write-read, and 151 | read-write dependencies: 152 | 153 | ![A dependency graph showing read-write, write-read, write-write, and realtime dependencies](images/plot-example.png) 154 | 155 | ## Usage 156 | 157 | As a user, your main entry points into Elle will be `elle.list-append/check` 158 | and `elle.rw-register/check`. Both namespaces also have code for generating 159 | sequences of transactions which you can apply to your database; see, for 160 | example, `elle.list-append/gen`. 161 | 162 | Elle has a broad variety of anomalies and consistency models; see 163 | `elle.consistency-model` for their definitions. Not every anomaly is 164 | detectable, but we aim for completeness. 165 | 166 | If you'd like to define your own relationships between transactions, see 167 | `elle.core`. 168 | 169 | ### Observed Histories 170 | 171 | Elle expects its observed histories in the same format as [Jepsen](https://github.com/jepsen-io/jepsen). See [jepsen.history](https://github.com/jepsen-io/history) for the structure of these histories. 172 | 173 | ### Types of Tests 174 | 175 | - `elle.core`: The heart of Elle's inference system. Computes transaction graphs and finds cycles over them. Includes general-purpose graphs for per-process and realtime orders. 176 | - `elle.rw-register`: Write/Read registers. Weaker inference rules, but applicable to basically all systems. Objects are registers; writes blindly replace values. 177 | - `elle.list-append`: Elle's most powerful inference rules. Objects are lists, writes append unique elements to those lists. 178 | 179 | ## Consistency Models 180 | 181 | The following plot shows Elle's relationships between consistency models: an 182 | arrow `a -> b` implies if `a` holds, then so does `b`. Sources for this 183 | structure can be found in `elle.consistency-model`. 184 | 185 | ![](images/models.png) 186 | 187 | This plot shows the relationships between Elle's anomalies. An arrow `a -> b` 188 | implies if we observe anomaly `a` in a history, then `b` exists in the history 189 | as well. 190 | 191 | ![](images/anomalies.png) 192 | 193 | ## Soundness 194 | 195 | Elle can check for every non-predicate anomaly from Adya, Liskov, and O'Neil's [Generalized Isolation Level Definitions](http://pmg.csail.mit.edu/papers/icde00.pdf). These include: 196 | 197 | - G0: Write cycle. 198 | - G1a: Aborted read. 199 | - G1b: Intermediate read. 200 | - G1c: Cyclic information flow. 201 | - G-Single: Read skew. 202 | - G2: Anti-dependency cycle. 203 | 204 | There are additional anomalies (e.g. garbage reads, dirty updates, inconsistent version orders) available for specific checkers. Not all of these are implemented fully yet---see the paper for details. 205 | 206 | - Internal Inconsistency: A transaction fails to observe its own prior reads/writes. 207 | - Inconsistent Version Orders: Inference rules suggested a cyclic order of updates to a single key. 208 | - Dirty Updates: A write promotes aborted state into committed state. 209 | - Duplicate Writes: A write occurs more than once. 210 | - Garbage Reads: A read observes a state which could not have been the product of any write. 211 | 212 | In addition, Elle can infer transaction dependencies on the basis of process 213 | (e.g. session) or realtime order, allowing it to distinguish between, say, 214 | strict serializability and serializability. 215 | 216 | For lists, Elle can infer a complete prefix of the Adya version order for a key 217 | based on a single read. For registers, Elle can infer version orders on the 218 | basis of the initial state, writes-follow-reads, process, and real-time orders. 219 | 220 | When Elle claims an anomaly in an observable history, it specifically means 221 | that in any abstract Adya-style history which is compatible with that observed 222 | history, either a corresponding anomaly exists, or something worse 223 | happened---e.g. an aborted read. This is a natural consequence of testing 224 | real-world databases; if the database lies in *just the right way*, it might 225 | appear to exhibit anomalies which didn't actually happen, or mask anomalies 226 | which did. We limit the impact of this problem by being able to distinguish 227 | between many classes of reads, and sampling many anomalies---hoping that 228 | eventually, we get lucky and see the anomaly for what it "really is". 229 | 230 | ## Completeness 231 | 232 | Elle is not complete: it may fail to identify anomalies which were present in 233 | the system under test. This is a consequence of two factors: 234 | 235 | 1. Elle checks histories observed from real databases, where the results of transactions might go unobserved, and timing information might not be as precise as one would like. 236 | 2. Serializability checking is NP-complete; Elle intentionally limits its inferences to those solvable in linear (or log-linear) time. 237 | 238 | In practice, we believe Elle is "complete enough". Indeterminacy is generally 239 | limited to unobserved transactions, or a small set of transactions at the very 240 | end of the history. 241 | 242 | ## Performance 243 | 244 | Elle has been extensively optimized and many of its components are parallelized. 245 | It can check real-world histories of 22 million transactions for (e.g.) strong 246 | session serializability in in roughly two minutes, consuming ~60 GB of heap. 247 | 100-160,000 transactions/sec is readily attainable on modern hardware. Most of Elle's analyses scale linearly or as `n log(n)`. 248 | 249 | ![Graphs of Elle's performance vs Knossos](images/perf.svg) 250 | 251 | These plots, from the original Elle paper before optimization, show Elle's 252 | performance vs the [Knossos](https://github.com/jepsen-io/knossos) 253 | linearizability checker, verifying histories of various lengths (l) and 254 | concurrencies (c), recorded from a simulated serializable snapshot isolated 255 | in-memory database. Lower is better. 256 | 257 | In general, Elle checks real-world histories in a matter of seconds to minutes, 258 | rather than seconds to millennia. Where Knossos is often limited to a few 259 | hundred operations per history, Elle can handle hundreds of thousands of 260 | operations easily. 261 | 262 | Knossos runtimes diverge exponentially with concurrency; Elle is effectively 263 | constant. There's a slight drop in runtime as concurrency increases, as more 264 | transactions abort due to conflicts. Knossos is also mildly superlinear in 265 | history length; Elle is effectively linear. 266 | 267 | ## License 268 | 269 | Elle is copyright 2019--2020 Jepsen, LLC and Peter Alvaro. The Elle library is available under the Eclipse Public License, version 2.0, or, at your option, GPL-2.0 with the classpath exception. 270 | 271 | ## Thanks 272 | 273 | Elle was inspired by conversations with Asha Karim, and Kit Patella (@mkcp) wrote the first prototype of the Elle checker. 274 | 275 | ## See Also 276 | 277 | - [elle-cli](https://github.com/ligurio/elle-cli), a standalone command-line 278 | frontend to Elle (and other checkers) 279 | -------------------------------------------------------------------------------- /histories/paper-example.edn: -------------------------------------------------------------------------------- 1 | {:index 0 :type :invoke :value [[:append 253 1] [:append 253 3] [:append 253 4] [:append 255 2] [:append 255 3] [:append 255 4] [:append 255 5] [:append 256 1] [:append 256 2]]} 2 | {:index 1 :type :ok :value [[:append 253 1] [:append 253 3] [:append 253 4] [:append 255 2] [:append 255 3] [:append 255 4] [:append 255 5] [:append 256 1] [:append 256 2]]} 3 | {:index 2 :type :invoke, :value [[:append 255 8] [:r 253 nil]]} 4 | {:index 3 :type :ok, :value [[:append 255 8] [:r 253 [1 3 4]]]} 5 | {:index 4 :type :invoke, :value [[:append 256 4] [:r 255 nil] [:r 256 nil] [:r 253 nil]]} 6 | {:index 5 :type :ok, :value [[:append 256 4] [:r 255 [2 3 4 5 8]] [:r 256 [1 2 4]] [:r 253 [1 3 4]]]} 7 | {:index 6 :type :invoke, :value [[:append 250 10] [:r 253 nil] [:r 255 nil] [:append 256 3]]} 8 | {:index 7 :type :ok :value [[:append 250 10] [:r 253 [1 3 4]] [:r 255 [2 3 4 5]] [:append 256 3]]} 9 | -------------------------------------------------------------------------------- /histories/si-without-g-single.edn: -------------------------------------------------------------------------------- 1 | ; T1 ww T3 on 9 2 | ; T1 wr T4 on 9 3 | ; T2 rw T1 on 9 4 | ; T3 rw T2 on 8 5 | ; T3 rw T4 on 6 6 | ; T4 rw T3 on 9 7 | 8 | ; T1: read by T4 9 | {:index 10, :time 0, :type :invoke, :process 2, :f :txn, :value [[:append 9 2]]} 10 | {:index 11, :time 0, :type :ok, :process 2, :f :txn, :value [[:append 9 2]]} 11 | ; T2: Does not see T1's append to 9 12 | {:index 20, :time 0, :type :invoke, :process 4, :f :txn, :value [[:append 8 1] [:r 9 nil]]} 13 | {:index 21, :time 0, :type :ok, :process 4, :f :txn, :value [[:append 8 1] [:r 9 nil]]} 14 | ; T3: Does not see T2's append to 8 or T4's append to 6, overwrites T1 on 9 15 | {:index 30, :time 0, :type :invoke, :process 7, :f :txn, :value [[:r 6 nil] [:r 8 nil] [:append 9 5]]} 16 | {:index 31, :time 0, :type :ok, :process 7, :f :txn, :value [[:r 6 nil] [:r 8 nil] [:append 9 5]]} 17 | ; T4: does not see T3's append to 9 18 | {:index 40, :time 0, :type :invoke, :process 9, :f :txn, :value [[:append 6 2] [:r 9 nil]]} 19 | {:index 41, :time 0, :type :ok, :process 9, :f :txn, :value [[:append 6 2] [:r 9 [2]]]} 20 | -------------------------------------------------------------------------------- /images/anomalies.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/anomalies.png -------------------------------------------------------------------------------- /images/g1c-example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/g1c-example.png -------------------------------------------------------------------------------- /images/list.dot: -------------------------------------------------------------------------------- 1 | digraph proof { 2 | // concentrate=true 3 | 4 | 5 | subgraph cluster0 { 6 | label = "Versions" 7 | node [shape="oval"] 8 | v [label="[]"] 9 | v1 [label="[1]",style="dashed"] 10 | v12 [label="[1,2]"] 11 | v123 [label="[1,2,3]"] 12 | 13 | // Version trace 14 | edge [label="tr",color="cyan4",fontcolor="cyan4"] 15 | v123 -> v12 16 | v12 -> v1 17 | v1 -> v 18 | 19 | // Version order 20 | edge [label="≪",color="chartreuse4",fontcolor="chartreuse4"] 21 | v123 -> v12 22 | v12 -> v 23 | 24 | // Inferred version order 25 | edge [label="<",color="darkgreen",fontcolor="darkgreen"] 26 | v12 -> v 27 | } 28 | 29 | subgraph cluster1 { 30 | label = "Observed Transactions" 31 | node [shape=record,height="0.3"] 32 | ot1 [label=" r([])| r([1,2])| c"] 33 | ot2 [label=" w(_, 1)| w(_, 2)"] 34 | ot3 [label=" r(_)| w(_, 3)"] 35 | } 36 | 37 | subgraph cluster2 { 38 | label = "Adya Transactions" 39 | node [shape=record,height="0.3"] 40 | at1 [label=" r([])|r([1,2])| c"] 41 | at2 [label=" w([], 1)| w([1], 2)| c"] 42 | at3 [label=" r []| w([1,2], 3)| c"] 43 | } 44 | 45 | // Actual dependencies 46 | edge [color="slateblue",fontcolor="slateblue"] 47 | at1:op0 -> at2:op1 [label="rw"] 48 | at2:op1 -> at1:op1 [label="wr"] 49 | at2:op1 -> at3:op1 [label="ww"] 50 | at3:op0 -> at2:op1 [label="rw"] 51 | at1:op1 -> at3:op1 [label="rw"] 52 | 53 | // Inferred dependencies 54 | ot1:op0 -> ot2:op1 [label="rw"] 55 | ot2:op1 -> ot1:op1 [label="wr"] 56 | 57 | // Reads 58 | edge [label="read",dir="both",color="maroon3",fontcolor="maroon3"] 59 | v -> ot1:op0 60 | v12 -> ot1:op1 61 | 62 | // Recoverability 63 | edge [dir="forward",label="rec",color="orangered2",fontcolor="orangered2"] 64 | v1 -> ot2:op0 65 | v12 -> ot2:op1 66 | 67 | // Compatibility 68 | edge [label="R",dir="both",color="slategray",fontcolor="slategray"] 69 | ot1 -> at1 70 | ot2 -> at2 71 | ot3 -> at3 72 | 73 | // Adya version/txn relationshiops 74 | edge [dir="none",color="thistle3",style="dashed",label=""] 75 | //at1:op0 -> v 76 | //at1:op1 -> v12 77 | //at2:op0 -> v1 78 | //at2:op1 -> v12 79 | //at3:op0 -> v 80 | //at3:op1 -> v123 81 | 82 | // Purely for appearances 83 | ot2 -> ot3 [style=invis] 84 | at2 -> ot2 [style=invis] 85 | at3 -> ot3 [style=invis] 86 | // I'd love to put adya and observed transactions at the same rank but this 87 | // horribly breaks, complaining about lost edges. Sigh. 88 | } 89 | -------------------------------------------------------------------------------- /images/list.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/list.png -------------------------------------------------------------------------------- /images/models.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/models.png -------------------------------------------------------------------------------- /images/plot-example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/plot-example.png -------------------------------------------------------------------------------- /images/register.dot: -------------------------------------------------------------------------------- 1 | digraph proof { 2 | // concentrate=true 3 | 4 | subgraph cluster0 { 5 | label = "Versions" 6 | node [shape="diamond"] 7 | v0 [] 8 | v1 [style="filled"] 9 | v2 [] 10 | v3 [] 11 | 12 | // Version trace 13 | edge [label="tr",color="royalblue2",fontcolor="royalblue2"] 14 | v3 -> v2 15 | v2 -> v1 16 | v1 -> v0 17 | 18 | // Version order 19 | edge [label="≪",color="palegreen4",fontcolor="palegreen4"] 20 | v3 -> v2 21 | v2 -> v0 22 | 23 | // Inferred version order 24 | edge [label="<",color="mediumturquoise",fontcolor="mediumturquoise"] 25 | v2 -> v0 26 | } 27 | 28 | subgraph cluster1 { 29 | label = "Observed Transactions" 30 | node [shape=record,height="0.3"] 31 | ot1 [label=" r0| r2| c"] 32 | ot2 [label=" w1| w2"] 33 | ot3 [label=" r_| w3"] 34 | } 35 | 36 | subgraph cluster2 { 37 | label = "Ayda Transactions" 38 | node [shape=record,height="0.3"] 39 | at1 [label=" r0| r2| c"] 40 | at2 [label=" w1| w2| c"] 41 | at3 [label=" r0| w3| c"] 42 | } 43 | 44 | // Actual dependencies 45 | edge [color="slateblue",fontcolor="slateblue"] 46 | at1:op0 -> at2:op1 [label="rw"] 47 | at2:op1 -> at1:op1 [label="wr"] 48 | at2:op1 -> at3:op1 [label="ww"] 49 | at3:op0 -> at2:op1 [label="rw"] 50 | 51 | // Inferred dependencies 52 | ot1:op0 -> ot2:op1 [label="rw"] 53 | ot2:op1 -> ot1:op1 [label="wr"] 54 | 55 | // Reads 56 | edge [label="read",dir="both",color="maroon3",fontcolor="maroon3"] 57 | v0 -> ot1:op0 58 | v2 -> ot1:op1 59 | 60 | // Recoverability 61 | edge [dir="forward",label="rec",color="orangered2",fontcolor="orangered2"] 62 | v1 -> ot2:op0 63 | v2 -> ot2:op1 64 | 65 | // Compatibility 66 | edge [dir="forward",label="R",dir="both",color="slategray",fontcolor="slategray"] 67 | ot1 -> at1 68 | ot2 -> at2 69 | ot3 -> at3 70 | 71 | // Adya version/txn relationshiops 72 | //edge [dir="none",color="thistle3",style="dashed",label=""] 73 | //at1:op0 -> v0 74 | //at1:op1 -> v2 75 | //at2:op0 -> v1 76 | //at2:op1 -> v2 77 | //at3:op0 -> v0 78 | //at3:op1 -> v3 79 | } 80 | -------------------------------------------------------------------------------- /images/severity.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/images/severity.png -------------------------------------------------------------------------------- /images/watch.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Watches file for changes and rebuilds it when written. 4 | inotifywait -e close_write,moved_to,create -m "$1" | 5 | while read -r directory events filename 6 | do 7 | echo $directory, $events, $filename 8 | if [ ${filename: -4} == ".dot" ] && [ "$events" = "CLOSE_WRITE,CLOSE" ] 9 | then 10 | basename=$(echo "${filename}" | cut -f 1 -d '.') 11 | dot -T png -o "${basename}.png" "$filename" 12 | fi 13 | done 14 | -------------------------------------------------------------------------------- /paper/elle.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/paper/elle.pdf -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject elle "0.2.5-SNAPSHOT" 2 | :description "Black-box transactional consistency checker based on cycle detection" 3 | :url "https://github.com/jepsen-io/elle" 4 | :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" 5 | :url "https://www.eclipse.org/legal/epl-2.0/"} 6 | :dependencies [[slingshot "0.12.2"] 7 | [com.aphyr/bifurcan-clj "0.1.3"] 8 | ; Has to be here for our java classes to use Clojure 9 | [org.clojure/clojure "1.12.0"] 10 | [dom-top "1.0.9"] 11 | [hiccup "1.0.5"] 12 | [org.clojure/tools.logging "1.3.0"] 13 | [rhizome "0.2.9"] 14 | [io.jepsen/history "0.1.5"] 15 | [jepsen.txn "0.1.2"]] 16 | :java-source-paths ["src"] 17 | ; We need jepsen.history.Op available before we can compile our java code 18 | ;:prep-tasks [["compile" "jepsen.history"] 19 | ; "javac" 20 | ; "compile"] 21 | :javac-options ["-target" "1.8" "-source" "1.8" 22 | ] 23 | :profiles {:dev {:dependencies [[com.gfredericks/test.chuck "0.2.15"] 24 | [io.jepsen/history.sim "0.1.1"] 25 | [org.clojure/test.check "1.1.1"] 26 | [spootnik/unilog "0.7.32"]]}} 27 | :jvm-opts ["-server" 28 | "-XX:-OmitStackTraceInFastThrow" 29 | ;"-XX:+PrintGC" 30 | ;"-agentpath:/home/aphyr/yourkit/bin/linux-x86-64/libyjpagent.so=disablestacktelemetry,exceptions=disable,delay=10000,usedmem=50" 31 | ] 32 | :repl-options {:init-ns elle.core} 33 | :test-selectors {:default (fn [m] (not (or (:perf m) 34 | (:interactive m) 35 | (:overflow m)))) 36 | :all (fn [m] true) 37 | :perf :perf 38 | :focus :focus 39 | :overflow :overflow 40 | :interactive :interactive}) 41 | -------------------------------------------------------------------------------- /proof/.Traceable-Objects.thy.marks: -------------------------------------------------------------------------------- 1 | !d;832;832 2 | -------------------------------------------------------------------------------- /proof/Anomaly.thy: -------------------------------------------------------------------------------- 1 | theory Anomaly 2 | imports Main DSG Observation 3 | begin 4 | 5 | section \Non-Cyclic Anomalies\ 6 | 7 | text \We are now ready to encode notions of Adya's anomalies. An aborted read, or g1a, implies some 8 | pair of transactions exist such that one wrote v1 and aborted, and another read v1 and committed.\ 9 | 10 | definition has_g1a :: "history \ bool" where 11 | "has_g1a h \ (\t1 t2 k v1 a v2 r. (t1 \ (all_atxns h)) \ 12 | (t2 \ (all_atxns h)) \ 13 | (\(a_is_committed t1)) \ 14 | (a_is_committed t2) \ 15 | (AWrite k v1 a v2 r) \ (all_aops t1) \ 16 | (ARead k v2) \ (all_aops t2))" 17 | 18 | text \An empty history does not have an aborted read.\ 19 | 20 | lemma "\(has_g1a (History {(register 1)} {} {(KeyVersionOrder 1 [[0]])}))" 21 | by (simp add:has_g1a_def) 22 | 23 | text "But this history does: we write 1 and fail to commit, then read it! We don't actually 24 | have to constrain the version order for this to happen, either." 25 | 26 | lemma "has_g1a (History {(register 1)} 27 | {(ATxn [(AWrite 1 [0] 1 [1] [])] False), 28 | (ATxn [(ARead 1 [1])] True)} 29 | kvo)" 30 | using has_g1a_def by fastforce 31 | 32 | (* TODO: intermediate read, dirty update *) 33 | 34 | section \Cyclic Anomalies\ 35 | 36 | text \In an G0 anomaly, a cycle exists in the DSG composed purely of write dependencies.\ 37 | 38 | definition has_g0 :: "history \ bool" where 39 | "has_g0 h \ (\path. (cycle (dsg h) path) \ ((path_dep_types path) = {WW}))" 40 | 41 | text \For example...\ 42 | 43 | lemma ww_depends_ex: 44 | assumes "(distinct [x,y]) \ (distinct [v0,v1,v2])" 45 | shows "ww_depends (History objs 46 | {(ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True), 47 | (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)} 48 | {(KeyVersionOrder x [v0,v1,v2]), 49 | (KeyVersionOrder y [v0,v1,v2])}) 50 | (ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True) 51 | (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)" 52 | apply (simp add:ww_depends_def) 53 | proof- 54 | obtain t1 t2 where "t1 = (ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True) \ 55 | t2 = (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)" 56 | by blast 57 | oops 58 | 59 | 60 | lemma 61 | assumes "(distinct [x,y]) \ (distinct [v0,v1,v2])" 62 | shows "has_g0 (History objs 63 | {(ATxn [(AWrite x v0 a1 v1 r1), (AWrite y v1 a2 v2 r2)] True), 64 | (ATxn [(AWrite y v0 a1 v1 r1), (AWrite x v1 a2 v2 r2)] True)} 65 | {(KeyVersionOrder x [v0,v1,v2]), 66 | (KeyVersionOrder y [v0,v1,v2])})" 67 | apply (simp add:has_g0_def dsg_def path_def cycle_def) 68 | oops 69 | 70 | text \A G1c anomaly is a cycle comprised of write-write and write-read dependencies. We diverge from 71 | Adya here in classifying G0 and G1c as distinct classes; feels more useful to distinguish them.\ 72 | 73 | definition has_g1c :: "history \ bool" where 74 | "has_g1c h \ (\path. (cycle (dsg h) path) \ ((path_dep_types path) = {WW,WR}))" 75 | 76 | text \And a G2 anomaly is a cycle involving read-write dependencies.\ 77 | 78 | definition has_g2 :: "history \ bool" where 79 | "has_g2 h \ (\path. (cycle (dsg h) path) \ (RW \ (path_dep_types path)))" 80 | 81 | 82 | 83 | end -------------------------------------------------------------------------------- /proof/DSG.thy: -------------------------------------------------------------------------------- 1 | theory DSG 2 | imports Main History 3 | begin 4 | 5 | section \Transaction Dependencies\ 6 | 7 | text \We begin by formalizing three types of dependencies between transactions: wr-depends, 8 | ww-depends, and rw-depends. The wr-depends relation captures the idea of a transaction t2 reading 9 | another transaction T1's write.\ 10 | 11 | definition wr_depends :: "history \ atxn \ atxn \ bool" where 12 | "wr_depends h t1 t2 \ \w1 r2. (a_is_committed t1) \ 13 | (a_is_committed t2) \ 14 | (w1 \ ext_awrites t1) \ 15 | (r2 \ ext_areads t2) \ 16 | ((key w1) = (key r2)) \ 17 | ((post_version w1) = (pre_version r2))" 18 | 19 | text \We say t1 ww-depends t2 if t2 overwrote t1--that is, if t1 installed 20 | some version v1 of k, and t2 wrote v2, such that v1 came immediately before v2 in the version order 21 | of k.\ 22 | 23 | definition ww_depends :: "history \ atxn \ atxn \ bool" where 24 | "ww_depends h t1 t2 \ \w1 w2. 25 | (a_is_committed t1) \ 26 | (a_is_committed t2) \ 27 | (w1 \ ext_awrites t1) \ 28 | (w2 \ ext_awrites t2) \ 29 | ((key w1) = (key w2)) \ 30 | (is_next_in_history h (key w1) (apost_version w1) (apost_version w2))" 31 | 32 | lemma ww_depends_example: "ww_depends 33 | (History objs 34 | {(ATxn [(AWrite x v0 a1 v1 [])] True), 35 | (ATxn [(AWrite x v1 a2 v2 [])] True)} 36 | {(KeyVersionOrder x [v0, v1, v2])}) 37 | (ATxn [(AWrite x v0 a1 v1 [])] True) 38 | (ATxn [(AWrite x v1 a2 v2 [])] True) 39 | = True" 40 | apply (simp add:ww_depends_def) 41 | done 42 | 43 | text \An rw-dependency is just like a ww-dependency, only transaction t1 *read* state just prior to 44 | t2's write.\ 45 | 46 | definition rw_depends :: "history \ atxn \ atxn \ bool" where 47 | "rw_depends h t1 t2 \ \r1 w2. 48 | (a_is_committed t1) \ 49 | (a_is_committed t2) \ 50 | (r1 \ ext_areads t1) \ 51 | (w2 \ ext_awrites t2) \ 52 | ((key r1) = (key w2)) \ 53 | (is_next_in_history h (key r1) (apost_version r1) (apost_version w2))" 54 | 55 | section \Direct Serialization Graphs\ 56 | 57 | text \Now, we define a Direct Serialization Graph of a history as a graph where nodes are 58 | transactions in that history, and arcs are dependencies between them. We codify these three types of 59 | dependency with a type, and create a dependency type to wrap them. We call these aDeps for abstract 60 | dependencies; later, we'll define analogous observed dependencies.\ 61 | 62 | datatype depType = WR | WW | RW 63 | 64 | datatype adep = ADep atxn depType atxn 65 | 66 | primrec adep_head :: "adep \ atxn" where 67 | "adep_head (ADep t _ _) = t" 68 | 69 | primrec adep_tail :: "adep \ atxn" where 70 | "adep_tail (ADep _ _ t) = t" 71 | 72 | class dep_typed = 73 | fixes dep_type :: "'a \ depType" 74 | 75 | instantiation adep :: "dep_typed" 76 | begin 77 | primrec dep_type_adep :: "adep \ depType" where 78 | "dep_type_adep (ADep _ t _) = t" 79 | instance .. 80 | end 81 | 82 | type_synonym dsg = "(atxn, adep) pre_digraph" 83 | 84 | text \The DSG of a history is defined by mapping each dependency to an edge in the graph.\ 85 | 86 | definition dsg :: "history \ dsg" where 87 | "dsg h \ \verts = all_atxns h, 88 | arcs = ({(ADep t1 WR t2) | t1 t2. wr_depends h t1 t2} \ 89 | {(ADep t1 WW t2) | t1 t2. ww_depends h t1 t2} \ 90 | {(ADep t1 RW t2) | t1 t2. rw_depends h t1 t2}), 91 | tail = adep_tail, 92 | head = adep_head\" 93 | 94 | 95 | text \Now, we need to characterize a cycle in a DSG. TODO: I don't know how to use the definitions 96 | in the locales in Arc_Walk.thy, but I assume we should take advantage of them. Copy-pasting with 97 | slight mods for now.\ 98 | 99 | type_synonym 'a path = "'a list" 100 | 101 | text \The list of vertices of a walk. The additional vertex argument is there to deal with the case 102 | of empty walks.\ 103 | 104 | primrec path_verts :: "('a,'b) pre_digraph \ 'a \ 'b path \ 'a list" where 105 | "path_verts G u [] = [u]" 106 | | "path_verts G u (e # es) = tail G e # path_verts G (head G e) es" 107 | 108 | text \ 109 | Tests whether a list of arcs is a consistent arc sequence, 110 | i.e. a list of arcs, where the head G node of each arc is 111 | the tail G node of the following arc. 112 | \ 113 | fun cas :: "('a, 'b) pre_digraph => 'a \ 'b path \ 'a \ bool" where 114 | "cas G u [] v = (u = v)" | 115 | "cas G u (e # es) v = (tail G e = u \ cas G (head G e) es v)" 116 | 117 | definition path :: "('a,'b) pre_digraph \ 'a \ 'b path \ 'a \ bool" where 118 | "path G u p v \ u \ verts G \ set p \ arcs G \ cas G u p v" 119 | 120 | text \Is the given path a cycle in the given graph?\ 121 | 122 | definition cycle :: "('a,'b) pre_digraph \ 'b path \ bool" where 123 | "cycle G p \ \u. path G u p u \ distinct (tl (path_verts G u p)) \ p \ []" 124 | 125 | text \We would like a cycle whose edges are all of the given set of dependency types.\ 126 | 127 | primrec path_dep_types :: "('a::dep_typed) path \ depType set" where 128 | "path_dep_types [] = {}" | 129 | "path_dep_types (x # xs) = (Set.insert (dep_type x) (path_dep_types xs))" 130 | 131 | end -------------------------------------------------------------------------------- /proof/FinMap.thy: -------------------------------------------------------------------------------- 1 | theory FinMap 2 | imports Main HOL.Map 3 | begin 4 | 5 | section \Finite Maps\ 6 | 7 | text \A finite map can be thought of as a set of (k,v) pairs, with unique keys. Think an erlang 8 | proplist. We use this as a wrapper around Isabelle's Maps because those maps use optional, and it 9 | makes quantification over kv pairs kind of messy.\ 10 | 11 | definition keys :: "('a,'b) map \ 'a set" where 12 | "keys m = dom m" 13 | 14 | definition vals :: "('a,'b) map \ 'b set" where 15 | "vals m = ran m" 16 | 17 | definition kv_pairs :: "('a,'b) map \ ('a \ 'b) set" where 18 | "kv_pairs m = {(k,v) | k v. (k \ (keys m)) \ ((Some v) = (m k))}" 19 | 20 | text \A function for building map literals out of keys and values.\ 21 | definition map1 :: "'a \ 'b \ ('a,'b) map" where 22 | "map1 k v \ (Map.empty(k:=Some v))" 23 | 24 | definition map2 :: "'a \ 'b \ 'a \ 'b \ ('a,'b) map" where 25 | "map2 k1 v1 k2 v2 \ (Map.empty(k1:=Some v1, k2:=Some v2))" 26 | 27 | end -------------------------------------------------------------------------------- /proof/History.thy: -------------------------------------------------------------------------------- 1 | theory History 2 | imports Main HOL.Map Transaction VersionOrder 3 | begin 4 | 5 | section \History\ 6 | 7 | text \An abstract history, as defined by Adya, is a set of objects, transactions over them, 8 | and a version order.\ 9 | 10 | datatype history = History "object set" "atxn set" "versionOrder" 11 | 12 | class all_objects = 13 | fixes all_objects :: "'a \ object set" 14 | 15 | instantiation history :: all_objects 16 | begin 17 | primrec all_objects_history :: "history \ object set" where 18 | "all_objects_history (History objs txns vo) = objs" 19 | instance .. 20 | end 21 | 22 | primrec all_atxns :: "history \ atxn set" where 23 | "all_atxns (History obs txns vo) = txns" 24 | 25 | text \It's going to be handy to get every version, operation, every write, and read out of a 26 | history. We say a history's versions and writes are those in its transaction set, not every 27 | version in its objects.\ 28 | 29 | instantiation history :: all_versions 30 | begin 31 | primrec all_versions_history :: "history \ version set" where 32 | "all_versions_history (History objs txns vo) = \{all_versions t | t. t \ txns}" 33 | instance .. 34 | end 35 | 36 | instantiation history :: all_aops 37 | begin 38 | primrec all_aops_history :: "history \ aop set" where 39 | "all_aops_history (History objs txns vo) = \{all_aops t | t. t \ txns}" 40 | instance .. 41 | end 42 | 43 | text \We constrain the version order for each object to be compatible with some trace in that 44 | object's version graph.\ 45 | 46 | primrec key_version_order_is_in_object :: "keyVersionOrder \ object \ bool" where 47 | "key_version_order_is_in_object (KeyVersionOrder k vl) obj = ( 48 | (k = key obj) \ (\tr. (is_trace_of obj tr (last vl))))" 49 | 50 | text \A well-formed history satisfies this property for every key in the version order; there's got 51 | to be a corresponding object where that version order is a legal trace.\ 52 | 53 | primrec version_order_is_in_corresponding_object :: "history \ bool" where 54 | "version_order_is_in_corresponding_object (History objs txns vo) = 55 | (\ kvo. kvo \ vo \ (\obj. (obj \ objs) \ (key_version_order_is_in_object kvo obj)))" 56 | 57 | text \Histories also need to ensure that their transactions are over their objects. For every op 58 | in the history, we ensure that op's key identifies an object in the history, that that op's versions 59 | are in that object, and if it's a write that the write is in the transaction graph of that object.\ 60 | 61 | primrec transactions_are_over_objects :: "history \ bool" where 62 | "transactions_are_over_objects (History objs txns vo) = 63 | (\ op. (op \ (all_aops (History objs txns vo))) \ 64 | (let k = (key op) in 65 | (\obj. (k = (key obj)) \ 66 | (obj \ objs) \ 67 | ((all_versions op) \ (all_versions obj)) \ 68 | (if Read = (op_type op) then True else op \ (all_aops obj)))))" 69 | 70 | 71 | 72 | text \We need to be able to discuss whether a specific transaction wrote a given key and version, in 73 | a history.\ 74 | 75 | (* 76 | primrec wrote :: "history \ atxn \ key \ version \ bool" where 77 | "wrote h t k v = " 78 | *) 79 | 80 | text \A well-formed history is made up of well formed objects, transactions, and a version order, 81 | and ensures transactions are over objects, and the version orders are in their corresponding 82 | objects.\ 83 | 84 | primrec wf_history :: "history \ bool" where 85 | "wf_history (History objs txns vo) = (let h = (History objs txns vo) in 86 | (\obj. (obj \ objs) \ (wf_object obj)) \ 87 | (\t. (t \ txns) \ (wf_atxn t)) \ 88 | (wf_version_order vo) \ 89 | ((transactions_are_over_objects h) \ 90 | (version_order_is_in_corresponding_object h)))" 91 | 92 | text \We'd like to know if two versions occurred consecutively in the version order for some key.\ 93 | primrec is_next_in_history :: "history \ key \ version \ version \ bool" where 94 | "is_next_in_history (History objs txns vo) k v1 v2 = 95 | (\kvo. (key kvo = k) \ (kvo \ vo) \ 96 | (is_next_in_key_version_order kvo v1 v2))" 97 | 98 | end -------------------------------------------------------------------------------- /proof/IDSG.thy: -------------------------------------------------------------------------------- 1 | theory IDSG 2 | imports Main Observation 3 | begin 4 | 5 | section \Inferred Version Order\ 6 | 7 | text \We begin by inferring a version order based on traceability and recoverability. TODO: we're 8 | not handling intermediate dependencies yet.\ 9 | 10 | text \Pick a version from the committed read set with the longest trace.\ 11 | 12 | value "((\x::nat. (Suc x)) ` ({1,2}))" 13 | 14 | definition o_committed_txns :: "observation \ otxn set" where 15 | "o_committed_txns obs \ {t \ (all_otxns obs). o_definitely_committed t}" 16 | 17 | definition o_committed_reads :: "observation \ oop set" where 18 | "o_committed_reads obs \ \(all_oreads ` (o_committed_txns obs))" 19 | 20 | definition o_committed_versions_k :: "observation \ key \ version set" where 21 | "o_committed_versions_k obs k \ 22 | \(all_versions ` {r. r \ (o_committed_reads obs) \ ((key r) = k)})" 23 | 24 | definition x_longest :: "observation \ k \ version" 25 | "x_longest obs \ (let vs (o_committed_versions obs k) in 26 | (THE v. (v \ vs) \ \(\v2. (trace_length v1) < (trace_length v2)) 27 | 28 | TODO what a mess; pick up here later 29 | 30 | section \Inferred Transaction Dependencies\ 31 | 32 | 33 | 34 | text \We use recoverability to map observed versions in a history back into writes, and infer 35 | dependencies between them.\ 36 | 37 | definition 38 | 39 | end -------------------------------------------------------------------------------- /proof/InferredAnomaly.thy: -------------------------------------------------------------------------------- 1 | theory InferredAnomaly 2 | imports Main Observation 3 | begin 4 | 5 | section \Inferred Non-Cyclic Anomalies\ 6 | 7 | text \Using observations, we set out to infer anomalies which should (we hope) be present in 8 | any compatible observation. We prefix these versions of the anomalies with 'i' for 'inferred'.\ 9 | 10 | definition has_ig1a :: "observation \ bool" where 11 | "has_ig1a obs \ (\t1 t2 k v. t1\ all_otxns obs \ 12 | t2 \ all_otxns obs \ 13 | o_is_committed t1 = Some False \ 14 | o_is_committed t2 = Some True \ 15 | is_recoverable obs k v t1 \ 16 | (ORead k (Some v)) \ (all_oops obs))" 17 | 18 | theorem ig1a_sound "has_ig1a obs \ (\i. i \ interpretations obs \ has_g1a (history i))" 19 | 20 | 21 | end 22 | -------------------------------------------------------------------------------- /proof/LocaleTest.thy: -------------------------------------------------------------------------------- 1 | theory LocaleTest 2 | imports Main 3 | begin 4 | 5 | (* A box for things of some unspecified type 'a *) 6 | datatype 'a box = Box "'a" 7 | 8 | (* A typeclass that can make boxes? 9 | 10 | class boxable = 11 | fixes makebox :: "'o \ ('a box)" 12 | *) 13 | 14 | (* This complains "multiple variables in type specification, and I can't seem to parameterize 15 | the typeclass with type variables itself. Shit. *) 16 | 17 | locale menagerie = 18 | fixes animal_type :: "'at" 19 | and favorite :: "'a" 20 | begin 21 | 22 | (* We can't use animal_type at the type level here, so... while you CAN apparently pass types 23 | to locales when constructing intepretations, those types can't be used in definitions. Which... 24 | I guess makes sense, cuz the definitions here should typecheck on their *own*. Right? *) 25 | definition feed :: "'at \ bool" where 26 | "feed a \ (case a of favorite \ True | x \ False)" 27 | end 28 | 29 | interpretation pets: menagerie nat 0 . 30 | 31 | -------------------------------------------------------------------------------- /proof/Object.thy: -------------------------------------------------------------------------------- 1 | theory Object 2 | imports 3 | Main Op "graphs/Digraph" 4 | begin 5 | 6 | section \Version Graphs\ 7 | 8 | text \A version graph is a directed graph between versions, whose arcs (edges) are writes.\ 9 | 10 | type_synonym "versionGraph" = "(version, aop) pre_digraph" 11 | 12 | section \Paths\ 13 | 14 | text \A path is a non-empty list of abstract writes such that each write's postversion connects to 15 | the next write's preversion.\ 16 | 17 | type_synonym "path" = "aop list" 18 | 19 | primrec is_path :: "aop list \ bool" where 20 | "is_path [] = False" | 21 | "is_path (w1 # ws) = (case ws of [] \ True | (w2 # _) \ 22 | ((post_version w1) = (pre_version w2)) \ (is_path ws))" 23 | 24 | lemma "is_path [AWrite k [0] 1 [1] [], AWrite k [1] 2 [2] []]" 25 | apply auto 26 | done 27 | 28 | text \We can also retrieve every version along a path, including the preversion of the first 29 | write, and the postversion of the last write.\ 30 | 31 | primrec path_versions :: "aop list \ version list" where 32 | "path_versions [] = []" | 33 | "path_versions (w # ws) = ((apre_version w) # (map apost_version (w # ws)))" 34 | 35 | text \We say a path is in a version graph if every write in the path is in the version graph too.\ 36 | primrec is_path_in_graph :: "aop list \ versionGraph \ bool" where 37 | "is_path_in_graph [] g = True" | 38 | "is_path_in_graph (w # ws) g = ((w \ (Digraph.arcs g)) \ (is_path_in_graph ws g))" 39 | 40 | 41 | 42 | section \Objects\ 43 | 44 | text \We define an Object as a key, an initial version, and a digraph over versions, where arcs 45 | are writes."\ 46 | 47 | datatype object = Object "key" "version" "versionGraph" 48 | 49 | text \Some basic accessors for objects\ 50 | 51 | instantiation object :: keyed 52 | begin 53 | primrec key_object :: "object \ key" where 54 | "key_object (Object k i g) = k" 55 | instance .. 56 | end 57 | 58 | primrec initial_version :: "object \ version" where 59 | "initial_version (Object k i g) = i" 60 | 61 | primrec version_graph :: "object \ versionGraph" where 62 | "version_graph (Object k i g) = g" 63 | 64 | instantiation object :: all_versions 65 | begin 66 | primrec all_versions_object :: "object \ version set" where 67 | "all_versions (Object k i g) = (Digraph.verts g)" 68 | instance .. 69 | end 70 | 71 | instantiation object :: all_aops 72 | begin 73 | primrec all_aops_object :: "object \ aop set" where 74 | "all_aops_object (Object k i g) = (Digraph.arcs g)" 75 | instance .. 76 | end 77 | 78 | section \Traces\ 79 | 80 | text \A trace is a path in some object's version graph which connects the initial version to some 81 | chosen version.\ 82 | 83 | definition is_trace_of :: "object \ path \ version \ bool" where 84 | "is_trace_of obj p v \ ((is_path p) \ 85 | (is_path_in_graph p (version_graph obj)) \ 86 | ((initial_version obj) = (apre_version (hd p))) \ 87 | (v = (apost_version (last p))))" 88 | 89 | text \We say an object is fully reachable if every element other than init has a trace.\ 90 | 91 | definition is_fully_reachable :: "object \ bool" where 92 | "is_fully_reachable obj \ (\v. (v \ (all_versions obj)) \ (\p. (is_trace_of obj p v)))" 93 | 94 | 95 | 96 | 97 | text \We can now define a well-formed object: they are fully reachable, and their initial version 98 | is in the version graph. That second part might be redundant.\ 99 | 100 | definition wf_object_init_in_graph :: "object \ bool" where 101 | "wf_object_init_in_graph obj \ ((initial_version obj) \ (all_versions obj))" 102 | 103 | definition wf_object :: "object \ bool" where 104 | "wf_object obj \ (wf_object_init_in_graph obj) \ 105 | (is_fully_reachable obj)" 106 | 107 | 108 | text \We might want to know the set of all operations which could result in some version.\ 109 | 110 | definition awrites_of :: "object \ version \ aop set" where 111 | "awrites_of obj v \ {w. w \ all_awrites obj \ v = apost_version w}" 112 | 113 | 114 | 115 | text \Now, we aim to include a new property: traceability\ 116 | 117 | text \Does this object have exactly one write resulting in a version?\ 118 | 119 | definition version_has_only_one_write :: "object \ version \ bool" where 120 | "version_has_only_one_write obj v \ (\!w. w \ awrites_of obj v)" 121 | 122 | definition every_version_has_only_one_write :: "object \ bool" where 123 | "every_version_has_only_one_write obj \ (\v. (v \ (all_versions obj)) \ 124 | (version_has_only_one_write obj v))" 125 | 126 | definition every_version_has_at_most_one_write :: "object \ bool" where 127 | "every_version_has_at_most_one_write obj \ (\v. (v \ (all_versions obj)) \ 128 | ((\(\w. (apost_version w) = v)) \ 129 | (\!w. (apost_version w) = v)))" 130 | 131 | text \We say an object is traceable if it has exactly one trace for every version other than 132 | the initial version.\ 133 | 134 | definition is_traceable :: "object \ bool" where 135 | "is_traceable obj \ (\v. (v \ (all_versions obj) \ (\!p. (is_trace_of obj p v))))" 136 | 137 | (* I don't exactly understand the THE quantifier, but hopefully this works in conjunction with 138 | traceable objects? *) 139 | definition trace_of :: "object \ version \ path" where 140 | "trace_of obj version \ (THE path. is_trace_of obj path version)" 141 | 142 | text \For traceable objects, we can define a trace_length for any version.\ 143 | 144 | definition trace_length :: "object \ version \ nat" where 145 | "trace_length obj v \ (length (trace_of obj v))" 146 | 147 | 148 | subsection \Implementations of objects\ 149 | 150 | 151 | text \Our digraphs need sets of vertices and arcs. We can write infinite sets, but for debugging and 152 | examples, it's nice to think about finite domains. Let's construct the set of singleton lists up to 153 | size s...\ 154 | (* This throws a well-sortedness error value "{(v :: version). True}" *) 155 | 156 | primrec nats_up_to :: "nat \ nat list" where 157 | "nats_up_to 0 = []" | 158 | "nats_up_to (Suc n) = (n # (nats_up_to n))" 159 | value "nats_up_to 2" 160 | 161 | (* Takes a list and returns every variant of that list but starting with nats up to n. *) 162 | definition tack_on_nats_up_to :: "nat \ nat list \ nat list list" where 163 | "tack_on_nats_up_to n xs \ (map (\x. (x # xs)) (nats_up_to n))" 164 | value "tack_on_nats_up_to 3 (1 # [])" 165 | 166 | (* Map and concatenate *) 167 | definition mapcat :: "('a \ 'b list) \ 'a list \ 'b list" where 168 | "mapcat f xs \ (concat (map f xs))" 169 | value "mapcat nats_up_to (1 # 2 # 3 # [])" 170 | 171 | (* Fixed lists *) 172 | primrec lists_of_n_nats_up_to_m :: "nat \ nat \ nat list list" where 173 | "lists_of_n_nats_up_to_m 0 m = ([] # [])" | 174 | "lists_of_n_nats_up_to_m (Suc n) m = (mapcat (tack_on_nats_up_to m) (lists_of_n_nats_up_to_m n m))" 175 | value "lists_of_n_nats_up_to_m 2 2" 176 | 177 | (* Variable lists *) 178 | definition lists_of_nats_up_to :: "nat \ nat list list" where 179 | "lists_of_nats_up_to m \ (mapcat (\n. (lists_of_n_nats_up_to_m (Suc n) m)) 180 | (nats_up_to m))" 181 | 182 | text \Given a set of versions, an initial version, and a write function which takes a current 183 | version and an argument to a resulting version and return value, we can build an object.\ 184 | 185 | (* 186 | (AWrite k v1 a v2 r) | v1 a v2 r. (v1 \ domain) \ 187 | (v2 \ domain) \ 188 | (f v1 a) = (v2,r)}, 189 | *) 190 | 191 | text \We define a finite object constructor for debugging purposes--this version is executable.\ 192 | definition smol_object :: "version list \ writeArg list \ version \ 193 | (version \ writeArg \ (version \ writeRet)) \ key \ object" where 194 | "smol_object vs args init f k \ (Object k init 195 | \verts = (set vs), 196 | arcs = (set (mapcat (\v1. (mapcat (\v2. (mapcat (\a. 197 | (let (v2,r) = (f v1 a) in 198 | (if (v2 \ (set vs)) then ((AWrite k v1 a v2 r) # []) else []))) 199 | args)) vs)) vs)), 200 | tail = apost_version, 201 | head = apre_version\)" 202 | 203 | text \And an object whose values are single-element sets up to the number n, such that writes 204 | always overwrite the current value, and return values are always the empty list.\ 205 | 206 | definition smol_register :: "nat \ key \ object" where 207 | "smol_register n k \ (smol_object (lists_of_n_nats_up_to_m 1 n) 208 | (nats_up_to n) 209 | (0 # []) 210 | (\ver arg. ((arg # []), [])) 211 | k)" 212 | 213 | value "smol_register 2 k" 214 | 215 | text \It's easier to prove properties of infinitely defined registers.\ 216 | 217 | definition register :: "key \ object" where 218 | "register k \ (Object k [0] \verts = {[v] | v. v \ Nats}, 219 | arcs = {(AWrite k [v1] a [a] []) | v1 a. v1 \ Nats \ a \ Nats}, 220 | tail = apost_version, 221 | head = apre_version\)" 222 | 223 | text \We show that all finite registers can only reach values up to [n].\ 224 | 225 | lemma "(all_versions (smol_register n k)) = (set (map (\x.[x]) (nats_up_to n)))" 226 | apply (simp add:smol_register_def mapcat_def tack_on_nats_up_to_def 227 | nats_up_to_def smol_object_def) 228 | done 229 | 230 | text \And that finite nonempty registers are well-formed.\ 231 | 232 | (* Not working yet 233 | lemma "(0 < n) \ wf_object (smol_register n k)" 234 | apply (simp add:wf_object_def wf_object_init_in_graph_def smol_register_def initial_version_def 235 | smol_object_def mapcat_def tack_on_nats_up_to_def nats_up_to_def) 236 | apply (induct_tac n) 237 | apply simp 238 | apply auto 239 | done 240 | 241 | text \The single-element register is traceable\ 242 | 243 | lemma smol_singleton_register_traceable: "is_traceable (smol_register n k)" 244 | apply (simp add:is_traceable_def all_versions_def smol_register_def smol_object_def mapcat_def 245 | tack_on_nats_up_to_def is_trace_of_def nats_up_to_def is_path_def is_path_in_graph_def 246 | apre_version_def apost_version_def) 247 | (* huh not sure *) 248 | oops 249 | *) 250 | 251 | text \The set of versions of an infinite register is all single-element lists.\ 252 | 253 | lemma register_versions [simp]: "(all_versions (register k)) = {[x] | x. x \ Nats}" 254 | apply (simp add:register_def) 255 | done 256 | 257 | 258 | lemma helper1: "(initial_version (register k)) = [0]" 259 | by (simp add: register_def) 260 | 261 | lemma helper2: "AWrite k [0] (Suc 0) [Suc 0] [] \ arcs (version_graph (register k))" 262 | apply (simp add:register_def) 263 | by (metis Nats_1 One_nat_def) 264 | 265 | lemma zero_in_N: "0 \ Nats" 266 | by auto 267 | 268 | lemma n_in_N_implies_suc_in_N: "(n \ Nats) \ (Suc n \ Nats)" 269 | by (metis (full_types) Nats_1 Nats_add One_nat_def add.right_neutral add_Suc_right) 270 | 271 | (* REALLY? *) 272 | lemma n_in_N [simp]: "(n::nat) \ Nats" 273 | proof - 274 | obtain nn :: "(nat \ bool) \ nat" where 275 | f1: "\p n. (\ p 0 \ p (nn p) \ \ p (Suc (nn p))) \ p n" 276 | using nat_induct by moura 277 | have "(0::nat) \ \ \ (nn (\n. n \ \) \ \ \ Suc (nn (\n. n \ \)) \ \)" 278 | using n_in_N_implies_suc_in_N by force 279 | then show ?thesis 280 | using f1 by (metis (no_types)) 281 | qed 282 | 283 | (* I am... shocked this is this complicated *) 284 | lemma succ_n_in_N [simp]: "(Suc n) \ Nats" 285 | by (simp add:n_in_N) 286 | 287 | lemma helper3: "AWrite k [Suc 0] n [n] [] \ arcs (version_graph (register k))" 288 | by (simp add:register_def) 289 | 290 | text \There is a single-write trace to any version.\ 291 | 292 | lemma register_one_trace: "is_trace_of (register k) [AWrite k [0] n [n] []] [n]" 293 | apply (simp add:is_trace_of_def register_def) 294 | done 295 | 296 | text \There is a second trace to any version going 0\1\v\ 297 | 298 | lemma register_two_trace: "is_trace_of (register k) [(AWrite k [0] 1 [1] []), 299 | (AWrite k [1] n [n] [])] [n]" 300 | unfolding is_trace_of_def 301 | apply auto 302 | apply (simp add:helper2) 303 | apply (simp add:helper3) 304 | by (simp add: helper1) 305 | 306 | lemma register_has_a_trace: "\p. is_trace_of (register k) p [n]" 307 | using register_two_trace by blast 308 | 309 | (* not working yet 310 | lemma register_has_two_traces: "let r = (register k) in \p1 p2. (is_trace_of r p1 [n]) \ 311 | (is_trace_of r p2 [n]) \ 312 | (p \ q)" 313 | proof- 314 | { fix x assume "x = 2" } 315 | using register_one_trace 316 | using register_two_trace 317 | 318 | lemma register_not_traceable: "~(is_traceable (register k))" 319 | oops 320 | *) 321 | 322 | subsection \Next, we define a construct for a list-append object. The initial value is the empty 323 | list, and writes append an entry to the end of the list.\ 324 | 325 | definition list_append :: "key \ object" where 326 | "list_append k \ (Object k [] \verts = {l::(nat list). True}, 327 | arcs = {(AWrite k v a (v @ [a]) []) | v a. a \ Nats }, 328 | tail = apost_version, 329 | head = apre_version\)" 330 | 331 | text \We wish to show that list append is traceable. We can show that a singleton list has a trace 332 | if we feed that trace to the checker...\ 333 | 334 | lemma list_append_singleton_list_has_trace_definite: 335 | "is_trace_of (list_append k) [(AWrite k [] x1 [x1] [])] [x1]" 336 | apply (simp add:is_trace_of_def list_append_def) 337 | done 338 | 339 | text \But... weirdly I can't figure out how to convince Isabelle that a trace DOES exist, even 340 | though we just showed one exists. God, I wish I knew how to do proof by construction in Isabelle.\ 341 | 342 | lemma list_append_singleton_list_has_trace: "\p. is_trace_of (list_append k) p [x1]" 343 | apply (simp add:is_trace_of_def list_append_def) 344 | oops 345 | 346 | text \And this is... right out.\ 347 | 348 | lemma list_append_traceable: "is_traceable (list_append k)" 349 | oops 350 | 351 | end -------------------------------------------------------------------------------- /proof/Object2.thy: -------------------------------------------------------------------------------- 1 | theory Object2 2 | imports Main 3 | begin 4 | 5 | section \Datatypes\ 6 | 7 | text \We begin by defining a datatype as an initial value plus a transition function, which takes a 8 | verson and argument to a (value', ret-val) tuple. We define a datatype to encapsulate this tuple:\ 9 | 10 | datatype ('v, 'r) write_out = WriteOut 'v 'r 11 | 12 | primrec write_out_value :: "('v, 'r) write_out \ 'v" where 13 | "write_out_value (WriteOut v r) = v" 14 | 15 | primrec write_out_ret :: "('v, 'r) write_out \ 'r" where 16 | "write_out_ret (WriteOut v r) = r" 17 | 18 | text \And a locale which fixes the initial value and transition function w.\ 19 | 20 | locale data_type = 21 | fixes init :: "'v" 22 | and w :: "'v \ 'a \ ('v, 'r) write_out" 23 | begin 24 | 25 | text \Given a sequence of write arguments, we can construct a function which applies those arguments 26 | in sequence.\ 27 | 28 | primrec apply_args :: "'v \ 'a list \ 'v" where 29 | "apply_args v [] = v" | 30 | "apply_args v (a # as) = apply_args (write_out_value (w v a)) as" 31 | 32 | text \Some lemmata around apply_args\ 33 | 34 | lemma apply_args_Cons: "apply_args v (a#as) = apply_args (write_out_value (w v a)) as" 35 | by auto 36 | 37 | text \A database is traceable if, for any version, there exists exactly one sequence of args that 38 | leads to that version.\ 39 | 40 | definition is_traceable :: "bool" where 41 | "is_traceable \ \ args1 args2 . apply_args init args1 = apply_args init args2 \ args1 = args2" 42 | 43 | end 44 | 45 | locale traceable_data_type = data_type init w for init w + 46 | assumes traceable:"is_traceable" 47 | begin 48 | 49 | text \Here, we prove facts about traceable data types.\ 50 | 51 | end 52 | 53 | section \Append-only lists\ 54 | 55 | text \We begin by showing that list append over lists of naturals can form a data type.\ 56 | 57 | definition list_append_w :: "'x list \ 'x \ ('x list, bool) write_out" where 58 | "list_append_w xs x \ WriteOut (xs @ [x]) True" 59 | 60 | value "list_append_w [a, b] c" 61 | 62 | interpretation list_append: data_type "[]" list_append_w . 63 | 64 | text \We want to show this datatype is traceable. First, we prove that applying a sequence of args 65 | produces that list of args itself.\ 66 | 67 | value "list_append.apply_args x [a,b]" 68 | 69 | lemma list_append_args_are_value:"list_append.apply_args [] xs = xs" 70 | proof (induct xs) 71 | case Nil 72 | then show ?case 73 | by simp 74 | next 75 | case (Cons x xs) 76 | then show ?case 77 | apply (simp add: data_type.apply_args_Cons) 78 | 79 | qed 80 | 81 | interpretation list_append_traceable:traceable_data_type "[]" "list_append_w" 82 | using list_append.is_traceable_def traceable_data_type_def 83 | 84 | end 85 | -------------------------------------------------------------------------------- /proof/Observation.thy: -------------------------------------------------------------------------------- 1 | theory Observation 2 | imports Main History 3 | begin 4 | 5 | section \Observations\ 6 | 7 | text \Fundamentally, an observation is a set of objects and observed transactions over them.\ 8 | 9 | datatype observation = Observation "object set" "otxn set" 10 | 11 | text \We define some basic accessors...\ 12 | 13 | primrec all_otxns :: "observation \ otxn set" where 14 | "all_otxns (Observation objs txns) = txns" 15 | 16 | instantiation observation :: all_objects 17 | begin 18 | primrec all_objects_observation :: "observation \ object set" where 19 | "all_objects_observation (Observation objs txns) = objs" 20 | instance .. 21 | end 22 | 23 | instantiation observation :: all_versions 24 | begin 25 | primrec all_versions_observation :: "observation \ version set" where 26 | "all_versions_observation (Observation objs txns) = \{all_versions t | t. t \ txns}" 27 | instance .. 28 | end 29 | 30 | instantiation observation :: all_oops 31 | begin 32 | primrec all_oops_observation :: "observation \ oop set" where 33 | "all_oops_observation (Observation objs txns) = \{all_oops t | t. t \ txns}" 34 | instance .. 35 | end 36 | 37 | text \A well-formed observation is made up of well-formed objects and transactions, and its 38 | transactions are over those objects.\ 39 | 40 | primrec wf_observation :: "observation \ bool" where 41 | "wf_observation (Observation objs txns) = 42 | ((\obj. obj \ objs \ wf_object obj) \ 43 | (\t. t \ txns \ (wf_otxn t \ (\oop. (oop \ (all_oops t)) \ 44 | (\!obj. (obj \ objs) \ ((key oop) = (key obj)))))))" 45 | 46 | 47 | text \We say an observation is compatible with a history via relation m if they have the same 48 | object set, the same number of transactions, and m is a bijective mapping from observed transactions 49 | in the observation to compatible abstract transactions in the history.\ 50 | 51 | definition is_compatible_observation :: "observation \ (otxn \ atxn) \ history \ bool" where 52 | "is_compatible_observation obs m h = 53 | ((all_objects obs = all_objects h) \ 54 | (\otxn. otxn \ (all_otxns obs) \ (is_compatible_txn otxn (m otxn))))" 55 | 56 | 57 | section \Interpretations\ 58 | 59 | text \An interpretation of an observation O is a history H and a bijection M which translates 60 | operations in O to compatible observations in H. Interpretation is a reserved word, so...\ 61 | 62 | datatype interp = Interp "observation" "(otxn \ atxn)" "history" 63 | 64 | primrec history :: "interp \ history" where 65 | "history (Interp obs m h) = h" 66 | 67 | text \We say f is a total bijection between a and b iff f is bijective and every a maps to a b. 68 | I feel like there should be something for this in Isabelle already but I'm not sure.\ 69 | 70 | text \Giuliano: you can use the query panel to search for constants or theorems. 71 | Here, look for a constant of the following type: "(_ \ _) \ _ set \ _ set \ bool", and it will find:\ 72 | thm Fun.bij_betw_def \ \That is probably what you wanted\ 73 | 74 | definition total_bij :: "('a \ 'b) \ 'a set \ 'b set \ bool" where 75 | "total_bij f as bs \ ((bij f) \ (\a. (a \ as) \ ((f a) \ bs)))" 76 | 77 | (* I can't even show this? Really? *) 78 | text \Giuliano: it's because it does not hold :) You forgot to assume that @{term \a \ as\}. 79 | It's often a good idea to run nitpick as a first sanity check. Here, it immediately finds a counter-example\ 80 | lemma "(total_bij f as bs \ (b = (f a))) \ (b \ bs)" 81 | nitpick 82 | apply (simp add:total_bij_def) 83 | apply auto 84 | oops 85 | 86 | lemma my_lemma: 87 | assumes "total_bij f as bs" and "b = f a" and "a \ as" 88 | shows "(b \ bs)" \ \Note that this syntax is better becuase it produces a lemma in rule format, ready to be applied without transformation.\ 89 | using assms total_bij_def by fastforce \ \found by sledgehammer in a few seconds\ 90 | 91 | lemma my_lemma_bad: 92 | "total_bij f as bs \ b = f a \ a \ as \ b \ bs" 93 | using total_bij_def by fastforce 94 | 95 | text \Now check what the lemmas looks like with @{command thm}\ 96 | thm my_lemma \ \In rule form\ 97 | thm my_lemma_bad \ \Not in rule form; cannot be applied directly by generic proof tools like auto\ 98 | 99 | (* Huh, would have thought this would be easy *) 100 | lemma total_bij_image1: "(total_bij f a b) \ ((f`a) = b)" 101 | nitpick \ \Again, nitpick shows that it does not hold\ 102 | apply (simp add: total_bij_def) 103 | 104 | oops 105 | 106 | text \Well-formed interpretations are made up of a well-formed observation, a bijection between 107 | observed and abstract transactions, and a well-formed history, such that the observation and 108 | the history are compatible via that bijection.\ 109 | 110 | primrec wf_interpretation :: "interp \ bool" where 111 | "wf_interpretation (Interp obs m h) = ((wf_observation obs) \ 112 | (wf_history h) \ 113 | (total_bij m (all_otxns obs) (all_atxns h)) \ 114 | (is_compatible_observation obs m h))" 115 | 116 | text \This lets us talk about corresponding transactions via that bijection m.\ 117 | 118 | primrec corresponding_atxn :: "interp \ otxn \ atxn" where 119 | "corresponding_atxn (Interp obs m h) otxn = (m otxn)" 120 | 121 | primrec corresponding_otxn :: "interp \ atxn \ otxn" where 122 | "corresponding_otxn (Interp obs m h) atxn = (THE otxn. atxn = m otxn)" 123 | 124 | text \These are invertible, thanks to m being bijective.\ 125 | 126 | lemma "(corresponding_otxn (Interp obs h m) atxn) \ (all_otxns obs)" 127 | 128 | 129 | lemma corresponding_invertible: "(corresponding_otxn i (corresponding_atxn i t)) = t" 130 | oops 131 | 132 | section \Recoverability\ 133 | 134 | text \Recoverability allows us to (in some cases) map a version of some key to a specific 135 | observed transaction which must have produced it. To start, we figure out when a transaction 136 | could have written a particular version of an object: some write resulting in this version of the 137 | object is compatible with a write in the transaction.\ 138 | 139 | definition could_have_been_written_by :: "object \ version \ otxn \ bool" where 140 | "could_have_been_written_by obj v t \ (\aw ow. aw \ awrites_of obj v \ 141 | ow \ all_owrites t \ 142 | is_compatible_op ow aw)" 143 | 144 | (* might have this wrong *) 145 | lemma "((could_have_been_written_by obj v ot) \ (is_compatible_txn ot atxn)) \ 146 | (\v0 a r. (AWrite k v0 a v r) \ all_awrites atxn)" 147 | oops 148 | 149 | 150 | text \Given an observation, we say a version v of key k is recoverable to a transaction t if t is 151 | the only transaction which could have written that v of k.\ 152 | 153 | definition is_recoverable :: "observation \ key \ version \ otxn \ bool" where 154 | "is_recoverable obs k v ot \ (let obj = (THE ob. ob \ all_objects obs \ key ob = k) in 155 | (could_have_been_written_by obj v ot) \ 156 | (\!t. t \ all_otxns obs \ could_have_been_written_by obj v t))" 157 | 158 | 159 | 160 | 161 | end -------------------------------------------------------------------------------- /proof/Op.thy: -------------------------------------------------------------------------------- 1 | theory Op 2 | imports Main 3 | begin 4 | 5 | section \Keys, Versions, and Operations\ 6 | 7 | text \Our database is conceptually modeled as a map of keys to values. We don't demand anything of 8 | our keys, other than that they exist and have equality.\ 9 | 10 | typedecl key 11 | 12 | text \We're going to define our databases in terms of versions, arguments, and return value types 13 | which are polymorphic. One option would be to have these as type parameters in... literally every 14 | single function, but that's going to be exhausting, and it also means we can't use typeclasses, 15 | because typeclasses can't return things with type variables. Another option is to define a version 16 | explicitly as, say, a list of nats, but discussions with Galois engineers suggests that this is 17 | counterproductive: we're forcing the solver to pull in a whole bunch of theorems that it doesn't 18 | actually need, which makes automated proof search harder. 19 | 20 | So... another option to try here might be to do this with *locales*, which... I honestly don't 21 | understand even 10% of. I *think* they allow us to prove a bunch of properties about structures 22 | involving type parameters without actually defining what those type parameters *are*, and... also 23 | making those structures sort of... an implicitly available argument to every function we define? But 24 | that leaves other questions, like... what if I have two arguments? Are locales meant to be more... 25 | about universal structures? The Digraph library doesn't think so, but I don't understand half of 26 | what it's doing. :(\ 27 | 28 | text \It'd be nice to define our versions, arguments, and return values as polymorphic type 29 | parameters. However, owing to what I think is a limitation in Isabelle's typeclass system, we can't. 30 | What we CAN do is fix our versions, arguments, and retvals as lists of naturals, naturals, and lists 31 | of naturals, respectively. We can use this representation for lists, sets, counters, and registers 32 | easily, by defining different types of graphs. Also, we won't have to carry these type parameters on 33 | everything.\ 34 | 35 | type_synonym "version" = "nat list" 36 | type_synonym "writeArg" = "nat" 37 | type_synonym "writeRet" = "nat list" 38 | 39 | text \Reads and writes are different types of operations. We're going to want to distinguish 40 | them.\ 41 | 42 | datatype opType = Read | Write 43 | 44 | text \Reads and writes have different types of arguments and return values. However, it's going to 45 | be convenient to talk about and compare their arguments and return values without caring what type 46 | of operation we performed. We define wrapper types for arguments and return values here.\ 47 | 48 | datatype arg = WriteArg "writeArg" | ReadArg 49 | datatype ret = WriteRet "writeRet" | ReadRet "version" 50 | 51 | text \An operation acts on the state of some key, taking a preversion of an object and, using an 52 | argument, producing a postversion and a return value. In general, we don't know exactly what the 53 | versions and return value are; we represent these as options.\ 54 | 55 | class keyed = 56 | fixes key :: "'a \ key" 57 | 58 | class op = 59 | fixes op_type :: "'a \ opType" 60 | fixes pre_version :: "'a \ version option" 61 | fixes arg :: "'a \ arg" 62 | fixes post_version :: "'a \ version option" 63 | fixes ret :: "'a \ ret option" 64 | 65 | text \We now define two types of operations. Abstract operations (beginning with a) have definite 66 | versions and values. Observed operations may not know their versions and return values. Reads take 67 | no argument and return their current version; writes may change their versions somehow.\ 68 | 69 | datatype aop = 70 | ARead "key" "version" | 71 | AWrite "key" "version" "writeArg" "version" "writeRet" 72 | 73 | datatype oop = 74 | ORead "key" "version option" | 75 | OWrite "key" "version option" "writeArg" "version option" "writeRet option" 76 | 77 | text \A few accessors for when we don't want to deal with optionals...\ 78 | 79 | primrec apre_version :: "aop \ version" where 80 | "apre_version (ARead k v) = v" | 81 | "apre_version (AWrite k v1 a v2 r) = v1" 82 | 83 | primrec aret :: "aop \ ret" where 84 | "aret (ARead k v) = (ReadRet v)" | 85 | "aret (AWrite k v1 a v2 r) = (WriteRet r)" 86 | 87 | primrec apost_version :: "aop \ version" where 88 | "apost_version (ARead k v) = v" | 89 | "apost_version (AWrite k v1 a v2 r) = v2" 90 | 91 | definition aversions_in_op :: "aop \ version set" where 92 | "aversions_in_op op \ {apre_version op, apost_version op}" 93 | 94 | text \These accessors allow us to extract keys, versions, etc from all types of operations in 95 | a uniform way.\ 96 | 97 | instantiation aop :: keyed 98 | begin 99 | primrec key_aop :: "aop \ key" where 100 | "key_aop (ARead k v) = k" | 101 | "key_aop (AWrite k v1 a v2 r) = k" 102 | instance .. 103 | end 104 | 105 | instantiation aop :: op 106 | begin 107 | primrec op_type_aop :: "aop \ opType" where 108 | "op_type_aop (ARead k v) = Read" | 109 | "op_type_aop (AWrite k v1 a v2 r) = Write" 110 | 111 | primrec pre_version_aop :: "aop \ version option" where 112 | "pre_version_aop (ARead k v) = Some v" | 113 | "pre_version_aop (AWrite k v1 a v2 r) = Some v1" 114 | 115 | primrec arg_aop :: "aop \ arg" where 116 | "arg_aop (ARead k v) = ReadArg" | 117 | "arg_aop (AWrite k v1 a v2 r) = WriteArg a" 118 | 119 | primrec post_version_aop :: "aop \ version option" where 120 | "post_version_aop (ARead k v) = Some v" | 121 | "post_version_aop (AWrite k v1 a v2 r) = Some v2" 122 | 123 | primrec ret_aop :: "aop \ ret option" where 124 | "ret_aop (ARead k v) = Some (ReadRet v)" | 125 | "ret_aop (AWrite k v1 a v2 r) = Some (WriteRet r)" 126 | 127 | instance .. 128 | end 129 | 130 | text \As a quick test of these accessors...\ 131 | lemma "arg (ARead k v) = ReadArg" 132 | by auto 133 | 134 | lemma "pre_version (AWrite k v1 a v2 r) = Some v1" 135 | by auto 136 | 137 | lemma "post_version (AWrite k v1 a v2 r) = Some v2" 138 | by auto 139 | 140 | lemma "(key (ARead k v1)) = (key (AWrite k v2 a v3 r))" 141 | by auto 142 | 143 | text \Moving on to accessors for observed operations...\ 144 | 145 | instantiation oop :: keyed 146 | begin 147 | primrec key_oop :: "oop \ key" where 148 | "key_oop (ORead k v) = k" | 149 | "key_oop (OWrite k v1 a v2 r) = k" 150 | instance .. 151 | end 152 | 153 | instantiation oop :: op 154 | begin 155 | 156 | primrec op_type_oop :: "oop \ opType" where 157 | "op_type_oop (ORead k v) = Read" | 158 | "op_type_oop (OWrite k v1 a v2 r) = Write" 159 | 160 | primrec pre_version_oop :: "oop \ version option" where 161 | "pre_version_oop (ORead k v) = v" | 162 | "pre_version_oop (OWrite k v1 a v2 r) = v1" 163 | 164 | primrec arg_oop :: "oop \ arg" where 165 | "arg_oop (ORead k v) = ReadArg" | 166 | "arg_oop (OWrite k v1 a v2 r) = WriteArg a" 167 | 168 | primrec post_version_oop :: "oop \ version option" where 169 | "post_version_oop (ORead k v) = v" | 170 | "post_version_oop (OWrite k v1 a v2 r) = v2" 171 | 172 | primrec ret_oop :: "oop \ ret option" where 173 | "ret_oop (ORead k v) = (case v of Some v \ Some (ReadRet v) | None \ None)" | 174 | "ret_oop (OWrite k v1 a v2 r) = (case r of Some r \ Some (WriteRet r) | None \ None)" 175 | 176 | instance .. 177 | end 178 | 179 | text \And as a quick check...\ 180 | lemma "(post_version (ORead k1 (Some v))) = 181 | (pre_version (OWrite k2 (Some v) a None None))" 182 | by auto 183 | 184 | text \We're going to be asking a lot about "the set of all versions in ".\ 185 | class all_versions = 186 | fixes all_versions :: "'a \ version set" 187 | 188 | 189 | instantiation aop :: all_versions 190 | begin 191 | primrec all_versions_aop :: "aop \ version set" where 192 | "all_versions_aop (ARead k v) = {v}" | 193 | "all_versions_aop (AWrite k v1 a v2 r) = {v1, v2}" 194 | instance .. 195 | end 196 | 197 | instantiation oop :: all_versions 198 | begin 199 | primrec all_versions_oop :: "oop \ version set" where 200 | "all_versions_oop (ORead k v) = (case v of None \ {} | (Some v) \ {v})" | 201 | "all_versions_oop (OWrite k v1 a v2 r) = (case v1 of 202 | None \ (case v2 of None \ {} | (Some v2) \ {v2}) | 203 | (Some v1) \ (case v2 of None \ {v1} | (Some v2) \ {v1, v2}))" 204 | instance .. 205 | end 206 | 207 | text \... And all keys in something \ 208 | class all_keys = 209 | fixes all_keys :: "'a \ key set" 210 | 211 | text \And similarly, we're going to want to talk about all operations in a transaction, version 212 | graph, object, history, observation, etc...\ 213 | 214 | class all_aops = 215 | fixes all_aops :: "'a \ aop set" 216 | 217 | class all_oops = 218 | fixes all_oops :: "'a \ oop set" 219 | 220 | text \And if you have the set of all ops, you can filter that to the set of writes or reads.\ 221 | 222 | definition all_owrites :: "'a::all_oops \ oop set" where 223 | "all_owrites a = {op. (op \ (all_oops a)) \ ((op_type op = Write))}" 224 | 225 | definition all_oreads :: "'a::all_oops \ oop set" where 226 | "all_oreads a = {op. (op \ (all_oops a)) \ ((op_type op = Read))}" 227 | 228 | definition all_awrites :: "'a::all_aops \ aop set" where 229 | "all_awrites a = {op. (op \ (all_aops a)) \ ((op_type op = Write))}" 230 | 231 | definition all_areads :: "'a::all_aops \ aop set" where 232 | "all_areads a = {op. (op \ (all_aops a)) \ ((op_type op = Read))}" 233 | 234 | text \An observed operation is definite if its optional fields are known. Might want to break this 235 | up later; it might be helpful to talk about postversion-definite, retval-definite, write-definite, 236 | etc.\ 237 | 238 | class definite = 239 | fixes is_definite :: "'a \ bool" 240 | 241 | (* Huh, can't instantiate a typeclass over a polymorphic type? 242 | instantiation "'a option" :: definite 243 | begin 244 | *) 245 | 246 | primrec is_definite_option :: "'a option \ bool" where 247 | "is_definite_option None = False" | 248 | "is_definite_option (Some x) = True" 249 | 250 | instantiation oop :: definite 251 | begin 252 | primrec is_definite :: "oop \ bool" where 253 | "is_definite (ORead k v) = is_definite_option v" | 254 | "is_definite (OWrite k v1 a v2 r) = (is_definite_option v1 \ 255 | is_definite_option v2 \ 256 | is_definite_option r)" 257 | instance .. 258 | end 259 | 260 | 261 | 262 | text \We now define a notion of compatibility, which says whether an observed operation could 263 | correspond to some abstract operation. The idea here is that the database executed the abstract 264 | operation, but that we don't know, due to the client protocol, or perhaps due to missing responses, 265 | exactly what happened. We compare Options to actual values, ensuring that either the optional is 266 | None (e.g. we don't know), or if it's Some, that the values are equal. 267 | 268 | I'd like to do this as a typeclass, but without multi-type-parameter typeclasses, we can't 269 | write a generic function over a \ b \ bool. This seems like something I'm likely to mess up, 270 | so instead, we write a family of compatibility functions with type names.\ 271 | 272 | primrec is_compatible_option :: "'a option \ 'a \ bool" where 273 | "is_compatible_option None y = True" | 274 | "is_compatible_option (Some x) y = (x = y)" 275 | 276 | text \An observed operation is compatible with an abstract operation if their types, keys, 277 | versions, arguments, and return values are all compatible.\ 278 | definition is_compatible_op :: "oop \ aop \ bool" where 279 | "is_compatible_op oop aop \ 280 | (((op_type oop) = (op_type aop)) \ 281 | ((key oop) = (key aop)) \ 282 | (is_compatible_option (pre_version oop) (apre_version aop)) \ 283 | ((arg oop) = (arg aop)) \ 284 | (is_compatible_option (ret oop) (aret aop)) \ 285 | (is_compatible_option (post_version oop) (apost_version aop)))" 286 | 287 | text \Some basic lemmata around compatibility. These are... surprisingly expensive proofs for 288 | sledgehammer to find...\ 289 | 290 | lemma compatible_same_type: "is_compatible_op oop aop \ ((op_type oop) = (op_type aop))" 291 | using is_compatible_op_def by blast 292 | 293 | lemma compatible_same_key: "is_compatible_op oop aop \ ((key oop) = (key aop))" 294 | using is_compatible_op_def by blast 295 | 296 | lemma compatible_same_arg: "is_compatible_op oop aop \ ((arg oop) = (arg aop))" 297 | using is_compatible_op_def by blast 298 | 299 | lemma compatible_pre_version: 300 | "is_compatible_op oop aop \ (((pre_version oop) = None) \ 301 | ((pre_version oop) = Some (apre_version aop)))" 302 | by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq) 303 | 304 | lemma compatible_post_version: 305 | "is_compatible_op oop aop \ (((post_version oop) = None) \ 306 | ((post_version oop) = Some (apost_version aop)))" 307 | by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq) 308 | 309 | lemma compatible_ret: 310 | "is_compatible_op oop aop \ (((ret oop) = None) \ 311 | ((ret oop) = Some (aret aop)))" 312 | by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq) 313 | 314 | lemma compatible_definite_same_pre_version: 315 | "(is_compatible_op oop aop \ is_definite oop) \ ((pre_version oop) = (pre_version aop))" 316 | by (smt aop.exhaust apre_version.simps(1) apre_version.simps(2) is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(1) is_definite.simps(2) is_definite_option.simps(1) oop.exhaust option.exhaust pre_version_aop.simps(1) pre_version_aop.simps(2) pre_version_oop.simps(1) pre_version_oop.simps(2)) 317 | 318 | lemma compatible_definite_same_post_version: 319 | "(is_compatible_op oop aop \ is_definite oop) \ ((post_version oop) = (post_version aop))" 320 | by (smt aop.exhaust apost_version.simps(2) compatible_definite_same_pre_version is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(2) is_definite_option.simps(1) oop.exhaust opType.distinct(1) op_type_aop.simps(1) op_type_aop.simps(2) op_type_oop.simps(1) op_type_oop.simps(2) option.exhaust post_version_aop.simps(1) post_version_aop.simps(2) post_version_oop.simps(1) post_version_oop.simps(2) pre_version_aop.simps(1) pre_version_oop.simps(1)) 321 | 322 | lemma compatible_definite_same_ret: 323 | "(is_compatible_op oop aop \ is_definite oop) \ ((ret oop) = (ret aop))" 324 | by (smt aop.exhaust aret.simps(1) aret.simps(2) is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(1) is_definite.simps(2) is_definite_option.simps(1) not_None_eq oop.exhaust option.case(2) ret_aop.simps(1) ret_aop.simps(2) ret_oop.simps(1) ret_oop.simps(2)) 325 | 326 | text \If two operations are compatible and the observed one is definite, they share exactly 327 | the same values.\ 328 | 329 | lemma definite_compatible_same: 330 | "is_compatible_op oop aop \ is_definite oop \ 331 | (((pre_version oop) = (pre_version aop)) \ 332 | ((post_version oop) = (post_version aop)) \ 333 | ((ret oop) = (ret aop)))" 334 | by (simp add: compatible_definite_same_post_version compatible_definite_same_pre_version compatible_definite_same_ret) 335 | 336 | 337 | end -------------------------------------------------------------------------------- /proof/Op2.thy: -------------------------------------------------------------------------------- 1 | theory Op2 2 | imports Main 3 | begin 4 | 5 | section \Keys, Versions, Operations\ 6 | 7 | -------------------------------------------------------------------------------- /proof/PolymorphismTest.thy: -------------------------------------------------------------------------------- 1 | theory PolymorphismTest 2 | imports Main 3 | begin 4 | 5 | (* This is a little scratchpad/demo for polymorphic functions; I dunno whether I can just write 6 | them directly with pattern matching or if I need typeclasses *) 7 | 8 | (* Unrelated types of animals with a leg count and, for warydog, a wariness state *) 9 | datatype cat = Cat "bool list" 10 | datatype dog = Dog "nat" | 11 | WaryDog "nat" "bool" 12 | 13 | class pet = 14 | fixes legs :: "'a => nat" 15 | fixes friendly :: "'a => bool" 16 | 17 | (* Make cats treatable as pets! Note that these monomorphic function names are *magic*: Isabelle 18 | expects them in this format when it generates... whatever its eldritch equivalent of type dispatch 19 | tables are for polymorphic functions*) 20 | 21 | instantiation cat :: pet 22 | begin 23 | primrec legs_cat :: "cat \ nat" where 24 | "legs_cat (Cat leg_count) = (length leg_count)" 25 | 26 | definition friendly_cat :: "cat \ bool" where 27 | "friendly_cat cat = True" 28 | 29 | (* "Trivial instantiation proof" -- I don't understand this but I don't think I need to yet *) 30 | instance .. 31 | end 32 | 33 | (* OK now do dogs *) 34 | instantiation dog :: pet 35 | begin 36 | primrec legs_dog :: "dog \ nat" where 37 | "legs_dog (Dog leg_count) = leg_count" | 38 | "legs_dog (WaryDog leg_count wary) = leg_count" 39 | 40 | fun friendly_dog :: "dog \ bool" where 41 | "friendly_dog (WaryDog _ wary) = (\ wary)" | 42 | "friendly_dog d = True" 43 | 44 | instance .. 45 | end 46 | 47 | value "legs (Cat (True # False # []))" 48 | value "legs (WaryDog 4 False)" 49 | value "friendly (WaryDog 2 False)" 50 | (* extremely joe damato voice: COOOOOL *) 51 | 52 | (* A typeclass can't be used as a type. I assume there's some sort of constraint syntax which 53 | lets us say "'a is in class pet" but I can't find it so far 54 | definition friendly_four :: "pet \ bool" where 55 | "friendly_four p \ ((friendly p) \ (4 = legs p))" 56 | *) 57 | 58 | (* Can we define it with a type parameter and rely on unification to figure it out for us? No, 59 | this complains "'a is not of sort pet" 60 | definition friendly_four2 :: "'a \ bool" where 61 | "friendly_four2 p \ ((friendly p) \ (4 = legs p))" 62 | *) 63 | 64 | (* lmao oh right of course. Sorts/Kinds/higher-rank-types are types of types. We put a type on 65 | the type! *) 66 | definition friendly_four3 :: "('a::pet) \ bool" where 67 | "friendly_four3 p \ ((friendly p) \ (4 = legs p))" 68 | 69 | (* OK, now... how do we define a class that returns a class? We can't use a type parameter because 70 | typeclasses can only have a single polymorphism site... 71 | class shelter = 72 | fixes adopt :: "'a \ 'b::pet" 73 | *) 74 | 75 | (* Can we define a type synonym, so the type variable doesn't appear lexically in the class? 76 | No, this throws Undefined type name: "a_pet 77 | type_synonym "a_pet" = "'a::pet" *) 78 | 79 | class shelter = 80 | fixes adopt :: "'a \ a_pet" -------------------------------------------------------------------------------- /proof/ProofTest.thy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jepsen-io/elle/e9cff9fe2a02cbd6a21a9d1539524813b1c275d5/proof/ProofTest.thy -------------------------------------------------------------------------------- /proof/Scratch.thy: -------------------------------------------------------------------------------- 1 | theory Scratch 2 | imports Main Observation 3 | begin 4 | 5 | text \So, you can't have a typeclass return a type parameter. Let's see if we can define a type with 6 | no properties, then later, assert some properties *of* that type and use them in a proof. So... some 7 | `foo` exists. We don't know what it is.\ 8 | 9 | typedecl foo 10 | 11 | text \We can make a container for foo\ 12 | 13 | datatype box = Box "foo" 14 | 15 | text \We can use foo for equality...\ 16 | 17 | lemma "(x :: foo) \ (y :: foo) \ (Box x) \ (Box y)" 18 | apply auto 19 | done 20 | 21 | lemma "(x :: foo) = (y :: foo) \ (Box x) = (Box y)" 22 | apply auto 23 | done 24 | 25 | text \We can define a typeclass which returns foos...\ 26 | 27 | class openable = 28 | fixes open1 :: "'a \ foo" 29 | 30 | instantiation box :: openable 31 | begin 32 | primrec open1 :: "box \ foo" where 33 | "open1 (Box f) = f" 34 | instance .. 35 | end 36 | 37 | text \Now it'd be nice if we could show something trivial, like... if foo is, say, a nat, then open1 38 | returns a nat. If we were using type parameters, I'd make a "box nat", but since we're NOT using 39 | type parameters... I want to write, like, (foo = nat) \ is_nat (openable x)" but I have no idea how\ 40 | 41 | text \I think what I want here is maybe... a locale? Let's try that...\ 42 | 43 | locale partial_order = 44 | fixes le :: "'a \ 'a \ bool" 45 | assumes refl [intro, simp]: "le x x" 46 | and anti_sym [intro]: "\le x y; le y x\ \ x = y" 47 | and trans [trans]: "\le x y; le y z\ \ le x z" 48 | 49 | text \So... what we've done here is assert a le function exists, and it obeys these laws, but we 50 | haven't actually said what le is. le could operate over cats or cargo ships. It could be < or >. Can 51 | I define a locale that returns a type parameter?\ 52 | 53 | locale openable2 = 54 | fixes open2 :: "'a \ 'b" 55 | 56 | text \Huh. So... all I've said here is that a binary function exists. What about... making a box for 57 | a type parameter? That's something we can't do with typeclasses...\ 58 | 59 | datatype 'a abstract_box = AbstractBox "'a" 60 | locale boxable = 61 | fixes box :: "'a \ ('b abstract_box)" 62 | 63 | text \Okay, so I can define a boxable function which returns something with type parameters. Note 64 | that our box is over a different type, so we could, I dunno, take strings and constantly return 65 | AbstractBox 2 or something.\ 66 | 67 | -------------------------------------------------------------------------------- /proof/Traceable-Objects.thy: -------------------------------------------------------------------------------- 1 | theory "Traceable-Objects" 2 | imports Main 3 | begin 4 | 5 | section \A few properties of foldl\ 6 | 7 | lemma l1:"foldl (o) a (rev (x#xs)) = (foldl (o) a (rev xs)) o x" 8 | by simp 9 | 10 | lemma l2:"foldl (o) a (x#xs) = a o (foldl (o) x xs)" 11 | proof (induct "rev xs" arbitrary:a x xs) 12 | case Nil 13 | then show ?case 14 | by auto 15 | next 16 | case (Cons a xa) 17 | then show ?case 18 | by (metis (no_types, lifting) append_Cons comp_assoc l1 rev.simps(2) rev_swap) 19 | qed 20 | 21 | lemma l3:"foldl (o) x xs = x o (foldl (o) id xs)" 22 | by (metis comp_id foldl_Cons l2) 23 | 24 | text \TODO: this could be generalized to multiplicative commutative monoids 25 | (functions with the composition operation are a multiplicative commutative monoid).\ 26 | 27 | section \Data types and traceability\ 28 | 29 | locale data_type = 30 | fixes f :: "'b \ 'a \ 'a" \ \the transition function of the data type\ 31 | and init :: "'a" 32 | begin 33 | 34 | definition exec \ \a state transformer corresponding to applying all operations in order\ 35 | where "exec ops \ foldl (o) id (map f ops)" \ \@{term "(o)"} is function composition \ 36 | 37 | lemma exec_Cons:"exec (x#xs) = (f x) o (exec xs)" 38 | using exec_def l3 by force 39 | 40 | lemma exec_Nil:"exec [] = id" 41 | by (simp add: exec_def) 42 | 43 | definition is_traceable \ \A state has a unique history from the initial state\ 44 | where "is_traceable \ \ ops\<^sub>1 ops\<^sub>2 . exec ops\<^sub>1 init = exec ops\<^sub>2 init \ ops\<^sub>1 = ops\<^sub>2" 45 | 46 | end 47 | 48 | locale traceable_data_type = data_type f init for f init + 49 | assumes traceable:"is_traceable" 50 | begin 51 | 52 | text \Prove some facts about traceable datatypes...\ 53 | 54 | end 55 | 56 | section \Append-only lists are traceable\ 57 | 58 | interpretation list_data_type: data_type "(#)" "[]" . 59 | 60 | lemma l4:"list_data_type.exec xs [] = xs" 61 | proof (induct xs) 62 | case Nil 63 | then show ?case 64 | by (simp add: list_data_type.exec_Nil) 65 | next 66 | case (Cons a xs) 67 | then show ?case 68 | by (simp add: data_type.exec_Cons) 69 | qed 70 | 71 | interpretation list_traceable:traceable_data_type "(#)" "[]" 72 | using l4 list_data_type.is_traceable_def traceable_data_type_def by fastforce 73 | 74 | text \Now the facts proved about traceable datatypes are available for append-only lists.\ 75 | 76 | end -------------------------------------------------------------------------------- /proof/Transaction.thy: -------------------------------------------------------------------------------- 1 | theory Transaction 2 | imports 3 | Main 4 | "./Object" 5 | begin 6 | 7 | section \Transactions\ 8 | 9 | text \A transaction is a list of object operations followed by (possibly) a commit or abort 10 | operation. In the Adya formalism, a transaction ends in a commit or abort operation; we also 11 | need to allow for observed operations where the operation outcome is unknown. To simplify our 12 | types, we model the committed state as a separate field.\ 13 | 14 | (* I literally can't figure out how to write a class that returns classes, so we're gonna 15 | do this with explicit abstract and observed functions for everything. *) 16 | 17 | (* TODO: add an ID for transactions so you can execute the same ops more than once *) 18 | 19 | datatype atxn = ATxn "aop list" "bool" 20 | datatype otxn = OTxn "oop list" "bool option" 21 | 22 | text \Some basic accessors.\ 23 | 24 | primrec a_ops :: "atxn \ aop list" where 25 | "a_ops (ATxn ops _) = ops" 26 | 27 | primrec o_ops :: "otxn \ oop list" where 28 | "o_ops (OTxn ops _) = ops" 29 | 30 | primrec a_is_committed :: "atxn \ bool" where 31 | "a_is_committed (ATxn _ committed) = committed" 32 | 33 | primrec o_is_committed :: "otxn \ bool option" where 34 | "o_is_committed (OTxn _ committed) = committed" 35 | 36 | primrec o_definitely_committed :: "otxn \ bool" where 37 | "o_definitely_committed (OTxn _ c) = ((Some True) = c)" 38 | 39 | primrec o_definitely_aborted :: "otxn \ bool" where 40 | "o_definitely_aborted (OTxn _ c) = ((Some False = c))" 41 | 42 | instantiation atxn :: all_versions 43 | begin 44 | primrec all_versions_atxn :: "atxn \ version set" where 45 | "all_versions_atxn (ATxn ops _) = \{(all_versions op) | op. op \ (set ops)}" 46 | instance .. 47 | end 48 | 49 | instantiation otxn :: all_versions 50 | begin 51 | primrec all_versions_otxn :: "otxn \ version set" where 52 | "all_versions_otxn (OTxn ops _) = \{all_versions op | op. op \ (set ops)}" 53 | instance .. 54 | end 55 | 56 | instantiation atxn :: all_aops 57 | begin 58 | primrec all_aops_atxn :: "atxn \ aop set" where 59 | "all_aops_atxn (ATxn ops _) = set ops" 60 | instance .. 61 | end 62 | 63 | instantiation otxn :: all_oops 64 | begin 65 | primrec all_oops_otxn :: "otxn \ oop set" where 66 | "all_oops_otxn (OTxn ops _) = set ops" 67 | instance .. 68 | end 69 | 70 | text \We define the external abstract writes of a transaction as the writes w such that no other 71 | write to the same key as w followed w in that transaction. We start with functions to extract 72 | the first and last objects by key from a list...\ 73 | 74 | primrec first_per_keys :: "'a::keyed list \ (key,'a) map" where 75 | "first_per_keys [] = Map.empty" | 76 | "first_per_keys (x # xs) = ((first_per_keys xs)((key x):=(Some x)))" 77 | 78 | primrec ext_awrites :: "atxn \ aop set" where 79 | "ext_awrites (ATxn ops _) = (ran (first_per_keys (rev ops)))" 80 | 81 | primrec ext_areads :: "atxn \ aop set" where 82 | "ext_areads (ATxn ops _) = (ran (first_per_keys ops))" 83 | 84 | text \A brief test...\ 85 | 86 | lemma "(let wx1 = (AWrite 1 [0] 1 [1] []); 87 | wx2 = (AWrite 1 [1] 2 [2] []); 88 | wy3 = (AWrite 2 [0] 0 [3] []) in 89 | {wx1,wy3} = (ext_awrites (ATxn [wx1,wy3,wx1] c)))" 90 | apply (simp add: ext_awrites_def ran_def) 91 | by (smt Collect_cong Suc_inject insert_compr numeral_1_eq_Suc_0 numeral_2_eq_2 numeral_One 92 | singleton_iff zero_neq_one) 93 | 94 | 95 | 96 | text \A well-formed transaction...\ 97 | 98 | primrec wf_atxn :: "atxn \ bool" where 99 | "wf_atxn (ATxn ops committed) = True" 100 | 101 | text \For observed transactions, we require that when committed, they definitely have a return 102 | value.\ 103 | 104 | primrec wf_otxn :: "otxn \ bool" where 105 | "wf_otxn (OTxn ops committed) = (if ((Some True) = committed) then 106 | (\op. (op \ set ops) \ ((ret op) \ None)) 107 | else True)" 108 | 109 | text \We define compatibility in terms of operation and committed state compatibility\ 110 | 111 | fun is_compatible_op_list :: "oop list \ aop list \ bool" where 112 | "is_compatible_op_list [] [] = True" | 113 | "is_compatible_op_list (a # as) [] = False" | 114 | "is_compatible_op_list [] (oo # os) = False" | 115 | "is_compatible_op_list (aop # aops') (oop # oops') = 116 | ((is_compatible_op aop oop) \ (is_compatible_op_list aops' oops'))" 117 | 118 | lemma is_compatible_op_list_size: "(is_compatible_op_list l1 l2) \ ((length l1) = (length l2))" 119 | oops 120 | 121 | (* My kingdom for indicating shadowing in binding exprs: every short name in Isabelle is taken *) 122 | definition is_compatible_txn :: "otxn \ atxn \ bool" where 123 | "is_compatible_txn otx atx \ ((is_compatible_op_list (o_ops otx) (a_ops atx)) \ 124 | (is_compatible_option (o_is_committed otx) (a_is_committed atx)))" 125 | 126 | 127 | text \Some lemmata around compatibility\ 128 | 129 | lemma is_compatible_txn_op_count: "is_compatible_txn otxn atxn \ 130 | ((size (o_ops otxn)) = (size (a_ops atxn)))" 131 | oops 132 | 133 | 134 | end -------------------------------------------------------------------------------- /proof/VersionOrder.thy: -------------------------------------------------------------------------------- 1 | theory VersionOrder 2 | imports Main Op FinMap 3 | begin 4 | 5 | section \Orders\ 6 | 7 | text \For our purposes, we're interested in total orders. Our orders aren't exactly total orders, 8 | because they might contain a single element, like the initial sets. They're mathematically "chains", 9 | but we encode them here as lists of distinct elements.\ 10 | 11 | text \In order to be an order, we need a list to be distinct.\ 12 | 13 | definition wf_order :: "('a list) \ bool" where 14 | "wf_order ord \ (distinct ord)" 15 | 16 | text \We're going to be asking frequently for a pair of successive versions in some order.\ 17 | primrec is_next :: "('a list) \ 'a \ 'a \ bool" where 18 | "is_next [] a b = False" | 19 | "is_next (x # xs) a b = (case xs of 20 | [] \ False | 21 | (y # ys) \ ((a = x \ b = y) \ (is_next xs a b)))" 22 | 23 | text \We say that order a is compatible with b iff a's elements occur in b, in the same order.\ 24 | fun is_compatible_order :: "('a list) \ ('a list) \ bool" where 25 | "is_compatible_order [] [] = True" | 26 | "is_compatible_order (x # xs) [] = False" | 27 | "is_compatible_order [] (y # ys) = True" | 28 | "is_compatible_order (x # xs) (y # ys) = 29 | (if x = y then (is_compatible_order xs ys) 30 | else (is_compatible_order (x # xs) ys))" 31 | 32 | 33 | section \Version Orders\ 34 | 35 | text \A key version order is a key associated with an order of distinct versions. 36 | It captures the notion that some key's value went through a particular series of versions 37 | over time.\ 38 | 39 | datatype keyVersionOrder = KeyVersionOrder "key" "version list" 40 | 41 | instantiation keyVersionOrder :: keyed 42 | begin 43 | primrec key_keyVersionOrder :: "keyVersionOrder \ key" where 44 | "key_keyVersionOrder (KeyVersionOrder k vl) = k" 45 | instance .. 46 | end 47 | 48 | text \Is v1 right before v2 in this version order?\ 49 | 50 | primrec is_next_in_key_version_order :: "keyVersionOrder \ version \ version \ bool" where 51 | "is_next_in_key_version_order (KeyVersionOrder k vl) v1 v2 = (is_next vl v1 v2)" 52 | 53 | text \A version order is a set of key version orders with unique keys.\ 54 | 55 | type_synonym "versionOrder" = "keyVersionOrder set" 56 | 57 | text \We define basic accessors for these too.\ 58 | 59 | definition version_order_keys :: "versionOrder \ key set" where 60 | "version_order_keys vo \ {k. (\vl. (KeyVersionOrder k vl) \ vo)}" 61 | 62 | definition version_order_version_lists :: "versionOrder \ version list set" where 63 | "version_order_version_lists vo \ {vl. (\k. (KeyVersionOrder k vl) \ vo)}" 64 | 65 | text \We'll often want to assert that given a set of objects, they're uniquely identified by 66 | some function f.\ 67 | 68 | definition unique_by :: "('a \ 'b) \ 'a set \ bool" where 69 | "unique_by f s \ (\el. (el \ s) \ (\!x. x = (f el)))" 70 | 71 | text \We enforce uniqueness and well-formed orders.\ 72 | 73 | definition wf_version_order :: "versionOrder \ bool" where 74 | "wf_version_order vo = ((unique_by key vo) \ 75 | (\vl. (vl \ (version_order_version_lists vo)) \ wf_order vl))" 76 | 77 | end -------------------------------------------------------------------------------- /proof/graphs/Bidirected_Digraph.thy: -------------------------------------------------------------------------------- 1 | theory Bidirected_Digraph 2 | imports 3 | Digraph 4 | "HOL-Library.Permutations" 5 | begin 6 | 7 | section \Bidirected Graphs\ 8 | 9 | locale bidirected_digraph = wf_digraph G for G + 10 | fixes arev :: "'b \ 'b" 11 | assumes arev_dom: "\a. a \ arcs G \ arev a \ a" 12 | assumes arev_arev_raw: "\a. a \ arcs G \ arev (arev a) = a" 13 | assumes tail_arev[simp]: "\a. a \ arcs G \ tail G (arev a) = head G a" 14 | 15 | lemma (in wf_digraph) bidirected_digraphI: 16 | assumes arev_eq: "\a. a \ arcs G \ arev a = a" 17 | assumes arev_neq: "\a. a \ arcs G \ arev a \ a" 18 | assumes arev_arev_raw: "\a. a \ arcs G \ arev (arev a) = a" 19 | assumes tail_arev: "\a. a \ arcs G \ tail G (arev a) = head G a" 20 | shows "bidirected_digraph G arev" 21 | using assms by unfold_locales (auto simp: permutes_def) 22 | 23 | context bidirected_digraph begin 24 | 25 | lemma bidirected_digraph[intro!]: "bidirected_digraph G arev" 26 | by unfold_locales 27 | 28 | lemma arev_arev[simp]: "arev (arev a) = a" 29 | using arev_dom by (cases "a \ arcs G") (auto simp: arev_arev_raw) 30 | 31 | lemma arev_o_arev[simp]: "arev o arev = id" 32 | by (simp add: fun_eq_iff) 33 | 34 | lemma arev_eq: "a \ arcs G \ arev a = a" 35 | by (simp add: arev_dom) 36 | 37 | lemma arev_neq: "a \ arcs G \ arev a \ a" 38 | by (simp add: arev_dom) 39 | 40 | lemma arev_in_arcs[simp]: "a \ arcs G \ arev a \ arcs G" 41 | by (metis arev_arev arev_dom) 42 | 43 | lemma head_arev[simp]: 44 | assumes "a \ arcs G" shows "head G (arev a) = tail G a" 45 | proof - 46 | from assms have "head G (arev a) = tail G (arev (arev a)) " 47 | by (simp only: tail_arev arev_in_arcs) 48 | then show ?thesis by simp 49 | qed 50 | 51 | lemma ate_arev[simp]: 52 | assumes "a \ arcs G" shows "arc_to_ends G (arev a) = prod.swap (arc_to_ends G a)" 53 | using assms by (auto simp: arc_to_ends_def) 54 | 55 | lemma bij_arev: "bij arev" 56 | using arev_arev by (metis bij_betw_imageI inj_on_inverseI surjI) 57 | 58 | lemma arev_permutes_arcs: "arev permutes arcs G" 59 | using arev_dom bij_arev by (auto simp: permutes_def bij_iff) 60 | 61 | lemma arev_eq_iff: "\x y. arev x = arev y \ x = y" 62 | by (metis arev_arev) 63 | 64 | lemma in_arcs_eq: "in_arcs G w = arev ` out_arcs G w" 65 | by auto (metis arev_arev arev_in_arcs image_eqI in_out_arcs_conv tail_arev) 66 | 67 | lemma inj_on_arev[intro!]: "inj_on arev S" 68 | by (metis arev_arev inj_on_inverseI) 69 | 70 | lemma even_card_loops: 71 | "even (card (in_arcs G w \ out_arcs G w))" (is "even (card ?S)") 72 | proof - 73 | { assume "\finite ?S" 74 | then have ?thesis by simp 75 | } 76 | moreover 77 | { assume A:"finite ?S" 78 | have "card ?S = card (\{{a,arev a} | a. a \ ?S})" (is "_ = card (\ ?T)") 79 | by (rule arg_cong[where f=card]) (auto intro!: exI[where x="{x, arev x}" for x]) 80 | also have "\= sum card ?T" 81 | proof (rule card_Union_disjoint) 82 | show "\A. A\{{a, arev a} |a. a \ ?S} \ finite A" by auto 83 | show "pairwise disjnt {{a, arev a} |a. a \ in_arcs G w \ out_arcs G w}" 84 | unfolding pairwise_def disjnt_def 85 | by safe (simp_all add: arev_eq_iff) 86 | qed 87 | also have "\ = sum (\a. 2) ?T" 88 | by (intro sum.cong) (auto simp: card_insert_if dest: arev_neq) 89 | also have "\ = 2 * card ?T" by simp 90 | finally have ?thesis by simp 91 | } 92 | ultimately 93 | show ?thesis by blast 94 | qed 95 | 96 | end 97 | 98 | (*XXX*) 99 | sublocale bidirected_digraph \ sym_digraph 100 | proof (unfold_locales, unfold symmetric_def, intro symI) 101 | fix u v assume "u \\<^bsub>G\<^esub> v" 102 | then obtain a where "a \ arcs G" "arc_to_ends G a = (u,v)" by (auto simp: arcs_ends_def) 103 | then have "arev a \ arcs G" "arc_to_ends G (arev a) = (v,u)" 104 | by (auto simp: arc_to_ends_def) 105 | then show "v \\<^bsub>G\<^esub> u" by (auto simp: arcs_ends_def intro: rev_image_eqI) 106 | qed 107 | 108 | 109 | 110 | end 111 | -------------------------------------------------------------------------------- /proof/graphs/Digraph_Component_Vwalk.thy: -------------------------------------------------------------------------------- 1 | (* Title: Digraph_Component_Vwalk.thy 2 | Author: Lars Noschinski, TU München 3 | *) 4 | 5 | theory Digraph_Component_Vwalk 6 | imports 7 | Digraph_Component 8 | Vertex_Walk 9 | begin 10 | 11 | section \Lemmas for Vertex Walks\ 12 | 13 | lemma vwalkI_subgraph: 14 | assumes "vwalk p H" 15 | assumes "subgraph H G" 16 | shows "vwalk p G" 17 | proof 18 | show "set p \ verts G" and "p \ []" 19 | using assms by (auto simp add: subgraph_def vwalk_def) 20 | 21 | have "set (vwalk_arcs p) \ arcs_ends H" 22 | using assms by (simp add: vwalk_def) 23 | also have "\ \ arcs_ends G" 24 | using \subgraph H G\ by (rule arcs_ends_mono) 25 | finally show "set (vwalk_arcs p) \ arcs_ends G" . 26 | qed 27 | 28 | lemma vpathI_subgraph: 29 | assumes "vpath p G" 30 | assumes "subgraph G H" 31 | shows "vpath p H" 32 | using assms by (auto intro: vwalkI_subgraph) 33 | 34 | lemma (in loopfree_digraph) vpathI_arc: 35 | assumes "(a,b) \ arcs_ends G" 36 | shows "vpath [a,b] G" 37 | using assms 38 | by (intro vpathI vwalkI) (auto intro: adj_in_verts adj_not_same) 39 | 40 | end 41 | -------------------------------------------------------------------------------- /proof/graphs/Graph_Theory.thy: -------------------------------------------------------------------------------- 1 | (* Title: Graph_Theory.thy 2 | Author: Lars Noschinski, TU München 3 | *) 4 | 5 | theory Graph_Theory 6 | imports 7 | Digraph 8 | Bidirected_Digraph 9 | Arc_Walk 10 | 11 | Digraph_Component 12 | Digraph_Component_Vwalk 13 | Digraph_Isomorphism 14 | Pair_Digraph 15 | Vertex_Walk 16 | Subdivision 17 | 18 | Euler 19 | Kuratowski 20 | Shortest_Path 21 | 22 | begin 23 | 24 | end 25 | -------------------------------------------------------------------------------- /proof/graphs/ROOT: -------------------------------------------------------------------------------- 1 | chapter AFP 2 | 3 | session "Graph_Theory" (AFP) = "HOL-Library" + 4 | options [timeout = 600] 5 | theories 6 | Graph_Theory 7 | document_files 8 | "root.tex" 9 | "root.bib" 10 | -------------------------------------------------------------------------------- /proof/graphs/Rtrancl_On.thy: -------------------------------------------------------------------------------- 1 | (* Title: Rtrancl_On.thy 2 | Author: Lars Noschinski, TU München 3 | Author: René Neumann, TU München 4 | *) 5 | 6 | theory Rtrancl_On 7 | imports Main 8 | begin 9 | 10 | section \Reflexive-Transitive Closure on a Domain\ 11 | 12 | text \ 13 | In this section we introduce a variant of the reflexive-transitive closure 14 | of a relation which is useful to formalize the reachability relation on 15 | digraphs. 16 | \ 17 | 18 | inductive_set 19 | rtrancl_on :: "'a set \ 'a rel \ 'a rel" 20 | for F :: "'a set" and r :: "'a rel" 21 | where 22 | rtrancl_on_refl [intro!, Pure.intro!, simp]: "a \ F \ (a, a) \ rtrancl_on F r" 23 | | rtrancl_on_into_rtrancl_on [Pure.intro]: 24 | "(a, b) \ rtrancl_on F r \ (b, c) \ r \ c \ F 25 | \ (a, c) \ rtrancl_on F r" 26 | 27 | definition symcl :: "'a rel \ 'a rel" ("(_\<^sup>s)" [1000] 999) where 28 | "symcl R = R \ (\(a,b). (b,a)) ` R" 29 | 30 | lemma in_rtrancl_on_in_F: 31 | assumes "(a,b) \ rtrancl_on F r" shows "a \ F" "b \ F" 32 | using assms by induct auto 33 | 34 | lemma rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]: 35 | assumes "(a, b) \ rtrancl_on F r" 36 | and "a \ F \ P a" 37 | "\y z. \(a, y) \ rtrancl_on F r; (y,z) \ r; y \ F; z \ F; P y\ \ P z" 38 | shows "P b" 39 | using assms by (induct a b) (auto dest: in_rtrancl_on_in_F) 40 | 41 | lemma rtrancl_on_trans: 42 | assumes "(a,b) \ rtrancl_on F r" "(b,c) \ rtrancl_on F r" shows "(a,c) \ rtrancl_on F r" 43 | using assms(2,1) 44 | by induct (auto intro: rtrancl_on_into_rtrancl_on) 45 | 46 | lemma converse_rtrancl_on_into_rtrancl_on: 47 | assumes "(a,b) \ r" "(b, c) \ rtrancl_on F r" "a \ F" 48 | shows "(a, c) \ rtrancl_on F r" 49 | proof - 50 | have "b \ F" using \(b,c) \ _\ by (rule in_rtrancl_on_in_F) 51 | show ?thesis 52 | apply (rule rtrancl_on_trans) 53 | apply (rule rtrancl_on_into_rtrancl_on) 54 | apply (rule rtrancl_on_refl) 55 | by fact+ 56 | qed 57 | 58 | lemma rtrancl_on_converseI: 59 | assumes "(y, x) \ rtrancl_on F r" shows "(x, y) \ rtrancl_on F (r\)" 60 | using assms 61 | proof induct 62 | case (step a b) 63 | then have "(b,b) \ rtrancl_on F (r\)" "(b,a) \ r\" by auto 64 | then show ?case using step 65 | by (metis rtrancl_on_trans rtrancl_on_into_rtrancl_on) 66 | qed auto 67 | 68 | theorem rtrancl_on_converseD: 69 | assumes "(y, x) \ rtrancl_on F (r\)" shows "(x, y) \ rtrancl_on F r" 70 | using assms by - (drule rtrancl_on_converseI, simp) 71 | 72 | lemma converse_rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]: 73 | assumes major: "(a, b) \ rtrancl_on F r" 74 | and cases: "b \ F \ P b" 75 | "\x y. \(x,y) \ r; (y,b) \ rtrancl_on F r; x \ F; y \ F; P y\ \ P x" 76 | shows "P a" 77 | using rtrancl_on_converseI[OF major] cases 78 | by induct (auto intro: rtrancl_on_converseD) 79 | 80 | lemma converse_rtrancl_on_cases: 81 | assumes "(a, b) \ rtrancl_on F r" 82 | obtains (base) "a = b" "b \ F" 83 | | (step) c where "(a,c) \ r" "(c,b) \ rtrancl_on F r" 84 | using assms by induct auto 85 | 86 | lemma rtrancl_on_sym: 87 | assumes "sym r" shows "sym (rtrancl_on F r)" 88 | using assms by (auto simp: sym_conv_converse_eq intro: symI dest: rtrancl_on_converseI) 89 | 90 | lemma rtrancl_on_mono: 91 | assumes "s \ r" "F \ G" "(a,b) \ rtrancl_on F s" shows "(a,b) \ rtrancl_on G r" 92 | using assms(3,1,2) 93 | proof induct 94 | case (step x y) show ?case 95 | using step assms by (intro converse_rtrancl_on_into_rtrancl_on[OF _ step(5)]) auto 96 | qed auto 97 | 98 | lemma rtrancl_consistent_rtrancl_on: 99 | assumes "(a,b) \ r\<^sup>*" 100 | and "a \ F" "b \ F" 101 | and consistent: "\a b. \ a \ F; (a,b) \ r \ \ b \ F" 102 | shows "(a,b) \ rtrancl_on F r" 103 | using assms(1-3) 104 | proof (induction rule: converse_rtrancl_induct) 105 | case (step y z) then have "z \ F" by (rule_tac consistent) simp 106 | with step have "(z,b) \ rtrancl_on F r" by simp 107 | with step.prems \(y,z) \ r\ \z \ F\ show ?case 108 | using converse_rtrancl_on_into_rtrancl_on 109 | by metis 110 | qed simp 111 | 112 | lemma rtrancl_on_rtranclI: 113 | "(a,b) \ rtrancl_on F r \ (a,b) \ r\<^sup>*" 114 | by (induct rule: rtrancl_on_induct) simp_all 115 | 116 | lemma rtrancl_on_sub_rtrancl: 117 | "rtrancl_on F r \ r^*" 118 | using rtrancl_on_rtranclI 119 | by auto 120 | 121 | 122 | 123 | end 124 | -------------------------------------------------------------------------------- /proof/graphs/Stuff.thy: -------------------------------------------------------------------------------- 1 | (* Title: Stuff.thy 2 | Author: Lars Noschinski, TU München 3 | *) 4 | 5 | theory Stuff 6 | imports 7 | Main 8 | "HOL-Library.Extended_Real" 9 | 10 | begin 11 | 12 | section \Additional theorems for base libraries\ 13 | 14 | text \ 15 | This section contains lemmas unrelated to graph theory which might be 16 | interesting for the Isabelle distribution 17 | \ 18 | 19 | lemma ereal_Inf_finite_Min: 20 | fixes S :: "ereal set" 21 | assumes "finite S" and "S \ {}" 22 | shows "Inf S = Min S" 23 | using assms 24 | by (induct S rule: finite_ne_induct) (auto simp: min_absorb1) 25 | 26 | lemma finite_INF_in: 27 | fixes f :: "'a \ ereal" 28 | assumes "finite S" 29 | assumes "S \ {}" 30 | shows "(INF s\ S. f s) \ f ` S" 31 | proof - 32 | from assms 33 | have "finite (f ` S)" "f ` S \ {}" by auto 34 | then show "Inf (f ` S) \ f ` S" 35 | using ereal_Inf_finite_Min [of "f ` S"] by simp 36 | qed 37 | 38 | lemma not_mem_less_INF: 39 | fixes f :: "'a \ 'b :: complete_lattice" 40 | assumes "f x < (INF s\ S. f s)" 41 | assumes "x \ S" 42 | shows "False" 43 | using assms by (metis INF_lower less_le_not_le) 44 | 45 | lemma sym_diff: 46 | assumes "sym A" "sym B" shows "sym (A - B)" 47 | using assms by (auto simp: sym_def) 48 | 49 | 50 | 51 | subsection \List\ 52 | 53 | lemmas list_exhaust2 = list.exhaust[case_product list.exhaust] 54 | 55 | lemma list_exhaust_NSC: 56 | obtains (Nil) "xs = []" | (Single) x where "xs = [x]" | (Cons_Cons) x y ys where "xs = x # y # ys" 57 | by (metis list.exhaust) 58 | 59 | lemma tl_rev: 60 | "tl (rev p) = rev (butlast p)" 61 | by (induct p) auto 62 | 63 | lemma butlast_rev: 64 | "butlast (rev p) = rev (tl p)" 65 | by (induct p) auto 66 | 67 | lemma take_drop_take: 68 | "take n xs @ drop n (take m xs) = take (max n m) xs" 69 | proof cases 70 | assume "m < n" then show ?thesis by (auto simp: max_def) 71 | next 72 | assume "\m < n" 73 | then have "take n xs = take n (take m xs)" by (auto simp: min_def) 74 | then show ?thesis by (simp del: take_take add: max_def) 75 | qed 76 | 77 | lemma drop_take_drop: 78 | "drop n (take m xs) @ drop m xs = drop (min n m) xs" 79 | proof cases 80 | assume A: "\m < n" 81 | then show ?thesis 82 | using drop_append[of n "take m xs" "drop m xs"] 83 | by (cases "length xs < n") (auto simp: not_less min_def) 84 | qed (auto simp: min_def) 85 | 86 | lemma not_distinct_decomp_min_prefix: 87 | assumes "\ distinct ws" 88 | shows "\ xs ys zs y. ws = xs @ y # ys @ y # zs \ distinct xs \ y \ set xs \ y \ set ys " 89 | proof - 90 | obtain xs y ys where "y \ set xs" "distinct xs" "ws = xs @ y # ys" 91 | using assms by (auto simp: not_distinct_conv_prefix) 92 | moreover then obtain xs' ys' where "xs = xs' @ y # ys'" by (auto simp: in_set_conv_decomp) 93 | ultimately show ?thesis by auto 94 | qed 95 | 96 | lemma not_distinct_decomp_min_not_distinct: 97 | assumes "\ distinct ws" 98 | shows "\xs y ys zs. ws = xs @ y # ys @ y # zs \ distinct (ys @ [y])" 99 | using assms 100 | proof (induct ws) 101 | case (Cons w ws) 102 | show ?case 103 | proof (cases "distinct ws") 104 | case True 105 | then obtain xs ys where "ws = xs @ w # ys" "w \ set xs" 106 | using Cons.prems by (fastforce dest: split_list_first) 107 | then have "distinct (xs @ [w])" "w # ws = [] @ w # xs @ w # ys" 108 | using \distinct ws\ by auto 109 | then show ?thesis by blast 110 | next 111 | case False 112 | then obtain xs y ys zs where "ws = xs @ y # ys @ y # zs \ distinct (ys @ [y])" 113 | using Cons by auto 114 | then have "w # ws = (w # xs) @ y # ys @ y # zs \ distinct (ys @ [y])" 115 | by simp 116 | then show ?thesis by blast 117 | qed 118 | qed simp 119 | 120 | lemma card_Ex_subset: 121 | "k \ card M \ \N. N \ M \ card N = k" 122 | by (induct rule: inc_induct) (auto simp: card_Suc_eq) 123 | 124 | lemma list_set_tl: "x \ set (tl xs) \ x \ set xs" 125 | by (cases xs) auto 126 | 127 | 128 | section \NOMATCH simproc\ 129 | 130 | text \ 131 | The simplification procedure can be used to avoid simplification of terms of a certain form 132 | \ 133 | 134 | definition NOMATCH :: "'a \ 'a \ bool" where "NOMATCH val pat \ True" 135 | lemma NOMATCH_cong[cong]: "NOMATCH val pat = NOMATCH val pat" by (rule refl) 136 | 137 | simproc_setup NOMATCH ("NOMATCH val pat") = \fn _ => fn ctxt => fn ct => 138 | let 139 | val thy = Proof_Context.theory_of ctxt 140 | val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd) 141 | val m = Pattern.matches thy (dest_binop (Thm.term_of ct)) 142 | in if m then NONE else SOME @{thm NOMATCH_def} end 143 | \ 144 | 145 | text \ 146 | This setup ensures that a rewrite rule of the form @{term "NOMATCH val pat \ t"} 147 | is only applied, if the pattern @{term pat} does not match the value @{term val}. 148 | \ 149 | 150 | 151 | end 152 | -------------------------------------------------------------------------------- /proof/graphs/Weighted_Graph.thy: -------------------------------------------------------------------------------- 1 | (* Title: Weighted_Graph.thy 2 | Author: Lars Noschinski, TU München 3 | *) 4 | 5 | theory Weighted_Graph 6 | imports 7 | Digraph 8 | Arc_Walk 9 | Complex_Main 10 | begin 11 | 12 | section \Weighted Graphs\ 13 | 14 | type_synonym 'b weight_fun = "'b \ real" 15 | 16 | context wf_digraph begin 17 | 18 | definition awalk_cost :: "'b weight_fun \ 'b awalk \ real" where 19 | "awalk_cost f es = sum_list (map f es)" 20 | 21 | lemma awalk_cost_Nil[simp]: "awalk_cost f [] = 0" 22 | unfolding awalk_cost_def by simp 23 | 24 | lemma awalk_cost_Cons[simp]: "awalk_cost f (x # xs) = f x + awalk_cost f xs" 25 | unfolding awalk_cost_def by simp 26 | 27 | lemma awalk_cost_append[simp]: 28 | "awalk_cost f (xs @ ys) = awalk_cost f xs + awalk_cost f ys" 29 | unfolding awalk_cost_def by simp 30 | 31 | end 32 | 33 | end 34 | -------------------------------------------------------------------------------- /proof/graphs/document/root.bib: -------------------------------------------------------------------------------- 1 | @BOOK{bangjensen2009digraphs, 2 | title = {Digraphs: Theory, Algorithms and Applications}, 3 | publisher = {Springer}, 4 | year = {2009}, 5 | author = {Jørgen Bang-Jensen and Gregory Z. Gutin}, 6 | edition = {2}, 7 | } 8 | 9 | @INCOLLECTION{harary1974nullgraph, 10 | author = {Harary, Frank and Read, RonaldC.}, 11 | title = {Is the null-graph a pointless concept?}, 12 | booktitle = {Graphs and Combinatorics}, 13 | publisher = {Springer Berlin Heidelberg}, 14 | year = {1974}, 15 | editor = {Bari, RuthA. and Harary, Frank}, 16 | volume = {406}, 17 | series = {Lecture Notes in Mathematics}, 18 | pages = {37-44}, 19 | doi = {10.1007/BFb0066433}, 20 | isbn = {978-3-540-06854-9}, 21 | url = {https://doi.org/10.1007/BFb0066433} 22 | } 23 | -------------------------------------------------------------------------------- /proof/graphs/document/root.tex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt,a4paper]{article} 2 | \usepackage[english]{babel} 3 | \usepackage{amssymb} 4 | \usepackage{wasysym} 5 | \usepackage{isabelle,isabellesym} 6 | 7 | % this should be the last package used 8 | \usepackage{pdfsetup} 9 | 10 | % urls in roman style, theory text in math-similar italics 11 | \urlstyle{rm} 12 | \isabellestyle{it} 13 | 14 | 15 | \begin{document} 16 | 17 | \title{Graph Theory} 18 | \author{By Lars Noschinski} 19 | \maketitle 20 | 21 | \begin{abstract} 22 | This development provides a formalization of directed graphs, supporting 23 | (labelled) multi-edges and infinite graphs. A polymorphic edge type allows 24 | edges to be treated as pairs of vertices, if multi-edges are not required. 25 | Formalized properties are i.a. walks (and related concepts), connectedness and 26 | subgraphs and basic properties of isomorphisms. 27 | 28 | This formalization is used to prove characterizations of Euler Trails, Shortest 29 | Paths and Kuratowski subgraphs. 30 | 31 | Definitions and nomenclature are based on \cite{bangjensen2009digraphs}. 32 | \end{abstract} 33 | 34 | 35 | \tableofcontents 36 | 37 | % sane default for proof documents 38 | \parindent 0pt\parskip 0.5ex 39 | 40 | % generated text of all theories 41 | \input{session} 42 | 43 | % optional bibliography 44 | \bibliographystyle{abbrv} 45 | \bibliography{root} 46 | 47 | \end{document} 48 | 49 | %%% Local Variables: 50 | %%% mode: latex 51 | %%% TeX-master: t 52 | %%% End: 53 | -------------------------------------------------------------------------------- /src/elle/BFSPath.java: -------------------------------------------------------------------------------- 1 | package elle; 2 | 3 | import io.lacuna.bifurcan.IList; 4 | 5 | /* A specialized representation of a path taken during BFS search through a transaction graph. See elle.bfs. 6 | */ 7 | 8 | import io.lacuna.bifurcan.ISet; 9 | import io.lacuna.bifurcan.IntSet; 10 | import io.lacuna.bifurcan.LinearList; 11 | import io.lacuna.bifurcan.List; 12 | import io.lacuna.bifurcan.Set; 13 | 14 | import java.util.ArrayList; 15 | import java.util.Iterator; 16 | import java.util.NoSuchElementException; 17 | import java.util.function.BinaryOperator; 18 | 19 | import javax.swing.border.EmptyBorder; 20 | 21 | import clojure.lang.Keyword; 22 | import clojure.lang.PersistentHashSet; 23 | 24 | public class BFSPath { 25 | // Mode for RW edges. NONE means take RW edges iff legal. SINGLE means take 26 | // exactly one RW edge, then flip to NONE. NONADJACENT_FREE and 27 | // NONADJACENT_TAKEN flip back and forth to find G-nonadjacent. 28 | public enum RWMode { 29 | NONE, SINGLE, NONADJACENT_FREE, NONADJACENT_TAKEN 30 | } 31 | 32 | // Takes a set of up to four BitRels and packs it into an integer. 33 | public static int packRelsSet(final ISet relsSet) { 34 | assert relsSet.size() <= 4; 35 | int i = 0; 36 | int packed = 0; 37 | for (final BitRels rels : relsSet) { 38 | packed = packed | (Byte.toUnsignedInt(rels.rels) << i); 39 | i += 8; 40 | } 41 | return packed; 42 | } 43 | 44 | // Unpacks a set of BitRels from an integer. 45 | public static ISet unpackRelsSet(final int relsSet) { 46 | ISet set = Set.EMPTY; 47 | BitRels rels; 48 | for (byte i = 0; i < 32; i += 8) { 49 | rels = new BitRels((byte) (relsSet >>> i)); 50 | if (! rels.isEmpty()) { 51 | set = set.add(rels); 52 | } 53 | } 54 | return set; 55 | } 56 | 57 | // Takes a packed set of BitRels and collapses it into a single mask which will intersect with any BitRels that intersects with any element of the set 58 | public static byte packedSetToMask(int rels) { 59 | // We shift rels over one byte at a time, unioning with itself. 60 | for (byte i = 0; i < 32; i += 8) { 61 | rels = rels | rels >>> i; 62 | } 63 | // This means the lower byte is now the mask we want. 64 | return (byte) rels; 65 | } 66 | 67 | // Takes a set of (up to) four wanted BitRels packed into an int, and a BitRels rel we're taking. Returns the wanted set with up to one of the four BitRels zeroed out iff the given rel intersects with it. 68 | public static int checkOffRelInPackedSet(final int rels, final byte rel) { 69 | // Loop through bytes 70 | int mask; 71 | byte thisRel; 72 | for (byte i = 0; i < 32; i += 8) { 73 | mask = 0xFF << i; 74 | thisRel = (byte) ((rels & mask) >>> i); 75 | if (0 != BitRels.rawIntersection(thisRel, rel)) { 76 | // Our rel intersects this rel. Zero it out. 77 | return rels & (~mask); 78 | } 79 | } 80 | return rels; 81 | } 82 | 83 | // BitRels representation of the edges we can normally take 84 | public final byte legal; 85 | // Up to four BitRels packed into an int, representing the rels we still want to take. This number needs to be zero for a path to be valid. We can zero out any single bitrels set in this structure by taking a rel that intersects that set. 86 | public final int want; 87 | // Number of RW edges we're waiting to take: 0, 1, or 2 88 | public final byte wantRW; 89 | // What kind of RW traversal we're doing 90 | public final RWMode rwMode; 91 | // What's the index of the last op we visited? 92 | public final long lastIndex; 93 | // The set of indices we've visited 94 | public final IntSet indexSet; 95 | // The list of ops we visited, in order 96 | public final IList ops; 97 | 98 | public BFSPath(final byte legal, final int want, final byte wantRW, final RWMode rwMode, final long lastIndex, 99 | final IntSet indexSet, final IList ops) { 100 | this.legal = legal; 101 | this.want = want; 102 | this.wantRW = wantRW; 103 | this.rwMode = rwMode; 104 | this.lastIndex = lastIndex; 105 | this.indexSet = indexSet; 106 | this.ops = ops; 107 | } 108 | 109 | public BFSPath(final byte legal, final ISet want, final byte wantRW, final RWMode rwMode) { 110 | this(legal, packRelsSet(want), wantRW, rwMode, -1L, new IntSet(), (IList) List.EMPTY); 111 | assert rwMode != null; 112 | } 113 | 114 | // A path is valid when the wanted edge bitset is 0, we want no more rws, 115 | // and our nonadjacent mode is not nonadjacent-taken (since we always start 116 | // with an rw edge for nonadjacent paths) 117 | public boolean isValid() { 118 | return ((0 == want) && 119 | (0 == wantRW) && 120 | (!(rwMode == RWMode.NONADJACENT_TAKEN))); 121 | } 122 | 123 | // A path forms a loop when its last index has been visited before. 124 | public boolean isLoop() { 125 | return indexSet.contains(lastIndex); 126 | } 127 | 128 | // Starts a path off on a single op. We take index and op separately to avoid 129 | // having to refer to the Op class. 130 | public BFSPath start(final long index, final Object op) { 131 | return new BFSPath(legal, want, wantRW, rwMode, index, indexSet, ops.addLast(op)); 132 | } 133 | 134 | // Takes a single step between to the given op using the given singleton rel. 135 | private BFSPath stepRel(final byte rel, final long index, final Object op) { 136 | // System.out.println("StepRel " + new BitRels(rel) + " legal " + new BitRels(legal) + " RW mode " + rwMode); 137 | // assert (new BitRels(rel).isSingleton()); 138 | final boolean isRw = BitRels.rawIsAnyRW(rel); 139 | // We can simply take this rel; it's legal 140 | if (0 != BitRels.rawIntersection(rel, legal)) { 141 | // System.out.println("Legal step"); 142 | // Keep track of how many RWs we want 143 | final byte wantRW; 144 | if (isRw) { 145 | if (0 == this.wantRW) { 146 | wantRW = 0; 147 | } else { 148 | wantRW = (byte) (this.wantRW - 1); 149 | } 150 | } else { 151 | wantRW = this.wantRW; 152 | } 153 | // The only case where RW is legal is if RWMode is nil. Any of these implies we 154 | // did not take an RW edge. 155 | RWMode rwMode = RWMode.NONE; 156 | switch (this.rwMode) { 157 | case NONE: 158 | rwMode = RWMode.NONE; 159 | break; 160 | case SINGLE: 161 | rwMode = RWMode.SINGLE; 162 | break; 163 | case NONADJACENT_FREE: 164 | rwMode = RWMode.NONADJACENT_FREE; 165 | break; 166 | case NONADJACENT_TAKEN: 167 | rwMode = RWMode.NONADJACENT_FREE; 168 | break; 169 | } 170 | return new BFSPath(legal, checkOffRelInPackedSet(want, rel), wantRW, rwMode, index, indexSet.add(lastIndex), 171 | ops.addLast(op)); 172 | } else if (isRw) { 173 | // System.out.println("RW step"); 174 | // So the rel wasn't normally legal, but RWs are special 175 | switch (this.rwMode) { 176 | // No more RWs possible 177 | case NONE: 178 | return null; 179 | // We can do exactly one RW 180 | case SINGLE: 181 | return new BFSPath(legal, checkOffRelInPackedSet(want, rel), (byte) 0, RWMode.NONE, index, 182 | indexSet.add(lastIndex), 183 | ops.addLast(op)); 184 | // We can take a nonadjacent RW 185 | case NONADJACENT_FREE: 186 | final byte wantRW; 187 | if (0 == this.wantRW) { 188 | wantRW = 0; 189 | } else { 190 | wantRW = (byte) (this.wantRW - 1); 191 | } 192 | return new BFSPath(legal, checkOffRelInPackedSet(want, rel), wantRW, RWMode.NONADJACENT_TAKEN, index, 193 | indexSet.add(lastIndex), ops.addLast(op)); 194 | // Can't take two RWs in a row (unless legal) 195 | case NONADJACENT_TAKEN: 196 | return null; 197 | } 198 | } 199 | return null; 200 | } 201 | 202 | // Extends a path to an adjacent op along the given set of rels, returning a 203 | // list of paths. 204 | public IList step(final BitRels edge, final long index, final Object op) { 205 | final byte rels = edge.rels; 206 | // There are basically three classes of rel we can take here. One is an RW, 207 | // which is special. Another is wanted edges. A third is the legal edges. Legal 208 | // edges are degenerate--they don't result in any difference as far as path 209 | // state goes, so we need only take one of them. We compute masks for these 210 | // three different classes of rels. 211 | // 212 | // First, is an RW of interest? 213 | final byte rwMask; 214 | // If we want RWs, or have a single or free RW Mode, then we can take an RW. 215 | if ((0 < wantRW) || (rwMode == RWMode.SINGLE) || (rwMode == RWMode.NONADJACENT_FREE)) { 216 | rwMask = BitRels.ANY_RW.rels; 217 | } else { 218 | rwMask = BitRels.NONE.rels; 219 | } 220 | 221 | // Now, what rels do we want to take eventually? 222 | final byte wantMask = BitRels.rawDifference(packedSetToMask(want), rwMask); 223 | 224 | // And what rels are otherwise legal? 225 | final byte legalMask = BitRels.rawDifference(BitRels.rawDifference(legal, rwMask), wantMask); 226 | 227 | // Our output paths 228 | IList paths = new LinearList(); 229 | BFSPath path; 230 | int i; 231 | byte rel; 232 | 233 | // With our masks prepared, we can start taking steps. First, RW. 234 | final byte rwRels = BitRels.rawIntersection(rels, rwMask); 235 | if (0 != rwRels) { 236 | // System.out.println("Considering RW rels"); 237 | for (i = 0; i < BitRels.ALL.length; i++) { 238 | rel = BitRels.rawIntersection(rwRels, (byte) (1 << i)); 239 | if (0 != rel) { 240 | path = stepRel(rel, index, op); 241 | if (path != null) { 242 | paths = paths.addLast(path); 243 | } 244 | } 245 | } 246 | } 247 | 248 | // Performance optimization: if we want an RW, that's *all* we're willing to 249 | // take for the first step. We're done here. 250 | if (0 < wantRW && 1 == ops.size()) { 251 | return paths; 252 | } 253 | 254 | // What about a wanted rel? 255 | final byte wantRels = BitRels.rawIntersection(rels, wantMask); 256 | if (0 != wantRels) { 257 | // System.out.println("Considering want rels"); 258 | for (i = 0; i < BitRels.ALL.length; i++) { 259 | rel = BitRels.rawIntersection(wantRels, (byte) (1 << i)); 260 | if (0 != rel) { 261 | path = stepRel(rel, index, op); 262 | if (null != path) { 263 | paths = paths.addLast(path); 264 | } 265 | } 266 | } 267 | } 268 | 269 | // Performance optimization, part II: on our first step, we only care about 270 | // taking RW or wanted rels. 271 | if (0 != want && 1 == ops.size()) { 272 | return paths; 273 | } 274 | 275 | // Finally, we can take legal rels. It doesn't matter which. 276 | final byte legalRels = BitRels.rawIntersection(rels, legalMask); 277 | if (0 != legalRels) { 278 | // System.out.println("Considering legal rels"); 279 | for (i = 0; i < BitRels.ALL.length; i++) { 280 | rel = BitRels.rawIntersection(legalRels, (byte) (1 << i)); 281 | if (0 != rel) { 282 | path = stepRel(rel, index, op); 283 | if (null != path) { 284 | paths = paths.addLast(path); 285 | // No point in trying any other rels here; they'd all give equivalent paths. 286 | return paths; 287 | } 288 | } 289 | } 290 | } 291 | return paths; 292 | } 293 | 294 | public boolean equals(Object other) { 295 | if (other instanceof BFSPath) { 296 | final BFSPath o = (BFSPath) other; 297 | if (legal == o.legal 298 | && want == o.want 299 | && wantRW == o.wantRW 300 | && rwMode == o.rwMode 301 | && lastIndex == o.lastIndex 302 | && indexSet == o.indexSet 303 | && ops == o.ops) { 304 | return true; 305 | } 306 | } 307 | return false; 308 | } 309 | 310 | public String toString() { 311 | return "(Path :legal " + new BitRels(legal) 312 | + " :want " + unpackRelsSet(want) 313 | + " :want-rw " + wantRW 314 | + " :rw-mode " + rwMode 315 | + " :last-index " + lastIndex 316 | + " :indexes " + indexSet 317 | + " :ops " + ops; 318 | } 319 | } -------------------------------------------------------------------------------- /src/elle/BitRels.java: -------------------------------------------------------------------------------- 1 | package elle; 2 | 3 | /* A bitmask-backed set of relationships like {ww, rw}. */ 4 | 5 | import io.lacuna.bifurcan.ISet; 6 | import io.lacuna.bifurcan.Set; 7 | 8 | import java.util.ArrayList; 9 | import java.util.Iterator; 10 | import java.util.NoSuchElementException; 11 | import java.util.function.BinaryOperator; 12 | 13 | import clojure.lang.Keyword; 14 | import clojure.lang.PersistentHashSet; 15 | 16 | public class BitRels implements Iterable { 17 | public static BitRels NONE = new BitRels((byte) 0x00); 18 | public static BitRels WW = new BitRels((byte) 0x01); 19 | public static BitRels WR = new BitRels((byte) 0x02); 20 | public static BitRels RW = new BitRels((byte) 0x04); 21 | public static BitRels WWP = new BitRels((byte) 0x08); 22 | public static BitRels WRP = new BitRels((byte) 0x10); 23 | public static BitRels RWP = new BitRels((byte) 0x20); 24 | public static BitRels PROCESS = new BitRels((byte) 0x40); 25 | public static BitRels REALTIME = new BitRels((byte) 0x80); 26 | 27 | public static BitRels ANY_RW = RW.union(RWP); 28 | 29 | // IMPORTANT: the ALL array is in exactly the order of ascending set bits. 30 | public static BitRels[] ALL = { WW, WR, RW, WWP, WRP, RWP, PROCESS, REALTIME }; 31 | // IMPORTANT: These arrays are all in the same order 32 | public static String[] NAMES = { "ww", "wr", "rw", "wwp", "wrp", "rwp", "process", "realtime" }; 33 | public static Keyword[] KEYWORDS = { 34 | Keyword.intern("ww"), 35 | Keyword.intern("wr"), 36 | Keyword.intern("rw"), 37 | Keyword.intern("wwp"), 38 | Keyword.intern("wrp"), 39 | Keyword.intern("rwp"), 40 | Keyword.intern("process"), 41 | Keyword.intern("realtime") 42 | }; 43 | 44 | public static BinaryOperator UNION = (a, b) -> a.union(b); 45 | 46 | public final byte rels; 47 | 48 | /* Performs set union on raw byte representations */ 49 | public static byte rawUnion(byte a, byte b) { 50 | return (byte) (a | b); 51 | } 52 | 53 | /* Set difference on raw byte representation */ 54 | public static byte rawDifference(byte a, byte b) { 55 | return (byte) (a & ~b); 56 | } 57 | 58 | /* Set intersection on raw byte representation */ 59 | public static byte rawIntersection(byte a, byte b) { 60 | return (byte) (a & b); 61 | } 62 | 63 | /* Is the given raw byte representation any kind of RW? */ 64 | public static boolean rawIsAnyRW(final byte rel) { 65 | return (0 != rawIntersection(rel, ANY_RW.rels)); 66 | } 67 | 68 | public BitRels(final byte rels) { 69 | this.rels = rels; 70 | } 71 | 72 | // Is this an empty set? 73 | public boolean isEmpty() { 74 | return rels == 0x00; 75 | } 76 | 77 | // Is this a singleton set? 78 | public boolean isSingleton() { 79 | return (Integer.bitCount(rels) == 1); 80 | } 81 | 82 | // Is this purely a predicate edge, or are there other edges? 83 | public boolean isPredicate() { 84 | return !(intersection(WWP.union(WRP).union(RWP)).isEmpty()); 85 | } 86 | 87 | // Is this an RW edge, either a single or predicate? 88 | public boolean isAnyRW() { 89 | return !(intersection(ANY_RW).isEmpty()); 90 | } 91 | 92 | public BitRels intersection(final BitRels other) { 93 | return new BitRels((byte) (rels & other.rels)); 94 | } 95 | 96 | public BitRels intersection(final byte other) { 97 | return new BitRels((byte) (rels & other)); 98 | } 99 | 100 | public BitRels union(final BitRels other) { 101 | return new BitRels((byte) (rels | other.rels)); 102 | } 103 | 104 | public BitRels union(final byte other) { 105 | return new BitRels((byte) (rels | other)); 106 | } 107 | 108 | // Returns a Rels with everything in this rels that is *not* in the other rels. 109 | public BitRels difference(BitRels other) { 110 | return new BitRels((byte) (rels & (~other.rels))); 111 | } 112 | 113 | // Explodes into a collection of singleton BitRels. 114 | public Iterator iterator() { 115 | return new BitRelsIterator(this); 116 | } 117 | 118 | public boolean equals(Object other) { 119 | if (!(other instanceof BitRels)) { 120 | return false; 121 | } 122 | return (rels == ((BitRels) other).rels); 123 | } 124 | 125 | public int hashCode() { 126 | return rels; 127 | } 128 | 129 | public String toString() { 130 | StringBuilder sb = new StringBuilder(); 131 | sb.append("#{"); 132 | boolean comma = false; 133 | for (int i = 0; i < ALL.length; i++) { 134 | if (!intersection(ALL[i]).isEmpty()) { 135 | if (comma) { 136 | sb.append(", "); 137 | } else { 138 | comma = true; 139 | } 140 | sb.append(NAMES[i]); 141 | } 142 | } 143 | sb.append('}'); 144 | return sb.toString(); 145 | } 146 | 147 | public ISet toBifurcan() { 148 | ISet set = Set.EMPTY.linear(); 149 | for (int i = 0; i < ALL.length; i++) { 150 | if (!intersection(ALL[i]).isEmpty()) { 151 | set = set.add(KEYWORDS[i]); 152 | } 153 | } 154 | return set.forked(); 155 | } 156 | 157 | public Object toClojure() { 158 | final ArrayList kws = new ArrayList(ALL.length); 159 | for (int i = 0; i < ALL.length; i++) { 160 | if (!intersection(ALL[i]).isEmpty()) { 161 | kws.add(KEYWORDS[i]); 162 | } 163 | } 164 | return PersistentHashSet.create(kws); 165 | } 166 | 167 | class BitRelsIterator implements Iterator { 168 | private byte i = -1; // Index of the current rel in ALL, also index of the bit set. 169 | private final BitRels rels; 170 | 171 | BitRelsIterator(final BitRels rels) { 172 | this.rels = rels; 173 | } 174 | 175 | @Override 176 | public boolean hasNext() { 177 | // Taking advantage of the fact that ALL's order is exactly bit order 178 | // 0xFF << i masks off every bit at or lower than i. Note that Java doesn't have bitwise & on bytes: it implicitly widens both bytes to ints, which would fill in the upper bits of rels.rels with 1s. That's why we do the unsigned int conversion here. 179 | if ((Byte.toUnsignedInt(rels.rels) & (0xFF << (i + 1))) != 0) { 180 | return true; 181 | } 182 | return false; 183 | } 184 | 185 | @Override 186 | public BitRels next() { 187 | // Increment i until we run out of ALLs 188 | BitRels r; 189 | while (i < (ALL.length - 1)) { 190 | i++; 191 | r = ALL[i]; 192 | if (!rels.intersection(r).isEmpty()) { 193 | // We contain this singleton! 194 | return r; 195 | } 196 | } 197 | // Done 198 | throw new NoSuchElementException(); 199 | } 200 | } 201 | } -------------------------------------------------------------------------------- /src/elle/bfs.clj: -------------------------------------------------------------------------------- 1 | (ns elle.bfs 2 | "Provides fast, specialized breadth-first search for cycles in graphs of 3 | operations. It's been several years: we know exactly what kinds of cycles 4 | we're looking for, and we can write their state machines in code instead of 5 | as general predicates." 6 | (:require [bifurcan-clj [core :as b] 7 | [graph :as bg] 8 | [map :as bm] 9 | [list :as bl] 10 | [linear-list :as bll] 11 | [set :as bs]] 12 | [clojure [datafy :refer [datafy]] 13 | [pprint :refer [pprint]]] 14 | [clojure.core [protocols :as p]] 15 | [clojure.tools.logging :refer [info warn]] 16 | [dom-top.core :refer [loopr]] 17 | [elle [graph :as g] 18 | [util :refer [maybe-interrupt]] 19 | [rels :as rels :refer [ww wwp wr wrp rw rwp 20 | process realtime]]] 21 | [potemkin :refer [definterface+]]) 22 | (:import (elle BFSPath 23 | BFSPath$RWMode 24 | BitRels) 25 | (jepsen.history Op))) 26 | 27 | (defn tail? 28 | "A path has a tail if the index of the first op is different than the last." 29 | [^BFSPath path] 30 | (not= (.lastIndex path) (.index ^Op (b/nth (.ops path) 0)))) 31 | 32 | (defn ^BFSPath spec->path 33 | "Constructs an empty path from a cycle-anomaly spec." 34 | [{:keys [^BitRels rels 35 | required-rels 36 | ^BitRels nonadjacent-rels 37 | ^BitRels single-rels 38 | ^BitRels multiple-rels] 39 | :as spec}] 40 | (BFSPath. ; Legal, normally allowed rels 41 | (.rels rels) 42 | ; Wanted rels. Note that our :required spec breaks out p/rt 43 | ; right now, for implementation reasons. When we drop the old 44 | ; implementation we can simplify. 45 | (bs/from (or required-rels #{})) 46 | 47 | ; RW wanted count 48 | (cond single-rels 49 | (do (assert (.isEmpty (.difference single-rels 50 | BitRels/ANY_RW)) 51 | (str single-rels)) 52 | 53 | 1) 54 | 55 | multiple-rels 56 | (do (assert (.isEmpty (.difference multiple-rels 57 | BitRels/ANY_RW)) 58 | (str multiple-rels)) 59 | 2) 60 | 61 | true 0) 62 | 63 | ; RW mode 64 | (condp = nonadjacent-rels 65 | nil (if (and single-rels (.isAnyRW single-rels)) 66 | BFSPath$RWMode/SINGLE 67 | BFSPath$RWMode/NONE) 68 | rw BFSPath$RWMode/NONADJACENT_FREE 69 | (rels/union rw rwp) BFSPath$RWMode/NONADJACENT_FREE 70 | (throw (IllegalArgumentException. (str "Unexpected nonadjacent rels: " 71 | nonadjacent-rels)))))) 72 | 73 | (defn expand-paths 74 | "Takes a graph and a list of paths. Expands each path out by one hop, 75 | returning a new linear list of paths." 76 | [g paths] 77 | (loopr [paths' (bll/linear-list)] 78 | [^BFSPath path paths :via :iterator] 79 | ; For each path... 80 | (let [op (bl/last (.ops path))] 81 | (recur (loopr [paths' paths'] 82 | [^Op op' (bg/out g op) :via :iterator] 83 | ; And each op reachable from the tip of that path... 84 | (let [edge (bg/edge g op op') 85 | ;_ (prn :path (str path) 86 | ; :op' (:index op') 87 | ; :edge (into #{} edge)) 88 | paths'' (.step path edge (.index op') op') 89 | ; Faster concat 90 | paths''' (reduce bl/add-last paths' paths'')] 91 | ;(prn :paths''' (datafy paths''')) 92 | (recur paths'''))))))) 93 | 94 | (declare search-from-op) 95 | 96 | (defn trim-loop 97 | "Takes a graph, a loop path with a tail, and tries to cut the tail 98 | off. Returns either a tail-less loop, or nil." 99 | [g init-path ^BFSPath path] 100 | (let [; We just hit a loop. Find the loop, restrict the graph to just those 101 | ; vertices, and search it for a cycle. We know the last op visited must 102 | ; be the pin where we link the loop shut. 103 | ops (.ops path) 104 | pin (.index ^Op (bl/last ops)) 105 | ; So where does our path begin? 106 | pin-index (loopr [i 0] 107 | [^Op op ops :via :iterator] 108 | (if (= pin (.index op)) 109 | i 110 | (recur (inc i)))) 111 | ; Which means our candidate path is 112 | trimmed (bl/slice ops pin-index (b/size ops)) 113 | n (b/size trimmed) 114 | ; Restrict graph to just those elements 115 | g' (bg/select g (bs/from trimmed))] 116 | ; Now search that graph. 117 | (loopr [] 118 | [op trimmed :via :iterator] 119 | (or (search-from-op g' init-path op) 120 | (recur))))) 121 | 122 | (defn search-from-op 123 | "Searches a graph for a cycle matching the given initial path, starting with 124 | `op`." 125 | [g ^BFSPath init-path ^Op op] 126 | ; Expand in incremental shells from the starting vertex. 127 | (loop [paths (bl/add-last bl/empty (.start init-path (.index op) op))] 128 | ;(prn :search-from-op :paths paths) 129 | (maybe-interrupt) 130 | (when (< 0 (b/size paths)) 131 | ; (prn :paths (datafy paths)) 132 | ; First, do we have any paths which are loops? Try to find one which is 133 | ; valid without a tail. If we have one, we're done. If not, we discard 134 | ; those loops. 135 | (loopr [paths' (b/linear bl/empty)] 136 | [^BFSPath path paths :via :iterator] 137 | (if (.isLoop path) 138 | (if (.isValid path) 139 | (if (not (tail? path)) 140 | ; Done! 141 | (do ;(prn :found (datafy path)) 142 | (into [] (.ops path))) 143 | ; We have a tail--can we prune it? 144 | (do ;(prn :loop-has-tail (datafy path)) 145 | (or (trim-loop g init-path path) 146 | (recur paths')))) 147 | ; A loop, but not valid: drop this 148 | (do ;(prn :loop-not-valid (datafy path)) 149 | (recur paths'))) 150 | ; Not a loop; keep going 151 | (recur (bl/add-last paths' path))) 152 | ; We now have a set of non-loop paths to expand 153 | (do ;(prn :remaining-paths paths' (datafy paths')) 154 | ; Recurs to enclosing loop! 155 | (recur (expand-paths g paths'))))))) 156 | 157 | (defn search 158 | "Searches a graph for a cycle matching `spec`. Returns a cycle, or nil." 159 | [g spec] 160 | (let [init-path (spec->path spec)] 161 | ;(prn :init-path init-path) 162 | (loopr [] 163 | [op (bg/vertices g) :via :iterator] 164 | (do ;(prn) 165 | ;(prn "Starting with" (:index op)) 166 | (or (search-from-op g init-path op) 167 | (recur)))))) 168 | -------------------------------------------------------------------------------- /src/elle/rels.clj: -------------------------------------------------------------------------------- 1 | (ns elle.rels 2 | "Relationships between transactions." 3 | (:import (elle BitRels))) 4 | 5 | (def none "A dependency with no relationships" BitRels/NONE) 6 | (def ww "A write-write dependency" BitRels/WW) 7 | (def wr "A write-read dependency" BitRels/WR) 8 | (def rw "A read-write dependency" BitRels/RW) 9 | (def wwp "A predicate write-write dependency" BitRels/WWP) 10 | (def wrp "A predicate write-read dependency" BitRels/WRP) 11 | (def rwp "A predicate read-write dependency" BitRels/RWP) 12 | (def process "A process dependency" BitRels/PROCESS) 13 | (def realtime "A realtime dependency" BitRels/REALTIME) 14 | 15 | (defn bit-rels? 16 | "Is this a BitRels?" 17 | [x] 18 | (instance? BitRels x)) 19 | 20 | (defn ^BitRels union 21 | "Unions any number of BitRels. Nil is treated as BitRels/NONE" 22 | ([] 23 | BitRels/NONE) 24 | ([a] 25 | (if a a BitRels/NONE)) 26 | ([^BitRels a, ^BitRels b] 27 | (cond (nil? a) b 28 | (nil? b) a 29 | true (.union a b))) 30 | ([^BitRels a ^BitRels b & more] 31 | (reduce union (union a b) more))) 32 | -------------------------------------------------------------------------------- /src/elle/util.clj: -------------------------------------------------------------------------------- 1 | (ns elle.util 2 | "Kitchen sink" 3 | (:require [clojure.core.reducers :as r] 4 | [clojure.tools.logging :refer [info warn]] 5 | [dom-top.core :refer [loopr]] 6 | [jepsen.history :as h]) 7 | (:import (java.util.concurrent ExecutionException) 8 | (java.util.function BinaryOperator) 9 | (io.lacuna.bifurcan IMap 10 | IntMap 11 | Map) 12 | (jepsen.history Op))) 13 | 14 | (defn empty->nil 15 | "Takes a collection coll and returns coll iff it is non-empty; otherwise nil." 16 | [coll] 17 | (when (seq coll) 18 | coll)) 19 | 20 | (defn nanos->secs [nanos] (/ nanos 1e9)) 21 | 22 | (defn maybe-interrupt 23 | "Throws an InterruptedException if our interrupt flag is set." 24 | [] 25 | (when (Thread/interrupted) 26 | (throw (InterruptedException.)))) 27 | 28 | (defmacro timeout 29 | "Times out body after n millis, returning timeout-val if that occurs." 30 | [millis timeout-val & body] 31 | `(let [worker# (future ~@body) 32 | retval# (try 33 | (deref worker# ~millis ::timeout) 34 | (catch ExecutionException ee# 35 | (throw (.getCause ee#))))] 36 | (if (= retval# ::timeout) 37 | (do (future-cancel worker#) 38 | ~timeout-val) 39 | retval#))) 40 | 41 | (defn map-kv 42 | "Takes a function (f [k v]) which returns [k v], and builds a new map by 43 | applying f to every pair." 44 | [f m] 45 | (into {} (r/map f m))) 46 | 47 | (defn map-vals 48 | "Maps values in a map." 49 | [f m] 50 | (map-kv (fn [[k v]] [k (f v)]) m)) 51 | 52 | (defn index-of 53 | "Type-hinted .indexOf" 54 | [^java.util.List coll element] 55 | (.indexOf coll element)) 56 | 57 | (defn fast-frequencies 58 | "Like frequencies, but faster. Returns an IMap." 59 | [coll] 60 | (let [add (reify BinaryOperator 61 | (apply [_ x y] (+ ^Long x ^Long y)))] 62 | (loopr [^IMap m (.linear (Map.))] 63 | [x coll] 64 | (recur (.put m x 1 add)) 65 | (.forked m)))) 66 | 67 | (defn op-memoize 68 | "Memoizes a pure function of an operation. Uses the op's index as a key to 69 | speed up access. Thread-safe." 70 | [f] 71 | (let [cache (atom (IntMap.)) 72 | add-cache (fn [^IntMap m, ^long k, v] 73 | (.put m k v))] 74 | (fn memoized [^Op op] 75 | (let [index (.index op) 76 | res (.get ^IntMap @cache index ::not-found)] 77 | (if (identical? res ::not-found) 78 | (let [res (f op)] 79 | (swap! cache add-cache index res) 80 | res) 81 | res))))) 82 | 83 | (defn fand 84 | "Functional and. Takes a collection of unary functions and returns a single 85 | function which calls each f and returns the first non-truthy return value, or 86 | the last return value." 87 | [fs] 88 | (condp = (count fs) 89 | 0 (constantly true) 90 | 1 (first fs) 91 | 2 (let [[f2 f1] fs] 92 | (fn binary [x] 93 | (and (f1 x) (f2 x)))) 94 | (fn nary [x] 95 | (reduce (fn [_ f] 96 | (let [r (f x)] 97 | (if r r (reduced r)))) 98 | nil 99 | fs)))) 100 | -------------------------------------------------------------------------------- /src/elle/viz.clj: -------------------------------------------------------------------------------- 1 | (ns elle.viz 2 | (:require [bifurcan-clj [core :as b] 3 | [graph :as bg]] 4 | [clojure.string :as str] 5 | [clojure.java.io :as io] 6 | [clojure.tools.logging :refer [info warn]] 7 | [elle [core :as elle] 8 | [graph :as g] 9 | [util :as util]] 10 | [rhizome [dot :as dot] 11 | [viz :as rv]])) 12 | 13 | (def ^:private escapable-characters "\\|{}\"") 14 | 15 | (defn escape-string 16 | "Escape characters that are significant for the dot format." 17 | [s] 18 | (reduce 19 | #(str/replace %1 (str %2) (str "\\" %2)) 20 | s 21 | escapable-characters)) 22 | 23 | (defn dot 24 | "We're gonna be doing some weird stuff with html and referencing record ports 25 | that none of the existing clojure graphviz libraries are really built for. 26 | Just gonna roll our own ast and generator for dot here." 27 | [node] 28 | ; (prn node) 29 | (cond (sequential? node) 30 | (let [[node-type a b c] node] 31 | (case node-type 32 | :lit a 33 | :lines (str/join "\n" (map dot a)) 34 | :digraph (str "digraph a_graph {\n" (dot [:lines a]) "\n}") 35 | :record-label (->> (map-indexed 36 | (fn [i x] (str " " 37 | (escape-string x) "")) 38 | a) 39 | (str/join "|") 40 | dot) 41 | :node (str a " [" (dot b) "]") 42 | :edge (str a " -> " b " [" (dot c) "]") 43 | :html (str "<" a ">"))) 44 | 45 | (map? node) 46 | (str/join "," (map (fn [[k v]] (str (name k) "=" (dot v))) node)) 47 | 48 | (string? node) 49 | (str "\"" node "\"") 50 | 51 | (keyword? node) 52 | (name node) 53 | 54 | true 55 | (pr-str node))) 56 | 57 | (def type->color 58 | "Takes a type of operation (e.g. :ok) and returns a hex color." 59 | {:ok "#0058AD" 60 | :info "#AC6E00" 61 | :fail "#A50053"}) 62 | 63 | (defn short-f 64 | "Short names for common operations" 65 | [f] 66 | (case f 67 | :append "a" 68 | (if (instance? clojure.lang.Named f) 69 | (name f) 70 | (str f)))) 71 | 72 | (defn mop->str 73 | "Converts a micro-op to a short string" 74 | [[f k v]] 75 | (str (short-f f) " " (pr-str k) " " (pr-str v))) 76 | 77 | (defn short-rel 78 | "Short names for relations" 79 | [rel] 80 | (case rel 81 | :realtime "rt" 82 | :process "p" 83 | (str rel))) 84 | 85 | (defn rel->color 86 | "Colors for each type of relationship in a graph." 87 | [rel] 88 | (case rel 89 | :ww "#C02700" 90 | :wr "#C000A5" 91 | :rw "#5B00C0" 92 | :realtime "#0050C0" 93 | :process "#00C0C0" 94 | #"#585858")) 95 | 96 | (def rel-priority 97 | "Which relationships have the highest priorities? Lower is more relevant." 98 | {:wr 0 99 | :ww 1 100 | :rw 2 101 | :process 3 102 | :realtime 4}) 103 | 104 | (defn highest-priority-rel 105 | "Given a set of relationships, returns the highest priority one; e.g., what 106 | do we think is the most fundamentally inferrable or important." 107 | [rels] 108 | (first (sort-by rel-priority rels))) 109 | 110 | (defn rels->html 111 | "Turns a relationship set into an HTML AST node." 112 | [rels] 113 | [:html 114 | (->> (sort-by rel-priority rels) 115 | (map (fn [rel] 116 | (str "color rel) "\">" 117 | (short-rel rel) 118 | ""))) 119 | (str/join ","))]) 120 | 121 | (defn op->node 122 | "Turns an operation into a node descriptor ast." 123 | [node-idx {:keys [f value] :as op}] 124 | [:node (node-idx op) 125 | {:height 0.4 126 | :shape :record 127 | :label (case f 128 | ; Inits are special; their value is a single op. 129 | :init [:record-label [(str "init " (pr-str value))]] 130 | ; Otherwise, assume a txn of micro-ops 131 | [:record-label (map mop->str value)]) 132 | :color (type->color (:type op)) 133 | :fontcolor (type->color (:type op))}]) 134 | 135 | (defn op-op->edge 136 | "Given an analysis, node index, and pair of operations, yields an edge AST 137 | node." 138 | [analysis node-index a b] 139 | (let [edge (bg/edge (:graph analysis) a b) 140 | explainer (:explainer analysis) 141 | ex (elle/explain-pair-data explainer a b) 142 | ; _ (prn ex) 143 | ; So... there's a chance the explainer might be able to give us a 144 | ; *local* explanation with a particular index into the source and 145 | ; destination transactions. Let's try to render that... 146 | an (node-index a) 147 | bn (node-index b) 148 | an (if-let [ami (:a-mop-index ex)] 149 | (str an ":f" ami) 150 | an) 151 | bn (if-let [bmi (:b-mop-index ex)] 152 | (str bn ":f" bmi) 153 | bn)] 154 | [:edge an bn 155 | {:label (short-rel (:type ex)) 156 | :fontcolor (rel->color (:type ex)) 157 | :color (rel->color (:type ex))}])) 158 | 159 | (defn op->edges 160 | "Takes an analysis, a node-index, and an operation. Returns a sequence of ast 161 | edges out of that op" 162 | [analysis scc node-idx op] 163 | (->> (g/out (:graph analysis) op) 164 | (filter (g/->clj scc)) 165 | (map (partial op-op->edge analysis node-idx op)))) 166 | 167 | (defn node-idx 168 | "Builds an map of nodes to node names." 169 | [nodes] 170 | (->> nodes 171 | (map-indexed (fn [i node] 172 | [node (if-let [i (:index node)] 173 | (str "T" i) ; We know the transaction number 174 | (str "n" i))])) 175 | (into {}))) 176 | 177 | (defn scc->ast 178 | "Turns an scc in an analysis into a dot ast" 179 | [analysis scc] 180 | (let [node-idx (node-idx scc)] 181 | [:digraph 182 | (concat (map (partial op->node node-idx) scc) 183 | (mapcat (partial op->edges analysis scc node-idx) scc))])) 184 | 185 | (defn save-dot! 186 | "Renders dot to a file. Options are the same as plot-analysis!" 187 | [^String dot directory opts i] 188 | (if (< (:max-plot-bytes opts 65536) ; 65K 189 | (.length dot)) 190 | (info "Skipping plot of" (.length dot) "bytes") 191 | (case (:plot-format opts :svg) 192 | :png (rv/save-image (rv/dot->image dot) 193 | (io/file directory (str i ".png"))) 194 | :svg (spit (io/file directory (str i ".svg")) 195 | (rv/dot->svg dot))))) 196 | 197 | (defn plot-analysis! 198 | "Takes an analysis (e.g. {:graph g, :explainer e, :sccs [...]} and a 199 | directory, and renders every SCC in that analysis to a file in the given 200 | directory. Returns analysis. 201 | 202 | Options: 203 | 204 | :plot-format Either :png or :svg 205 | :max-plot-bytes Maximum number of bytes of DOT-formatted graph to feed 206 | to graphviz. Big SCCs can make graphviz choke! 207 | :plot-timeout Timeout, in milliseconds, to render an SCC 208 | " 209 | ([analysis directory] 210 | (plot-analysis! analysis directory {})) 211 | ([analysis directory opts] 212 | (when (seq (:sccs analysis)) 213 | (io/make-parents (io/file directory "."))) 214 | (->> (:sccs analysis) 215 | (map-indexed vector) 216 | (pmap (fn [[i scc]] 217 | (util/timeout (:plot-timeout opts 5000) 218 | (info "Timing out visualization of SCC no." i "containing" 219 | (count scc) "transactions") 220 | (-> analysis 221 | (scc->ast scc) 222 | dot 223 | (save-dot! directory opts i))))) 224 | dorun) 225 | analysis)) 226 | 227 | (defn view-scc 228 | "Shows a strongly connected component. Analysis should be a map of 229 | 230 | :graph g 231 | :explainer e 232 | 233 | Helpful for testing." 234 | [analysis scc] 235 | (let [ast (scc->ast analysis scc) 236 | dot (dot ast)] 237 | ;(println dot) 238 | (rv/view-image (rv/dot->image dot)))) 239 | -------------------------------------------------------------------------------- /test/elle/bfs_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.bfs-test 2 | (:require [bifurcan-clj [core :as b] 3 | [list :as bl] 4 | [graph :as bg] 5 | [set :as bs]] 6 | [clojure [pprint :refer [pprint]]] 7 | [clojure.core [protocols :as p]] 8 | [elle [bfs :refer :all] 9 | [graph :as g] 10 | [rels :as rels :refer :all] 11 | [txn :as t]] 12 | [jepsen [history :as h]] 13 | [clojure.test :refer :all] 14 | [slingshot.slingshot :refer [try+ throw+]]) 15 | (:import (io.lacuna.bifurcan IMap 16 | Map) 17 | (elle BFSPath))) 18 | 19 | ; Just for debugging 20 | (extend-protocol p/Datafiable 21 | elle.BFSPath 22 | (datafy [p] 23 | {:ops (mapv :index (.ops p))})) 24 | 25 | (defn op 26 | "Takes a number, returns an Op with that as its index." 27 | [index] 28 | (h/op {:index index})) 29 | 30 | (defn indices 31 | "Takes a collection of Ops and extracts their indexes." 32 | [ops] 33 | (when ops 34 | (mapv :index ops))) 35 | 36 | (defn op-graph 37 | "Takes a graph of integers and lifts them into a graph of Ops where the 38 | integers are their index fields. We do this because our graph search is 39 | optimized for Ops, but we don't want to write a zillion ops in testing." 40 | [g] 41 | (g/map-vertices op g)) 42 | 43 | (deftest packed-rels-set-test 44 | (are [rels] (= rels (-> rels bs/from BFSPath/packRelsSet BFSPath/unpackRelsSet set)) 45 | #{} 46 | #{ww} 47 | #{rw rwp} 48 | #{ww realtime} 49 | #{ww process realtime} 50 | #{ww wwp wr realtime})) 51 | 52 | (deftest realtime-test 53 | ; Realtime is tricky--it occupies the high bit in our byte representation of 54 | ; bitrels, and that causes sign extension bugs when Clojure emits 55 | ; auto-widening code. 56 | (testing "G0" 57 | (let [p (spec->path (t/cycle-anomaly-specs :G0-realtime))] 58 | (is (= (.rels (union ww wwp realtime)) (.legal p))) 59 | (is (= #{realtime} (set (BFSPath/unpackRelsSet (.want p))))))) 60 | (testing "G1c" 61 | (let [p (spec->path (t/cycle-anomaly-specs :G1c-realtime))] 62 | (is (= (.rels (union ww wwp wr wrp realtime)) (.legal p))) 63 | (is (= #{realtime (rels/union wr wrp)} (set (BFSPath/unpackRelsSet (.want p)))))))) 64 | 65 | (defn s 66 | "Takes an anomaly spec type and a series of [from-idx to-idx rel] triples. 67 | Builds an op graph, searches it for a cycle, and returns the cycle's 68 | indices." 69 | [spec-type & triples] 70 | (-> (reduce (partial apply g/link) (g/digraph) (partition 3 triples)) 71 | op-graph 72 | (search (t/cycle-anomaly-specs spec-type)) 73 | indices)) 74 | 75 | (deftest g0-test 76 | (testing "empty" 77 | (is (= nil (s :G0)))) 78 | 79 | (testing "simple" 80 | (is (= [2 1 2] (s :G0 81 | 1 2 ww 82 | 2 1 ww)))) 83 | 84 | (testing "longer" 85 | (is (= [3 1 2 3] (s :G0 86 | 1 2 ww 87 | 2 3 ww 88 | 3 1 ww)))) 89 | 90 | (testing "not present" 91 | (is (= nil (s :G0 92 | 1 2 ww 93 | 2 1 rw 94 | 2 1 wr)))) 95 | 96 | (testing "indirect" 97 | (is (= [3 1 2 3] (s :G0 98 | 1 2 ww 99 | 2 3 ww 100 | 3 1 ww 101 | 2 1 rw 102 | 3 2 wr))))) 103 | 104 | (deftest g1c-test 105 | (testing "simple" 106 | (is (= [2 1 2] (s :G1c 107 | 1 2 ww 108 | 2 1 wr)))) 109 | 110 | (testing "hidden" 111 | (is (= [3 1 2 3] 112 | (s :G1c 113 | 1 2 ww 114 | 2 3 wr 115 | 2 1 rw 116 | 3 1 wr 117 | 3 2 rw))))) 118 | 119 | (deftest g1c-realtime-test 120 | ; This is trickier: we have to get a realtime edge and a *separate* wr or wrp 121 | ; edge. It's not enough for them to be combined! 122 | (testing "simple" 123 | (is (= [2 1 2] 124 | (s :G1c-realtime 125 | 1 2 wrp 126 | 2 1 realtime)))) 127 | 128 | (testing "not present" 129 | (is (= nil 130 | (s :G1c-realtime 131 | 1 2 ww 132 | 2 1 realtime 133 | 2 1 wrp))))) 134 | 135 | (deftest g-single-test 136 | (testing "simple" 137 | (is (= [2 1 2] (s :G-single 138 | 1 2 ww 139 | 2 1 rw)))) 140 | 141 | (testing "hidden" 142 | (is (= [1 2 3 4 1] 143 | (s :G-single 144 | 1 2 rw 145 | 2 1 rw 146 | 2 3 ww 147 | 3 1 rw 148 | 3 4 wr 149 | 4 1 wr))))) 150 | 151 | (deftest g-nonadjacent-test 152 | (testing "hidden" 153 | (is (= [3 4 1 2 3] 154 | (s :G-nonadjacent 155 | ; Cycle 156 | 1 2 rw 157 | 2 3 ww 158 | 3 4 rw 159 | 4 1 wr 160 | ; But also a shorter g-single 161 | 2 1 ww 162 | ; And a shorter G0 163 | 3 2 ww))))) 164 | 165 | (deftest g2-test 166 | (testing "hidden" 167 | (is (= [3 4 1 2 3] 168 | (s :G2 169 | ; G2 Cycle 170 | 1 2 ww 171 | 2 3 wr 172 | 3 4 rw 173 | 4 1 rw 174 | ; G0 175 | 2 1 ww 176 | ; G-single 177 | 4 3 wr))))) 178 | 179 | (deftest g0-realtime-test 180 | (testing "hidden" 181 | (is (= [2 3 1 2] 182 | (s :G0-realtime 183 | ; G0-realtime 184 | 1 2 ww 185 | 2 3 realtime 186 | 3 1 ww 187 | ; G0 188 | 2 1 ww))))) 189 | 190 | (deftest g-nonadjacent-process-test 191 | (testing "hidden" 192 | (is (= [3 4 1 2 3] 193 | (s :G-nonadjacent-process 194 | ; G-nonadjacent-process 195 | 1 2 rw 196 | 2 3 process 197 | 3 4 rw 198 | 4 1 ww 199 | ; G-single 200 | 4 3 wr 201 | ; G-nonadjacent 202 | 2 5 wr 203 | 5 6 rw 204 | 6 1 ww))))) 205 | -------------------------------------------------------------------------------- /test/elle/consistency_model_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.consistency-model-test 2 | "Elle finds anomalies in histories. This namespace helps turn those anomalies 3 | into claims about what kind of consistency models are supported by, or ruled 4 | out by, a given history." 5 | (:require [bifurcan-clj [graph :as bg]] 6 | [clojure [datafy :refer [datafy]] 7 | [pprint :refer [pprint]] 8 | [test :refer :all]] 9 | [elle.consistency-model :refer :all])) 10 | 11 | (deftest implied-anomalies-test 12 | (is (every? keyword? (bg/vertices implied-anomalies)))) 13 | 14 | (deftest all-anomalies-test 15 | ; Note: these are in implication & severity order 16 | (is (= [:G-MSR 17 | :G-SI 18 | :G-SIb 19 | :G-cursor 20 | :G-monotonic 21 | :G-single-item 22 | :G-update 23 | :G0 24 | :G1b 25 | :GSIa 26 | :PL-1-cycle-exists 27 | :PL-2-cycle-exists 28 | :PL-2.99-cycle-exists 29 | :PL-3-cycle-exists 30 | :PL-SI-cycle-exists 31 | :PL-SS-cycle-exists 32 | :cyclic-versions 33 | :dirty-update 34 | :duplicate-elements 35 | :future-read 36 | :incompatible-order 37 | :internal 38 | :lost-update 39 | :predicate-read-miss 40 | :strong-PL-1-cycle-exists 41 | :strong-PL-2-cycle-exists 42 | :strong-session-PL-1-cycle-exists 43 | :strong-session-PL-2-cycle-exists 44 | :strong-session-serializable-cycle-exists 45 | :strong-session-snapshot-isolation-cycle-exists 46 | :strong-snapshot-isolation-cycle-exists 47 | :G-nonadjacent-item 48 | :G-single-item-process 49 | :G1a 50 | :G1c 51 | :write-skew 52 | :G-nonadjacent-item-process 53 | :G-single 54 | :G-single-item-realtime 55 | :G1 56 | :G2-item 57 | :G-nonadjacent 58 | :G-nonadjacent-item-realtime 59 | :GSIb 60 | :G2 61 | :GSI 62 | :G0-process 63 | :G1c-process 64 | :G-single-process 65 | :G1-process 66 | :G2-item-process 67 | :G-nonadjacent-process 68 | :G2-process 69 | :G0-realtime 70 | :G1c-realtime 71 | :G-single-realtime 72 | :G1-realtime 73 | :G2-item-realtime 74 | :G-nonadjacent-realtime 75 | :G2-realtime] 76 | (vec all-anomalies)))) 77 | 78 | (deftest all-implied-anomalies-test 79 | (is (= [:G-SI] (seq (all-implied-anomalies [:G-SI]))))) 80 | 81 | (deftest weakest-models-test 82 | (let [s #(set (map friendly-model-name (weakest-models %)))] 83 | (testing "empty" 84 | (is (= #{} (s [])))) 85 | 86 | (testing "simple" 87 | (is (= #{:serializable} 88 | (s [:serializable :strict-serializable])))) 89 | 90 | (testing "independent" 91 | (is (= #{:read-your-writes 92 | :read-committed} 93 | (s [:repeatable-read 94 | :read-committed 95 | :sequential 96 | :read-your-writes])))) 97 | 98 | (testing "cerone-end-to-end" 99 | (is (= #{:read-atomic} 100 | (s [:serializable :read-atomic]) 101 | (s [:read-atomic :serializable])))))) 102 | 103 | (deftest strongest-models-test 104 | (let [s #(set (map friendly-model-name (strongest-models %)))] 105 | (testing "empty" 106 | (is (= #{} (s [])))) 107 | 108 | (testing "simple" 109 | (is (= #{:strong-serializable} 110 | (s [:serializable :strong-serializable :strict-serializable])))) 111 | 112 | (testing "independent" 113 | (is (= #{:repeatable-read 114 | :sequential} 115 | (s [:repeatable-read 116 | :read-committed 117 | :sequential 118 | :read-your-writes])))) 119 | 120 | (testing "cerone-end-to-end" 121 | (is (= #{:serializable} 122 | (s [:serializable :read-atomic]) 123 | (s [:read-atomic :serializable])))))) 124 | 125 | (let [as #(into (sorted-set) 126 | (anomalies-prohibited-by %))] 127 | (deftest anomalies-prohibited-by-test 128 | (testing "read committed" 129 | (is (= #{:dirty-update 130 | :G1a 131 | :G1b 132 | :G1c 133 | :G1 134 | :G0 135 | :PL-1-cycle-exists 136 | :PL-2-cycle-exists 137 | :cyclic-versions 138 | :duplicate-elements 139 | :incompatible-order 140 | :future-read} 141 | (as [:read-committed])))) 142 | 143 | (testing "unknown anomaly" 144 | (is (thrown-with-msg? IllegalArgumentException #"Unknown consistency model" 145 | (anomalies-prohibited-by 146 | [:stricct-snappshot-isolation])))))) 147 | 148 | 149 | (let [as #(into (sorted-set) 150 | (map friendly-model-name (anomalies->impossible-models %)))] 151 | 152 | (deftest anomaly->impossible-models-test 153 | (testing "G-single" 154 | (is (= #{:consistent-view 155 | :forward-consistent-view 156 | :strong-serializable 157 | :serializable 158 | :snapshot-isolation 159 | :strong-session-serializable 160 | :strong-session-snapshot-isolation 161 | :strong-snapshot-isolation 162 | :update-serializable} 163 | (as [:G-single])))) 164 | 165 | (testing "G-SI" 166 | (is (= #{:snapshot-isolation 167 | :serializable 168 | :strong-serializable 169 | :strong-session-serializable 170 | :strong-session-snapshot-isolation 171 | :strong-snapshot-isolation} 172 | (as [:G-SI])))) 173 | 174 | (testing "dirty update" 175 | (is (= #{:read-committed 176 | :monotonic-atomic-view 177 | :snapshot-isolation 178 | :repeatable-read 179 | :update-atomic 180 | :serializable 181 | :strong-serializable 182 | :update-serializable 183 | :cursor-stability 184 | :forward-consistent-view 185 | :consistent-view 186 | :monotonic-view 187 | :monotonic-snapshot-read 188 | :causal-cerone 189 | :parallel-snapshot-isolation 190 | :prefix 191 | :read-atomic 192 | :strong-session-read-committed 193 | :strong-session-serializable 194 | :strong-session-snapshot-isolation 195 | :strong-read-committed 196 | :strong-snapshot-isolation 197 | } 198 | (as [:dirty-update])))) 199 | 200 | (testing "internal" 201 | (is (= #{:causal-cerone 202 | :parallel-snapshot-isolation 203 | :prefix 204 | :read-atomic 205 | :update-atomic 206 | :serializable 207 | :snapshot-isolation 208 | :strong-serializable 209 | :strong-session-serializable 210 | :strong-session-snapshot-isolation 211 | :strong-snapshot-isolation 212 | } 213 | (as [:internal])))))) 214 | 215 | (deftest friendly-boundary-test 216 | (testing "empty" 217 | (is (= {:not #{} 218 | :also-not #{}} 219 | (friendly-boundary [])))) 220 | 221 | (testing "cyclic-versions" 222 | (is (= {:not #{:read-uncommitted} 223 | :also-not #{:read-committed 224 | :snapshot-isolation 225 | :causal-cerone 226 | :consistent-view 227 | :cursor-stability 228 | :forward-consistent-view 229 | :monotonic-atomic-view 230 | :monotonic-snapshot-read 231 | :monotonic-view 232 | ; Not sure about this one. PSI allows long fork, and 233 | ; I think long fork explicitly looks like inconsistent 234 | ; version orders. Then again, it's not so much that the 235 | ; version orders themselves are inconsistent, as the 236 | ; transactions using those orders are. OTOH, if we've 237 | ; invalidated read committed, then we've also broken 238 | ; read atomic, and that covers the various SIs! 239 | :parallel-snapshot-isolation 240 | :prefix 241 | :read-atomic 242 | :repeatable-read 243 | :update-atomic 244 | :serializable 245 | :strong-read-committed 246 | :strong-read-uncommitted 247 | :strong-serializable 248 | :strong-session-read-committed 249 | :strong-session-read-uncommitted 250 | :strong-session-serializable 251 | :strong-session-snapshot-isolation 252 | :strong-snapshot-isolation 253 | :update-serializable 254 | }} 255 | (friendly-boundary [:cyclic-versions])))) 256 | 257 | (testing "internal" 258 | (is (= {:not #{:read-atomic} 259 | :also-not #{:causal-cerone 260 | :parallel-snapshot-isolation 261 | :prefix 262 | :update-atomic 263 | :serializable 264 | :snapshot-isolation 265 | :strong-serializable 266 | :strong-session-serializable 267 | :strong-session-snapshot-isolation 268 | :strong-snapshot-isolation}} 269 | (friendly-boundary [:internal])))) 270 | 271 | (testing "G1a" 272 | (is (= {:not #{:read-committed} 273 | :also-not #{:read-atomic 274 | :update-atomic :causal-cerone :consistent-view :cursor-stability 275 | :forward-consistent-view :monotonic-atomic-view 276 | :monotonic-snapshot-read :monotonic-view 277 | :parallel-snapshot-isolation :prefix :repeatable-read 278 | :serializable :snapshot-isolation 279 | :strong-read-committed 280 | :strong-snapshot-isolation 281 | :strong-serializable 282 | :strong-session-read-committed 283 | :strong-session-serializable 284 | :strong-session-snapshot-isolation 285 | :update-serializable}} 286 | (friendly-boundary [:G1a])))) 287 | 288 | (testing "G-single" 289 | (is (= {:not #{:consistent-view} 290 | :also-not #{:snapshot-isolation 291 | :serializable 292 | :strong-serializable 293 | :strong-session-snapshot-isolation 294 | :strong-snapshot-isolation 295 | :strong-session-serializable 296 | :forward-consistent-view 297 | :update-serializable}} 298 | (friendly-boundary [:G-single])))) 299 | 300 | (testing "internal and G2" 301 | (is (= {:not #{:read-atomic} 302 | :also-not #{:update-atomic :causal-cerone 303 | :parallel-snapshot-isolation 304 | :prefix 305 | :serializable 306 | :snapshot-isolation 307 | :strong-serializable 308 | :strong-session-serializable 309 | :strong-session-snapshot-isolation 310 | :strong-snapshot-isolation}} 311 | (friendly-boundary [:G2 :internal])))) 312 | 313 | (testing "lost update" 314 | (is (= #{:update-atomic :cursor-stability} 315 | (:not (friendly-boundary [:lost-update]))))) 316 | 317 | (testing "G-single-realtime" 318 | (is (= {:not #{:strong-snapshot-isolation} 319 | :also-not #{:strong-serializable}} 320 | (friendly-boundary [:G-single-realtime]))))) 321 | 322 | (deftest all-impossible-models-test 323 | (is (= #{:strong-session-serializable :PL-SS} 324 | (set (all-impossible-models #{:strong-session-serializable}))))) 325 | 326 | ; This is more for building plots than anything else; it's not actually testing 327 | ; anything. 328 | (deftest plot-test 329 | (plot-models!) 330 | (plot-anomalies!) 331 | (plot-severity!)) 332 | -------------------------------------------------------------------------------- /test/elle/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.core-test 2 | (:require [clojure [test :refer :all] 3 | [edn :as edn]] 4 | [clojure.java.io :as io] 5 | [dom-top.core :refer [real-pmap]] 6 | [elle [core :refer :all] 7 | [graph :as g]] 8 | [jepsen [history :as h] 9 | [txn :as txn]] 10 | [slingshot.slingshot :refer [try+ throw+]]) 11 | (:import (java.io PushbackReader))) 12 | 13 | (defn read-history 14 | "Reads a history of op maps from a file." 15 | [filename] 16 | (with-open [r (PushbackReader. (io/reader filename))] 17 | (->> (repeatedly #(edn/read {:eof nil} r)) 18 | (take-while identity) 19 | h/history))) 20 | 21 | (defn op-graph 22 | "Builder for op digraphs. Takes a flat series of [from edge to] triples and 23 | builds an operation digraph with those bitrels." 24 | [& triples] 25 | (reduce (fn [g [from edge to]] 26 | (g/link g from to edge)) 27 | (g/op-digraph) 28 | (partition 3 triples))) 29 | 30 | (deftest process-graph-test 31 | (let [[o1 o2 o3 o4 :as h] 32 | (h/history [{:index 0 :process 1 :type :ok} 33 | {:index 1 :process 2 :type :ok} 34 | {:index 2 :process 2 :type :ok} 35 | {:index 3 :process 1 :type :ok}])] 36 | (is (= {o1 #{o4}, o2 #{o3}, o3 #{}, o4 #{}} 37 | (g/->clj (:graph (process-graph h))))))) 38 | 39 | (deftest monotonic-key-graph-test 40 | (testing "basics" 41 | (let [[r1 r2 r3 r4 :as h] 42 | (h/history [{:index 0 :type :ok, :f :read, :value {:x 0, :y 0}} 43 | {:index 2 :type :ok, :f :read, :value {:x 1, :y 0}} 44 | {:index 4 :type :ok, :f :read, :value {:x 1, :y 1}} 45 | {:index 5 :type :ok, :f :read, :value {:x 0, :y 1}}])] 46 | (is (= {r1 #{r2 r3 r4} 47 | r2 #{r3 r4} 48 | r3 #{} 49 | r4 #{r2 r3}} 50 | (g/->clj (:graph (monotonic-key-graph h))))))) 51 | 52 | (testing "Can bridge missing values" 53 | (let [[r1 r2 r3 r4 :as h] 54 | (h/history [{:index 0 :type :ok, :f :read, :value {:x 0, :y 0}} 55 | {:index 2 :type :ok, :f :read, :value {:x 1, :y 1}} 56 | {:index 4 :type :ok, :f :read, :value {:x 4, :y 1}} 57 | {:index 5 :type :ok, :f :read, :value {:x 0, :y 1}}])] 58 | (is (= {r1 #{r2 r3 r4} 59 | r2 #{r3} 60 | r3 #{} 61 | r4 #{r2}} 62 | (g/->clj (:graph (monotonic-key-graph h)))))))) 63 | 64 | (defn big-history-gen 65 | [v] 66 | (let [f (rand-nth [:inc :read]) 67 | proc (rand-int 100) 68 | k (rand-nth [[:x] [:y] [:x :y]]) 69 | type (rand-nth [:ok :ok :ok :ok :ok 70 | :fail :info :info])] 71 | [{:process proc, :type :invoke, :f f, :value {k v}} 72 | {:process proc, :type type, :f f, :value {k v}}])) 73 | 74 | (deftest checker-test 75 | (testing "valid" 76 | (let [history 77 | (h/history 78 | [{:index 0 :type :invoke :process 0 :f :read :value nil} 79 | {:index 1 :type :ok :process 0 :f :read :value {:x 0 :y 0}} 80 | {:index 2 :type :invoke :process 0 :f :inc :value [:x]} 81 | {:index 3 :type :ok :process 0 :f :inc :value {:x 1}} 82 | {:index 4 :type :invoke :process 0 :f :read :value nil} 83 | {:index 5 :type :ok :process 0 :f :read :value {:x 1 :y 1}}])] 84 | (is (= {:valid? true 85 | :scc-count 0 86 | :cycles []} 87 | (check {:analyzer monotonic-key-graph} history))))) 88 | 89 | (testing "invalid" 90 | (let [r00 {:index 0 :type :invoke :process 0 :f :read :value nil} 91 | r00' {:index 1 :type :ok :process 0 :f :read :value {:x 0 :y 0}} 92 | r10 {:index 2 :type :invoke :process 0 :f :read :value nil} 93 | r10' {:index 3 :type :ok :process 0 :f :read :value {:x 1 :y 0}} 94 | r11 {:index 4 :type :invoke :process 0 :f :read :value nil} 95 | r11' {:index 5 :type :ok :process 0 :f :read :value {:x 1 :y 1}} 96 | r01 {:index 6 :type :invoke :process 0 :f :read :value nil} 97 | r01' {:index 7 :type :ok :process 0 :f :read :value {:x 0 :y 1}} 98 | history (h/history [r00 r00' r10 r10' r11 r11' r01 r01']) 99 | msg "Let:\n T1 = {:index 7, :time -1, :type :ok, :process 0, :f :read, :value {:x 0, :y 1}}\n T2 = {:index 3, :time -1, :type :ok, :process 0, :f :read, :value {:x 1, :y 0}}\n\nThen:\n - T1 < T2, because T1 observed :x = 0, and T2 observed a higher value 1.\n - However, T2 < T1, because T2 observed :y = 0, and T1 observed a higher value 1: a contradiction!"] 100 | (is (= {:valid? false 101 | :scc-count 1 102 | :cycles [msg]} 103 | (check {:analyzer monotonic-key-graph 104 | :directory "test-output/checker-test/invalid/sccs"} 105 | history))) 106 | (is (= (str "Cycle #0\n" msg) (slurp "test-output/checker-test/invalid/sccs/cycles.txt"))))) 107 | 108 | (testing "large histories" 109 | (let [history (->> (range) 110 | (mapcat big-history-gen) 111 | (take 10000) 112 | h/history) 113 | r (check {:analyzer monotonic-key-graph} history)] 114 | (is (:valid? r))))) 115 | 116 | (deftest monotonic+process-test 117 | ; Here, we construct an order which is legal on keys AND is sequentially 118 | ; consistent, but the key order is incompatible with process order. 119 | (let [[r1 r2 :as history] 120 | (h/history [{:type :ok, :process 0, :f :read, :value {:x 1}} 121 | {:type :ok, :process 0, :f :read, :value {:x 0}}])] 122 | (testing "combined order" 123 | (let [{:keys [graph explainer]} 124 | ((combine monotonic-key-graph process-graph) history)] 125 | (is (= {r1 #{r2} r2 #{r1}} 126 | (g/->clj graph))))) 127 | (testing "independently valid" 128 | (is (= {:valid? true 129 | :scc-count 0 130 | :cycles []} 131 | (check {:analyzer monotonic-key-graph} history))) 132 | (is (= {:valid? true 133 | :scc-count 0 134 | :cycles []} 135 | (check {:analyzer process-graph} history)))) 136 | (testing "combined invalid" 137 | (is (= {:valid? false 138 | :scc-count 1 139 | :cycles ["Let:\n T1 = {:index 0, :time -1, :type :ok, :process 0, :f :read, :value {:x 1}}\n T2 = {:index 1, :time -1, :type :ok, :process 0, :f :read, :value {:x 0}}\n\nThen:\n - T1 < T2, because process 0 executed T1 before T2.\n - However, T2 < T1, because T2 observed :x = 0, and T1 observed a higher value 1: a contradiction!" 140 | ]} 141 | (check {:analyzer (combine monotonic-key-graph 142 | process-graph)} 143 | history)))))) 144 | 145 | (defn read-only-gen 146 | [v] 147 | (let [proc (rand-int 100)] 148 | [{:process proc, :type :ok, :f :read, :value {:x v :y v}}])) 149 | 150 | (deftest ^:overflow stackoverflow-test 151 | (testing "just inducing the depth limit problem" 152 | (let [history (->> (range) 153 | (mapcat read-only-gen) 154 | (take 1000000) 155 | h/history)] 156 | (time 157 | (dotimes [n 1] 158 | (print "Run" n ":") 159 | (time (let [r (check {:analyzer monotonic-key-graph} history)] 160 | (is (:valid? r))))))))) 161 | 162 | (defn graph 163 | "Takes a history, indexes it, uses the given analyzer function to construct a 164 | graph+explainer, extracts just the graph, converts it to Clojure, and removes 165 | indices and times from the ops." 166 | [analyzer history] 167 | (->> history 168 | h/history 169 | analyzer 170 | :graph 171 | g/->clj 172 | (map (fn [[k vs]] 173 | [(dissoc k :time :index) 174 | (map #(dissoc % :time :index) vs)])) 175 | (into {}))) 176 | 177 | (deftest realtime-graph-test 178 | ; We're gonna try a bunch of permutations of diff orders, so we'll index, 179 | ; analyze, then remove indices, to simplify comparison. This is safe because 180 | ; all ops are unique without indices. 181 | (let [o (comp (partial graph realtime-graph) h/history vector) 182 | a {:type :invoke, :process 1, :f :read, :value nil} 183 | a' {:type :ok :process 1, :f :read, :value 1} 184 | b {:type :invoke, :process 2, :f :read, :value nil} 185 | b' {:type :ok :process 2, :f :read, :value 2} 186 | c {:type :invoke, :process 3, :f :read, :value nil} 187 | c' {:type :ok :process 3, :f :read, :value 3} 188 | d {:type :invoke, :process 4, :f :read, :value nil} 189 | d' {:type :ok :process 4, :f :read, :value 4} 190 | e {:type :invoke, :process 5, :f :read, :value nil} 191 | e' {:type :ok :process 5, :f :read, :value 5}] 192 | (testing "empty history" 193 | (is (= {} (o)))) 194 | (testing "single op" 195 | (is (= {} (o a a')))) 196 | (testing "two sequential ops" 197 | (is (= {a' [b'], b' []} 198 | (o a a' b b')))) 199 | (testing "three ops in a row" 200 | (is (= {a' [b'], b' [c'], c' []} 201 | (o a a' b b' c c')))) 202 | (testing "one followed by two concurrent" 203 | (is (= {a' [c' b'], b' [], c' []} 204 | (o a a' b c c' b')))) 205 | (testing "two concurrent followed by one" 206 | (is (= {a' [c'], b' [c'], c' []} 207 | (o a b a' b' c c')))) 208 | (testing "two concurrent followed by two concurrent" 209 | (is (= {a' [c' d'], b' [c' d'], c' [], d' []} 210 | (o a b b' a' c d c' d')))) 211 | (testing "complex" 212 | ; ==a== ==c== ==e== 213 | ; ==b== 214 | ; ==d=== 215 | ; 216 | (is (= {a' [d' b'], b' [c'], c' [e'], d' [e'], e' []} 217 | (o a a' b d b' c d' c' e e')))))) 218 | 219 | 220 | (deftest ^:perf collapse-graph-test-perf 221 | ; Generate a random history 222 | (let [history (atom []) 223 | threads (real-pmap 224 | (fn [p] 225 | (dotimes [i 5000] 226 | ; Simulate a generation and random key 227 | (let [k [(mod i 32) (rand-int 5)]] 228 | (swap! history conj {:type :invoke, :process p, :key k }) 229 | (swap! history conj {:type :ok, :process p, :key k})))) 230 | (range 5)) 231 | history (h/history @history) 232 | graph (:graph (realtime-graph history))] 233 | (time 234 | (g/collapse-graph (comp #{[3 0]} :key) graph)))) 235 | -------------------------------------------------------------------------------- /test/elle/graph_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.graph-test 2 | (:require [bifurcan-clj [core :as b] 3 | [graph :as bg] 4 | [set :as bs]] 5 | [clojure [pprint :refer [pprint]]] 6 | [elle [core-test :as core-test] 7 | [graph :refer :all] 8 | [rels :refer :all]] 9 | [jepsen [history :as h] 10 | [txn :as txn]] 11 | [clojure.test :refer :all] 12 | [slingshot.slingshot :refer [try+ throw+]]) 13 | (:import (io.lacuna.bifurcan IMap 14 | Map))) 15 | 16 | (defn op 17 | "Takes a number, returns an Op with that as its index." 18 | [index] 19 | (h/op {:index index})) 20 | 21 | (def ops 22 | "An infinite series of ops with indices 0, 1, 2, ..." 23 | (map op (range))) 24 | 25 | (defn op-graph 26 | "Takes a graph of integers and lifts them into a graph of Ops where the 27 | integers are their index fields. We do this because our graph search is 28 | optimized for Ops, but we don't want to write a zillion ops in testing." 29 | [g] 30 | (map-vertices op g)) 31 | 32 | (def og core-test/op-graph) 33 | 34 | (defn indices 35 | "Takes a collection of Ops and extracts their indexes." 36 | [ops] 37 | (mapv :index ops)) 38 | 39 | (defn prng 40 | "Prints a graph, just indices." 41 | [g] 42 | (println (map-vertices :index g))) 43 | 44 | (deftest tarjan-test 45 | (let [tarjan (comp set tarjan)] 46 | (testing "Can analyze integer graphs" 47 | ;; From wikipedia 48 | (let [graph {1 #{2} 2 #{3} 49 | 3 #{1} 4 #{2 3 5} 50 | 5 #{4 6} 6 #{3 7} 51 | 7 #{6} 8 #{7 8}}] 52 | (is (= (tarjan graph) 53 | #{#{3 2 1} #{6 7} #{5 4}}))) 54 | 55 | ;; Big lööp 56 | (let [graph {1 #{2} 2 #{3} 57 | 3 #{4} 4 #{5} 58 | 5 #{6} 6 #{7} 59 | 7 #{8} 8 #{1}}] 60 | (is (= (tarjan graph) 61 | #{#{1 2 3 4 5 6 7 8}}))) 62 | 63 | ;; smol lööps 64 | (let [graph {0 #{1} 1 #{0} 65 | 2 #{3} 3 #{2} 66 | 4 #{5} 5 #{4} 67 | 6 #{7} 7 #{6}}] 68 | (is (= (tarjan graph) 69 | #{#{0 1} #{2 3} 70 | #{4 5} #{6 7}})))) 71 | 72 | (testing "Can flag unlinked as solo sccs" 73 | (let [graph {1 #{} 2 #{} 74 | 3 #{} 4 #{}}] 75 | (is (= (tarjan graph) 76 | #{})))) 77 | 78 | (testing "Can flag self-ref as solo sccs" 79 | (let [graph {1 #{1} 2 #{2} 80 | 3 #{3} 4 #{4}}] 81 | (is (= (tarjan graph) 82 | #{})))) 83 | 84 | (testing "can check monotonic loop histories" 85 | ;; Linear 86 | (let [graph {0 #{1} 1 #{2} 87 | 2 #{3} 3 #{}}] 88 | (is (= (tarjan graph) 89 | #{}))) 90 | 91 | ;; Loop 92 | (let [graph {0 #{1} 1 #{2} 93 | 2 #{1} 3 #{}}] 94 | (is (= (tarjan graph) 95 | #{#{1 2}}))) 96 | 97 | ;; Linear but previously bugged case 98 | (let [graph {0 #{1} 1 #{2} 99 | 2 #{} 3 #{2 1}}] 100 | (is (= (tarjan graph) 101 | #{}))) 102 | 103 | (let [graph {0 #{1} 1 #{0} 104 | 2 #{} 3 #{2 1}}] 105 | (is (= (tarjan graph) 106 | #{#{0 1}}))) 107 | 108 | ;; FIXME Busted case 109 | (let [graph {1 #{7 3 5} 3 #{7 5} 110 | 5 #{} 7 #{3 5}}] 111 | (is (= (tarjan graph) 112 | #{#{3 7}})))) 113 | 114 | (testing "can check a one node graph" 115 | (let [graph {0 #{}}] 116 | (is (= (tarjan graph) 117 | #{})))) 118 | 119 | (testing "busted" 120 | (let [graph {1 #{7 3 5} 3 #{7 5} 121 | 5 #{} 7 #{3 5}}] 122 | (is (= (tarjan graph) 123 | #{#{3 7}})))) 124 | 125 | (testing "wiki" 126 | (let [graph {1 #{2} 2 #{3} 127 | 3 #{1} 4 #{2 3 5} 128 | 5 #{4 6} 6 #{3 7} 129 | 7 #{6} 8 #{7 8}}] 130 | (is (= (tarjan graph) 131 | #{#{3 2 1} #{6 7} #{5 4}})))))) 132 | 133 | (deftest path-shells-test 134 | (let [g (map->bdigraph {0 [1 2] 1 [3] 2 [3] 3 [0]}) 135 | paths (path-shells g [[0]])] 136 | (is (= [[[0]] 137 | [[0 1] [0 2]] 138 | [[0 1 3]] 139 | [[0 1 3 0]]] 140 | (take 4 paths))))) 141 | 142 | (deftest find-cycle-test 143 | (let [g (map->bdigraph {0 [1 2] 144 | 1 [4] 145 | 2 [3] 146 | 3 [4] 147 | 4 [0 2]})] 148 | (testing "basic cycle" 149 | (is (= [3 4 2 3] 150 | (indices (find-cycle (op-graph g)))))) 151 | 152 | ; We may restrict a graph to a particular relationship and look for cycles 153 | ; in an SCC found in a larger graph; this should still work. 154 | (testing "scc without cycle in graph" 155 | (is (= nil 156 | (find-cycle (op-graph (bg/select g (bs/from #{0 2 4}))))))))) 157 | 158 | (deftest fallback-cycle-test 159 | (is (= [2 3 4 2] (fallback-cycle 160 | (map->bdigraph {1 [2] 161 | 2 [3] 162 | 3 [4] 163 | 4 [2]}))))) 164 | 165 | (deftest link-test 166 | (let [g (-> (digraph) 167 | (link 1 2 ww) 168 | (link 1 2 wr))] 169 | (is (= (union ww wr) (->clj (bg/edge g 1 2)))))) 170 | 171 | (deftest collapse-graph-test 172 | (testing "simple" 173 | (is (= (map->bdigraph {1 [3]}) 174 | (->> (map->bdigraph {1 [2] 175 | 2 [3]}) 176 | (collapse-graph odd?))))) 177 | 178 | (testing "complex" 179 | (is (= (map->bdigraph {1 [1 5 7] 180 | 3 [1 5 7 9]}) 181 | (->> (map->bdigraph {1 [4] 182 | 3 [4 9] 183 | 4 [5 6 7] 184 | 6 [1]}) 185 | (collapse-graph odd?)))))) 186 | 187 | (deftest map-vertices-test 188 | (testing "empty" 189 | (is (= (map->bdigraph {}) (map-vertices identity (map->bdigraph {}))))) 190 | 191 | (testing "complex" 192 | (is (= (-> (b/linear (digraph)) 193 | (link 1 1 ww) 194 | (link 1 2 wr) 195 | (link 1 2 rw)) 196 | (map-vertices {1 1, 2 1, 3 2, 4 2} 197 | (-> (b/linear (digraph)) 198 | (link 1 2 ww) ; becomes a self-edge 199 | (link 1 3 wr) ; becomes 1->2 200 | (link 2 4 rw) ; becomes 1->2 201 | )))))) 202 | 203 | (deftest rel-graph-test 204 | (let [[o0 o1 o2 o3 o4 o5 o6] (map #(h/op {:index %}) (range 7)) 205 | a (-> (op-digraph) 206 | (link o1 o2 ww) 207 | (link o1 o3 ww)) 208 | b (-> (op-digraph) 209 | (link o1 o2 wr) 210 | (link o1 o4 wr) 211 | (link o5 o6 wr)) 212 | g (reduce digraph-union (digraph-union) [a b])] 213 | (is (= true (.isDirected g))) 214 | (is (= #{o1 o2 o3 o4 o5 o6} (->clj (.vertices g)))) 215 | (is (= a (project-rels ww g))) 216 | (is (= b (project-rels wr g))) 217 | (is (= g (project-rels (union ww wr realtime) g))) 218 | (is (= #{o2 o3 o4} (->clj (.out g o1)))) 219 | (is (thrown? IllegalArgumentException (->clj (.out g o0)))) 220 | (is (= #{o6} (->clj (.out g o5)))))) 221 | 222 | (deftest sequential-composition-test 223 | (let [[x1 y1 y2 z1 z2 z3 q r s] ops 224 | a (og x1 ww y1 225 | x1 ww y2 226 | r ww s) 227 | b (og y1 ww z1 228 | y1 ww z2 229 | y2 ww z3 230 | r ww q 231 | q ww r)] 232 | (is (= (og x1 none z1 233 | x1 none z2 234 | x1 none z3) 235 | (sequential-composition a b))))) 236 | 237 | (deftest sequential-composition-omit-intermediates-test 238 | ; A neat little G2 graph that found a bug, I think 239 | (let [[t1 t2 t3 t4] ops 240 | g (og t1 ww t3 241 | t1 wr t4 242 | t2 rw t1 243 | t3 rw t2 244 | t3 rw t4 245 | t4 rw t3) 246 | g-ww+wr (project-rels (union ww wr) g) 247 | g-rw (project-rels rw g)] 248 | (is (= (og t1 ww t3 249 | t1 wr t4) 250 | g-ww+wr)) 251 | (is (= (og t2 rw t1 252 | t3 rw t2 253 | t3 rw t4 254 | t4 rw t3) 255 | g-rw)) 256 | ; The sequential composition `ww+wr ; rw`, if we followed the mathematical 257 | ; definition, would be: 258 | ; 259 | ; t1 -> t2 (via t3) 260 | ; t1 -> t3 (via t4) 261 | ; t1 -> t4 (via t3) 262 | ; 263 | ; Which would make the sequential extension ww+wr U (ww+wr ; rw): 264 | ; 265 | ; t1 -> t2 266 | ; t1 -> t3 267 | ; t1 -> t4 268 | ; 269 | ; Note that both these graphs are acyclic. We thought we'd be clever and 270 | ; retain the intermediate vertices in the sequential composition. But this 271 | ; causes us to include extra edges in the graph. In particular, this pair 272 | ; of double-hops: 273 | ; 274 | ; t1 ww t3 rw t4 should collapse to t1 -> t4 275 | ; t1 wr t4 rw t3 should collapse to t1 -> t3 276 | ; 277 | ; ... if we retain the original edges, we include an rw cycle between t3 278 | ; and t4! This is *not* acyclic! 279 | ; 280 | ; This is why we must omit intermediate edges. 281 | (is (= (og t1 none t2 ; Via t3 282 | t1 none t3 ; Via t4 283 | t1 none t4) ; Via t3 284 | (sequential-composition g-ww+wr g-rw))) 285 | (is (= (og t1 none t2 ; Via t3 286 | t1 ww t3 ; Via t4 287 | t1 wr t4) ; Via t3 288 | (sequential-extension g-ww+wr g-rw))))) 289 | 290 | (deftest topo-depths-test 291 | (is (= {:a1 0 :a2 0 292 | :b1 1 293 | :c1 2 :c2 2} 294 | (topo-depths (map->dag {:a1 [:b1] 295 | :a2 [:b1] 296 | :b1 [:c1 :c2]}))))) 297 | -------------------------------------------------------------------------------- /test/elle/rels_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.rels-test 2 | (:require [clojure [test :refer :all] 3 | [pprint :refer [pprint]]] 4 | [clojure.set :as set] 5 | [elle [rels :refer :all]]) 6 | (:import (elle BitRels))) 7 | 8 | (deftest raw-difference-test 9 | (are [expected rels minus] 10 | (= expected 11 | (.toClojure 12 | (BitRels. 13 | (BitRels/rawDifference (.rels (apply union rels)) 14 | (.rels (apply union minus)))))) 15 | #{:ww} [ww wr] [wr rw] 16 | #{:rwp :realtime} [rwp rw realtime] [rw] 17 | #{:rw} [rwp rw realtime] [realtime rwp])) 18 | 19 | (deftest raw-intersection-test 20 | (are [expected as bs] 21 | (= expected 22 | (.toClojure 23 | (BitRels. 24 | (BitRels/rawIntersection (.rels (apply union as)) 25 | (.rels (apply union bs)))))) 26 | #{} [ww wr] [wrp rwp] 27 | #{:realtime} [ww realtime] [realtime rw] 28 | #{:process :rwp} [rwp process ww] [rwp process wr])) 29 | 30 | (deftest to-clojure-test 31 | (are [expected rels] (= expected (.toClojure (apply union rels))) 32 | #{} [] 33 | #{:ww} [ww] 34 | #{:ww :realtime} [ww realtime])) 35 | 36 | (deftest iterate-test 37 | (is (= nil (seq none))) 38 | (are [rels] (= rels (seq (apply union rels))) 39 | [ww] 40 | [rw] 41 | [process] 42 | [realtime] 43 | [rwp] 44 | [ww wr] 45 | [ww rw realtime] 46 | [ww rwp realtime])) 47 | -------------------------------------------------------------------------------- /test/elle/txn_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.txn-test 2 | (:require [bifurcan-clj [core :as b] 3 | [set :as bs]] 4 | [clojure [pprint :refer [pprint]] 5 | [test :refer :all]] 6 | [elle [graph :as g] 7 | [graph-test :refer [ops og]] 8 | [rels :refer :all] 9 | [txn :refer :all]] 10 | [jepsen [history :as h]])) 11 | 12 | (defn valid-mop? 13 | [[f k v]] 14 | (is (#{:r :w} f)) 15 | (is (integer? k)) 16 | (case f 17 | :r (is (= nil v)) 18 | (is (integer? v)))) 19 | 20 | (deftest wr-txns-test 21 | (let [txns (take 100 (wr-txns {:key-count 3})) 22 | mops (mapcat identity txns) 23 | ks (map second mops) 24 | key-dist (frequencies ks)] 25 | (is (every? vector? txns)) 26 | (is (every? #(<= 1 (count %) 2) txns)) 27 | (is (every? valid-mop? mops)) 28 | ; This is gonna vary by RNG, but there are 3 keys per pool by default, 29 | ; and their frequency (for the first 3 anyway) should be in ascending order. 30 | (is (< (key-dist 0) (key-dist 1) (key-dist 2))))) 31 | 32 | (defn fg 33 | "Wraps a graph in a filtered-graphs fn." 34 | [g] 35 | #(g/project-rels % g)) 36 | 37 | (deftest cycle-exists-subgraph-test 38 | ; A simple G-single; stresses the AST interpreter for subgraphs, union, 39 | ; composition, extension. 40 | (let [[op0 op1 op2 op3] ops 41 | g (-> (g/op-digraph) 42 | (g/link op0 op1 wr) 43 | (g/link op1 op2 ww) 44 | (g/link op2 op0 rw) 45 | ; Double-rw link to op3 46 | (g/link op0 op3 rw)) 47 | fg (fg g)] 48 | (testing "simple keyword" 49 | (is (= (-> (g/op-digraph) 50 | (g/link op1 op2 ww)) 51 | (cycle-exists-subgraph fg ww)))) 52 | (testing "union" 53 | (is (= (-> (g/op-digraph) 54 | (g/link op0 op1 wr) 55 | (g/link op1 op2 ww)) 56 | (cycle-exists-subgraph fg [:union ww wr])))) 57 | (testing "composition" 58 | (is (= (og op1 none op0) ; Through ww-rw 59 | (cycle-exists-subgraph fg [:composition ww rw])))) 60 | (testing "extension" 61 | (is (= (og op0 wr op1 ; Original wr edge 62 | op1 ww op2 ; Original ww edge 63 | op1 none op0) ; Through ww-rw 64 | (cycle-exists-subgraph fg [:extension [:union ww wr] rw])))))) 65 | 66 | (deftest cycle-exists-cases-G-single-test 67 | ; A simple G-single; stresses the AST interpreter for subgraphs and also the 68 | ; sequential extension mechanism 69 | (let [[op0 op1] ops 70 | g (og op0 ww op1 71 | op1 rw op0) 72 | cases (cycle-exists-cases (fg g))] 73 | (is (= [{:type :PL-SI-cycle-exists 74 | :not :snapshot-isolation 75 | :subgraph [:extension [:union :ww :wwp :wr :wrp] 76 | [:union :rw :rwp]] 77 | :scc-size 1 ; Because of our sequential extension trick! 78 | :scc #{0}} 79 | {:type :PL-2.99-cycle-exists 80 | :not :repeatable-read 81 | :subgraph [:union :ww :wwp :wr :wrp :rw] 82 | :scc-size 2 83 | :scc #{0 1}}] 84 | cases)))) 85 | -------------------------------------------------------------------------------- /test/elle/util_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.util-test 2 | (:require [clojure [test :refer :all]] 3 | [elle.util :as u])) 4 | 5 | (deftest fand-test 6 | (testing "unary" 7 | (let [f (u/fand [#{1 3}])] 8 | (is (= 1 (f 1))) 9 | (is (= nil (f 2))) 10 | (is (= 3 (f 3))))) 11 | 12 | (testing "binary" 13 | (let [f (u/fand [#{1 3} #{2 3}])] 14 | (is (= nil (f 1))) 15 | (is (= nil (f 2))) 16 | (is (= 3 (f 3))))) 17 | 18 | (testing "nary" 19 | (let [f (u/fand [#{1 4} #{2 4} #{3 4}])] 20 | (is (= nil (f 1))) 21 | (is (= nil (f 2))) 22 | (is (= nil (f 3))) 23 | (is (= 4 (f 4)))))) 24 | -------------------------------------------------------------------------------- /test/elle/viz_test.clj: -------------------------------------------------------------------------------- 1 | (ns elle.viz-test 2 | (:require [clojure.pprint :refer [pprint]] 3 | [elle [core :as elle] 4 | [graph :as g] 5 | [viz :refer :all] 6 | [txn :as t] 7 | [list-append :as la] 8 | [list-append-test :as lat :refer [pair]] 9 | [rw-register :as r] 10 | [rw-register-test :as rt]] 11 | [jepsen.history :as h] 12 | [clojure.test :refer :all])) 13 | 14 | (defn list-analysis 15 | [] 16 | (let [[t1 t1'] (pair (lat/op 1 :ok "ax1ry1rz12")) 17 | [t2 t2'] (pair (lat/op 2 :ok "az1")) 18 | [t3 t3'] (pair (lat/op 3 :ok "rx12rz1")) 19 | [t4 t4'] (pair (lat/op 4 :ok "az2ay1")) 20 | [t5 t5'] (pair (lat/op 5 :ok "rzax2")) 21 | h (h/history [t3 t3' t1 t1' t2 t2' t4 t4' t5 t5']) 22 | 23 | analyzer (elle/combine la/graph elle/realtime-graph)] 24 | (elle/check- analyzer h))) 25 | 26 | (deftest ^:interactive view-scc-test 27 | (let [a (list-analysis)] 28 | (view-scc a (first (:sccs a))))) 29 | 30 | (deftest plot-analysis!-test 31 | (plot-analysis! (list-analysis) "plots/list-append")) 32 | 33 | (defn register-analysis 34 | [] 35 | (let [[t1 t1'] (pair (rt/op 1 :ok "wx1ry1")) 36 | [t2 t2'] (pair (rt/op 1 :ok "wx2")) 37 | [t3 t3'] (pair (rt/op 2 :ok "rx2wy1")) 38 | [t4 t4'] (pair (rt/op 3 :ok "rx1")) 39 | h (h/history [t1 t1' t2 t2' t3 t3' t4 t4']) 40 | 41 | analyzer (partial r/graph {:additional-graphs [elle/process-graph] 42 | :sequential-keys? true})] 43 | (elle/check- analyzer h))) 44 | 45 | (deftest ^:interactive view-r-scc-test 46 | (let [a (register-analysis)] 47 | (view-scc a (first (:sccs a))))) 48 | 49 | (deftest plot-r-analysis!-test 50 | (plot-analysis! (register-analysis) "plots/rw-register")) 51 | --------------------------------------------------------------------------------