├── .gitignore ├── LICENSE ├── README.md ├── doc ├── gretchen.gif └── intro.md ├── project.clj ├── src └── gretchen │ ├── bottleneck.clj │ ├── constraint.clj │ ├── constraint │ └── flatzinc.clj │ ├── core.clj │ ├── gen.clj │ ├── graph.clj │ ├── history.clj │ ├── recurset.clj │ └── util.clj └── test └── gretchen ├── bottleneck_test.clj ├── constraint └── flatzinc_test.clj ├── constraint_test.clj ├── core_test.clj ├── gen_test.clj ├── graph_test.clj ├── history_test.clj └── recurset_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | ~* 9 | *.swp 10 | /.lein-* 11 | /.nrepl-port 12 | .hgignore 13 | .hg/ 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Gretchen 2 | 3 | ![Gretchen Wieners. She knows every transaction's business. She thinks about 4 | every ordering of every history. That's why her state space is so big--it's 5 | full of secrets.](doc/gretchen.gif) 6 | 7 | Gretchen takes a history: a collection of transactions of reads or writes over 8 | a set of named registers, and determines whether that history is 9 | *serializable*: informally, whether there exists some sequential execution of 10 | those transactions with equivalent effects. We adapt [Cerone, Bernardi, and 11 | Gotsman's formulation of transactional consistency 12 | models](http://drops.dagstuhl.de/opus/volltexte/2015/5375/pdf/15.pdf), 13 | decomposing serializability into internal and external consistency, plus a 14 | total visibility order, and verify external consistency by solving a constraint 15 | problem for that ordering. We use fzn-gecode as our solver. 16 | 17 | This problem is almost too NP to function, but with some heuristics, we should 18 | be able to assess reasonably-sized histories. 19 | 20 | Like [Knossos](https://github.com/jepsen-io/knossos), Gretchen is intended to 21 | analyze observed histories of operations from real databases, generated by the 22 | [Jepsen](https://github.com/jepsen-io/jepsen) distributed systems testing tool. 23 | 24 | Gretchen is experimental. The input and output formats and error types will 25 | probably change. It does detect known serializability errors, and finds 26 | solutions for generated serializable histories. However, we have not verified 27 | its behavior in depth, the solver often segfaults, and key optimizations are 28 | not yet in place. 29 | 30 | There is no support for verifying strict serializability, though we should be 31 | able to add this by introducing restrictions on transaction order based on 32 | invocation/completion order. There is no representation of predicates, so we 33 | cannot verify phantoms. There is no support for indeterminate transactions, 34 | which may have succeeded or failed; the caller is responsible for determining 35 | the total set of transactions which constitute a history. 36 | 37 | See `gretchen.core` for an in-depth discussion. 38 | 39 | ## Installation 40 | 41 | We rely on lacuna/bifurcan, which you can build with `lein install`. 42 | 43 | You'll need the Flatzinc gecode constraint solver on your path. On Debian, you 44 | can install it with `sudo apt-get install flatzinc`. 45 | 46 | An operation is a map of the form: 47 | 48 | ```clj 49 | {:f A function, either :read or :write 50 | :k A key, e.g. a keyword or string 51 | :v A value to read or write} 52 | ``` 53 | 54 | A transaction is a map with a single mandatory key: a sequence of operations. 55 | Gretchen may internally augment a transaction with additional fields. 56 | 57 | ```clj 58 | {:ops [op1, op2, ...]} 59 | ``` 60 | 61 | As a shorthand, we can use `(t op1 op2 ...)` to build a transaction, `(r key 62 | value)` for a read, and `(w key value)` for a write. 63 | 64 | ```clj 65 | user=> (require '[gretchen.gen :refer [t r w]]) 66 | user=> (t (w :x 0) (r :y 1)) 67 | {:ops (0 {:f :read :k :y :v 1})} 68 | ``` 69 | 70 | A history is a map with an initial state, and a collection of transactions. For instance, 71 | 72 | ```clj 73 | user=> (require '[gretchen.gen :as gen]) 74 | user=> (gen/history 2 {:x 0 :y 0}) 75 | {:initial {:epoch 0 :x 0 :y 0} 76 | :txns ({:ops [{:f :read :k :epoch :v 0} 77 | {:f :read :k :y :v 0} 78 | {:f :write :k :x :v 20}]} 79 | {:ops [{:f :read :k :epoch :v 0} 80 | {:f :read :k :x :v 20} 81 | {:f :read :k :x :v 20} 82 | {:f :write :k :x :v 58} 83 | {:f :read :k :y :v 0}]})} 84 | ``` 85 | 86 | To check a history, use `gretchen.core/check` with a solver. `check` returns an 87 | augmented history, numbering transactions with an index `:i`, computing indices 88 | of external reads and writes over values of registers, and deriving a 89 | serialization of the history, if one exists. Gretchen introduces an initial transaction at `:i 0` to establish the initial state. 90 | 91 | ```clj 92 | user=> (require '[gretchen.constraint.flatzinc :refer [flatzinc]]) 93 | user=> (require '[gretchen.core :as g]) 94 | user=> (g/check (gen/history 3 {:x 0 :y 0}) (flatzinc)) 95 | {:ext-reads {:epoch {0 (3 2 1)} :x {0 (2 1)} :y {0 (1) 36 (3 2)}} 96 | :ext-writes {:epoch {0 (0)} :x {0 (0)} :y {0 (0) 36 (1)}} 97 | :initial {:epoch 0 :x 0 :y 0} 98 | :solution ({:i 0 99 | :ops ({:f :write :k :x :v 0} 100 | {:f :write :k :y :v 0} 101 | {:f :write :k :epoch :v 0})} 102 | {:i 1 103 | :ops [{:f :read :k :epoch :v 0} 104 | {:f :read :k :y :v 0} 105 | {:f :read :k :x :v 0} 106 | {:f :write :k :y :v 36}]} 107 | {:i 2 108 | :ops [{:f :read :k :epoch :v 0} 109 | {:f :read :k :x :v 0} 110 | {:f :read :k :x :v 0} 111 | {:f :read :k :y :v 36}]} 112 | {:i 3 :ops [{:f :read :k :epoch :v 0} {:f :read :k :y :v 36}]}) 113 | :txns ({:i 0 114 | :ops ({:f :write :k :x :v 0} 115 | {:f :write :k :y :v 0} 116 | {:f :write :k :epoch :v 0})} 117 | {:i 1 118 | :ops [{:f :read :k :epoch :v 0} 119 | {:f :read :k :y :v 0} 120 | {:f :read :k :x :v 0} 121 | {:f :write :k :y :v 36}]} 122 | {:i 2 123 | :ops [{:f :read :k :epoch :v 0} 124 | {:f :read :k :x :v 0} 125 | {:f :read :k :x :v 0} 126 | {:f :read :k :y :v 36}]} 127 | {:i 3 :ops [{:f :read :k :epoch :v 0} {:f :read :k :y :v 36}]})} 128 | ``` 129 | 130 | Gretchen can identify internal consistency errors; for instance, failing to 131 | read a prior write from a transaction: 132 | 133 | ```clj 134 | user=> (g/check {:txns [(t (w :x 1) (r :x 2))]} 135 | (flatzinc)) 136 | {:errors ({:error {:expected 1 :op {:f :read :k :x :v 2} :type :internal} 137 | :i 1 138 | :ops [{:f :write :k :x :v 1} {:f :read :k :x :v 2}]}) 139 | ...} 140 | ``` 141 | 142 | Or external consistency errors. For instance, a lost update, where two 143 | transactions both compare-and-set 0 to 1: 144 | 145 | ```clj 146 | user=> (g/check {:initial {:x 0} 147 | :txns [(t (r :x 0) (w :x 1)) 148 | (t (r :x 0) (w :x 1))]} 149 | (flatzinc)) 150 | {:error {:type :no-ext-solution} 151 | :ext-reads {:x {0 (2 1)}} 152 | :ext-writes {:x {0 (0) 1 (2 1)}} 153 | :initial {:x 0} 154 | :txns ({:i 0 :ops ({:f :write :k :x :v 0})} 155 | {:i 1 :ops ({:f :read :k :x :v 0} {:f :write :k :x :v 1})} 156 | {:i 2 :ops ({:f :read :k :x :v 0} {:f :write :k :x :v 1})})} 157 | ``` 158 | 159 | Or read skew, in which a transaction overwrites values between another 160 | transaction's reads. 161 | 162 | ```clj 163 | user=> (g/check {:initial {:x 0, :y 0} 164 | :txns [(t (r :x 0) (r :y 1)) 165 | (t (w :x 1) (w :y 1))]} 166 | (flatzinc)) 167 | {:error {:type :no-ext-solution} 168 | :ext-reads {:x {0 (1)} :y {1 (1)}} 169 | :ext-writes {:x {0 (0) 1 (2)} :y {0 (0) 1 (2)}} 170 | :initial {:x 0 :y 0} 171 | :txns ({:i 0 :ops ({:f :write :k :x :v 0} {:f :write :k :y :v 0})} 172 | {:i 1 :ops ({:f :read :k :x :v 0} {:f :read :k :y :v 1})} 173 | {:i 2 :ops ({:f :write :k :x :v 1} {:f :write :k :y :v 1})})} 174 | ``` 175 | 176 | Or write skew. This history is legal under Snapshot Isolation, because the two 177 | transactions' write sets do not intersect; however, either transaction's 178 | completion would invalidate the other's reads. 179 | 180 | ```clj 181 | user=> (g/check {:initial {:x 0, :y 0} 182 | :txns [(t (r :x 0) (r :y 0) (w :x 1)) 183 | (t (r :x 0) (r :y 0) (w :y 2))]} 184 | (flatzinc)) 185 | {:error {:type :no-ext-solution} 186 | :ext-reads {:x {0 (2 1)} :y {0 (2 1)}} 187 | :ext-writes {:x {0 (0) 1 (1)} :y {0 (0) 2 (2)}} 188 | :initial {:x 0 :y 0} 189 | :txns ({:i 0 :ops ({:f :write :k :x :v 0} {:f :write :k :y :v 0})} 190 | {:i 1 191 | :ops ({:f :read :k :x :v 0} 192 | {:f :read :k :y :v 0} 193 | {:f :write :k :x :v 1})} 194 | {:i 2 195 | :ops ({:f :read :k :x :v 0} 196 | {:f :read :k :y :v 0} 197 | {:f :write :k :y :v 2})})} 198 | ``` 199 | 200 | For more examples, see `gretchen.core-test`. 201 | 202 | ## License 203 | 204 | Copyright © 2016 Kyle Kingsbury 205 | 206 | Distributed under the Eclipse Public License either version 1.0 or (at 207 | your option) any later version. 208 | -------------------------------------------------------------------------------- /doc/gretchen.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/aphyr/gretchen/bb7c4439884494a218561bc08a164ff0da84af36/doc/gretchen.gif -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to regina 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject gretchen "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.8.0"] 7 | [potemkin "0.4.3"] 8 | [io.lacuna/bifurcan "0.1.0-alpha1"] 9 | [loco "0.3.1"]] 10 | :profiles {:dev {:dependencies [[org.clojure/math.numeric-tower "0.0.4"] 11 | [org.clojure/test.check "0.9.0"]]}} 12 | :jvm-opts ["-Xmx12g" 13 | "-XX:+UseConcMarkSweepGC" 14 | "-XX:+UseParNewGC" 15 | "-XX:+CMSParallelRemarkEnabled" 16 | "-XX:+AggressiveOpts" 17 | "-XX:+UseFastAccessorMethods" 18 | "-XX:+CMSClassUnloadingEnabled" 19 | "-XX:-OmitStackTraceInFastThrow" 20 | ]) 21 | -------------------------------------------------------------------------------- /src/gretchen/bottleneck.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.bottleneck 2 | "Imagine a history H of transactions with a partial precedence order < over 3 | those transactions. In generality, we might have to consider every possible 4 | permutation of those transactions, which is expensive. 5 | 6 | However, if we are lucky, there might exist a *bottleneck* transaction 7 | c--perhaps inserted by a magnanimous tester who produced the history in the 8 | first place--which cleanly cuts the other transactions in the history into 9 | two sets A and B, such that: 10 | 11 | 0. (c ∉ A) ∧ (c ∉ B) Neither A nor B contains c 12 | 1. A ∩ B = {} A and B are disjoint 13 | 2. A ∪ B ∪ {c} = H A, B, and c partition (loosely, A and B might be empty) 14 | the history 15 | 3. ∀ a ∈ A, a < c A precedes c 16 | 4. ∀ b ∈ B, c < b c precedes B 17 | 18 | Visually: 19 | 20 | A c B 21 | ______|______ | _____|_____ 22 | | | | | | 23 | /-a1--a3| /-b0--b2 24 | a0 ---c--- 25 | |-a2--a4/ |-b1 26 | 27 | To abuse notation, since A < c < B, then A < B. This implies that no 28 | transactions in B can affect the serializability of A. This gives us two 29 | advantages: 30 | 31 | 1. If A is nonserializable, H must be nonserializable. This lets us identify 32 | illegal histories more quickly, and *localize* the fault to a particular 33 | part of the history. 34 | 35 | 2. If all keys externally read in B were externally read or written by c, 36 | then the serializability of B does not depend on the serialization we 37 | choose for A. Why? Because c sets out a complete initial state for the 38 | transactions in B, and no transaction from A could interfere. We call c 39 | \"total\" in this case, and \"partial\" otherwise. 40 | 41 | For example, consider: 42 | 43 | 1. Say our transactions implement a series of counters {x 0, y 44 | 0}, and most transactions get and increment a single counter by one. But 45 | every so often, a transaction occurs that sets all counters to, say, {x 46 | 1000, y 1000}, then {x 2000, y 2000}--values which would not be reachable 47 | by regular increments alone. We can infer that these resetting 48 | transactions are total bottlenecks. 49 | 50 | 2. Or alternatively, imagine a special epoch key which is periodically 51 | incremented, and read by every transaction, segmenting transactions into 52 | groups. This is effectively a view change algorithm: writes to the epoch 53 | constitute bottlenecks. 54 | 55 | 3. Or consider a history in which all transactions read and write the same 56 | set of variables, and no state is ever repeated--perhaps a series of 57 | additions to a set, or increments to a single counter. The dependency graph 58 | is *linear* in this case, and every transaction is a total bottleneck. 59 | 60 | If c is total, we can verify the serializability of H by checking that A ∪ 61 | {c} is serializable, and that {c} ∪ B is serializable. Any serialization S_A 62 | for A, and S_B for B, can be stitched together to form a serialization for 63 | the complete history S_H = S_A + (S_B without the initial c). 64 | 65 | If c is *not* total, then the serializability of B depends on the order we 66 | choose for A. However, we can exploit degeneracy at the bottleneck: it is 67 | likely the case that there are only a few possible outcomes for A, though 68 | there could be many more possible serializations. Wetherefore compute 69 | *all* serializations of A ∪ {c}, but only retain the set of distinct 70 | outcome states from those histories: O. 71 | 72 | We can then check B by taking each state o ∈ O, and verifying that B is 73 | serializable beginning with state O. If we wish to find *any* serialization, 74 | we can pick any serialization for B, preceded by any serialization of A ∪ {c} 75 | which produced the bottleneck state O. If we wish to find all possible 76 | outcome states--for instance, as a part of a recursive solution to a history 77 | with many bottlenecks, we do not need to retain every serialization of A ∪ 78 | {c}. A single serialization from A ∪ {c} for each bottleneck state o will 79 | suffice." 80 | (:require [clojure.set :as set] 81 | [gretchen [history :as h] 82 | [recurset :as recurset] 83 | [util :refer :all]])) 84 | 85 | (defn bottlenecks- 86 | "This function takes an augmented history, and returns a collection of 87 | bottleneck transactions. 88 | 89 | We do this by identifying transactions t which have a casual relationship with 90 | every other transaction o in the history: either t < o, or o < t." 91 | [history] 92 | (let [txns (set (:txns history)) 93 | ; A map of tranactions to recursets of transactions that they depend 94 | ; on. 95 | ancestors (h/ancestors history) 96 | ; A map of transactions to the set of transactions which must depend on 97 | ; them. 98 | candidates (persistent! 99 | (reduce (fn [candidates [t ancestors-of-t]] 100 | (assoc! candidates t 101 | (set/difference 102 | txns 103 | #{t} 104 | (recurset/to-set ancestors-of-t)))) 105 | (transient {}) 106 | ancestors))] 107 | (keys 108 | (reduce (fn [candidates t] 109 | ; For every transaction t... 110 | (let [ancestors-of-t (recurset/to-set (get ancestors t))] 111 | (reduce (fn [candidates [candidate required]] 112 | ; For every candidate 113 | (cond ; candidate already has a relationship with t 114 | (not (required t)) candidates 115 | 116 | ; candidate is an ancestor of t 117 | (ancestors-of-t candidate) candidates 118 | 119 | ; We can't prove any relationship 120 | true 121 | (dissoc candidates candidate))) 122 | candidates 123 | candidates))) 124 | candidates 125 | txns)))) 126 | -------------------------------------------------------------------------------- /src/gretchen/constraint.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.constraint 2 | "Polymorphic interface for constraint generation." 3 | (:require [potemkin :refer [definterface+]] 4 | [clojure.core :as c] 5 | [clojure.pprint :refer [pprint]] 6 | [clojure.walk :as walk] 7 | [loco.constraints :as loco] 8 | [clojure.set :as set] 9 | [loco.core] 10 | [gretchen.util :refer [fixed-point]]) 11 | (:refer-clojure :exclude [t and or not < <= distinct type])) 12 | 13 | (definterface+ Solver 14 | (solution [s c])) 15 | 16 | (defn t [] true) 17 | (defn f [] false) 18 | (defn v [v] (keyword (str v))) 19 | (defn and [& as] (vec (cons 'and as))) 20 | (defn or [& as] (vec (cons 'or as))) 21 | (defn and* [as] (vec (cons 'and as))) 22 | (defn or* [as] (vec (cons 'or as))) 23 | (defn not [a] ['not a]) 24 | (defn < [a b] ['< a b]) 25 | (defn <= [a b] ['<= a b]) 26 | (defn bool [v] ['bool v]) 27 | (defn in [v min max] ['in v min max]) 28 | (defn distinct [vs] (vec (cons 'distinct vs))) 29 | 30 | (defn unfurl-binary-operators 31 | "Takes a Clojure tree and unfurls n-arity relations to binary form." 32 | [tree] 33 | (walk/postwalk (fn [tree] 34 | (if (c/and (sequential? tree) 35 | (c/or (= 'and (first tree)) 36 | (= 'or (first tree)) 37 | (= '< (first tree)) 38 | (= '<= (first tree)))) 39 | (reduce (partial vector (first tree)) (next tree)) 40 | tree)) 41 | tree)) 42 | 43 | 44 | (defn simplify-1 45 | "Simplify a Clojure constraint, in one pass." 46 | [c] 47 | ; Terminals 48 | (if-not (sequential? c) 49 | c ; Can't optimize terminals 50 | (let [[type & children] c 51 | children (map simplify-1 children) ; Recursively simplify 52 | c (vec (cons type children))] ; Rebuild expression 53 | (condp = type 54 | 'and (condp = (count children) 55 | 0 true 56 | 1 (second c) 57 | (reduce (fn [as a] 58 | (cond ; Short-circuit false 59 | (false? a) 60 | false 61 | 62 | ; Skip constant true 63 | (true? a) 64 | as 65 | 66 | ; Flatten nested and 67 | (c/and (sequential? a) (= 'and (first a))) 68 | (into as (next a)) 69 | 70 | :else 71 | (conj as a))) 72 | ['and] 73 | (c/distinct children))) 74 | 'or (condp = (count children) 75 | 0 true 76 | 1 (second c) 77 | (reduce (fn [as a] 78 | (cond ; Short-circuit true 79 | (true? a) 80 | true 81 | 82 | ; Skip constant false 83 | (false? a) 84 | as 85 | 86 | ; Flatten nested and 87 | (c/and (sequential? a) (= 'or (first a))) 88 | (into as (next a)) 89 | 90 | :else 91 | (conj as a))) 92 | ['or] 93 | (c/distinct children))) 94 | 'not (let [child (first children)] 95 | (cond ; Constant negation 96 | (true? child) false 97 | (false? child) true 98 | 99 | ; Double negation 100 | (c/and (sequential? child) (= 'not (first child))) 101 | (second child) 102 | 103 | ; Pass through 104 | true 105 | c)) 106 | 107 | ; All other node types are unoptimized 108 | c)))) 109 | 110 | (defn common-subexpressions 111 | "Identifies subexpressions which must be true in all branches of an 112 | expression." 113 | [c] 114 | (if-not (sequential? c) 115 | #{c} 116 | (let [[type & children] c] 117 | (condp = type 118 | 'and (reduce set/union (map common-subexpressions children)) 119 | 'or (if (seq children) 120 | (reduce set/intersection (map common-subexpressions children)) 121 | #{}) 122 | #{c})))) 123 | 124 | (defn simplify-cse 125 | "Simplify a Clojure constraint by eliminating common subexpressions, moving 126 | them to a top-level 'and." 127 | [c] 128 | (let [common (common-subexpressions c)] 129 | (if-not (seq common) 130 | c ; Nothing to eliminate 131 | (vec (into ['and (walk/postwalk-replace 132 | (fn rep [c] (or (contains? common c) c)) c)] 133 | common))))) 134 | 135 | (defn simplify 136 | "Simplify-1 until done." 137 | [c] 138 | (->> c 139 | ; (fixed-point simplify-1) 140 | ; simplify-cse 141 | (fixed-point simplify-1))) 142 | 143 | (defn cnf-literal? 144 | "Is the given Clojure constraint tree a CNF literal? In our case, we want to 145 | make sure there's no 'and or 'or nodes in the tree--inequalities are 146 | considered literals, and of course 'nots are as well." 147 | [tree] 148 | (->> tree 149 | (tree-seq sequential? next) 150 | (filter sequential?) 151 | (map first) 152 | (not-any? #{'and 'or}))) 153 | 154 | (defn cnf-or-of-literals? 155 | "Is the given tree either a literal, or an or of literals?" 156 | [tree] 157 | (c/or (cnf-literal? tree) 158 | (c/and (= 'or (first tree)) 159 | (every? cnf-literal? (next tree))))) 160 | 161 | (defn cnf? 162 | "Is a given tree in CNF? e.g. is it: 163 | 164 | - a literal 165 | - an or of literals 166 | - and and of ors of literals" 167 | [tree] 168 | (c/or (cnf-literal? tree) 169 | (cnf-or-of-literals? tree) 170 | (c/and (= 'and (first tree)) 171 | (every? cnf-or-of-literals? (next tree))))) 172 | 173 | (defn ops-to-vars 174 | "For the Tseitin transformation, takes a tree and returns a map of and/or 175 | nodes to vars :v1, v2, where numbering begins at n." 176 | [tree n] 177 | (->> 178 | tree 179 | (tree-seq sequential? next) 180 | (remove cnf-literal?) 181 | (reduce 182 | (fn [[i m] [type & children :as tree]] 183 | (assert (c/or (= 'and type) 184 | (= 'or type) 185 | (= 'not type)) 186 | (str "Don't know how to tseitin-expand node " 187 | (pr-str tree))) 188 | [(inc i) 189 | (assoc m tree (keyword (str "_t" (+ n i))))]) 190 | [0 {}]) 191 | second)) 192 | 193 | (defn and-terms 194 | "Given a var representing an and axpression, and a sequence of vars in the 195 | and, returns a seq of disjunctions for the tseitin expansion of that op" 196 | [v args] 197 | ; x <-> (and y z) <=> (and (or x (not y)) (or x (not z)) (or (not x) y z)) 198 | (conj (mapv (partial vector 'or ['not v]) args) 199 | (apply vector 'or v (map (partial vector 'not) args)))) 200 | 201 | (defn or-terms 202 | "Given a var representing an or expression, and a sequence of vars in the or, 203 | returns a seq of disjunctions for the tseitin expansion of that op." 204 | [v args] 205 | ; x <-> (or y z) <=> (and (or x (not y)) (or x (not z)) (or (not x) y z)) 206 | (conj (mapv (fn invert [a] ['or v ['not a]]) args) 207 | (apply vector 'or ['not v] args))) 208 | 209 | (defn not-terms 210 | "Given a var representing a not expression, and the negated var, returns a seq of disjunctions for the tseitin expansion of that op." 211 | [v a] 212 | ; x <-> (not y) <=> (and (or (not x) (not y)) (or x y)) 213 | [['or v a] 214 | ['or ['not v] ['not a]]]) 215 | 216 | (defn flatten-ops 217 | "Takes a map of operations to vars and constructs a sequence of disjunctions 218 | for those ops." 219 | [ops-to-vars] 220 | (mapcat (fn [[op v]] 221 | (let [[type & args] op 222 | ; Replace child terms with their tseitin variables 223 | args (if (sequential? args) 224 | (map (fn [a] (get ops-to-vars a a)) args) 225 | args)] 226 | (condp = type 227 | 'and (and-terms v args) 228 | 'or (or-terms v args) 229 | 'not (not-terms v (first args))))) 230 | ops-to-vars)) 231 | 232 | (defn tseitin+ 233 | "Takes a Clojure constraint tree, and returns 234 | 235 | {:tree A new constraint tree in conjunctive normal form 236 | :new-vars A set of the new logic variables introduced, 237 | which may be discarded when computing solutions to this 238 | tree}" 239 | [tree] 240 | ; TODO: look at optimizations from Plaisted and Greenbaum 86 241 | ; TODO: eliminate superfluous checks like 242 | ; (and :_0 (or :_0 :_1) (or (not :_0) (not :_1)) ...) 243 | (cond 244 | ; If we're already in CNF, return unchanged 245 | (cnf? tree) 246 | {:tree tree 247 | :new-vars #{}} 248 | 249 | ; For the special case of a top-level 'and, we can partition our terms into 250 | ; those which are ors of literals (we'll call them literals for short), and 251 | ; those which require expansion (call those nonliterals). Pass through 252 | ; literals unchanged. Compute Tseitin vars for each non-literal term, and 253 | ; collect their resulting constraints. 254 | (= 'and (first tree)) 255 | (let [g (group-by cnf-or-of-literals? (next tree)) 256 | literals (get g true) 257 | nonliterals (get g false) 258 | ; For each nonliteral, compute a mapping of its nonliteral terms to 259 | ; tseitin vars, and merge that into a unified tree. 260 | mappings (->> nonliterals 261 | (reduce (fn [[i m] tree] 262 | (let [mapping (ops-to-vars tree i)] 263 | [(+ i (count mapping)) 264 | (merge mapping m)])) 265 | [0 {}]) 266 | second) 267 | ; Compute new constraints based on tseitin mappings 268 | tseitin-constraints (flatten-ops mappings) 269 | ; And global constraints for the top-level terms themselves 270 | top-level-constraints (map mappings nonliterals)] 271 | {:tree (simplify (vec (cons 'and (concat (map (partial vector 'bool) 272 | (vals mappings)) 273 | top-level-constraints 274 | literals 275 | tseitin-constraints)))) 276 | :new-vars (set (vals mappings))}) 277 | 278 | ; General case: compute full tseitin vars over the top-level tree 279 | true 280 | (let [mappings (ops-to-vars tree 0)] 281 | {:tree (simplify 282 | (vec (cons 'and 283 | (concat 284 | (map (partial vector 'bool) ; New booleans 285 | (vals mappings)) 286 | [(get mappings tree)] ; Top-level constraint 287 | (flatten-ops mappings))))) ; Sub-expressions 288 | :new-vars (set (vals mappings))}))) 289 | 290 | (defn tseitin 291 | "Like tseitin+, but just returns the new tree." 292 | [tree] 293 | (:tree (tseitin+ tree))) 294 | -------------------------------------------------------------------------------- /src/gretchen/constraint/flatzinc.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.constraint.flatzinc 2 | "Evaluates constraints by compiling them to flatzinc and running that against 3 | gecode, via the fzn-gecode binary that ships with flatzinc. You'll need 4 | fzn-gecode on your path for this to work. On Debian, you can apt-get install 5 | flatzinc for this." 6 | (:require [gretchen.constraint :as c] 7 | [clojure.java.shell :refer [sh]] 8 | [clojure.java.io :as io] 9 | [clojure.pprint :refer [pprint]]) 10 | (:import (java.io File 11 | BufferedReader 12 | StringReader) 13 | (gretchen.constraint Solver) 14 | (java.util.function BinaryOperator) 15 | (io.lacuna.bifurcan LinearMap))) 16 | 17 | (defn write-bool! 18 | "Write a boolean var definition like '(bool :x) to a flatzinc outputstream. 19 | Optionally takes whether this is a real variable or a temporary one we 20 | introduced." 21 | [os [_ v] real?] 22 | (.write os "var bool: ") 23 | (.write os (name v)) 24 | (if real? 25 | (.write os " :: output_var;\n") 26 | ; TODO: use is_defined_var and defines_var 27 | (.write os " :: var_is_introduced :: is_defined_var;\n"))) 28 | 29 | (defn write-int! 30 | "Write an integer var definition like '(in :x 0 5) to a flatzinc 31 | outputstream." 32 | [os [_ v lower upper]] 33 | (.write os "var ") 34 | (.write os (str lower)) 35 | (.write os "..") 36 | (.write os (str upper)) 37 | (.write os ": ") 38 | (.write os (name v)) 39 | (.write os " :: output_var;\n")) 40 | 41 | (defn write-constraint! 42 | "Write a constraint to the given outputstream, calling f with args." 43 | [os [f args annotations]] 44 | (assert f (str "No function? " f)) 45 | (assert (coll? args) (str "No args? " f " " args " " annotations)) 46 | 47 | (.write os "constraint ") 48 | (.write os (name f)) 49 | (.write os "(") 50 | (loop [args args] 51 | (.write os (let [a (first args)] 52 | (cond (string? a) 53 | a 54 | 55 | (keyword? a) 56 | (name (first args)) 57 | 58 | :else 59 | (pr-str a)))) 60 | (when-let [more (next args)] 61 | (.write os ", ") 62 | (recur more))) 63 | (.write os ")") 64 | 65 | (loop [anns annotations] 66 | (when-let [ann (first anns)] 67 | (.write os " :: ") 68 | (.write os (name (first ann))) 69 | (when (< 1 (count ann)) 70 | (.write os "(") 71 | ; Args 72 | (loop [a (next ann)] 73 | (when a 74 | (.write os (name (first a))) 75 | (when-let [more (next a)] 76 | (.write os ", ") 77 | (recur more)))) 78 | (.write os ")")) 79 | (recur (next anns)))) 80 | 81 | (.write os ";\n")) 82 | 83 | (defn write-constraints! 84 | "Write a series of constraints to the given outputstream." 85 | [os constraints] 86 | (doseq [c constraints] 87 | (write-constraint! os c))) 88 | 89 | (defn mapping 90 | "Take a tree, and a variable offset n. Compute [a new index n', a map of 91 | terms to temporary variables.] Mapping is a mutable LinearMap for 92 | performance. We don't emit a mapping for the top-level expression." 93 | [tree n] 94 | (->> tree 95 | (tree-seq sequential? next) 96 | (filter sequential?) 97 | (remove #{tree}) 98 | (reduce (fn [[i m] [type & children :as tree]] 99 | [(inc i) 100 | (.put m tree (keyword (str "_fz" (+ n i))))]) 101 | [0 (LinearMap.)]))) 102 | 103 | (defn mapping-constraints 104 | "Generates constraints from a mapping." 105 | [mapping] 106 | (assert (= (distinct (vals mapping)) 107 | (vec (vals mapping))) 108 | (str "Mapping without distinct variable names:\n" 109 | (with-out-str (pprint mapping)))) 110 | (map (fn [[tree v]] 111 | (let [[type & args] tree 112 | ; Replace child terms with their variables 113 | args (map (fn [a] (get mapping a a)) args) 114 | [a b] args] 115 | (condp = type 116 | '< [:int_lt_reif [a b v] [[:defines_var v]]] 117 | '<= [:int_le_reif [a b v] [[:defines_var v]]] 118 | 'and [:bool_and [a b v] [[:defines_var v]]] 119 | 'or [:bool_or [a b v] [[:defines_var v]]] 120 | 'not [:bool_not [a v] [[:defines_var v]]] 121 | true (throw (IllegalArgumentException. 122 | (str "What's a " (pr-str tree) "?")))))) 123 | mapping)) 124 | 125 | (defn direct-constraint 126 | "Compute a sequence of top-level flatzinc constraints from a given constraint 127 | expression, and optionally, a mapping of constraint expressions to boolean 128 | variables. Nil if we don't know how to emit a top-level constraint for this 129 | expression." 130 | ([tree] 131 | (direct-constraint nil tree)) 132 | ([mapping tree] 133 | (cond ; Plain old boolean 134 | (keyword? tree) 135 | [[:bool_eq [tree true]]] 136 | 137 | ; An expression we know how to handle directly? 138 | (seq tree) 139 | (let [[type a b] tree] 140 | (condp = type 141 | 'distinct [[:all_different_int 142 | [(str "[" 143 | (apply str 144 | (interpose ", " (map name (next tree)))) 145 | "]")]]] 146 | ;(for [a (next tree) 147 | ; b (next tree) 148 | ; :when (not= a b)] 149 | ; [:int_ne [a b]]) 150 | 'not (let [a (if (keyword? a) a (get mapping a))] 151 | (when (keyword? a) 152 | [[:bool_eq [a false]]])) 153 | 154 | ; Negation of a term we know how to directly express 155 | 'or (let [a (if (keyword? a) a (get mapping a)) 156 | b (if (keyword? b) b (get mapping b))] 157 | (when (and (keyword? a) (keyword? b)) 158 | [[:bool_or [a b true]]])) 159 | 'and (let [a (if (keyword? a) a (get mapping a)) 160 | b (if (keyword? b) b (get mapping b))] 161 | (when (and (keyword? a) (keyword? b)) 162 | [[:bool_and [a b true]]])) 163 | '< [[:int_lt [a b]]] 164 | '<= [[:int_le [a b]]] 165 | nil))))) 166 | 167 | (defn flat 168 | "We've got a CNF expression like (and o1 o2 ...) where each o could be (or n1 169 | n2 ...) and each n could be (not l) and l could be a boolean var or a 170 | comparison like (< a b). Our job is to flatten this mess by introducing 171 | temporary vars, into a form that minizinc can understand." 172 | [ors] 173 | (let [; First off, we need binary forms 174 | ors (map c/unfurl-binary-operators ors) 175 | ; Compute global mappings 176 | mapping (->> ors 177 | (remove direct-constraint) 178 | (reduce (fn merge-mappings 179 | [[i m] tree] 180 | (let [[n mapping] (mapping tree i)] 181 | [(+ i n) (.merge mapping m 182 | (reify BinaryOperator 183 | (apply [_ a b] 184 | a)))])) 185 | [0 (LinearMap.)]) 186 | second 187 | .toMap)] 188 | {:vars (map (partial vector 'bool) (vals mapping)) 189 | :constraints (->> ors 190 | (mapcat 191 | (fn compute-constraints [o] 192 | (or (direct-constraint mapping o) 193 | (throw (IllegalStateException. 194 | (str "Don't know how to generate constraint for " 195 | (pr-str o) "\ngiven value " 196 | (pr-str (get mapping o)) 197 | " from mapping\n" 198 | (with-out-str 199 | (pprint mapping)) 200 | "\nover top-level constraints\n" 201 | (pr-str ors))))))) 202 | 203 | (concat (mapping-constraints mapping)))})) 204 | 205 | (defn write-flatzinc! 206 | "Spits a constraint tree as flatzinc into an OutputStream. Simplifies tree, 207 | converts it to CNF via tseitin, and reifies logic vars as appropriate." 208 | [os tree] 209 | (let [; First, convert the tree to CNF 210 | ; {:keys [tree new-vars]} (c/tseitin+ (c/simplify tree)) 211 | ; new-vars (set (map (partial vector 'bool) new-vars)) 212 | 213 | tree (c/simplify tree) 214 | new-vars #{} 215 | 216 | ; Force tree to contain an and 217 | tree (if (and (sequential? tree) 218 | (= 'and (first tree))) 219 | tree 220 | ['and tree]) 221 | 222 | ; _ (prn :tree) 223 | ; _ (pprint tree) 224 | ; _ (prn) 225 | 226 | ; Split up terms of the 'and into integer definitions, boolean 227 | ; definitions, and other constraints 228 | {:keys [ints 229 | bools 230 | constraints]} (group-by (fn [t] 231 | (if (sequential? t) 232 | (condp = (first t) 233 | 'in :ints 234 | 'bool :bools 235 | :constraints) 236 | :constraints)) 237 | (next tree)) 238 | 239 | ; Flatten the tree and compute constraints 240 | flattened (flat constraints)] 241 | 242 | ; (prn :constraints) 243 | ; (pprint (:constraints flattened)) 244 | ; (prn) 245 | 246 | ; Predicates 247 | 248 | ; Write ints 249 | (doseq [v ints] 250 | (write-int! os v)) 251 | (.write os "\n") 252 | 253 | ; Bools 254 | (doseq [b bools] 255 | (when-not (new-vars b) 256 | (write-bool! os b true))) 257 | (.write os "\n") 258 | 259 | ; Temp vars from Tseitin expansion and our flatzinc flattening 260 | (doseq [b (concat new-vars (:vars flattened))] 261 | (write-bool! os b false)) 262 | (.write os "\n") 263 | 264 | ; Constraints 265 | (write-constraints! os (:constraints flattened)) 266 | (.write os "\n") 267 | 268 | ; Solve! 269 | ; We take advantage of the fact that our inputs were probably serialized 270 | ; in the same order they were submitted to the DB 271 | (.write os "solve") 272 | (when (seq ints) 273 | (.write os " :: int_search([") 274 | (->> (map (comp name second) ints) 275 | (interpose ", ") 276 | (apply str) 277 | (.write os)) 278 | (.write os "], input_order, indomain_split, complete)")) 279 | (.write os " satisfy;\n"))) 280 | 281 | (defn flatzinc-str 282 | "Converts constraint tree to a flatzinc string." 283 | [tree] 284 | (let [s (java.io.StringWriter.)] 285 | (write-flatzinc! s tree) 286 | (str s))) 287 | 288 | (defn parse-solution 289 | "Parse a single solution from a sequence of lines from fzn-gecode." 290 | [lines] 291 | (try 292 | (->> lines 293 | (map (fn [line] 294 | (let [[_ var val] (re-find #"\A(.+?) = (.+?);\z" line) 295 | parsed-val (condp = val 296 | "true" true 297 | "false" false 298 | (Long/parseLong val))] 299 | 300 | [(keyword var) parsed-val]))) 301 | (into {})) 302 | (catch Throwable t 303 | (println "Unable to parse solutions from:\n") 304 | (doall (map println lines)) 305 | (throw t)))) 306 | 307 | (defn parse-solutions 308 | "Parses a sequence of lines from fzn-gecode into a sequence of solutions." 309 | [lines] 310 | (when (and (seq lines) 311 | (not= "=====UNSATISFIABLE=====" (first lines))) 312 | (let [[solution more] (split-with (partial not= "----------") lines)] 313 | (if (= (first solution) "==========") 314 | nil ; Done here 315 | (cons (parse-solution solution) 316 | (lazy-seq (parse-solutions (next more)))))))) 317 | 318 | (defn parse-solutions-str 319 | "Parses a string from fzn-gecode into a sequence of solutions, each a map of 320 | keywords to values." 321 | [s] 322 | (-> s 323 | (StringReader.) 324 | (BufferedReader.) 325 | line-seq 326 | (parse-solutions))) 327 | 328 | (defn error-report! 329 | [res tree] 330 | (let [file (File/createTempFile "gretchen-crash" ".flatzinc")] 331 | (with-open [w (io/writer file)] 332 | (write-flatzinc! w tree)) 333 | (str "Constraint tree was\n" (with-out-str (pprint tree)) 334 | "\nGenerated flatzinc was:\n" (flatzinc-str tree) 335 | "\nfzn-gecode returned non-zero exit status " (:exit res) 336 | ".\nStderr:\n" (:err res) 337 | "\nStdout:\n" (:out res) 338 | "\nFlatzinc available in " (.getCanonicalPath file)))) 339 | 340 | (defn solve 341 | "Solves a constraint with flatzinc by shelling out. Emits up to n solutions." 342 | [tree n] 343 | (let [file (java.io.File/createTempFile "gretchen" ".flatzinc")] 344 | (try 345 | ; (prn) 346 | ; (println "-------------------------------") 347 | ; (println "tree:") 348 | ; (pprint tree) 349 | 350 | (with-open [w (io/writer file)] 351 | (write-flatzinc! w tree)) 352 | 353 | ; (prn) 354 | ; (println "flatzinc:") 355 | ; (println (slurp file)) 356 | (let [res (sh "fzn-gecode" 357 | "-n" (str n) 358 | "-p" "0" 359 | ; I thiiiink we can't prove nonexistence if we let it 360 | ; restart. It'll definitely spit out solutions forever if 361 | ; unlimited. 362 | ; "-restart" (if (= 0 n) "none" "luby") 363 | (.getCanonicalPath file))] 364 | (assert (zero? (:exit res)) (error-report! res tree)) 365 | (parse-solutions-str (:out res))) 366 | (finally 367 | (.delete file))))) 368 | 369 | (defn solution 370 | "Solve for one solution." 371 | [tree] 372 | (first (solve tree 1))) 373 | 374 | (defn solutions 375 | "Solve for all solutions." 376 | [tree] 377 | (solve tree 0)) 378 | 379 | (defn flatzinc 380 | "Flatzinc gecode based solver." 381 | [] 382 | (reify Solver 383 | (solution [_ c] 384 | (solution c)))) 385 | -------------------------------------------------------------------------------- /src/gretchen/core.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.core 2 | "In 'A Framework for Transactional Consistency Models with Atomic 3 | Visibility', Cerone, Bernardi, and Gotsman present a formal model for 4 | transactions composed of ordered reads and writes on a set of registers. 5 | They show that serializability can be defined in terms of three properties: 6 | 7 | INT (Internal Consistency): transactions read values consistent with their 8 | prior reads and writes. 9 | 10 | EXT (External Consistency): Let an 'external read' be the first read of a 11 | register r without a preceding write in a given transaction. Every external 12 | read of r in transaction Ti must see the final value written by the most 13 | recent transaction visible to Ti, where 'most recent' is determined by the 14 | arbitration order. 15 | 16 | TOTAL-VIS: VIS, the visibility relationship on transactions, must be a total 17 | order. 18 | 19 | ## Observations 20 | 21 | Note that INT can be verified in linear time: we simply check each 22 | transaction independently. But without knowing the visiblity order VIS and 23 | arbitration order AR (which, when TOTAL-VIS holds, are essentially (exactly?) 24 | the same), we have no efficient way to verify EXT. We must *find* a VIS 25 | consistent with EXT. 26 | 27 | We could enumerate all possible orders for AR; this is exponential time and 28 | can trivially overwhelm a SAT solver. Tests with a single register and 29 | single-op transactions suggests that no more than 30-50 operations can be 30 | directly checked for serializability in Alloy, at least using MiniSAT, which 31 | appears to be the fastest solver available. 32 | 33 | However, we can *reduce* the search space dramatically by applying 34 | heuristics. First, note that the denser the register state space--the more 35 | reads and writes have the same values--the more valid serializations we are 36 | likely to have. A test of serializability will likely *limit* degeneracy 37 | by using many distinct values. 38 | 39 | When degeneracy is small, we can identify prior transactions for EXT in 40 | constant time for any given transaction, so long as we have a few (linear 41 | time) indexes identifying which transactions could have written those values. 42 | 43 | ## Approach 44 | 45 | Consider a set of n transactions. For simplicity, we construct an initial 46 | transaction T_0, which simply writes the initial state. 47 | 48 | Then, for every transaction T_i where 0 < i <= n, take the set of external 49 | reads R: a map from keys to values. We want to obtain a constraint on the 50 | arbitrartion order of transactions AR which guarantees that by the time T_i 51 | executes, R is a subset of the current table state--e.g., T_i's external 52 | reads are satisfiable. 53 | 54 | For all external reads r = (k, v) in R, let the set of transactions 55 | externally writing (k, v) be W (Writes), and the set of all transactions 56 | externally writing (k, not-v) be O (Overwrites). r is satisfied iff: 57 | 58 | 1. There exists some T_w in W | w < i (e.g. the write precedes the read) 59 | 2. There exists no T_o in O | w < o < i (the write is not overwritten) 60 | 61 | So for each read, we will generate a series of alterative constraints on the 62 | indices of writes and overwrites, like so: 63 | 64 | (or (and (< w0 i) ; write constraint 65 | (or (< o0 w0) (< i o0)) ; overwrite constraint 66 | (or (< o1 w0) (< i o1))) ; another overwrite constraint 67 | (and (< w1 i) ; a different write constraint 68 | (or (< o0 w1) (< i o0)) ; overwrite constraint 69 | (or (< o1 w1) (< i o1))) ; another overwrite constraint 70 | 71 | The transaction is satisfied iff all its external reads are satisfied, so: 72 | 73 | (and (or ... r0 constraints ...) 74 | (or ... r1 constraints ...)) 75 | 76 | And the history is satisfied if all its transactions are satisfied, so: 77 | 78 | (and (or ... T0 r0 constraints ...) 79 | (or ... T0 r1 constraints ...) 80 | (or ... T1 r0 constraints ...) 81 | (or ... T1 r1 constraints ...)) 82 | 83 | Note that we have eliminated all notion of state variables, reads, writes, 84 | operations, and even transactional semantics from the constraints. We simply 85 | require a solution to the integer constraint problem: finding a unique 86 | assignment of integers to the n indices identifying each transaction's 87 | position in the order. A solution to this integer constraint problem provides 88 | us with a legal serialization of the history." 89 | (:require [clojure.string :as str] 90 | [clojure.pprint :refer [pprint]] 91 | [gretchen.history :as h] 92 | [gretchen.constraint :as c])) 93 | 94 | ;; Formatting 95 | 96 | (defn op-str 97 | "Formats an op as a string." 98 | [op] 99 | (let [f (condp = (:f op) :read "r", :write "w")] 100 | (str f (name (:k op)) "(" (:v op) ")"))) 101 | 102 | (defn txn-str 103 | "Formats a transaction as a string." 104 | [txn] 105 | (str "[" (str/join " " (map op-str (:ops txn))) "]")) 106 | 107 | (defn pr-history 108 | "Prints a history" 109 | [history] 110 | (doseq [txn history] 111 | (println (txn-str txn)))) 112 | 113 | (defn tiv 114 | "Transaction index variable for transaction index i" 115 | [i] 116 | (c/v (str "t" i))) 117 | 118 | ;; Internal consistency 119 | 120 | (defn check-int 121 | "Verifying internal consistency is easy. We need only check that every read 122 | in a transaction is preceded by an identical read or write. We iterate 123 | through operations in the transaction, building up a partial model of the 124 | current state and checking each new op against that state. Augments broken 125 | transactions with an :error field." 126 | [txn] 127 | (if-let [e (->> (:ops txn) 128 | (reduce (fn [state, {:keys [f k v] :as op}] 129 | (let [state' (assoc state k v)] 130 | (if (and (= f :read) 131 | (not= v (get state k v))) 132 | (reduced 133 | (assoc state' 134 | ::error {:type :internal 135 | :op op 136 | :expected (get state k)})) 137 | state'))) 138 | {}) 139 | ::error)] 140 | (assoc txn :error e) 141 | txn)) 142 | 143 | (defn check-int-history 144 | "Checks internal consistency on an entire history. Returns 145 | 146 | {:txns [t1 t2 ...] 147 | :errors [t3 ...]}" 148 | [history] 149 | (let [txns (->> history :txns (map check-int)) 150 | errors (filter :error txns) 151 | history (assoc history :txns txns)] 152 | (if (seq errors) 153 | (assoc history :errors errors) 154 | history))) 155 | 156 | ;; External consistency 157 | 158 | (defn check-spurious-reads 159 | "Takes a history, and checks for the presence of external reads without 160 | corresponding external writes." 161 | [history] 162 | (let [reads (:ext-reads history) 163 | writes (:ext-writes history) 164 | spurious (->> reads 165 | (mapcat 166 | (fn [[k reads-of-k]] 167 | ; (writes k) is a map of values to txn i's, so 168 | ; we can use it to cross off read values. 169 | (->> (keys reads-of-k) 170 | (remove (writes k)) 171 | (mapcat (fn [v] 172 | (mapv (fn [i] 173 | {:txn (nth (:txns history) i) 174 | :k k 175 | :v v}) 176 | (reads-of-k v))))))))] 177 | (if (seq spurious) 178 | (assoc history :error {:type :spurious-read 179 | :reads spurious}) 180 | history))) 181 | 182 | (defn priors 183 | "The txn ids which could satisfy the given transaction's external read of k 184 | with value v, and the txn ids which would invalidate that read." 185 | [history txn-id [k v]] 186 | (let [writes-to-k (-> history :ext-writes (get k)) 187 | good (remove #{txn-id} (get writes-to-k v)) 188 | bad (->> (dissoc writes-to-k v) 189 | vals 190 | (apply concat) 191 | (remove #{txn-id}))] 192 | [good bad])) 193 | 194 | (defn prior-constraint 195 | "Given a history, a constraint system, a transaction, and its read of [k v], 196 | constructs a constraint ensuring that read is satisfiable." 197 | [history txn [k v :as r]] 198 | (let [[W O] (priors history (:i txn) r) 199 | t (tiv (:i txn)) 200 | W (map tiv W) 201 | O (map tiv O)] 202 | (assert (seq W) "external read unsatisfied") ; Sanity check 203 | (c/or* (for [w W] 204 | (c/and* (cons (c/< w t) 205 | (for [o O] 206 | (c/or (c/< o w) (c/< t o))))))))) 207 | 208 | (defn txn-constraint 209 | "Given a history, a constraint system, and transaction, constructs a 210 | constraint ensuring the transaction's external consistency." 211 | [history txn] 212 | (c/and* (for [r (h/ext-reads txn)] 213 | (prior-constraint history txn r)))) 214 | 215 | (defn txn-constraints 216 | "Given a history and a constraint system, generates a constraint for all 217 | txns." 218 | [history] 219 | (c/and* (for [t (:txns history)] (txn-constraint history t)))) 220 | 221 | (defn distinct-constraint 222 | "Given a history and a constraint system, generates a constraint which 223 | demands all transaction identifiers are unique." 224 | [history] 225 | (->> history 226 | :txns 227 | (map (comp tiv :i)) 228 | (c/distinct))) 229 | 230 | (defn index-constraints 231 | "Given a history and a constraint system, generates a constraint declaring 232 | all transaction index variables to be integers from 0 to n." 233 | [history] 234 | (->> history 235 | :txns 236 | (map (fn [txn] 237 | (c/in (tiv (:i txn)) 0 (dec (count (:txns history)))))) 238 | (c/and*))) 239 | 240 | (defn history-constraint 241 | "Given a history and a constraint system, constructs a constraint ensuring 242 | the history is serializable." 243 | [history] 244 | (c/simplify 245 | (c/and* [(index-constraints history) 246 | (distinct-constraint history) 247 | (txn-constraints history)]))) 248 | 249 | (defn check-ext-history 250 | "Check history for external consistency." 251 | [history s] 252 | (let [constraint (history-constraint history) 253 | soln (c/solution s constraint)] 254 | ; Map solution back to history 255 | (if soln 256 | (assoc history :solution 257 | (let [var-order (map key (sort-by val soln)) 258 | txns-by-vars (->> (:txns history) 259 | (map (fn [txn] [(tiv (:i txn)) txn])) 260 | (into {}))] 261 | (map txns-by-vars var-order))) 262 | (assoc history :error {:type :no-ext-solution})))) 263 | 264 | (defn check-reduce 265 | "Transforms a history with a sequence of functions, applied in order. As soon 266 | as an :error is found, aborts and returns that history." 267 | [history fs] 268 | (reduce (fn [h f] 269 | (if (:error h) 270 | (reduced h) 271 | (f h))) 272 | history 273 | fs)) 274 | 275 | (defn check 276 | "Check history for correctness using the given constraint system." 277 | [history s] 278 | (check-reduce history [h/prepare-history 279 | check-int-history 280 | check-spurious-reads 281 | #(check-ext-history % s)])) 282 | -------------------------------------------------------------------------------- /src/gretchen/gen.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.gen 2 | "Generates histories for testing.") 3 | 4 | (def epoch-key 5 | "A key used as a monotonic epoch for breaking up large histories." 6 | :epoch) 7 | 8 | (defn rand-key 9 | [state] 10 | (rand-nth (remove #{epoch-key} (keys state)))) 11 | 12 | (defn r 13 | "Shorthand read constructor." 14 | [k v] 15 | {:f :read, :k k, :v v}) 16 | 17 | (defn w 18 | "Shorthand write constructor." 19 | [k v] 20 | {:f :write, :k k, :v v}) 21 | 22 | (defn t 23 | "Generate transaction from seq of ops." 24 | [& ops] 25 | {:ops (vec ops)}) 26 | 27 | (defn read-epoch-op 28 | "Op that reads the current epoch. Returns [state' op]" 29 | [state] 30 | [state {:f :read, :k epoch-key, :v (get state epoch-key)}]) 31 | 32 | (defn inc-epoch-op 33 | "Op that advances epoch by 1. Takes state, returns [state' op]" 34 | [state] 35 | (let [epoch (inc (get state epoch-key))] 36 | [(assoc state epoch-key epoch) 37 | {:f :write, :k epoch-key, :v epoch}])) 38 | 39 | (defn read-op 40 | "Constructs a random read op on state. Returns [state', read-op]" 41 | [state] 42 | (let [k (rand-key state) 43 | v (get state k)] 44 | [state, {:f :read, :k k, :v v}])) 45 | 46 | (defn write-op 47 | "Constructs a random write op on state. Returns [state', write-op]" 48 | [state] 49 | (let [k (rand-key state) 50 | v (rand-int 100)] 51 | [(assoc state k v), {:f :write, :k k, :v v}])) 52 | 53 | (defn op 54 | "Constructs a random op on state. Returns [state', op]." 55 | [state] 56 | ((rand-nth [read-op write-op]) state)) 57 | 58 | (defn txn 59 | "Constructs a random transaction on state. Returns [state', txn]." 60 | [state] 61 | (let [[state epoch-read] (read-epoch-op state) 62 | [state epoch-write] (if (< (rand) 0.1) 63 | (inc-epoch-op state) 64 | [state nil]) 65 | ops (if epoch-write 66 | [epoch-read epoch-write] 67 | [epoch-read])] 68 | (loop [i (inc (rand-int 4)) 69 | state state 70 | ops ops] 71 | (if (zero? i) 72 | [state {:ops ops}] 73 | (let [[state' op] (op state)] 74 | (recur (dec i) state' (conj ops op))))))) 75 | 76 | (defn txns 77 | "A lazy sequence of transactions on state." 78 | [state] 79 | (lazy-seq 80 | (let [[state' txn] (txn state)] 81 | (cons txn (txns state'))))) 82 | 83 | (defn history 84 | "Constructs a history with a lazy sequence of transactions from the given 85 | state." 86 | [txn-count state] 87 | (assert (not (contains? state epoch-key))) 88 | (let [state (assoc state epoch-key 0)] 89 | {:initial state 90 | :txns (take txn-count (txns state))})) 91 | 92 | (defn shuffle-history 93 | "A history with shuffled transactions." 94 | [txn-count state] 95 | (update (history txn-count state) :txns shuffle)) 96 | -------------------------------------------------------------------------------- /src/gretchen/graph.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.graph 2 | "Assists with graph operations. Our representation of a graph is a map with 3 | two keys: {:vertices, a collection of objects, and :neighbors, a function of 4 | vertices to vertices.} 5 | 6 | Graphs may not contain nil vertices." 7 | (:require [clojure.set :as set] 8 | [gretchen.util :refer :all])) 9 | 10 | (defn reachable 11 | "Takes a graph and a collection of vertices `start`, and returns a set of all 12 | vertices reachable from any vertex in `start`." 13 | [{:keys [vertices neighbors] :as graph} start] 14 | (loop [visited (set start) 15 | cambium start] 16 | (let [cambium' (->> (map neighbors cambium) 17 | (remove nil?) 18 | (remove visited) 19 | distinct)] 20 | (if (empty? cambium') 21 | visited 22 | (recur (into visited cambium') 23 | cambium'))))) 24 | 25 | (defn invert 26 | "Reverses every edge in a graph, such that in the new graph, a->b iff b->a in 27 | the original graph." 28 | [{:keys [vertices neighbors]}] 29 | {:vertices vertices 30 | :neighbors (persistent! 31 | (reduce (fn [in src] 32 | (reduce (fn [in dst] 33 | (let [x (get in dst [])] 34 | (assoc! in dst (conj x src)))) 35 | in 36 | (neighbors src))) 37 | (transient {}) 38 | vertices))}) 39 | 40 | (defn disjoint-subgraphs 41 | "Given a graph composed of :vertices and a function :neighbors, such that 42 | (neighbors vertex) returns a collection of vertices adjacent to that vertex, 43 | partitions the vertices graph into a collection of connected subgraphs, each 44 | a collection of vertices." 45 | [{:keys [vertices neighbors]}] 46 | (->> (vals 47 | ; We build up a map of nodes to the set of all nodes reachable from 48 | ; that node. 49 | (reduce (fn red [m vertex] 50 | (let [local (set (cons vertex (neighbors vertex))) 51 | unified (->> local 52 | (map m) 53 | distinct-identical 54 | (reduce set/union local))] 55 | (reduce (fn update-mapping [m vertex] 56 | (assoc m vertex unified)) 57 | m 58 | unified))) 59 | {} 60 | vertices)) 61 | distinct-identical 62 | (mapv (partial hash-map :neighbors neighbors :vertices)))) 63 | -------------------------------------------------------------------------------- /src/gretchen/history.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.history 2 | "Basic operations over transactions and histories." 3 | (:refer-clojure :exclude [ancestors descendants]) 4 | (:require [gretchen.recurset :as recurset] 5 | [clojure.set :as set])) 6 | 7 | (defn ext-reads 8 | "Given a transaction, returns the map of keys to values for its external 9 | reads." 10 | [txn] 11 | (->> (:ops txn) 12 | (reduce (fn [[ext ignore?] {:keys [f k v]}] 13 | [(if (or (= :write f) 14 | (ignore? k)) 15 | ext 16 | (assoc ext k v)) 17 | (conj ignore? k)]) 18 | [{} #{}]) 19 | first)) 20 | 21 | (defn ext-writes 22 | "Given a transaction, returns the map of keys to values for its external 23 | writes." 24 | [txn] 25 | (->> (:ops txn) 26 | (reduce (fn [ext {:keys [f k v]}] 27 | (if (= :read f) 28 | ext 29 | (assoc ext k v))) 30 | {}))) 31 | 32 | (defn add-initial-txn 33 | "Takes a history and prepends a transaction writing its initial state." 34 | [history] 35 | (let [t0 (->> (:initial history) 36 | (map (fn [[k v]] {:f :write, :k k, :v v})) 37 | (array-map :ops))] 38 | (assoc history :txns (cons t0 (:txns history))))) 39 | 40 | (defn add-txn-ids 41 | "Takes a history and adds ids :i = 0...n to its transactions." 42 | [history] 43 | (->> (:txns history) 44 | (mapv (fn [i txn] (assoc txn :i i)) (range)) 45 | (assoc history :txns))) 46 | 47 | (defn ext-index 48 | "Takes a history (with initial transaction and indices) and a function 49 | returning a map of keys to values for a transaction, and computes an index 50 | which maps keys to values to collections of transaction ids which yielded 51 | that (k, v) pair. Used to compute the external read and write indices for a 52 | history." 53 | [history index-fn] 54 | (assert (= 0 (:i (first (:txns history))))) 55 | (reduce (fn [index txn] 56 | (reduce (fn [index [k v]] 57 | (update-in index [k v] conj (:i txn))) 58 | index 59 | (index-fn txn))) 60 | {} 61 | (:txns history))) 62 | 63 | (defn add-ext-indices 64 | "Takes a history and adds :ext-reads and :ext-writes indexes, mapping keys to 65 | values to collections of transaction IDs." 66 | [history] 67 | (assoc history 68 | :ext-reads (ext-index history ext-reads) 69 | :ext-writes (ext-index history ext-writes))) 70 | 71 | (defn prepare-history 72 | "Introduces the initial transaction, assigns ids to transactions, and 73 | computes indices." 74 | [history] 75 | (-> history 76 | add-initial-txn 77 | add-txn-ids 78 | add-ext-indices)) 79 | 80 | (defn ancestors 81 | "Builds a partial transaction precedence graph based on each transaction's 82 | external reads and writes. THIS GRAPH IS NOT TOTAL: if the graph contains 83 | a->b, then a must execute after b, but the converse is not necessarily true: 84 | some dependencies may not be present. We only consider happens-before 85 | precedence, and don't use information about excluded intervals. 86 | 87 | That said, for those transactions we *do* prove lie before another, we 88 | actually compute the transitive closure." 89 | [history] 90 | ; dep graph: a map of txns t to a set of txns t definitely depends on. 91 | ; 92 | ; We build up the dep graph by visiting every transaction. Where a 93 | ; transaction has at most one dependency for every external read, we know 94 | ; those are its total dependencies. Where a transaction has multiple 95 | ; dependencies for a given read, we take the intersection of their 96 | ; dependencies. 97 | (let [ext-writes (:ext-writes history) 98 | txns (:txns history)] 99 | (loop [stack (list txns) ; A stack of lists of unvisited txns 100 | graph {}] ; Our accumulated dependency graph 101 | (if-not (seq stack) 102 | ; Stack empty; we're done 103 | graph 104 | 105 | (let [needed-txns (first stack)] 106 | (if-not (seq needed-txns) 107 | ; No more txns at this level; move back up 108 | (recur (next stack) graph) 109 | 110 | ; OK we have a txn. Is it in the graph yet? 111 | (let [txn (first needed-txns)] 112 | (if (get graph txn) 113 | ; Already computed; move on 114 | (recur (cons (next needed-txns) (next stack)) graph) 115 | 116 | ; Compute a conjunction of disjunctions of dependency txn ids. 117 | (let [writes (->> (ext-reads txn) 118 | (keep (fn [[k v]] 119 | (->> (-> ext-writes (get k) (get v)) 120 | (keep (fn [i] 121 | ; Don't depend on self 122 | (when (not= i (:i txn)) 123 | ; Map ids back to txns 124 | (nth txns i))))))) 125 | (filter seq)) 126 | ; Do we still need to visit any of these? 127 | needed (remove graph (flatten writes))] 128 | (if (seq needed) 129 | ; Hang on, we gotta figure out some dependencies first 130 | (recur (cons needed stack) graph) 131 | 132 | ; OK our dependencies are all figured out. Now, we want the 133 | ; intersection of the transitive dependency set for any of 134 | ; our alternative deps... 135 | (let [trans-deps (map (fn [txns] 136 | (->> txns 137 | (map graph) 138 | recurset/intersection)) 139 | writes) 140 | ; ... plus those transactions we definitely directly 141 | ; depend on 142 | direct-deps (keep #(when (= 1 (count %)) 143 | (first %)) 144 | writes) 145 | deps (recurset/union (cons direct-deps trans-deps))] 146 | 147 | ; Update graph and move to the next thing in the stack 148 | (recur (cons (next needed-txns) (next stack)) 149 | (assoc graph txn deps))))))))))))) 150 | 151 | -------------------------------------------------------------------------------- /src/gretchen/recurset.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.recurset 2 | "Persistent sorted sets with memory-efficient, constant-time union and 3 | intersection, and O((n + m) * c) iteration, where n is the number of 4 | elements, c is the typical size of the set at any given node, and m is the 5 | number of intersections and unions. 6 | 7 | Note that construction of unions and intersections sorts their arguments by a 8 | constant-time upper bound on their size, so that the biggest sub-nodes are 9 | probably first. When we append a node's elements to our backwards stack, we 10 | wind up working with smaller sets first." 11 | (:require [potemkin :refer [definterface+ deftype+]] 12 | [clojure.set :as set]) 13 | (:import (java.util ArrayList) 14 | (clojure.lang Seqable))) 15 | 16 | (def eager-max-count-limit 17 | "When you call union or intersection, we may perform that set operation 18 | immediately, rather than creating an indirect node. This is the upper bound 19 | on a set we'll realize eagerly." 20 | 64) 21 | 22 | (declare to-set) 23 | 24 | (definterface+ Node 25 | (xs [node])) 26 | 27 | (deftype Union [xs max-count] 28 | Node 29 | (xs [_] xs) 30 | 31 | Seqable 32 | (seq [this] (seq (to-set this))) 33 | 34 | Object 35 | (toString [this] (str "(∪ " (apply str (interpose " " xs)) ")"))) 36 | 37 | (deftype Intersection [xs max-count] 38 | Node 39 | (xs [_] xs) 40 | 41 | Seqable 42 | (seq [this] (seq (to-set this))) 43 | 44 | Object 45 | (toString [this] (str "(∩ " (apply str (interpose " " xs)) ")"))) 46 | 47 | (defmethod print-method Union 48 | [x ^java.io.Writer w] 49 | (.write w (str x))) 50 | 51 | (defmethod print-method Intersection 52 | [x ^java.io.Writer w] 53 | (.write w (str x))) 54 | 55 | (defn max-count 56 | "Upper bound on the number of elements in a collection." 57 | [coll] 58 | (condp identical? (class coll) 59 | Union (.max-count ^Union coll) 60 | Intersection (.max-count ^Intersection coll) 61 | (count coll))) 62 | 63 | (defn prepare 64 | "We need to make sure that everything we accept is a literal Set or a 65 | Union/Intersection type. This function coerces collections to those types." 66 | [coll] 67 | (if (or (identical? (class coll) Intersection) 68 | (identical? (class coll) Union) 69 | (set? coll)) 70 | coll 71 | (set coll))) 72 | 73 | (defn to-set 74 | [coll] 75 | ; We build a stack machine where the stack is of the form 76 | ; [coll op coll op coll], for instance [a :union b :intersection c], which 77 | ; means "compute the union of a and b, then intersect that result with c." 78 | ; 79 | ; If our stack is a single realized collection, we're done. If it is 80 | ; unrealized, expand it to [a op b op c ...]. Now, 81 | ; 82 | ; Let our stack be [a op1 b op2 c]. If a and b are realized collections, let 83 | ; res be (op1 a b), and our resulting stack is [res op2 c]. 84 | ; 85 | ; If a is an unrealized union or intersection o over a1, a2, and a3, then our 86 | ; resulting stack is [a1 o a2 o a3 op1 b op2 c]. 87 | ; 88 | ; If a is realized but b is not, our new stack is [b op1 a op2 c], by the 89 | ; commutativity of intersection and union. 90 | ; 91 | ; For performance reasons, our stack is an arraylist and is backwards--so the 92 | ; first element of the stack has index (dec (count stack)). 93 | ; 94 | ; TODO: use bifurcan LinearSet. 95 | ; TODO: optimize intersections by skipping elements not present in the 96 | ; intersection of all realized sets in the stack 97 | (if-not (or (identical? (class coll) Union) 98 | (identical? (class coll) Intersection)) 99 | (set coll) 100 | (let [stack (ArrayList. ^java.util.List (list coll))] 101 | (loop [] 102 | ; (prn :stack (reverse stack)) 103 | (let [size (.size stack)] 104 | (if (= 1 size) 105 | ; Just one element in the stack; we're either starting or finishing 106 | (let [a (.get stack 0) 107 | op (class a)] 108 | (if (or (identical? op Union) 109 | (identical? op Intersection)) 110 | ; Single unrealized node; expand 111 | (do (.clear stack) 112 | (.addAll stack (interpose op (.xs ^Node a))) 113 | (recur)) 114 | ; Realized, we're done! 115 | a)) 116 | 117 | ; OK, multiple elements. What's on deck? 118 | (let [size (.size stack) 119 | a (.get stack (- size 1)) 120 | op (.get stack (- size 2)) 121 | b (.get stack (- size 3))] 122 | (cond ; Haven't realized a yet, expand 123 | (or (identical? (class a) Union) 124 | (identical? (class a) Intersection)) 125 | (do (.remove stack (int (- size 1))) 126 | (.addAll stack (interpose (class a) (.xs ^Node a))) 127 | (recur)) 128 | 129 | ; We've got a but not b; swap 130 | (or (identical? (class b) Union) 131 | (identical? (class b) Intersection)) 132 | (do (.set stack (- size 3) a) 133 | (.set stack (- size 1) b) 134 | (recur)) 135 | 136 | ; Both a and b are realized; evaluate 137 | true 138 | (do (.remove stack (- size 1)) 139 | (.remove stack (- size 2)) 140 | (.set stack (- size 3) 141 | (if (identical? op Union) 142 | (set/union a b) 143 | (set/intersection a b))) 144 | (recur)))))))))) 145 | 146 | (defn union 147 | "Constructs a set representing the union of the given sets." 148 | [sets] 149 | (condp = (count sets) 150 | 0 #{} 151 | 1 (prepare (first sets)) 152 | (let [max-count' (reduce + (map max-count sets))] 153 | (if (<= max-count' eager-max-count-limit) 154 | ; Realize eagerly 155 | (apply set/union (map to-set sets)) 156 | ; Create a lazy node 157 | (Union. (sort-by (comp - max-count) (map prepare sets)) 158 | max-count'))))) 159 | 160 | (defn intersection 161 | "Constructs a set representing the intersection of the given sets." 162 | [sets] 163 | (condp = (count sets) 164 | 0 (throw (IllegalArgumentException. "Can't intersect 0 sets")) 165 | 1 (prepare (first sets)) 166 | (let [max-count' (reduce min (map max-count sets))] 167 | (if (<= max-count' eager-max-count-limit) 168 | (apply set/intersection (map to-set sets)) 169 | (Intersection. (sort-by (comp - max-count) (map prepare sets)) 170 | max-count'))))) 171 | -------------------------------------------------------------------------------- /src/gretchen/util.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.util 2 | "Kitchen sink") 3 | 4 | (defn map-vals 5 | "Maps values in a map." 6 | [f m] 7 | (->> m 8 | (map (fn [[k v]] [k (f v)])) 9 | (into {}))) 10 | 11 | (defn distinct-identical 12 | "Like distinct, but only skips elements which are identical to those already 13 | seen." 14 | ([xs] (distinct-identical xs {})) 15 | ([xs seen] 16 | (when (seq xs) 17 | (lazy-seq 18 | (let [x (first xs) 19 | h (hash x) 20 | seen-xs (get seen h)] 21 | (if (not-any? (partial identical? x) (get seen h)) 22 | (cons x (distinct-identical (next xs) 23 | (assoc seen h (conj seen-xs x)))) 24 | (distinct-identical (next xs) seen))))))) 25 | 26 | 27 | (defn fixed-point 28 | "Applies f repeatedly to x until it converges." 29 | [f x] 30 | (let [x' (f x)] 31 | (if (= x x') 32 | x 33 | (recur f x')))) 34 | -------------------------------------------------------------------------------- /test/gretchen/bottleneck_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.bottleneck-test 2 | (:require [clojure.test :refer :all] 3 | [gretchen [gen :refer [t r w]] 4 | [bottleneck :refer :all] 5 | [history :as h :refer [prepare-history]]])) 6 | 7 | (deftest bottlenecks-test 8 | (let [b (comp set bottlenecks- h/prepare-history)] 9 | (testing "empty history" 10 | (is (= #{{:i 0, :ops []}} ; implict first txn is a bottleneck 11 | (b {:initial {} 12 | :txns []})))) 13 | 14 | (testing "linear chain of txns" 15 | (let [h (prepare-history {:initial {:x 0} 16 | :txns [(t (r :x 0) (w :x 1)) 17 | (t (r :x 1) (w :x 2)) 18 | (t (r :x 2) (w :x 3))]}) 19 | [t0 t1 t2 t3] (:txns h)] 20 | (is (= #{t0 t1 t2 t3} (set (bottlenecks- h)))))) 21 | 22 | (testing "independent txns" 23 | (let [h (prepare-history {:initial {:x 0 :y 0} 24 | :txns [(t (r :y 0) (w :x 1)) 25 | (t (r :y 0) (w :x 2)) 26 | (t (r :x 2))]}) 27 | [t0 t1 t2 t3] (:txns h)] 28 | (is (= #{t0} (set (bottlenecks- h)))))) 29 | 30 | (testing "fork-and-join" 31 | ; t4 is a bottleneck because both t2 and t3 must precede it (and by 32 | ; extension, t1 and then t0). 33 | (let [h (prepare-history {:initial {:x 0} 34 | :txns [(t (r :x 0) (w :x 1)) ; 0 < 1 35 | (t (r :x 1) (w :y 2)) ; 1 < 2 36 | (t (r :x 1) (w :z 2)) ; 1 < 3 37 | (t (r :y 2) (r :z 2))]}) ; [2 & 3] < 4 38 | [t0 t1 t2 t3 t4] (:txns h)] 39 | (is (= #{t0 t1 t4} (set (bottlenecks- h)))))) 40 | 41 | (testing "fork-or-join" 42 | ; Here, t4 is not a bottleneck, because we can't prove that both t2 and t3 43 | ; had to happen prior. 44 | (let [h (prepare-history {:initial {:x 0} 45 | :txns [(t (r :x 0) (w :x 1) (w :y 1)) ; 0 < 1 46 | (t (r :x 1) (w :z 2)) ; 1 < 2 47 | (t (r :y 1) (w :z 2)) ; 1 < 3 48 | (t (r :z 2))]}) ; [2 or 3] < 4 49 | [t0 t1 t2 t3 t4] (:txns h)] 50 | (is (= #{t0 t1} (set (bottlenecks- h)))))))) 51 | -------------------------------------------------------------------------------- /test/gretchen/constraint/flatzinc_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.constraint.flatzinc-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.test.check :as tc] 4 | [clojure.test.check.generators :as gen] 5 | [clojure.test.check.properties :as prop] 6 | [clojure.test.check.clojure-test :refer [defspec]] 7 | [clojure.walk :refer [postwalk-replace]] 8 | [clojure.set :as set] 9 | [clojure.math.numeric-tower :refer [expt]] 10 | [clojure.pprint :refer [pprint]] 11 | [gretchen.constraint-test :as ct] 12 | [gretchen.constraint.flatzinc :refer :all])) 13 | 14 | (def n 100) ; test.spec iters 15 | 16 | (deftest flatzinc-test 17 | (is (= (str "\nvar bool: x :: output_var;\n" 18 | "\n\n" 19 | "constraint bool_eq(x, true);\n" 20 | "\n" 21 | "solve satisfy;\n") 22 | (flatzinc-str '(and (bool :x) 23 | :x)))) 24 | 25 | (is (= (str "var 0..2: a :: output_var;\n" 26 | "var 0..2: b :: output_var;\n" 27 | "\n\n\n" 28 | "constraint int_lt(a, b);\n" 29 | "\n" 30 | "solve :: int_search([a, b], input_order, indomain_split, complete) satisfy;\n") 31 | (flatzinc-str '(and (in :a 0 2) 32 | (in :b 0 2) 33 | (< :a :b))))) 34 | 35 | (is (= (str "var 0..2: a :: output_var;\n" 36 | "var 0..2: b :: output_var;\n" 37 | "\n\n" 38 | "var bool: _fz0 :: var_is_introduced :: is_defined_var;\n" 39 | "var bool: _fz1 :: var_is_introduced :: is_defined_var;\n" 40 | "\n" 41 | "constraint int_lt_reif(a, b, _fz0) :: defines_var(_fz0);\n" 42 | "constraint int_lt_reif(b, a, _fz1) :: defines_var(_fz1);\n" 43 | "constraint bool_or(_fz0, _fz1, true);\n" 44 | "\n" 45 | "solve :: int_search([a, b], input_order, indomain_split, complete) " 46 | "satisfy;\n") 47 | (flatzinc-str '(and (in :a 0 2) 48 | (in :b 0 2) 49 | (or (< :a :b) 50 | (< :b :a))))))) 51 | (deftest solutions-test 52 | (is (= #{{:a 0 :b 1} 53 | {:a 0 :b 2} 54 | {:a 1 :b 2} 55 | {:a 1 :b 0} 56 | {:a 2 :b 0} 57 | {:a 2 :b 1}} 58 | (set (solutions '(and (in :a 0 2) 59 | (in :b 0 2) 60 | (or (< :a :b) 61 | (< :b :a)))))))) 62 | 63 | ; TODO: verify that all_different works 64 | 65 | (defspec tseitin-spec 66 | n 67 | (prop/for-all [e ct/gen-full-expr] 68 | (let [brute-solutions (ct/solutions e) 69 | fz-solutions (solutions e)] 70 | (or (= (set brute-solutions) 71 | (set fz-solutions)) 72 | (println) 73 | (println "----------------------------------------------") 74 | (println "Expression to solve") 75 | (pprint e) 76 | (println) 77 | (println "Brute-force solutions") 78 | (pprint (set brute-solutions)) 79 | (println) 80 | (println "Flatzinc-gecode solutions") 81 | (pprint (set fz-solutions)))))) 82 | -------------------------------------------------------------------------------- /test/gretchen/constraint_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.constraint-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.test.check :as tc] 4 | [clojure.test.check.generators :as gen] 5 | [clojure.test.check.properties :as prop] 6 | [clojure.test.check.clojure-test :refer [defspec]] 7 | [clojure.walk :refer [postwalk 8 | postwalk-replace]] 9 | [clojure.set :as set] 10 | [clojure.math.numeric-tower :refer [expt]] 11 | [clojure.pprint :refer [pprint]] 12 | [gretchen.constraint :as c :refer [simplify 13 | tseitin]])) 14 | 15 | (def n 100) ; test.spec iters 16 | (def expr-complexity-limit "Max number of nodes in full expression generator" 12) 17 | (def int-vars #{:i :j}) 18 | (def bool-vars #{:a :b}) 19 | 20 | (defn var-declarations 21 | "Given a constraint tree, what variable declarations are in it?" 22 | [tree] 23 | (->> tree 24 | (tree-seq sequential? next) 25 | (filter sequential?) 26 | (filter (comp #{'in 'bool} first)) 27 | (into #{}))) 28 | 29 | (defn vars 30 | "Given a constraint tree, what variables (keywords) are in it?" 31 | [tree] 32 | (->> tree 33 | (tree-seq sequential? next) 34 | (filter keyword?) 35 | (into (sorted-set)))) 36 | 37 | (def gen-bool-var (gen/elements bool-vars)) 38 | (def gen-int-var (gen/elements int-vars)) 39 | 40 | (def gen-int-relation 41 | (->> (gen/tuple (gen/elements ['< '<=]) gen-int-var gen-int-var) 42 | (gen/such-that (fn [t] (= 3 (count t)))) 43 | (gen/fmap (partial apply vector)))) 44 | 45 | (def gen-bool-terminal (gen/one-of [gen-bool-var 46 | gen-int-relation])) 47 | 48 | 49 | 50 | (defn gen-compound 51 | [g] 52 | (gen/one-of [(gen/fmap (partial vector 'not) g) 53 | (gen/fmap (comp vec (partial cons 'and)) (gen/tuple g g)) 54 | (gen/fmap (comp vec (partial cons 'or)) (gen/tuple g g))])) 55 | 56 | (defn add-declarations 57 | "Add variable declarations to a generated expression." 58 | [tree] 59 | (apply list 'and tree 60 | (->> (vars tree) 61 | (map (fn [v] 62 | (if (bool-vars v) 63 | ['bool v] 64 | ['in v 0 2])))))) 65 | 66 | (defn expr-size 67 | "Takes an expression and returns the number of subexpressions in it" 68 | [expr] 69 | (count (tree-seq sequential? rest expr))) 70 | 71 | (def gen-bool-expr 72 | "Basic boolean expressions" 73 | (gen/fmap add-declarations 74 | (gen/recursive-gen gen-compound gen-bool-var))) 75 | 76 | (def gen-full-expr 77 | "Both booleans and integers" 78 | (let [g (gen/recursive-gen gen-compound gen-bool-terminal) 79 | g (gen/such-that (fn [expr] (< (expr-size expr) expr-complexity-limit)) 80 | g 100)] 81 | (gen/fmap add-declarations g))) 82 | 83 | (def gen-simple-expr 84 | (gen/fmap simplify gen-full-expr)) 85 | 86 | (defn bool-assignments 87 | "Given a collection of boolean variables like '(bool v), computes all 88 | possible maps of variables to boolean values. Only up to 62 vars." 89 | [vars] 90 | (if-not (seq vars) 91 | [{}] 92 | (let [vars (object-array (map second vars)) 93 | n (count vars)] 94 | (assert (< n 63)) ; Math.pow breaks here 95 | (->> (range (Math/pow 2 n)) 96 | (map (fn [i] 97 | (->> (range n) 98 | (map (fn [v] 99 | [(aget vars v) (pos? (bit-and i (expt 2 v)))])) 100 | (into {})))))))) 101 | 102 | (defn int-assignments- 103 | "Helper for int-assignments" 104 | [vars lowers uppers values] 105 | (cons (zipmap vars values) 106 | (lazy-seq 107 | (loop [i 0 108 | values values] 109 | (if (<= (count vars) i) 110 | ; Can't go any further 111 | nil 112 | (let [var (nth vars i) 113 | lower (nth lowers i) 114 | upper (nth uppers i) 115 | value (nth values i)] 116 | (if (< value upper) 117 | ; We can increment this value 118 | (int-assignments- vars lowers uppers 119 | (assoc values i (inc value))) 120 | ; Out of range; zero and carry 121 | (recur (inc i) (assoc values i lower))))))))) 122 | 123 | (defn int-assignments 124 | "Given a collection of integer declarations like '(in v 0 2), computes all 125 | possible maps of variables to integer values." 126 | [ins] 127 | (if-not (seq ins) 128 | [{}] 129 | (let [vars (mapv second ins) 130 | lowers (mapv #(nth % 2) ins) 131 | uppers (mapv #(nth % 3) ins)] 132 | (int-assignments- vars lowers uppers lowers)))) 133 | 134 | (deftest int-assignments-test 135 | (is (= [{:x 1 :y 0} 136 | {:x 2 :y 0} 137 | {:x 1 :y 1} 138 | {:x 2 :y 1} 139 | {:x 1 :y 2} 140 | {:x 2 :y 2}] 141 | (int-assignments '[(in :x 1 2) (in :y 0 2)])))) 142 | 143 | (defn assignments 144 | "Given a collection of variable declarations, computes all possible 145 | assignments to those variables." 146 | [vars] 147 | (let [vars (group-by first vars) 148 | ints (int-assignments (get vars 'in)) 149 | bools (bool-assignments (get vars 'bool))] 150 | (for [i ints, b bools] 151 | (merge i b)))) 152 | 153 | (deftest assignments-test 154 | (is (= [{:a false} 155 | {:a true}] 156 | (assignments '#{(bool :a)})))) 157 | 158 | (defn solution? 159 | "Is the given map of variables to boolean values a satisfying assignment for 160 | the given expression tree?" 161 | [tree assignment] 162 | (cond ; Variable lookup 163 | (keyword? tree) 164 | (get assignment tree) 165 | 166 | ; Recurse 167 | (sequential? tree) 168 | (let [[type & children] tree] 169 | (condp = type 170 | 'bool (let [v (get assignment (first children))] 171 | (or (true? v) (false? v))) 172 | 'in (let [[var lower upper] children] 173 | (<= lower (get assignment var) upper)) 174 | '< (let [[v1 v2] children] 175 | (< (solution? v1 assignment) (solution? v2 assignment))) 176 | '<= (let [[v1 v2] children] 177 | (<= (solution? v1 assignment) (solution? v2 assignment))) 178 | 'not (not (solution? (first children) assignment)) 179 | 'or (loop [v nil 180 | children children] 181 | (if-not (seq children) 182 | v 183 | (let [x (solution? (first children) assignment)] 184 | (if x 185 | x 186 | (recur x (next children)))))) 187 | 'and (loop [children children] 188 | (if-not (seq children) 189 | true 190 | (let [x (solution? (first children) assignment)] 191 | (if x 192 | (recur (next children)) 193 | x)))))) 194 | 195 | ; Literals fall through 196 | true 197 | tree)) 198 | 199 | (defn clojure-eval-able 200 | "Turns an expression tree into something you can eval with Clojure." 201 | [tree ass] 202 | (postwalk 203 | (fn [form] 204 | ; (prn :postwalk form) 205 | ; Look up variables in assignment map 206 | (cond (keyword? form) 207 | (get ass form) 208 | 209 | ; Turn declarations into clojure predicates 210 | (sequential? form) 211 | (let [form (seq form)] ; Map back to code 212 | (condp = (first form) 213 | 'in (list '<= 214 | (nth form 2) 215 | (second form) 216 | (nth form 3)) 217 | 'bool (or (true? (second form)) 218 | (false? (second form))) 219 | form)) 220 | 221 | true 222 | form)) 223 | tree)) 224 | 225 | 226 | (defspec solution-spec 227 | n 228 | (prop/for-all [expr gen-full-expr 229 | ass (gen/hash-map :a gen/boolean 230 | :b gen/boolean 231 | :c gen/boolean 232 | :i gen/int 233 | :j gen/int 234 | :k gen/int)] 235 | (try 236 | (or (= (solution? expr ass) 237 | (eval (clojure-eval-able expr ass))) 238 | (prn :ass ass) 239 | (prn :expr (solution? expr ass) expr) 240 | (prn :clj (eval (clojure-eval-able expr ass)) 241 | (clojure-eval-able expr ass))) 242 | (catch Throwable t 243 | (prn :ass ass) 244 | (prn :expr (solution? expr ass) expr) 245 | (prn :clj (clojure-eval-able expr ass)) 246 | (prn :clj-res (eval (clojure-eval-able expr ass))) 247 | (throw t))))) 248 | 249 | (defn solutions 250 | "Given a constraint tree, finds all maps of variables to boolean values which 251 | satisfy that constraint." 252 | [tree] 253 | (->> tree var-declarations assignments (filter (partial solution? tree)))) 254 | 255 | (defn equivalent? 256 | "Given two expressions a and b, does every assignment of variables result in 257 | identical boolean values?" 258 | [a b] 259 | (let [vars (set/union (var-declarations a) (var-declarations b))] 260 | ; (prn :a) 261 | ; (pprint a) 262 | ; (prn :b) 263 | ; (pprint b) 264 | (every? (fn [ass] (= (solution? a ass) 265 | (solution? b ass))) 266 | (assignments vars)))) 267 | 268 | (defn subsatisfiable? 269 | "Given two constraint trees a and b, where b's variables are a superset of 270 | a's, ensures that either: 271 | 272 | - a is not satisfiable, and b is not satisfiable 273 | - both are satisfiable, and every solution to b is also a solution to a" 274 | [a b] 275 | (let [b-solns (solutions b)] 276 | (or (and (empty? b-solns) 277 | (empty? (solutions a))) 278 | (every? (partial solution? a) b-solns)))) 279 | 280 | (deftest simplify-test 281 | (is (= false (simplify '(not true)))) 282 | (is (= true (simplify '(not false)))) 283 | (is (= 'a (simplify '(not (not a))))) 284 | (is (= '(not a) (simplify '(not a))))) 285 | 286 | (defspec simplify-spec 287 | n 288 | (prop/for-all [e gen-full-expr] 289 | (or (equivalent? (simplify e) e) 290 | (prn :full e) 291 | (prn :smpl (simplify e))))) 292 | 293 | (deftest cnf-literal?-test 294 | (is (c/cnf-literal? :a)) 295 | (is (c/cnf-literal? '(not :a))) 296 | (is (c/cnf-literal? '(not (< :a :b)))) 297 | (is (not (c/cnf-literal? '(not (or :a :b))))) 298 | (is (not (c/cnf-literal? '(and :a :b))))) 299 | 300 | ; See http://www.decision-procedures.org/handouts/Tseitin70.pdf 301 | ; See http://fmv.jku.at/biere/talks/Biere-VTSA12-talk.pdf 302 | (deftest and-terms-test 303 | (is (= '[(or (not x) y) 304 | (or (not x) z) 305 | (or x (not y) (not z))] 306 | (c/and-terms 'x '(y z))))) 307 | 308 | (deftest or-terms-test 309 | (is (= '[(or x (not y)) 310 | (or x (not z)) 311 | (or (not x) y z)] 312 | (c/or-terms 'x '(y z))))) 313 | 314 | (deftest not-terms-test 315 | (is (= '[(or x y) 316 | (or (not x) (not y))] 317 | (c/not-terms 'x 'y)))) 318 | 319 | (deftest ops-to-vars-test 320 | (testing "single level" 321 | (is (= {'(and :a :b) :_t1} 322 | (c/ops-to-vars '(and :a :b) 1)))) 323 | 324 | (testing "nested" 325 | (is (= {'(and :a :b) :_t2 326 | '(or (and :a :b) :c) :_t1} 327 | (c/ops-to-vars '(or (and :a :b) :c) 1))))) 328 | 329 | (deftest tseitin-test 330 | ; (testing "A constant" 331 | ; (is (= true (tseitin true)))) 332 | 333 | (testing "already in cnf" 334 | (testing "literals" 335 | (is (= true (tseitin true))) 336 | (is (= false (tseitin false))) 337 | (is (= '(< :a :b) (tseitin '(< :a :b)))) 338 | (is (= '(not :a) (tseitin '(not :a))))) 339 | 340 | (testing "empty and" 341 | (is (= '(and) (tseitin '(and))))) 342 | 343 | (testing "and of literals" 344 | (is (= '(and :a (not :b) (< :a :b)) 345 | (tseitin '(and :a (not :b) (< :a :b)))))) 346 | 347 | (testing "or of literals" 348 | (is (= '(or :a (not :b)) 349 | (tseitin '(or :a (not :b)))))) 350 | 351 | (testing "and of ors of literals" 352 | (is (= '(and :a (or :b (not :c))) 353 | (tseitin '(and :a (or :b (not :c)))))))) 354 | 355 | (testing "or of and" 356 | (is (= '(and ; New vars 357 | (bool :_t0) 358 | (bool :_t1) 359 | ; Top level constraint 360 | :_t0 361 | ; _0: (or :a :v1) 362 | (or :_t0 (not :a)) 363 | (or :_t0 (not :_t1)) 364 | (or (not :_t0) :a :_t1) 365 | ; _1: (and :b :c) 366 | (or (not :_t1) :b) 367 | (or (not :_t1) :c) 368 | (or :_t1 (not :b) (not :c))) 369 | (tseitin '(or :a (and :b :c)))))) 370 | 371 | (let [t '(or :a (and :b :c))] 372 | (is (subsatisfiable? t (tseitin t))))) 373 | 374 | (defspec tseitin-spec 375 | n 376 | (prop/for-all [e gen-simple-expr] 377 | (try 378 | (subsatisfiable? e (tseitin e)) 379 | (catch Throwable t 380 | (prn :expr e) 381 | (prn :tsei (tseitin e)) 382 | (throw t))))) 383 | -------------------------------------------------------------------------------- /test/gretchen/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.core-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.pprint :refer [pprint]] 4 | [gretchen.core :refer :all] 5 | [gretchen.history :refer [prepare-history]] 6 | [gretchen.constraint :as c] 7 | [gretchen.constraint.flatzinc :refer [flatzinc]] 8 | [gretchen.gen :as gen :refer [t r w]] 9 | [loco.core :as loco])) 10 | 11 | (deftest history-test 12 | (->> {:x 0 :y 0} 13 | (gen/history 10) 14 | check-int-history)) 15 | ; pr-history)) 16 | 17 | (deftest constraint-test 18 | (is (= '(and 19 | (in :t0 0 2) 20 | (in :t1 0 2) 21 | (in :t2 0 2) 22 | (distinct :t0 :t1 :t2) 23 | (< :t0 :t1) 24 | (or (< :t2 :t0) (< :t1 :t2))) 25 | (-> {:initial {:x 0} ; t0 26 | :txns [(t (r :x 0)) ; t1 27 | (t (w :x 1))]} ; t2 28 | prepare-history 29 | (history-constraint))))) 30 | 31 | (deftest check-test 32 | (testing "wx0, rx0, wx1" 33 | (is (= [{:ops [{:f :write, :k :x, :v 0}], :i 0} ; t0 34 | {:ops [{:f :read, :k :x, :v 0}], :i 1} ; t1 35 | {:ops [{:f :write, :k :x, :v 1}], :i 2}] ; t2 36 | (:solution (check {:initial {:x 0} ; t0 37 | :txns [(t (r :x 0)) ; t1 38 | (t (w :x 1))]} ; t2 39 | (flatzinc)))))) 40 | 41 | (testing "P0 Dirty Write" 42 | ; A value pops into appearance out of nowhere (e.g. written by an aborted 43 | ; back txn) 44 | (is (= {:type :spurious-read 45 | :reads [{:txn {:ops [(r :x 1)] :i 1} 46 | :k :x 47 | :v 1}]} 48 | (:error (check {:initial {:x 0} 49 | :txns [(t (r :x 1))]} 50 | (flatzinc)))))) 51 | 52 | (testing "P4 Lost Update" 53 | ; Two read-modify-write increments 54 | (is (= {:type :no-ext-solution} 55 | (:error (check {:initial {:x 0} 56 | :txns [(t (r :x 0) (w :x 1)) 57 | (t (r :x 0) (w :x 1))]} 58 | (flatzinc)))))) 59 | 60 | ; See Berenson, et al 1995, "A Critique of ANSI SQL Isolation Levels" 61 | ; https://arxiv.org/pdf/cs/0701157.pdf 62 | (testing "A5A Read Skew" 63 | (let [init {:x 0, :y 0} 64 | t1 (t (r :x 0) (r :y 1)) 65 | t2 (t (w :x 1) (w :y 1))] 66 | (is (= {:type :no-ext-solution} 67 | (:error (check {:initial init :txns [t1 t2]} (flatzinc))))))) 68 | 69 | (testing "A5B Write Skew" 70 | (let [init {:x 0, :y 0} 71 | t1 (t (r :x 0) (r :y 0) (w :x 1)) 72 | t2 (t (r :x 0) (r :y 0) (w :y 2))] 73 | (is (= {:type :no-ext-solution} 74 | (:error (check {:initial init :txns [t1 t2]} (flatzinc)))))))) 75 | 76 | (deftest perf-test 77 | (let [h (gen/history 100 {:x 0 :y 0 :z 0})] 78 | (pprint h) 79 | (prn) 80 | (println "---------------------------------------------") 81 | (prn) 82 | (pprint (history-constraint (prepare-history h))) 83 | (prn) 84 | (prn :solution) 85 | (pprint (check h (flatzinc))))) 86 | -------------------------------------------------------------------------------- /test/gretchen/gen_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.gen-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.test.check.generators :as gen] 4 | [gretchen.history :as history])) 5 | 6 | (def key-gen (gen/elements [:x :y :z])) 7 | (def val-gen gen/pos-int) 8 | (def op-gen (gen/hash-map :f (gen/elements [:read :write]) 9 | :k key-gen 10 | :v val-gen)) 11 | (def txn-gen (gen/hash-map 12 | :ops (gen/vector op-gen))) 13 | (def state-gen (gen/map key-gen val-gen)) 14 | (def history-gen (gen/hash-map :initial state-gen 15 | :txns (gen/vector txn-gen))) 16 | (def augmented-history-gen 17 | (gen/fmap history/prepare-history history-gen)) 18 | -------------------------------------------------------------------------------- /test/gretchen/graph_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.graph-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.test.check :as tc] 4 | [clojure.test.check.generators :as gen] 5 | [clojure.test.check.properties :as prop] 6 | [clojure.test.check.clojure-test :refer [defspec]] 7 | [clojure.set :as set] 8 | [clojure.pprint :refer [pprint]] 9 | [gretchen.graph :refer :all] 10 | [gretchen.util :refer :all])) 11 | 12 | (def n 1e2) ; test.spec iters 13 | 14 | (def gen-vertices (gen/set gen/pos-int)) 15 | 16 | (defn gen-neighbors 17 | "Given a collection of vertices, builds a generator which generates a map of 18 | vertices to collections of vertices." 19 | [vertices] 20 | (if (empty? vertices) 21 | (gen/return {}) 22 | (gen/map (gen/elements vertices) 23 | (gen/vector-distinct (gen/elements vertices))))) 24 | 25 | (def gen-graph 26 | "Emits directed graphs like 27 | 28 | {:vertices [1 2 3] 29 | :neighbors {1 [1 3] 2 [3]}}" 30 | (gen/bind gen-vertices 31 | (fn [vertices] 32 | (gen/hash-map :vertices (gen/return vertices) 33 | :neighbors (gen-neighbors vertices))))) 34 | 35 | (deftest reachable-test 36 | (is (= #{} (reachable {:vertices [1 2] 37 | :neighbors {1 2}} 38 | []))) 39 | (is (= #{1} (reachable {:vertices [1 2] 40 | :neighbors {2 1 1 1}} 41 | [1]))) 42 | 43 | (is (= #{1 2 3 4} (reachable {:vertices [1 2 3 4 5] 44 | :neighbors {2 3 3 4}} 45 | [1 2])))) 46 | 47 | (defspec invert-spec 48 | n 49 | (prop/for-all [g gen-graph] 50 | (let [i (invert g)] 51 | (and (= (:vertices g) 52 | (:vertices i)) 53 | (let [gn (->> (:neighbors g) 54 | (map (juxt key (comp set val))) 55 | (into {})) 56 | in (->> (:neighbors i) 57 | (map (juxt key (comp set val))) 58 | (into {}))] 59 | (every? true? 60 | (for [a (:vertices g) 61 | b (:vertices g)] 62 | ; Iff a->b in g, b->a in i. 63 | (= (contains? (gn a) b) 64 | (contains? (in b) a))))))))) 65 | 66 | (defn partition? 67 | "Do the given subgraphs form a total partition of the elements of universe?" 68 | [universe subgraphs] 69 | (= (sort (:vertices universe)) 70 | (sort (apply concat (map :vertices subgraphs))))) 71 | 72 | (defn weak-connected? 73 | "Is the given graph weakly connected--e.g. following neighbors in either 74 | direction, is every node reachable from every other?" 75 | [g] 76 | (let [neighbors (:neighbors g) 77 | bn (persistent! 78 | (reduce (fn invert [bn src] 79 | (reduce (fn [bn dst] 80 | (-> bn 81 | (assoc! src (conj (get bn src []) dst)) 82 | (assoc! dst (conj (get bn dst []) src)))) 83 | bn 84 | (neighbors src))) 85 | (transient {}) 86 | (:vertices g)))] 87 | (= (set (:vertices g)) 88 | (fixed-point (fn expand [nodes] 89 | (->> nodes 90 | (mapcat bn) 91 | (into nodes))) 92 | (set (take 1 (:vertices g))))))) 93 | 94 | (deftest weak-connected-test 95 | (is (weak-connected? {:vertices [1 2 3] :neighbors {3 [2] 1 [2]}})) 96 | (is (weak-connected? {:vertices [] :neighbors {}})) 97 | (is (not (weak-connected? {:vertices [1 2 3] :neighbors {1 [2] 98 | 2 [1] 99 | 3 [3]}})))) 100 | 101 | (deftest disjoint-subgraphs-test 102 | (is (= #{#{0 1} #{2 3}} 103 | (set (map :vertices 104 | (disjoint-subgraphs 105 | {:vertices #{0 1 2 3} 106 | :neighbors {1 [0] 107 | 2 [2 3] 108 | 3 [2]}})))))) 109 | 110 | (defspec disjoint-subgraphs-spec 111 | n 112 | (prop/for-all [g gen-graph] 113 | (let [subgraphs (disjoint-subgraphs g)] 114 | (or (and (partition? g subgraphs) 115 | (every? weak-connected? subgraphs)) 116 | (prn :----------) 117 | (pprint g) 118 | (pprint subgraphs))))) 119 | -------------------------------------------------------------------------------- /test/gretchen/history_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.history-test 2 | (:refer-clojure :exclude [ancestors descendants]) 3 | (:require [clojure.test :refer :all] 4 | [clojure.test.check :as tc] 5 | [clojure.test.check.generators :as gen] 6 | [clojure.test.check.properties :as prop] 7 | [clojure.test.check.clojure-test :refer [defspec]] 8 | [clojure.set :as set] 9 | [clojure.pprint :refer [pprint]] 10 | [gretchen [gen :refer [r w t]] 11 | [gen-test :refer [augmented-history-gen]] 12 | [graph :as graph] 13 | [history :refer :all] 14 | [recurset :as recurset] 15 | [util :refer :all]])) 16 | 17 | (def n 1e3) ; test.spec iters 18 | 19 | (deftest ancestors-test 20 | (testing "empty history" 21 | (is (= {{:i 0 :ops []} #{}} 22 | (ancestors 23 | (prepare-history 24 | {:txns []}))))) 25 | 26 | (testing "unrelated txns" 27 | (let [h (prepare-history {:txns [(t (w :x 0) (w :y 0)) 28 | (t (w :x 1) (w :y 1))]}) 29 | [t0 t1 t2] (:txns h)] 30 | (is (= {t0 #{} 31 | t1 #{} 32 | t2 #{}} 33 | (ancestors h))))) 34 | 35 | (testing "linear chain of txns" 36 | (let [h (prepare-history {:initial {:x 0} 37 | :txns [(t (r :x 0) (w :x 1)) 38 | (t (r :x 1) (w :x 2)) 39 | (t (r :x 2))]}) 40 | [t0 t1 t2 t3] (:txns h)] 41 | (is (= {t0 #{} 42 | t1 #{t0} 43 | t2 #{t0 t1} 44 | t3 #{t0 t1 t2}} 45 | (ancestors h))))) 46 | 47 | (testing "fork-and-join" 48 | (let [h (prepare-history {:initial {:x 0} 49 | :txns [(t (r :x 0) (w :x 1)) ; 0 < 1 50 | (t (r :x 1) (w :y 2)) ; 1 < 2 51 | (t (r :x 1) (w :z 2)) ; 1 < 3 52 | (t (r :y 2) (r :z 2))]}) ; [2 and 3] < 4 53 | [t0 t1 t2 t3 t4] (:txns h)] 54 | (is (= {t0 #{} 55 | t1 #{t0} 56 | t2 #{t1 t0} 57 | t3 #{t1 t0} 58 | t4 #{t3 t2 t1 t0}} 59 | (ancestors h))))) 60 | 61 | (testing "fork-or-join" 62 | (let [h (prepare-history {:initial {:x 0} 63 | :txns [(t (r :x 0) (w :x 1) (w :y 1)) ; 0 < 1 64 | (t (r :x 1) (w :z 2)) ; 1 < 2 65 | (t (r :y 1) (w :z 2)) ; 1 < 3 66 | (t (r :z 2))]}) ; [2 or 3] < 4 67 | [t0 t1 t2 t3 t4] (:txns h)] 68 | (is (= {t0 #{} 69 | t1 #{t0} 70 | t2 #{t1 t0} 71 | t3 #{t1 t0} 72 | t4 #{t1 t0}} 73 | (ancestors h)))))) 74 | -------------------------------------------------------------------------------- /test/gretchen/recurset_test.clj: -------------------------------------------------------------------------------- 1 | (ns gretchen.recurset-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.test.check :as tc] 4 | [clojure.test.check.generators :as gen] 5 | [clojure.test.check.properties :as prop] 6 | [clojure.test.check.clojure-test :refer [defspec]] 7 | [clojure.set :as set] 8 | [clojure.pprint :refer [pprint]] 9 | [gretchen [gen-test :refer [augmented-history-gen]] 10 | [recurset :refer :all] 11 | [util :refer :all]])) 12 | 13 | (def n 1e3) ; test.spec iters 14 | 15 | (def gen-set (gen/vector gen/pos-int)) 16 | (defn gen-ast-node 17 | [g] 18 | (gen/one-of [(gen/fmap (partial cons :union) (gen/vector g)) 19 | (gen/fmap (partial cons :intersection) (gen/vector g))])) 20 | (def gen-ast (gen/recursive-gen gen-ast-node gen-set)) 21 | 22 | (defn evaluate [[type & args :as ast]] 23 | (condp = type 24 | :union (apply set/union (map evaluate args)) 25 | :intersection (apply set/intersection (map evaluate args)) 26 | (set ast))) 27 | 28 | (defn build [[type & args :as ast]] 29 | (condp = type 30 | :union (union (map build args)) 31 | :intersection (intersection (map build args)) 32 | ast)) 33 | 34 | (defspec set-spec 35 | n 36 | (with-redefs [eager-max-count-limit 4] 37 | (prop/for-all [ast gen-ast] 38 | (let [clj-soln (try (evaluate ast) 39 | (catch clojure.lang.ArityException e 40 | :universe)) 41 | our-soln (try (to-set (build ast)) 42 | (catch IllegalArgumentException e 43 | (if (= (.getMessage e) 44 | "Can't intersect 0 sets") 45 | :universe 46 | (throw e))))] 47 | (or (= clj-soln our-soln) 48 | (prn) 49 | (pprint ast) 50 | (prn :clojures clj-soln) 51 | (prn :recurset our-soln)))))) 52 | --------------------------------------------------------------------------------