├── .gitignore ├── LICENSE ├── README.md ├── doc ├── propaganda.png ├── set_datatype.md └── stm_vs_system.md ├── examples ├── building_height.clj ├── readme_example.clj ├── supported_building_height.clj ├── system_building_height.clj └── system_supported_building_height.clj ├── project.clj ├── src └── propaganda │ ├── generic_operators.clj │ ├── intervals │ ├── common.clj │ ├── stm.clj │ └── system.clj │ ├── stm.clj │ ├── support_values.clj │ ├── system.clj │ ├── tms │ └── stm.clj │ └── values.clj └── test └── propaganda ├── intervals_test.clj └── system_intervals_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | pom.xml.asc 7 | *.jar 8 | *.class 9 | .lein-deps-sum 10 | .lein-failures 11 | .lein-plugins 12 | .lein-repl-history 13 | /crossover 14 | /js 15 | .nrepl-port 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Eclipse Public License - v 1.0 3 | 4 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 5 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 6 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 7 | 8 | 1. DEFINITIONS 9 | 10 | "Contribution" means: 11 | 12 | a) in the case of the initial Contributor, the initial code and documentation 13 | distributed under this Agreement, and 14 | b) in the case of each subsequent Contributor: 15 | i) changes to the Program, and 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' 20 | from a Contributor if it was added to the Program by such Contributor 21 | itself or anyone acting on such Contributor's behalf. Contributions do not 22 | include additions to the Program which: (i) are separate modules of 23 | software distributed in conjunction with the Program under their own 24 | license 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 | a) Subject to the terms of this Agreement, each Contributor hereby grants 40 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 41 | reproduce, prepare derivative works of, publicly display, publicly 42 | perform, distribute and sublicense the Contribution of such Contributor, 43 | if any, and such derivative works, in source code and object code form. 44 | b) Subject to the terms of this Agreement, each Contributor hereby grants 45 | Recipient a non-exclusive, worldwide, royalty-free patent license under 46 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 47 | transfer the Contribution of such Contributor, if any, in source code and 48 | object code form. This patent license shall apply to the combination of 49 | the Contribution and the Program if, at the time the Contribution is 50 | added by the Contributor, such addition of the Contribution causes such 51 | combination to be covered by the Licensed Patents. The patent license 52 | shall not apply to any other combinations which include the Contribution. 53 | No hardware per se is licensed hereunder. 54 | c) Recipient understands that although each Contributor grants the licenses 55 | to its Contributions set forth herein, no assurances are provided by any 56 | Contributor that the Program does not infringe the patent or other 57 | intellectual property rights of any other entity. Each Contributor 58 | disclaims any liability to Recipient for claims brought by any other 59 | entity based on infringement of intellectual property rights or 60 | otherwise. As a condition to exercising the rights and licenses granted 61 | hereunder, each Recipient hereby assumes sole responsibility to secure 62 | any other intellectual property rights needed, if any. For example, if a 63 | third party patent license is required to allow Recipient to distribute 64 | the Program, it is Recipient's responsibility to acquire that license 65 | before distributing the Program. 66 | d) Each Contributor represents that to its knowledge it has sufficient 67 | copyright rights in its Contribution, if any, to grant the copyright 68 | license set forth in this Agreement. 69 | 70 | 3. REQUIREMENTS 71 | 72 | A Contributor may choose to distribute the Program in object code form under 73 | its own license agreement, provided that: 74 | 75 | a) it complies with the terms and conditions of this Agreement; and 76 | b) its license agreement: 77 | i) effectively disclaims on behalf of all Contributors all warranties 78 | and conditions, express and implied, including warranties or 79 | conditions of title and non-infringement, and implied warranties or 80 | conditions of merchantability and fitness for a particular purpose; 81 | ii) effectively excludes on behalf of all Contributors all liability for 82 | damages, including direct, indirect, special, incidental and 83 | consequential damages, such as lost profits; 84 | iii) states that any provisions which differ from this Agreement are 85 | offered by that Contributor alone and not by any other party; and 86 | iv) states that source code for the Program is available from such 87 | Contributor, and informs licensees how to obtain it in a reasonable 88 | manner on or through a medium customarily used for software exchange. 89 | 90 | When the Program is made available in source code form: 91 | 92 | a) it must be made available under this Agreement; and 93 | b) a copy of this Agreement must be included with each copy of the Program. 94 | Contributors may not remove or alter any copyright notices contained 95 | within the Program. 96 | 97 | Each Contributor must identify itself as the originator of its Contribution, 98 | if 99 | any, in a manner that reasonably allows subsequent Recipients to identify the 100 | originator of the Contribution. 101 | 102 | 4. COMMERCIAL DISTRIBUTION 103 | 104 | Commercial distributors of software may accept certain responsibilities with 105 | respect to end users, business partners and the like. While this license is 106 | intended to facilitate the commercial use of the Program, the Contributor who 107 | includes the Program in a commercial product offering should do so in a manner 108 | which does not create potential liability for other Contributors. Therefore, 109 | if a Contributor includes the Program in a commercial product offering, such 110 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 111 | every other Contributor ("Indemnified Contributor") against any losses, 112 | damages and costs (collectively "Losses") arising from claims, lawsuits and 113 | other legal actions brought by a third party against the Indemnified 114 | Contributor to the extent caused by the acts or omissions of such Commercial 115 | Contributor in connection with its distribution of the Program in a commercial 116 | product offering. The obligations in this section do not apply to any claims 117 | or Losses relating to any actual or alleged intellectual property 118 | infringement. In order to qualify, an Indemnified Contributor must: 119 | a) promptly notify the Commercial Contributor in writing of such claim, and 120 | b) allow the Commercial Contributor to control, and cooperate with the 121 | Commercial Contributor in, the defense and any related settlement 122 | negotiations. The Indemnified Contributor may participate in any such claim at 123 | its own expense. 124 | 125 | For example, a Contributor might include the Program in a commercial product 126 | offering, Product X. That Contributor is then a Commercial Contributor. If 127 | that Commercial Contributor then makes performance claims, or offers 128 | warranties related to Product X, those performance claims and warranties are 129 | such Commercial Contributor's responsibility alone. Under this section, the 130 | Commercial Contributor would have to defend claims against the other 131 | Contributors related to those performance claims and warranties, and if a 132 | court requires any other Contributor to pay any damages as a result, the 133 | Commercial Contributor must pay those damages. 134 | 135 | 5. NO WARRANTY 136 | 137 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 138 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 139 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 140 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 141 | Recipient is solely responsible for determining the appropriateness of using 142 | and distributing the Program and assumes all risks associated with its 143 | exercise of rights under this Agreement , including but not limited to the 144 | risks and costs of program errors, compliance with applicable laws, damage to 145 | or loss of data, programs or equipment, and unavailability or interruption of 146 | operations. 147 | 148 | 6. DISCLAIMER OF LIABILITY 149 | 150 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 151 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 152 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 153 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 154 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 155 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 156 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 157 | OF SUCH DAMAGES. 158 | 159 | 7. GENERAL 160 | 161 | If any provision of this Agreement is invalid or unenforceable under 162 | applicable law, it shall not affect the validity or enforceability of the 163 | remainder of the terms of this Agreement, and without further action by the 164 | parties hereto, such provision shall be reformed to the minimum extent 165 | necessary to make such provision valid and enforceable. 166 | 167 | If Recipient institutes patent litigation against any entity (including a 168 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 169 | (excluding combinations of the Program with other software or hardware) 170 | infringes such Recipient's patent(s), then such Recipient's rights granted 171 | under Section 2(b) shall terminate as of the date such litigation is filed. 172 | 173 | All Recipient's rights under this Agreement shall terminate if it fails to 174 | comply with any of the material terms or conditions of this Agreement and does 175 | not cure such failure in a reasonable period of time after becoming aware of 176 | such noncompliance. If all Recipient's rights under this Agreement terminate, 177 | Recipient agrees to cease use and distribution of the Program as soon as 178 | reasonably practicable. However, Recipient's obligations under this Agreement 179 | and any licenses granted by Recipient relating to the Program shall continue 180 | and survive. 181 | 182 | Everyone is permitted to copy and distribute copies of this Agreement, but in 183 | order to avoid inconsistency the Agreement is copyrighted and may only be 184 | modified in the following manner. The Agreement Steward reserves the right to 185 | publish new versions (including revisions) of this Agreement from time to 186 | time. No one other than the Agreement Steward has the right to modify this 187 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 188 | Eclipse Foundation may assign the responsibility to serve as the Agreement 189 | Steward to a suitable separate entity. Each new version of the Agreement will 190 | be given a distinguishing version number. The Program (including 191 | Contributions) may always be distributed subject to the version of the 192 | Agreement under which it was received. In addition, after a new version of the 193 | Agreement is published, Contributor may elect to distribute the Program 194 | (including its Contributions) under the new version. Except as expressly 195 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 196 | licenses to the intellectual property of any Contributor under this Agreement, 197 | whether expressly, by implication, estoppel or otherwise. All rights in the 198 | Program not expressly granted under this Agreement are reserved. 199 | 200 | This Agreement is governed by the laws of the State of New York and the 201 | intellectual property laws of the United States of America. No party to this 202 | Agreement will bring a legal action under this Agreement more than one year 203 | after the cause of action arose. Each party waives its rights to a jury trial in 204 | any resulting litigation. 205 | 206 | 207 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # propaganda 2 | 3 | Punching values through the system 4 | 5 | The propaganda library is a Clojure implementation of the propagator computational model described in [The Art of the Propagator](http://dspace.mit.edu/handle/1721.1/44215). The aim of the library is to be easy to use and reason about, yet extensible. 6 | 7 | Two different strategies have been implemented: one using the [Clojure STM](http://clojure.org/refs) for handling the propagation of values in the system; and one representing the system as an immutable value, without the aid of any underlying transactional model. The latter approach makes it possible to use propagators from javascript, and is the biggest contribution from this project. 8 | 9 | There is a Clojars release containing an implementation that works in both Clojure and ClojureScript. 10 | 11 | The leiningen dependency is 12 | 13 | [propaganda "0.2.0"] 14 | 15 | ## Tutorial 16 | 17 | Here follows a short tutorial. For more in depth information, please consult the following sources: 18 | 19 | - The 2013 Clojure/conj talk [Propagators in Clojure](http://www.youtube.com/watch?v=JXOOO9MLvhs), which gives a broad overview of what propagators are, and how they are implemented in this library. 20 | 21 | - The 2014 London Clojurians meetup talk "Propaganda! A declarative programming model in Clojure" is available [here as a SkillsCast](https://skillsmatter.com/skillscasts/5103-propaganda-a-declarative-programming-model-in-clojure). The examples and the slides are [available here at github](https://github.com/tgk/propaganda-a-declarative-programming-model-in-clojure). 22 | 23 | - [Getting hot with propagators](http://tgk.github.io/2014/01/getting-hot-with-propagators.html) and [Taking propagators to the next level](http://tgk.github.io/2014/01/taking-propagators-to-the-next-level.html) - two tutorials that dive a bit deeper in explaining how the propaganda library works. 24 | 25 | - The `gh-pages` branch of this project contains a brief explanation of the basics of the propagator computational model. The page can be visited [here](http://tgk.github.io/propaganda/). 26 | 27 | - [STM vs. System propagation](https://github.com/tgk/propaganda/blob/master/doc/stm_vs_system.md) illustrates the differences between the STM and system approach to propagation using the building height problem. 28 | 29 | - [Extending propaganda with set values](https://github.com/tgk/propaganda/blob/master/doc/set_datatype.md) shows how to extend propaganda with support for sets. 30 | 31 | - [The Art of the Propagator](http://dspace.mit.edu/handle/1721.1/44215) contains a more in-depth explanation of how propagation can be implemented. 32 | 33 | 34 | To use the propaganda library, you need to define a merge, function, create cells and set up propagators. The merge function is invoked when a propagator attempts to store a new value in a cell. The merge function is invoked with the current value and the new value, and must return either a new value which will be stored in the cell, or a `Conflict` object. 35 | 36 | In this short example we just use the default merger function, we define the square and square-root propagator and set up relations beween simple cells. 37 | 38 | ```clojure 39 | (use 'propaganda.stm) 40 | (use 'propaganda.values) 41 | ``` 42 | 43 | `default-merge` will give us a merger that will merge 44 | nothing with anything, but will enforce that anything else 45 | that is attempted to be merged will return a contradiction 46 | ```clojure 47 | (def my-merge 48 | (default-merge)) 49 | ``` 50 | 51 | `nothing` can be merged with `nothing` and will return `nothing` 52 | ```clojure 53 | (my-merge nothing nothing) 54 | ;; => :propaganda.values/nothing 55 | ``` 56 | 57 | Anything else will be the result of the merge 58 | ```clojure 59 | (my-merge nothing 1) 60 | ;; => 1 61 | (my-merge 2 nothing) 62 | ;; => 2 63 | (my-merge 1 1) 64 | ;; => 1 65 | ``` 66 | 67 | ... unless it gives rise to a contradiction 68 | ```clojure 69 | (my-merge 1 2) 70 | ;; => #propaganda.core.Contradiction{:reason "1 != 2"} 71 | ``` 72 | 73 | The `function->propagator-constructor` can be used for setting up 74 | simple one way relations 75 | ```clojure 76 | (def squarer 77 | (function->propagator-constructor 78 | (fn [val] (* val val)))) 79 | 80 | (def sqrter 81 | (function->propagator-constructor 82 | (fn [val] (Math/sqrt val)))) 83 | ``` 84 | 85 | ... which can be extended to go both ways 86 | ```clojure 87 | (defn quadratic 88 | [x x-squared] 89 | (squarer x x-squared) 90 | (sqrter x-squared x)) 91 | ``` 92 | 93 | We can now construct cells and set up the quadratic relations to read 94 | the squared of a number in our system: 95 | ```clojure 96 | (let [x (make-cell) 97 | x-squared (make-cell)] 98 | (binding [*merge* my-merge] 99 | (quadratic x x-squared) 100 | (add-content x 10.0) 101 | (get-content x-squared))) 102 | ;; => 100.0 103 | ``` 104 | 105 | Or the square-root, depending on the input from the user 106 | ```clojure 107 | (let [y (make-cell) 108 | y-squared (make-cell)] 109 | (binding [*merge* my-merge] 110 | (quadratic y y-squared) 111 | (add-content y-squared 1764.0) 112 | (get-content y))) 113 | ;; => 42.0 114 | ``` 115 | 116 | We will be warned of any inconsistencies in our system when adding 117 | content 118 | ```clojure 119 | (let [z (make-cell) 120 | z-squared (make-cell)] 121 | (binding [*merge* my-merge] 122 | (quadratic z z-squared) 123 | (add-content z 10.0) 124 | (add-content z-squared 123.0))) 125 | ;; Exception: Inconsistency: 100.0 != 123.0 126 | ``` 127 | 128 | ## Motivation 129 | 130 | The objective of this project is to create an extinsible propagator library for Clojure. Propagators define a declarative computational model. They are described in the article [The Art of the Propagator](http://dspace.mit.edu/handle/1721.1/44215). 131 | 132 | Along with the library itself, the project should supply documentation of the API, good examples and tutorials. 133 | 134 | I have not previously worked with propagtors, so this will also be an exploration for me. 135 | 136 | ## Thanks to 137 | 138 | [Ragnar Dahlén](https://github.com/ragnard/) and [Kasper Langer](https://github.com/kasperlanger) for feedback on the library. 139 | -------------------------------------------------------------------------------- /doc/propaganda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tgk/propaganda/09eac861277dd9aaa7508088352dbcf46c0f79a8/doc/propaganda.png -------------------------------------------------------------------------------- /doc/set_datatype.md: -------------------------------------------------------------------------------- 1 | # Extending propaganda with set values 2 | 3 | This brief tutorial illustrates how to extend cell values with a new datatype, namely sets. The extension is performed in the system propagator approach, which means it can be used in both Clojure and ClojureScript. 4 | 5 | In this example, the semantics of a set value is as follows: a cell contains some other value, or a set. If it contains a set, and you add another set, the new values is the intersection of the sets. If the intersection is empty, this is a contradiction. If a value other than a set is added to a cell, the set in the cell is checked to see if the value is in the set. If it is, the new value of the cell is the value. If not, this is a contradiction. 6 | 7 | First, we need to get the basic dependencies 8 | 9 | ```clojure 10 | (ns user 11 | (:require [propaganda.system :as system] 12 | [propaganda.values :as values] 13 | [propaganda.generic-operators :as go] 14 | [clojure.set :refer [intersection union difference]])) 15 | ``` 16 | 17 | Next, we create two helper functions: one for creating intersections (or contradictions), and one for checking values are in sets (or raise contradictions). 18 | 19 | ```clojure 20 | (defn check-intersection 21 | [s1 s2] 22 | (let [i (intersection s1 s2)] 23 | (if (seq i) 24 | (if (= 1 (count i)) 25 | (first i) 26 | i) 27 | (values/contradiction 28 | (format "Intersection of %s and %s is empty" s1 s2))))) 29 | 30 | (defn check-in-set 31 | [e s] 32 | (if (contains? s e) 33 | e 34 | (values/contradiction 35 | (format "%s is not in %s" e s)))) 36 | ``` 37 | 38 | With `check-intersection` and `check-in-set`, we are ready to write a function for extending a `merge` operator, using generic operators. 39 | 40 | ```clojure 41 | (defn extend-merge 42 | [merge] 43 | (doto merge 44 | (go/assign-operation 45 | (fn [content increment] 46 | (check-in-set increment content)) 47 | set? values/any?) 48 | (go/assign-operation 49 | (fn [content increment] 50 | (check-in-set content increment)) 51 | values/any? set?) 52 | (go/assign-operation 53 | check-intersection 54 | set? set?))) 55 | ``` 56 | 57 | We introduce a helper function to extract cell values from a system and take our implementation for a spin: 58 | 59 | ```clojure 60 | (defn keyword-values 61 | [system] 62 | (let [ks (->> system :values keys (filter keyword?))] 63 | (select-keys (:values system) ks))) 64 | 65 | (let [my-merge (doto (values/default-merge) 66 | extend-merge) 67 | my-contradictory (values/default-contradictory?) 68 | s (system/make-system my-merge my-contradictory)] 69 | [(-> s 70 | (system/add-value :cell #{:foo :bar :baz}) 71 | (system/add-value :cell #{:foo :bar}) 72 | keyword-values) 73 | (-> s 74 | (system/add-value :cell #{:foo :bar}) 75 | (system/add-value :cell #{:foo}) 76 | keyword-values) 77 | (-> s 78 | (system/add-value :cell #{:foo :bar}) 79 | (system/add-value :cell :bar) 80 | keyword-values) 81 | (try 82 | (-> s 83 | (system/add-value :cell #{:bar}) 84 | (system/add-value :cell #{:foo})) 85 | (catch Exception e e))]) 86 | ``` 87 | 88 | The result of the three first expressions in the vector are cells with reasonable values. The last expression gives rise to a contradiction, which we capture and present. 89 | 90 | ```clojure 91 | [{:cell #{:foo :bar}} 92 | {:cell :foo} 93 | {:cell :bar} 94 | #] 95 | ``` 96 | 97 | That's all that is needed for basic set support. To help you set up relations between sets, here is a basic union relation. Creating other relations can be done in a similar manner. 98 | 99 | ```clojure 100 | (defn union-relation 101 | [system s1 s2 result] 102 | (-> system 103 | ((system/function->propagator-constructor union) s1 s2 result) 104 | ((system/function->propagator-constructor difference) result s1 s2) 105 | ((system/function->propagator-constructor difference) result s2 s1))) 106 | ``` 107 | 108 | Have fun exploring sets! 109 | -------------------------------------------------------------------------------- /doc/stm_vs_system.md: -------------------------------------------------------------------------------- 1 | # STM vs. System propagation 2 | 3 | The original [The Art of the Propagator](http://dspace.mit.edu/handle/1721.1/44215) paper uses an approach in which cells are created and maintained in the runtime of the environment hosting the implementation. This approach lends itself very nicely to Clojure's STM, as coordination between cells and propagators must happen in a synchronised manner. The implementation in the `propaganda.stm` namespace follows this approach. 4 | 5 | The approach does not directly translate to runtimes in which there are weaker synchronisation mechanisms, such as the javascript runtime. The propaganda library therefore contains a novel approach in which all values of a system is kept in an immutable datastructure, called the *system*. When values are added to cells, a new system is returned with the value added, or a contradiction is raised if the value contradicts facts already in the system. The implementation in the `propaganda.system` namespace follows this approach. 6 | 7 | This document outlines how the two different approaches can be used to solve the building height problem (also known as [the barometer question](http://en.wikipedia.org/wiki/Barometer_question)). 8 | 9 | ## The building height problem 10 | 11 | We wish to determine the height of a building, using only a barometer. We are going to use three different approaches to do so: 12 | 13 | - _Fall duration_ We are going to drop the barometer from the top of the building, measure the time until the barometer hits the ground, and estimate the height using the gravitational force. 14 | 15 | - _Barometer shadow_ We will measure the shadow of the building, the height of the barometer and the length of the barometers shadow. The barometer will represent a scaled version of the building, and by finding the ratio between the two shadows, we can apply the same ratio to the height of the barometer to find the height of the building. 16 | 17 | - _Bribing the superintendent_ We will give the barometer to the superintendent in exchange for the information. 18 | 19 | The two first approaches will have a lot of error associated with them, represented by interval values of our cells. As we add information, it will feed back into these cells to improve the estimates of our input variables. 20 | 21 | ## STM building height implementation 22 | 23 | First, we need the basic dependencies for having interval values and STM propagation. 24 | 25 | ```clojure 26 | (use 'propaganda.stm) 27 | (use 'propaganda.values) 28 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 29 | (use 'propaganda.intervals.stm) 30 | ``` 31 | 32 | We create a helper function for setting up a fall duration relation between cells. `(fall-duration t h)` will create the relationship between time `t` in seconds and heigth `h` subject to some uncertainty on the gravitational force. 33 | 34 | ```clojure 35 | (defn fall-duration 36 | [t h] 37 | (compound-propagator 38 | [t] 39 | (fn [] 40 | (let [g (make-cell) 41 | one-half (make-cell) 42 | t-squared (make-cell) 43 | gt-squared (make-cell)] 44 | ((constant (make-interval 9.789 9.832)) g) 45 | ((constant 0.5) one-half) 46 | (quadratic t t-squared) 47 | (product g t-squared gt-squared) 48 | (product one-half gt-squared h))))) 49 | ``` 50 | 51 | We also introduce a helper for the shadow relations, called `similar-triangles`. `(similar-triangles s-ba h-ba s h)` create the relation described in the previous section between the shadow and height of the barometer, and the shadow and height of the building. 52 | 53 | ```clojure 54 | (defn similar-triangles 55 | [s-ba h-ba s h] 56 | (compound-propagator 57 | [s-ba h-ba s] 58 | (fn [] 59 | (let [ratio (make-cell)] 60 | (product s-ba ratio h-ba) 61 | (product s ratio h))))) 62 | ``` 63 | 64 | We can now create a merge function that takes intervals into account, set up our cells and add the relations between them. 65 | 66 | ```clojure 67 | (let [custom-merge (doto (default-merge) extend-merge)] 68 | (binding [*merge* custom-merge] 69 | (let [building-height (make-cell) 70 | 71 | fall-time (make-cell) 72 | 73 | barometer-height (make-cell) 74 | barometer-shadow (make-cell) 75 | building-shadow (make-cell)] 76 | 77 | (fall-duration fall-time building-height) 78 | (add-value fall-time (make-interval 2.9 3.1)) 79 | 80 | (similar-triangles barometer-shadow barometer-height 81 | building-shadow building-height) 82 | (add-value building-shadow (make-interval 54.9 55.1)) 83 | (add-value barometer-height (make-interval 0.3 0.32)) 84 | (add-value barometer-shadow (make-interval 0.36 0.37)) 85 | 86 | (add-value building-height 45.0) 87 | 88 | [(get-value building-height) 89 | (get-value building-shadow) 90 | (get-value barometer-height) 91 | (get-value barometer-shadow) 92 | (get-value fall-time)]))) 93 | ``` 94 | 95 | As you can see, most of our input are intervals, as there will be some uncertainty on our observations (we are measuring the real world, after all). The output of the expression is given below. Notice how the intervals get refined on our input values. For example, we now have a much better estimate on the fal time than we had before (from [2.9, 3.1] to [3.026, 3.032]). 96 | 97 | ```clojure 98 | [45 99 | {:lo 54.9, :hi 55.1} 100 | {:lo 0.3, :hi 0.30327868852459017} 101 | {:lo 0.366, :hi 0.37} 102 | {:lo 3.025522031629098, :hi 3.0321598338046556}] 103 | ``` 104 | 105 | There are several annoying things about the example above: 106 | 107 | - We have to use bindings to set `*merge*`, the merging function that understands intervals. 108 | - Steps are performed in (implicit) `dosync`s. 109 | - We are (implictly) putting our propagators in global vars where they will never be garbage collected from. 110 | - We are unable to branch out. If we change the value of a cell, it will remain changed. We can't undo add a value to a cell. 111 | 112 | The system approach solves all of these problems. 113 | 114 | ## System building height implementation 115 | 116 | To switch to the system approach, we need the `system` namespaces where we used `stm` before. 117 | 118 | ```clojure 119 | (use 'propaganda.system) 120 | (use 'propaganda.values) 121 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 122 | (use 'propaganda.intervals.system) 123 | ``` 124 | 125 | The functions setting up our relations now have to take the system as a parameter and return an altered system, as opposed to registering global propagators. 126 | 127 | ```clojure 128 | (defn fall-duration 129 | [system t h] 130 | (let [g (gensym) 131 | one-half (gensym) 132 | t-squared (gensym) 133 | gt-squared (gensym)] 134 | (-> system 135 | ((constant (make-interval 9.789 9.790)) g) 136 | ((constant 0.5) one-half) 137 | (quadratic t t-squared) 138 | (product g t-squared gt-squared) 139 | (product one-half gt-squared h)))) 140 | 141 | (defn similar-triangles 142 | [system s-ba h-ba s h] 143 | (let [ratio (gensym)] 144 | (-> system 145 | (product s-ba ratio h-ba) 146 | (product s ratio h)))) 147 | ``` 148 | 149 | Likewise, when setting up the system, each function returns a new altered system that we need to thread through to the next function. We no longer need to bind any global variables - we simply pass our merge function to `make-system` when creating a blank system. 150 | 151 | ```clojure 152 | (let [custom-merge (doto (default-merge) extend-merge) 153 | system (make-system custom-merge (default-contradictory?)) 154 | result-system (-> system 155 | 156 | (fall-duration :fall-time :building-height) 157 | (add-value :fall-time (make-interval 2.9 3.1)) 158 | 159 | (similar-triangles :barometer-shadow :barometer-height 160 | :building-shadow :building-height) 161 | (add-value :building-shadow (make-interval 54.9 55.1)) 162 | (add-value :barometer-height (make-interval 0.3 0.32)) 163 | (add-value :barometer-shadow (make-interval 0.36 0.37)) 164 | 165 | (add-value :building-height 45.0))] 166 | 167 | [(get-value result-system :building-height) 168 | (get-value result-system :building-shadow) 169 | (get-value result-system :barometer-height) 170 | (get-value result-system :barometer-shadow) 171 | (get-value result-system :fall-time)]) 172 | ``` 173 | 174 | The result is the same as before. 175 | 176 | ```clojure 177 | [45 178 | {:lo 54.9, :hi 55.1} 179 | {:lo 0.3, :hi 0.30327868852459017} 180 | {:lo 0.366, :hi 0.37} 181 | {:lo 3.025522031629098, :hi 3.0321598338046556}] 182 | ``` 183 | 184 | To re-iterate, the system approach requires us to feed the system to each call and use the altered system in future calls. This means that 185 | 186 | - We no longer have to bind a global `*merge*` function. 187 | - Steps are no longer performed in implicit `dosync`s. 188 | - No propagators are put in global vars, they are kept in the system. 189 | - We can take a system at any time, perform experiments on it and choose to use it, or to revert back to our old copy (or copies) of the system. 190 | 191 | Have a go at altering facts and relations in the system. It helps in understanding which relations and values influence what in the system. 192 | -------------------------------------------------------------------------------- /examples/building_height.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'user) 2 | 3 | (use 'propaganda.stm) 4 | (use 'propaganda.values) 5 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 6 | (use 'propaganda.intervals.stm) 7 | 8 | (defn fall-duration 9 | [t h] 10 | (compound-propagator 11 | [t] 12 | (fn [] 13 | (let [g (make-cell) 14 | one-half (make-cell) 15 | t-squared (make-cell) 16 | gt-squared (make-cell)] 17 | ((constant (make-interval 9.789 9.832)) g) 18 | ((constant 0.5) one-half) 19 | (quadratic t t-squared) 20 | (product g t-squared gt-squared) 21 | (product one-half gt-squared h))))) 22 | 23 | (defn similar-triangles 24 | [s-ba h-ba s h] 25 | (compound-propagator 26 | [s-ba h-ba s] 27 | (fn [] 28 | (let [ratio (make-cell)] 29 | (product s-ba ratio h-ba) 30 | (product s ratio h))))) 31 | 32 | ;; Trying it all out while bribing the building's superintendent 33 | (clojure.pprint/pprint 34 | (let [custom-merge (doto (default-merge) extend-merge)] 35 | (binding [*merge* custom-merge] 36 | (let [building-height (make-cell) 37 | 38 | fall-time (make-cell) 39 | 40 | barometer-height (make-cell) 41 | barometer-shadow (make-cell) 42 | building-shadow (make-cell)] 43 | 44 | (fall-duration fall-time building-height) 45 | (add-value fall-time (make-interval 2.9 3.1)) 46 | 47 | (similar-triangles barometer-shadow barometer-height 48 | building-shadow building-height) 49 | (add-value building-shadow (make-interval 54.9 55.1)) 50 | (add-value barometer-height (make-interval 0.3 0.32)) 51 | (add-value barometer-shadow (make-interval 0.36 0.37)) 52 | 53 | (add-value building-height 45.0) 54 | 55 | [(get-value building-height) 56 | (get-value building-shadow) 57 | (get-value barometer-height) 58 | (get-value barometer-shadow) 59 | (get-value fall-time)])))) 60 | ;; => [45 61 | ;; {:lo 54.9, :hi 55.1} 62 | ;; {:lo 0.3, :hi 0.30327868852459017} 63 | ;; {:lo 0.366, :hi 0.37} 64 | ;; {:lo 3.025522031629098, :hi 3.0321598338046556}] 65 | -------------------------------------------------------------------------------- /examples/readme_example.clj: -------------------------------------------------------------------------------- 1 | (use 'propaganda.stm) 2 | (use 'propaganda.values) 3 | 4 | ;; default-merge will give us a merger that will merge 5 | ;; nothing with anything, but will enforce that anything else 6 | ;; that is attempted to be merged will return a contradiction 7 | (def my-merge 8 | (default-merge)) 9 | 10 | ;; nothing can be merged with nothing and will return nothing 11 | (my-merge nothing nothing) 12 | ;; => :propaganda.values/nothing 13 | 14 | ;; anything else will be the result of the merge 15 | (my-merge nothing 1) 16 | ;; => 1 17 | (my-merge 2 nothing) 18 | ;; => 2 19 | (my-merge 1 1) 20 | ;; => 1 21 | 22 | ;; ... unless it gives rise to a contradiction 23 | (my-merge 1 2) 24 | ;; => #propaganda.core.Contradiction{:reason "1 != 2"} 25 | 26 | 27 | ;; the function->propagator-constructore can be used for setting up 28 | ;; simple one way relations 29 | (def squarer 30 | (function->propagator-constructor 31 | (fn [val] (* val val)))) 32 | 33 | (def sqrter 34 | (function->propagator-constructor 35 | (fn [val] (Math/sqrt val)))) 36 | 37 | ;; ... which can be extended to go both ways 38 | (defn quadratic 39 | [x x-squared] 40 | (squarer x x-squared) 41 | (sqrter x-squared x)) 42 | 43 | 44 | ;; we can now construct cells and set up the quadratic relations to read 45 | ;; the squared of a number in our system: 46 | (let [x (make-cell) 47 | x-squared (make-cell)] 48 | (binding [*merge* my-merge] 49 | (quadratic x x-squared) 50 | (add-value x 10.0) 51 | (get-value x-squared))) 52 | ;; => 100.0 53 | 54 | ;; or the square-root, depending on the input from the user 55 | (let [y (make-cell) 56 | y-squared (make-cell)] 57 | (binding [*merge* my-merge] 58 | (quadratic y y-squared) 59 | (add-value y-squared 1764.0) 60 | (get-value y))) 61 | ;; => 42.0 62 | 63 | ;; we will be warned of any inconsistencies in our system when adding 64 | ;; content 65 | (let [z (make-cell) 66 | z-squared (make-cell)] 67 | (binding [*merge* my-merge] 68 | (quadratic z z-squared) 69 | (add-value z 10.0) 70 | (add-value z-squared 123.0))) 71 | ;; Exception: Inconsistency: 100.0 != 123.0 72 | -------------------------------------------------------------------------------- /examples/supported_building_height.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'user) 2 | 3 | (use 'propaganda.stm) 4 | (use 'propaganda.values) 5 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 6 | (use 'propaganda.intervals.stm) 7 | (require '(propaganda [support-values :as support-values])) 8 | 9 | (defn fall-duration 10 | "Creates propagator from fall duration t to building height h with 11 | some uncertainty on the gravitational acceleration." 12 | [t h] 13 | (compound-propagator 14 | [t] 15 | (fn [] 16 | (let [g (make-cell) 17 | one-half (make-cell) 18 | t-squared (make-cell) 19 | gt-squared (make-cell)] 20 | ((constant (make-interval 9.789 9.832)) g) 21 | ((constant 0.5) one-half) 22 | (quadratic t t-squared) 23 | (product g t-squared gt-squared) 24 | (product one-half gt-squared h))))) 25 | 26 | (defn similar-triangles 27 | [s-ba h-ba s h] 28 | (compound-propagator 29 | [s-ba h-ba s] 30 | (fn [] 31 | (let [ratio (make-cell)] 32 | (product s-ba ratio h-ba) 33 | (product s ratio h))))) 34 | 35 | ;; Trying it all out while bribing the building's superintendent 36 | (clojure.pprint/pprint 37 | (let [custom-merge (doto (default-merge) 38 | extend-merge 39 | support-values/extend-merge) 40 | custom-contradictory? (doto (default-contradictory?) 41 | support-values/extend-contradictory?)] 42 | (binding [*merge* custom-merge 43 | ;; No contradictions are found, but including it anyways 44 | *contradictory?* custom-contradictory?] 45 | (let [building-height (make-cell) 46 | 47 | fall-time (make-cell) 48 | 49 | barometer-height (make-cell) 50 | barometer-shadow (make-cell) 51 | building-shadow (make-cell)] 52 | 53 | (fall-duration fall-time building-height) 54 | (similar-triangles barometer-shadow barometer-height 55 | building-shadow building-height) 56 | 57 | 58 | (add-value building-shadow 59 | (support-values/supported 60 | (make-interval 54.9 55.1) 61 | :shadows)) 62 | (add-value barometer-height 63 | (support-values/supported 64 | (make-interval 0.3 0.32) 65 | :shadows)) 66 | (add-value barometer-shadow 67 | (support-values/supported 68 | (make-interval 0.36 0.37) 69 | :shadows)) 70 | 71 | 72 | (add-value fall-time 73 | (support-values/supported 74 | (make-interval 2.9 3.3) 75 | :lousy-fall-time)) 76 | 77 | 78 | (add-value fall-time 79 | (support-values/supported 80 | (make-interval 2.9 3.1) 81 | :better-fall-time)) 82 | 83 | 84 | (add-value building-height 85 | (support-values/supported 86 | 45.0 87 | :superintendent)) 88 | 89 | [(get-value building-height) 90 | (get-value building-shadow) 91 | (get-value barometer-height) 92 | (get-value barometer-shadow) 93 | (get-value fall-time)])))) 94 | ;; [{:value 45.0, :support-set #{:superintendent}} 95 | ;; {:value {:lo 54.9, :hi 55.1}, 96 | ;; :support-set #{:superintendent :shadows}} 97 | ;; {:value {:lo 0.3, :hi 0.30327868852459017}, 98 | ;; :support-set #{:better-fall-time :superintendent :shadows}} 99 | ;; {:value {:lo 0.366, :hi 0.37}, 100 | ;; :support-set #{:better-fall-time :superintendent :shadows}} 101 | ;; {:value {:lo 3.025522031629098, :hi 3.0321598338046556}, 102 | ;; :support-set #{:superintendent}}] 103 | ;; 104 | ;; Play around what information is available to change the results 105 | -------------------------------------------------------------------------------- /examples/system_building_height.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'user) 2 | 3 | (use 'propaganda.system) 4 | (use 'propaganda.values) 5 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 6 | (use 'propaganda.intervals.system) 7 | 8 | (defn fall-duration 9 | [system t h] 10 | (let [g (gensym) 11 | one-half (gensym) 12 | t-squared (gensym) 13 | gt-squared (gensym)] 14 | (-> system 15 | ((constant (make-interval 9.789 9.790)) g) 16 | ((constant 0.5) one-half) 17 | (quadratic t t-squared) 18 | (product g t-squared gt-squared) 19 | (product one-half gt-squared h)))) 20 | 21 | (defn similar-triangles 22 | [system s-ba h-ba s h] 23 | (let [ratio (gensym)] 24 | (-> system 25 | (product s-ba ratio h-ba) 26 | (product s ratio h)))) 27 | 28 | ;; Trying it all out while bribing the building's superintendent 29 | (clojure.pprint/pprint 30 | (let [custom-merge (doto (default-merge) extend-merge) 31 | system (make-system custom-merge (default-contradictory?)) 32 | result-system (-> system 33 | 34 | (fall-duration :fall-time :building-height) 35 | (add-value :fall-time (make-interval 2.9 3.1)) 36 | 37 | (similar-triangles :barometer-shadow :barometer-height 38 | :building-shadow :building-height) 39 | (add-value :building-shadow (make-interval 54.9 55.1)) 40 | (add-value :barometer-height (make-interval 0.3 0.32)) 41 | (add-value :barometer-shadow (make-interval 0.36 0.37)) 42 | 43 | (add-value :building-height 45.0))] 44 | 45 | [(get-value result-system :building-height) 46 | (get-value result-system :building-shadow) 47 | (get-value result-system :barometer-height) 48 | (get-value result-system :barometer-shadow) 49 | (get-value result-system :fall-time)])) 50 | ;; => [45.0 51 | ;; {:lo 54.9, :hi 55.1} 52 | ;; {:lo 0.3, :hi 0.30327868852459017} 53 | ;; {:lo 0.366, :hi 0.37} 54 | ;; {:lo 3.032004969797108, :hi 3.0321598338046556}] 55 | -------------------------------------------------------------------------------- /examples/system_supported_building_height.clj: -------------------------------------------------------------------------------- 1 | (in-ns 'user) 2 | 3 | (use 'propaganda.system) 4 | (use 'propaganda.values) 5 | (use '[propaganda.intervals.common :exclude [extend-merge]]) 6 | (use 'propaganda.intervals.system) 7 | (require '(propaganda [support-values :as support-values])) 8 | 9 | (defn fall-duration 10 | "Creates propagator from fall duration t to building height h with 11 | some uncertainty on the gravitational acceleration." 12 | [system t h] 13 | (let [g (gensym) 14 | one-half (gensym) 15 | t-squared (gensym) 16 | gt-squared (gensym)] 17 | (-> system 18 | ((constant (make-interval 9.789 9.790)) g) 19 | ((constant 0.5) one-half) 20 | (quadratic t t-squared) 21 | (product g t-squared gt-squared) 22 | (product one-half gt-squared h)))) 23 | 24 | (defn similar-triangles 25 | [system s-ba h-ba s h] 26 | (let [ratio (gensym)] 27 | (-> system 28 | (product s-ba ratio h-ba) 29 | (product s ratio h)))) 30 | 31 | ;; Trying it all out while bribing the building's superintendent 32 | (clojure.pprint/pprint 33 | (let [custom-merge (doto (default-merge) 34 | extend-merge 35 | support-values/extend-merge) 36 | custom-contradictory? (doto (default-contradictory?) 37 | support-values/extend-contradictory?) 38 | system (make-system custom-merge 39 | custom-contradictory?) 40 | result-system (-> system 41 | 42 | (fall-duration :fall-time :building-height) 43 | (similar-triangles :barometer-shadow :barometer-height 44 | :building-shadow :building-height) 45 | (add-value :building-shadow 46 | (support-values/supported 47 | (make-interval 54.9 55.1) 48 | :shadows)) 49 | (add-value :barometer-height 50 | (support-values/supported 51 | (make-interval 0.3 0.32) 52 | :shadows)) 53 | (add-value :barometer-shadow 54 | (support-values/supported 55 | (make-interval 0.36 0.37) 56 | :shadows)) 57 | 58 | (add-value :fall-time 59 | (support-values/supported 60 | (make-interval 2.9 3.3) 61 | :lousy-fall-time)) 62 | 63 | (add-value :fall-time 64 | (support-values/supported 65 | (make-interval 2.9 3.1) 66 | :better-fall-time)) 67 | 68 | (add-value :building-height 69 | (support-values/supported 70 | 45.0 71 | :superintendent)))] 72 | 73 | [(get-value result-system :building-height) 74 | (get-value result-system :building-shadow) 75 | (get-value result-system :barometer-height) 76 | (get-value result-system :barometer-shadow) 77 | (get-value result-system :fall-time)])) 78 | ;; [{:value 45.0, :support-set #{:superintendent}} 79 | ;; {:value {:lo 54.9, :hi 55.1}, 80 | ;; :support-set #{:superintendent :shadows}} 81 | ;; {:value {:lo 0.3, :hi 0.30327868852459017}, 82 | ;; :support-set #{:better-fall-time :superintendent :shadows}} 83 | ;; {:value {:lo 0.366, :hi 0.37}, 84 | ;; :support-set #{:better-fall-time :superintendent :shadows}} 85 | ;; {:value {:lo 3.025522031629098, :hi 3.0321598338046556}, 86 | ;; :support-set #{:superintendent}}] 87 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject propaganda "0.2.1-SNAPSHOT" 2 | :description "(Hopefully) extensible propagator library" 3 | :url "http://github.com/tgk/propaganda" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.5.1"]] 7 | :plugins [[lein-release "1.0.4"] 8 | [lein-cljsbuild "0.3.2"]] 9 | :hooks [leiningen.cljsbuild] 10 | :source-paths ["src"] 11 | :lein-release {:scm :git 12 | :deploy-via :shell 13 | :shell ["lein" "deploy" "clojars"]} 14 | :clojurescript? true 15 | :cljsbuild 16 | {:builds {:main 17 | {:source-paths ["crossover"] 18 | :jar true 19 | :compiler {:output-to "js/propaganda.js" 20 | :optimizations :advanced 21 | :pretty-print false}} 22 | :dev 23 | {:source-paths ["crossover"] 24 | :compiler {:optimizations :whitespace 25 | :pretty-print true}}} 26 | :crossovers [propaganda.values 27 | propaganda.system 28 | propaganda.generic-operators 29 | propaganda.support-values 30 | propaganda.intervals.common 31 | propaganda.intervals.system] 32 | :crossover-jar true 33 | :crossover-path "crossover"}) 34 | -------------------------------------------------------------------------------- /src/propaganda/generic_operators.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.generic-operators) 2 | 3 | (defn all-preds? 4 | "Returns true iff (pred vals) is truthy for all preds paired with 5 | vals." 6 | [preds vals] 7 | (and (= (count preds) (count vals)) 8 | (every? 9 | identity 10 | (for [[pred val] (map vector preds vals)] (pred val))))) 11 | 12 | (defn val-with-predicates 13 | "Returns the first val in pred&vals seq where all preds saitsfy args." 14 | [pred&vals & args] 15 | (second 16 | (first 17 | (filter 18 | (fn [[preds _]] (all-preds? preds args)) 19 | pred&vals)))) 20 | 21 | (defn execute-op 22 | "Choses an operation from pairs of predicates and operators and 23 | executes it on args. Executes default on args if no predicates match." 24 | [default pred&ops & args] 25 | (if-let [op (apply val-with-predicates pred&ops args)] 26 | (apply op args) 27 | (apply default args))) 28 | 29 | (defn generic-operator 30 | "Returns a generic operation with default operator default. Generic 31 | operators can be extended using assign-operation. For example, we can 32 | define a generic plus operator that works on numbers and vectors: 33 | 34 | (let [plus (generic-operator +)] 35 | (doto plus 36 | (assign-operation concat vector? vector?)) 37 | [(plus 1 2) 38 | (plus [1 2 3] [4 5])]) 39 | ;; => [3 [1 2 3 4 5]]" 40 | [default] 41 | (let [pred&ops (atom nil)] 42 | (with-meta 43 | (fn [& args] 44 | (apply execute-op default @pred&ops args)) 45 | {:pred&ops pred&ops}))) 46 | 47 | (defn assign-operation 48 | "Alters generic-operator, adding operation given preds." 49 | [generic-operator operation & preds] 50 | (let [preds&ops (:pred&ops (meta generic-operator))] 51 | (swap! preds&ops conj [preds operation]))) 52 | -------------------------------------------------------------------------------- /src/propaganda/intervals/common.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.intervals.common 2 | (:require [propaganda.values :as values] 3 | [propaganda.generic-operators :as go] 4 | [propaganda.support-values :as support-values])) 5 | 6 | ;; Interval arithmetics 7 | 8 | (defrecord Interval 9 | [lo hi]) 10 | 11 | (defn make-interval 12 | "Returns a new closed interval from lo to hi." 13 | [lo hi] 14 | (Interval. lo hi)) 15 | 16 | (defn mul-interval 17 | "Multiplies the intervals. Assumes all limits are positive." 18 | [x y] 19 | (make-interval (* (:lo x) (:lo y)) (* (:hi x) (:hi y)))) 20 | 21 | (defn div-interval 22 | "Divides the intervals. Assumes all limits are strictly positive." 23 | [x y] 24 | (mul-interval x (make-interval (/ 1 (:hi y)) (/ 1 (:lo y))))) 25 | 26 | (defn square-interval 27 | [x] 28 | (make-interval (* (:lo x) (:lo x)) 29 | (* (:hi x) (:hi x)))) 30 | 31 | (defn sqrt-interval 32 | [x] 33 | (make-interval (Math/sqrt (double (:lo x))) 34 | (Math/sqrt (double (:hi x))))) 35 | 36 | (defn empty-interval? 37 | "Determines if the interval is empty." 38 | [x] 39 | (> (:lo x) (:hi x))) 40 | 41 | (defn intersect-intervals 42 | "Creates an intersection of the intervals." 43 | [x y] 44 | (make-interval 45 | (max (:lo x) (:lo y)) 46 | (min (:hi x) (:hi y)))) 47 | 48 | (defn interval? 49 | "Returns true iff x is an interval." 50 | [x] 51 | (isa? (type x) Interval)) 52 | 53 | (defn ensure-inside 54 | "If number is in interval, the number is returned. If not, a 55 | descriptive contradiction is returned." 56 | [interval number] 57 | (if (<= (:lo interval) number (:hi interval)) 58 | number 59 | (values/contradiction 60 | (str number " not in interval [" (:lo interval?) ", " (:hi interval) "]")))) 61 | 62 | ;; Generic standard arithmetic operations 63 | 64 | (defn ->interval 65 | "Ensures x is an interval. If x is already an interval, x is 66 | returned. If x is not, an interval from x to x is returned." 67 | [x] 68 | (if (interval? x) 69 | x 70 | (make-interval x x))) 71 | 72 | (defn coercing 73 | "Returns a version of f that will coerce arguments using coercer 74 | before applying them." 75 | [coercer f] 76 | (fn [& args] 77 | (apply f (map coercer args)))) 78 | 79 | (def generic-mul (doto (go/generic-operator *) 80 | (go/assign-operation mul-interval 81 | interval? interval?) 82 | (go/assign-operation (coercing ->interval mul-interval) 83 | number? interval?) 84 | (go/assign-operation (coercing ->interval mul-interval) 85 | interval? number?))) 86 | (def generic-div (doto (go/generic-operator /) 87 | (go/assign-operation div-interval 88 | interval? interval?) 89 | (go/assign-operation (coercing ->interval div-interval) 90 | number? interval?) 91 | (go/assign-operation (coercing ->interval div-interval) 92 | interval? number?))) 93 | (def generic-square (doto (go/generic-operator (fn [x] (* x x))) 94 | (go/assign-operation 95 | square-interval 96 | interval?))) 97 | (def generic-sqrt (doto (go/generic-operator (fn [x] (Math/sqrt (double x)))) 98 | (go/assign-operation 99 | sqrt-interval 100 | interval?))) 101 | 102 | ;; Supported values 103 | 104 | (defn flat? 105 | "Determines if thing is flat, i.e. an interval or a number." 106 | [thing] 107 | (or (interval? thing) 108 | (number? thing))) 109 | 110 | (doseq [generic-op [generic-mul generic-div]] 111 | ;; supported values support 112 | (go/assign-operation generic-op 113 | (support-values/supported-unpacking generic-op) 114 | support-values/supported? support-values/supported?) 115 | (go/assign-operation generic-op 116 | (coercing support-values/->supported generic-op) 117 | support-values/supported? flat?) 118 | (go/assign-operation generic-op 119 | (coercing support-values/->supported generic-op) 120 | flat? support-values/supported?)) 121 | 122 | (doseq [generic-op [generic-square generic-sqrt]] 123 | (go/assign-operation generic-op 124 | (support-values/supported-unpacking generic-op) 125 | support-values/supported?)) 126 | 127 | ;; Extend supplied merge 128 | 129 | (defn extend-merge 130 | "Extends the supplied generic operator with interval mergings. These 131 | also include merging numbers with intervals." 132 | [generic-merge-operator] 133 | (doto generic-merge-operator 134 | (go/assign-operation (fn [content increment] 135 | (let [new-range (intersect-intervals content increment)] 136 | (if (empty-interval? new-range) 137 | (values/contradiction 138 | (str "Non-overlapping intervals: " content " and " increment)) 139 | new-range))) 140 | interval? interval?) 141 | (go/assign-operation (fn [content increment] 142 | (ensure-inside increment content)) 143 | number? interval?) 144 | (go/assign-operation (fn [content increment] 145 | (ensure-inside content increment)) 146 | interval? number?) 147 | ;; support values merging 148 | (go/assign-operation (coercing support-values/->supported generic-merge-operator) 149 | support-values/supported? flat?) 150 | (go/assign-operation (coercing support-values/->supported generic-merge-operator) 151 | flat? support-values/supported?))) 152 | -------------------------------------------------------------------------------- /src/propaganda/intervals/stm.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.intervals.stm 2 | (:require [propaganda.stm :as propaganda] 3 | [propaganda.tms.stm :as tms] 4 | [propaganda.generic-operators :as go] 5 | [propaganda.intervals.common :as intervals] 6 | [propaganda.support-values :as support-values])) 7 | 8 | ;; Propagator constructors 9 | 10 | (def multiplier (propaganda/function->propagator-constructor intervals/generic-mul)) 11 | (def divider (propaganda/function->propagator-constructor intervals/generic-div)) 12 | (def squarer (propaganda/function->propagator-constructor intervals/generic-square)) 13 | (def sqrter (propaganda/function->propagator-constructor intervals/generic-sqrt)) 14 | 15 | ;; Multidirectional propagators constructors (relations) 16 | 17 | (defn product 18 | "Creates the product relation x * y = total between the cells." 19 | [x y total] 20 | (multiplier x y total) 21 | (divider total x y) 22 | (divider total y x)) 23 | 24 | (defn quadratic 25 | "Creates the quadratic relation x * x = x-squared between the cells." 26 | [x x-squared] 27 | (squarer x x-squared) 28 | (sqrter x-squared x)) 29 | 30 | (doseq [generic-op [intervals/generic-mul intervals/generic-div]] 31 | ;; tms support 32 | (go/assign-operation generic-op 33 | (tms/full-tms-unpacking generic-op) 34 | tms/tms? tms/tms?) 35 | (go/assign-operation generic-op 36 | (intervals/coercing tms/->tms generic-op) 37 | tms/tms? support-values/supported?) 38 | (go/assign-operation generic-op 39 | (intervals/coercing tms/->tms generic-op) 40 | support-values/supported? tms/tms?) 41 | (go/assign-operation generic-op 42 | (intervals/coercing tms/->tms generic-op) 43 | tms/tms? intervals/flat?) 44 | (go/assign-operation generic-op 45 | (intervals/coercing tms/->tms generic-op) 46 | intervals/flat? tms/tms?)) 47 | 48 | (doseq [generic-op [intervals/generic-square intervals/generic-sqrt]] 49 | (go/assign-operation generic-op 50 | (tms/full-tms-unpacking generic-op) 51 | tms/tms?)) 52 | 53 | ;; Extend supplied merge 54 | 55 | (defn extend-merge 56 | "Extends the merge operator with support for interval under the STM 57 | version of propagators." 58 | [generic-merge-operator] 59 | (doto generic-merge-operator 60 | (intervals/extend-merge) 61 | ;; tms merging 62 | (go/assign-operation (intervals/coercing tms/->tms generic-merge-operator) 63 | tms/tms? support-values/supported?) 64 | (go/assign-operation (intervals/coercing tms/->tms generic-merge-operator) 65 | support-values/supported? tms/tms?) 66 | (go/assign-operation (intervals/coercing tms/->tms generic-merge-operator) 67 | tms/tms? intervals/flat?) 68 | (go/assign-operation (intervals/coercing tms/->tms generic-merge-operator) 69 | intervals/flat? tms/tms?))) 70 | -------------------------------------------------------------------------------- /src/propaganda/intervals/system.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.intervals.system 2 | (:require [propaganda.system :as propaganda] 3 | [propaganda.intervals.common :as intervals])) 4 | 5 | ;; Propagator constructors 6 | 7 | (def multiplier (propaganda/function->propagator-constructor intervals/generic-mul)) 8 | (def divider (propaganda/function->propagator-constructor intervals/generic-div)) 9 | (def squarer (propaganda/function->propagator-constructor intervals/generic-square)) 10 | (def sqrter (propaganda/function->propagator-constructor intervals/generic-sqrt)) 11 | 12 | ;; Multidirectional propagators constructors (relations) 13 | 14 | (defn product 15 | "Creates the product relation x * y = total between the cells." 16 | [system x y total] 17 | (-> system 18 | (multiplier x y total) 19 | (divider total x y) 20 | (divider total y x))) 21 | 22 | (defn quadratic 23 | "Creates the quadratic relation x * x = x-squared between the cells." 24 | [system x x-squared] 25 | (-> system 26 | (squarer x x-squared) 27 | (sqrter x-squared x))) 28 | 29 | (def extend-merge 30 | "Extends the merge operator with support for interval under the system 31 | version of propagators." 32 | intervals/extend-merge) 33 | -------------------------------------------------------------------------------- /src/propaganda/stm.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.stm 2 | (:use propaganda.values) 3 | (:require [propaganda.generic-operators :as generic-operators])) 4 | 5 | ;; Propagator framework 6 | 7 | (def alerting? (ref false)) 8 | (def alert-queue (ref clojure.lang.PersistentQueue/EMPTY)) 9 | 10 | (defn alert-propagators 11 | "Simple implementation of alerting propagators. Performed in a 12 | dosync." 13 | [propagators] 14 | (dosync 15 | (alter alert-queue into propagators) 16 | (when (not @alerting?) 17 | (ref-set alerting? true) 18 | (while (peek @alert-queue) 19 | (let [propagator (peek @alert-queue)] 20 | (alter alert-queue pop) 21 | (propagator))) 22 | (ref-set alerting? false)))) 23 | 24 | (def ^:private all-propagators 25 | "A reference to all the propagators in the runtime." 26 | (ref nil)) 27 | 28 | (defn alert-all-propagators! 29 | "Alerts all propagators in the runtime." 30 | [] 31 | (alert-propagators @all-propagators)) 32 | 33 | (defprotocol Cell 34 | "A cell with some content. All methods on cells are performed in a 35 | dosync." 36 | (new-neighbour! [this new-neighbour] 37 | "Adds a new function that gets invoked on content addition to the 38 | cell.") 39 | (add-value [this increment] 40 | "Adds content to the cell. If the increment is inconsistent with the 41 | current content, an exception is thrown.") 42 | (get-value [this] 43 | "Gets the current content of the cell.")) 44 | 45 | (def ^:dynamic *merge* 46 | "The merge function used by the cells. Must be bound." 47 | (fn [& args] 48 | (throw (Exception. "Missing propaganda.stm/*merge* binding.")))) 49 | 50 | (def ^:dynamic *contradictory?* 51 | "The contradictory function to be used." 52 | (default-contradictory?)) 53 | 54 | (defn make-cell 55 | "Creates a new Cell with empty content. The currently bound *merge* 56 | and *contradictory?* are used for merging and determining if there are 57 | contradictions." 58 | [] 59 | (let [neighbours (ref nil) 60 | content (ref nothing)] 61 | (reify 62 | Cell 63 | (new-neighbour! 64 | [this new-neighbour] 65 | (dosync 66 | (when (not (contains? (set @neighbours) new-neighbour)) 67 | (alter neighbours conj new-neighbour) 68 | (alter all-propagators conj new-neighbour) 69 | (alert-propagators [new-neighbour])))) 70 | (add-value 71 | [this increment] 72 | (dosync 73 | (let [answer (*merge* @content increment)] 74 | (cond 75 | (= answer @content) :ok 76 | (*contradictory?* answer) (throw (Exception. 77 | (str "Inconsistency: " 78 | (:reason answer)))) 79 | :else (do 80 | (ref-set content answer) 81 | (alert-propagators @neighbours)))))) 82 | (get-value 83 | [this] 84 | @content)))) 85 | 86 | (defn propagator 87 | "Adds a new propagator (to-do) to the neighbours and guarantees that 88 | it is called." 89 | [neighbours to-do] 90 | (doseq [cell neighbours] 91 | (new-neighbour! cell to-do)) 92 | (alert-propagators [to-do])) 93 | 94 | (defn lift-to-cell-contents 95 | "Returns a safe-guarded version of f which ensures that all arguments 96 | are different than nothing." 97 | [f] 98 | (fn [& args] 99 | (if (some nothing? args) 100 | nothing 101 | (apply f args)))) 102 | 103 | (defn function->propagator-constructor 104 | "Returns a propagtor constructor which will lift the content of f 105 | applied to the first cells to the last cell." 106 | [f] 107 | (fn [& cells] 108 | (let [inputs (butlast cells) 109 | output (last cells) 110 | lifted-f (lift-to-cell-contents f)] 111 | (propagator 112 | inputs 113 | (fn [] (add-value 114 | output 115 | (apply lifted-f (map get-value inputs)))))))) 116 | 117 | (defn compound-propagator 118 | "Constructs a propagtor which will observe the neighbours cells and 119 | run to-build when their values are all different from nothing." 120 | [neighbours to-build] 121 | (let [done? (ref false) 122 | test (fn [] (when-not @done? 123 | (when-not (some nothing? (map get-value neighbours)) 124 | (ref-set done? true) 125 | (to-build))))] 126 | (propagator neighbours test))) 127 | 128 | ;; Useful propagators 129 | 130 | (defn constant 131 | "Returns a propagator constructor taking cell and ensuring it always 132 | has the value value." 133 | [value] 134 | (function->propagator-constructor (fn [] value))) 135 | -------------------------------------------------------------------------------- /src/propaganda/support_values.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.support-values 2 | (:require clojure.set 3 | [propaganda.generic-operators :as go])) 4 | 5 | (defrecord Supported 6 | [value support-set]) 7 | 8 | (defn setify 9 | [v] 10 | (if (set? v) 11 | v 12 | #{v})) 13 | 14 | (defn supported 15 | [value support] 16 | (Supported. value (setify support))) 17 | 18 | (defn supported? 19 | [x] 20 | (isa? (type x) Supported)) 21 | 22 | (defn- more-informative-support? 23 | "Returns true if the support-set for support-1 contains strictly more 24 | information than the support-set in support-2." 25 | [support-1 support-2] 26 | (and (not= (:support-set support-1) (:support-set support-2)) 27 | (clojure.set/subset? (:support-set support-2) (:support-set support-1)))) 28 | 29 | (defn- merge-supports 30 | "Returns the merge of the supporting sets for supports." 31 | [& supports] 32 | (apply clojure.set/union (map :support-set supports))) 33 | 34 | (defn- implies? 35 | "Returns true if the val-1 information implies val-2 is val-1." 36 | [merge-operator val-1 val-2] 37 | (= val-1 (merge-operator val-1 val-2))) 38 | 39 | (defn subsumes? 40 | "Returns true iff the information in support-2 is deducible from 41 | support-1." 42 | [merge-operator support-1 support-2] 43 | (and (implies? merge-operator (:value support-1) (:value support-2)) 44 | (clojure.set/subset? (:support-set support-2) (:support-set support-1)))) 45 | 46 | (defn extend-merge 47 | "Extends the generic merge operator with support for supported 48 | values." 49 | [generic-merge-operator] 50 | (go/assign-operation 51 | generic-merge-operator 52 | ;; content increment 53 | (fn [support-1 support-2] 54 | (let [val-1 (:value support-1) 55 | val-2 (:value support-2) 56 | val-merge (generic-merge-operator val-1 val-2)] 57 | (cond 58 | (= val-merge val-1) (if (implies? generic-merge-operator 59 | val-2 val-merge) 60 | ;; Confirmation of existing 61 | (if (more-informative-support? 62 | support-2 support-1) 63 | support-2 64 | support-1) 65 | ;; New information is not interesting 66 | support-1) 67 | (= val-merge val-2) support-2 ;; New information overrides 68 | :else (Supported. val-merge 69 | (merge-supports support-1 support-2))))) 70 | supported? supported?)) 71 | 72 | (defn extend-contradictory? 73 | "Extends the generic contradictory? operator with support for 74 | supported values." 75 | [generic-contradictory?-operator] 76 | (go/assign-operation 77 | generic-contradictory?-operator 78 | (fn [support] 79 | (generic-contradictory?-operator (:value support))) 80 | supported?)) 81 | 82 | (defn supported-unpacking 83 | "Returns a function that will take supported arguments, apply f to 84 | them and return a supported value with their merged supporting sets." 85 | [f] 86 | (fn [& args] 87 | (supported 88 | (apply f (map :value args)) 89 | (apply merge-supports args)))) 90 | 91 | (defn ->supported 92 | "Returns thing if it is already a supported value. Creates new 93 | supported value with an empty support set otherwise." 94 | [thing] 95 | (if (supported? thing) 96 | thing 97 | (supported thing #{}))) 98 | -------------------------------------------------------------------------------- /src/propaganda/system.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.system 2 | (:require [propaganda.values :as values])) 3 | 4 | (defrecord PropagatorSystem 5 | [values propagators merge contradictory? alert-queue freezing?]) 6 | 7 | (defprotocol PropagatorSystemProtocol 8 | "A propagator system that contains a set of cells with values. Any 9 | clojure value can be used as a cell identifier. Cells do not need to 10 | be initialised. Their value defaults to 11 | propaganda.values/nothing. When a value is added to the system, 12 | propagators are alerted, bringing the system to an unstabile 13 | state. 14 | 15 | The system is cooled down until it reaches a stabile state again. If 16 | the :audit? key is true in the metadata of the system, each unstabile 17 | system is stored under the :prev key of the systems." 18 | (add-value [this cell value]) 19 | (get-value [this cell]) 20 | (add-propagator [this cells f]) 21 | (cool [this]) 22 | (stabile? [this]) 23 | (alert-all-propagators [this])) 24 | 25 | (defn- update-keys 26 | "Applies f to the values of m under ks." 27 | [m ks f & args] 28 | (reduce (fn [m k] (assoc m k (apply f (get m k) args))) 29 | m 30 | ks)) 31 | 32 | (defn- disturb-system 33 | "Helper for adding a value to the system, without cooling it." 34 | [system cell value] 35 | (let [content (get-value system cell) 36 | answer ((:merge system) content value) 37 | new-system (cond 38 | 39 | (= answer content) 40 | system 41 | 42 | ((:contradictory? system) answer) 43 | (throw (ex-info "Inconsistency" {:contradiction answer})) 44 | 45 | :else 46 | (-> system 47 | (assoc-in [:values cell] 48 | answer) 49 | (update-in [:alert-queue] 50 | concat 51 | (get-in system [:propagators cell]))))] 52 | (if (:audit? (meta system)) 53 | (with-meta new-system {:audit? true :prev system}) 54 | new-system))) 55 | 56 | (defn- freeze 57 | "Freezes the system down until it reaches a stabile state. If the 58 | system is already in the process of being cooled down, nothing is done 59 | to the system." 60 | [system] 61 | (if (:freezing? system) 62 | system 63 | (assoc 64 | (loop [system (assoc system :freezing? true)] 65 | (if (stabile? system) 66 | system 67 | (recur (cool system)))) 68 | :freezing? false))) 69 | 70 | (defn- all-propagators 71 | "Returns all propagators of the system." 72 | [system] 73 | (set (mapcat second (:propagators system)))) 74 | 75 | (extend-type PropagatorSystem 76 | 77 | PropagatorSystemProtocol 78 | 79 | (add-value [this cell value] 80 | (-> this 81 | (disturb-system cell value) 82 | freeze)) 83 | 84 | (get-value [this cell] 85 | (get-in this [:values cell] values/nothing)) 86 | 87 | (add-propagator [this cells f] 88 | (-> this 89 | (update-in [:propagators] #(update-keys % cells conj f)) 90 | (update-in [:alert-queue] conj f) 91 | freeze)) 92 | 93 | (stabile? [this] 94 | (empty? (:alert-queue this))) 95 | 96 | ;; If you are interested in values as the system ticks along, hook 97 | ;; into cool 98 | (cool [this] 99 | (if-let [[f & t] (:alert-queue this)] 100 | (f (assoc this :alert-queue t)) 101 | this)) 102 | 103 | (alert-all-propagators [this] 104 | (-> this 105 | (update-in [:alert-queue] concat (all-propagators this)) 106 | freeze))) 107 | 108 | (defn make-system 109 | "Creates a new system. If no merge and contradictory? is given, the 110 | default versions from the values namespace are used. To merge values, 111 | e.g. interval, supply a custom merge." 112 | ([] 113 | (make-system (values/default-merge) 114 | (values/default-contradictory?))) 115 | ([merge contradictory?] 116 | (PropagatorSystem. 117 | {} {} merge contradictory? [] false))) 118 | 119 | (defn lift-to-cell-contents 120 | "Returns a safe-guarded version of f which ensures that all arguments 121 | are different than nothing." 122 | [f] 123 | (fn [& args] 124 | (if (some values/nothing? args) 125 | values/nothing 126 | (apply f args)))) 127 | 128 | (defn function->propagator-constructor 129 | "Returns a propagtor constructor which will lift the content of f 130 | applied to the first cells to the last cell. The propagator 131 | constructor returned accepts a system and the cells. An altered system 132 | is returned." 133 | [f] 134 | (fn [system & cells] 135 | (let [inputs (butlast cells) 136 | output (last cells) 137 | lifted-f (lift-to-cell-contents f)] 138 | (add-propagator 139 | system 140 | inputs 141 | (fn [system] 142 | (add-value 143 | system 144 | output 145 | (apply lifted-f (map (partial get-value system) inputs)))))))) 146 | 147 | (defn constant 148 | "Returns a propagator constructor taking system and a cell, ensuring 149 | it always has the value value. Returns a new system." 150 | [value] 151 | (function->propagator-constructor (fn [] value))) 152 | -------------------------------------------------------------------------------- /src/propaganda/tms/stm.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.tms.stm 2 | (:require [clojure.set] 3 | [propaganda.values :as values] 4 | [propaganda.stm :as propaganda] 5 | [propaganda.support-values :as support-values] 6 | [propaganda.generic-operators :as go])) 7 | 8 | (defrecord TruthMaintenanceSystem [supported-values]) 9 | 10 | (defn make-tms 11 | [& supported-values] 12 | (TruthMaintenanceSystem. (set supported-values))) 13 | 14 | (defn tms? 15 | [thing] 16 | (isa? (class thing) TruthMaintenanceSystem)) 17 | 18 | (defn tms-assimilate-one 19 | "Adds support to the tms, but only if it adds a more precise 20 | value (that is, a different value than the existing) when combined 21 | with the existing values. Removes old values that do not add to the 22 | information anymore." 23 | [merge-operator tms support] 24 | ;; is the existing information better that the new support? 25 | (if (some (fn [old-support] 26 | (support-values/subsumes? 27 | merge-operator old-support support)) 28 | (:supported-values tms)) 29 | ;; then just return old tms 30 | tms 31 | ;; otherwise, find support values that can be removed as the new 32 | ;; information is better than what they bring to the table 33 | (let [subsumed (filter (fn [old-support] 34 | (support-values/subsumes? 35 | merge-operator support old-support)) 36 | (:supported-values tms))] 37 | (apply make-tms 38 | (clojure.set/union 39 | (clojure.set/difference (:supported-values tms) subsumed) 40 | #{support}))))) 41 | 42 | (defn tms-assimilate 43 | "Incorporate stuff into tms. stuff can be nothing, a supported value 44 | or a tms." 45 | [merge-operator tms stuff] 46 | (cond 47 | (values/nothing? stuff) tms 48 | (support-values/supported? stuff) (tms-assimilate-one tms stuff) 49 | (tms? stuff) (reduce (partial tms-assimilate-one merge-operator) 50 | tms 51 | (:supported-values stuff)) 52 | :else (throw (Exception. "Should never happen")))) 53 | 54 | ;; Premises 55 | 56 | ;;;;; A premise being in or out might belong in supported values? 57 | 58 | (def premises-out 59 | (ref #{})) 60 | 61 | (defn premise-in? 62 | [premise] 63 | (not (contains? @premises-out premise))) 64 | 65 | (defn mark-premise-in! 66 | [premise] 67 | (alter premises-out clojure.set/difference #{premise})) 68 | 69 | (defn mark-premise-out! 70 | [premise] 71 | (alter premises-out conj premise)) 72 | 73 | ;;; No premise-no-good collection for now 74 | 75 | (defn process-no-good! 76 | "Reacts to the premises that are no-good. Just throw an exception for 77 | now, but should allow the user to change the worldview." 78 | [premises] 79 | (throw (Exception. 80 | (str "The current worldview contains a conflict. " 81 | "The following premises are up to no good: " 82 | premises)))) 83 | 84 | (defn all-premises-in? 85 | "Checks that all premises for thing are valid in the current 86 | worldview. thing should be a supported value or a seq of premises." 87 | [thing] 88 | (if (support-values/supported? thing) 89 | (all-premises-in? (:support-set thing)) 90 | (every? premise-in? thing))) 91 | 92 | (defn strongest-consequence 93 | "Returns the most informative consequence of the current worldview." 94 | [merge-operator tms] 95 | (let [relevant-supports (filter all-premises-in? (:supported-values tms))] 96 | (reduce merge-operator values/nothing relevant-supports))) 97 | 98 | (defn check-consistent! 99 | [support] 100 | (when (propaganda/*contradictory?* support) 101 | (process-no-good! (:support-set support)))) 102 | 103 | ;; Extending merge 104 | 105 | (defn extend-merge 106 | "Extends merge. propaganda.core/*contradictory* must be set first." 107 | [generic-merge-operator] 108 | (go/assign-operation generic-merge-operator 109 | ;; content increment 110 | (fn [tms1 tms2] 111 | (let [candidate (tms-assimilate tms1 tms2) 112 | consequence (strongest-consequence candidate)] 113 | (check-consistent! consequence) 114 | (tms-assimilate generic-merge-operator candidate consequence))) 115 | tms? tms?)) 116 | 117 | ;; Querying 118 | 119 | (defn tms-query 120 | [tms] 121 | (let [answer (strongest-consequence tms) 122 | better-tms (tms-assimilate tms answer)] 123 | (if (not= tms better-tms) 124 | :do-nothing ;; The original article alters the tms-values of the 125 | ;; tms, but that would require a ref in the tms, and 126 | ;; it would no longer be immutable. Let's try not to 127 | ;; do that, and see what happens 128 | ) 129 | (check-consistent! answer) 130 | answer)) 131 | 132 | ;; Kicking out and bringing in 133 | 134 | ;;; Some fairly aggresive strategies being used here... 135 | 136 | (defn kick-out! 137 | [premise] 138 | (let [was-in? (premise-in? premise)] 139 | (mark-premise-out! premise) 140 | (when was-in? 141 | (propaganda/alert-all-propagators!)))) 142 | 143 | (defn bring-in! 144 | [premise] 145 | (let [was-out? (not (premise-in? premise))] 146 | (mark-premise-in! premise) 147 | (when was-out? 148 | (propaganda/alert-all-propagators!)))) 149 | 150 | (defn tms-unpacking 151 | "Returns a function that will find the current values of its 152 | arguments. If all are different from nothing, it will return a new tms 153 | with the value of f mapped over the values of the arguments." 154 | [f] 155 | (fn [& args] 156 | (let [relevant-information (map tms-query args)] 157 | (if (some values/nothing? relevant-information) 158 | values/nothing 159 | (make-tms (apply f relevant-information)))))) 160 | 161 | (defn full-tms-unpacking 162 | "Returns a function that will unpack its arguments to using 163 | tms-unpacking, pass it through supported-unpacking, which will 164 | guarantee the correct supported values are set, and use the value of 165 | f." 166 | [f] 167 | (tms-unpacking (support-values/supported-unpacking f))) 168 | 169 | (defn ->tms 170 | "Ensures thing is a tms." 171 | [thing] 172 | (if (tms? thing) 173 | thing 174 | (make-tms (support-values/->supported thing)))) 175 | -------------------------------------------------------------------------------- /src/propaganda/values.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.values 2 | (:require [propaganda.generic-operators :as generic-operators])) 3 | 4 | (def nothing 5 | "The value representing no content of a cell." 6 | ::nothing) 7 | 8 | (defn nothing? 9 | "Determins if thing is nothing." 10 | [thing] 11 | (= nothing thing)) 12 | 13 | (defn any? 14 | "Determins if thing is different than nothing." 15 | [thing] 16 | (not= nothing thing)) 17 | 18 | (defrecord Contradiction [reason]) 19 | 20 | (defn contradiction 21 | "Creates a new contradiction with the given reason, a string." 22 | [reason] 23 | (Contradiction. reason)) 24 | 25 | (defn- base-contradictory? 26 | "Base version of the contradiction function." 27 | [x] 28 | (isa? (type x) Contradiction)) 29 | 30 | (defn default-contradictory? 31 | "Constructs a default contradictory? generic operator that can be 32 | extended using assign-operation from the generic-operators namespace." 33 | [] 34 | (generic-operators/generic-operator base-contradictory?)) 35 | 36 | (defn- merge-base-case 37 | "Base version of the merge function. Only identical content and 38 | increments does not give rise to a contradiction." 39 | [content increment] 40 | (if (= content increment) 41 | content 42 | (contradiction (str (pr-str content) " != " (pr-str increment))))) 43 | 44 | (defn default-merge 45 | "The default merge function returns the content if the increment is 46 | nothing, and the increment if the content is nothing. Otherwise just 47 | checks to see if the values are the same, the default merge function 48 | can be extended using assign-operation." 49 | [] 50 | (doto (generic-operators/generic-operator merge-base-case) 51 | (generic-operators/assign-operation (fn [content increment] content) 52 | any? nothing?) 53 | (generic-operators/assign-operation (fn [content increment] increment) 54 | nothing? any?))) 55 | -------------------------------------------------------------------------------- /test/propaganda/intervals_test.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.intervals-test 2 | (:use clojure.test) 3 | (:require [propaganda.stm :as p] 4 | [propaganda.intervals.common :as i] 5 | [propaganda.intervals.stm :as ii] 6 | [propaganda.support-values :as sv] 7 | [propaganda.values :as v])) 8 | 9 | ;; building height example 10 | 11 | (defn fall-duration 12 | "Creates propagator from fall duration t to building height h with 13 | some uncertainty on the gravitational acceleration." 14 | [t h] 15 | (p/compound-propagator 16 | [t] 17 | (fn [] 18 | (let [g (p/make-cell) 19 | one-half (p/make-cell) 20 | t-squared (p/make-cell) 21 | gt-squared (p/make-cell)] 22 | ((p/constant (i/make-interval 9.789 9.832)) g) 23 | ((p/constant 0.5) one-half) 24 | (ii/quadratic t t-squared) 25 | (ii/product g t-squared gt-squared) 26 | (ii/product one-half gt-squared h))))) 27 | 28 | (defn similar-triangles 29 | [s-ba h-ba s h] 30 | (p/compound-propagator 31 | [s-ba h-ba s] 32 | (fn [] 33 | (let [ratio (p/make-cell)] 34 | (ii/product s-ba ratio h-ba) 35 | (ii/product s ratio h))))) 36 | 37 | (deftest building-height-test 38 | (let [custom-merge (doto (v/default-merge) ii/extend-merge)] 39 | (binding [p/*merge* custom-merge] 40 | (let [building-height (p/make-cell) 41 | fall-time (p/make-cell) 42 | barometer-height (p/make-cell) 43 | barometer-shadow (p/make-cell) 44 | building-shadow (p/make-cell)] 45 | 46 | (fall-duration fall-time building-height) 47 | (similar-triangles barometer-shadow barometer-height 48 | building-shadow building-height) 49 | 50 | (p/add-value fall-time (i/make-interval 2.9 3.1)) 51 | (p/add-value building-shadow (i/make-interval 54.9 55.1)) 52 | (p/add-value barometer-height (i/make-interval 0.3 0.32)) 53 | (p/add-value barometer-shadow (i/make-interval 0.36 0.37)) 54 | (p/add-value building-height 45.0) 55 | 56 | (is (= 45.0 57 | (p/get-value building-height))) 58 | (is (= (i/make-interval 54.9 55.1) 59 | (p/get-value building-shadow))) 60 | (is (= (i/make-interval 0.3 0.30327868852459017) 61 | (p/get-value barometer-height))) 62 | (is (= (i/make-interval 0.366 0.37) 63 | (p/get-value barometer-shadow))) 64 | (is (= (i/make-interval 3.025522031629098 3.0321598338046556) 65 | (p/get-value fall-time))))))) 66 | 67 | ;; building height with supported-values example 68 | 69 | (deftest building-height-with-supported-values-test 70 | (let [custom-merge (doto (v/default-merge) 71 | ii/extend-merge 72 | sv/extend-merge) 73 | custom-contradictory? (doto (v/default-contradictory?) 74 | sv/extend-contradictory?)] 75 | (binding [p/*merge* custom-merge] 76 | (let [building-height (p/make-cell) 77 | fall-time (p/make-cell) 78 | barometer-height (p/make-cell) 79 | barometer-shadow (p/make-cell) 80 | building-shadow (p/make-cell)] 81 | 82 | (fall-duration fall-time building-height) 83 | (similar-triangles barometer-shadow barometer-height 84 | building-shadow building-height) 85 | 86 | (p/add-value building-shadow 87 | (sv/supported 88 | (i/make-interval 54.9 55.1) 89 | :shadows)) 90 | (p/add-value barometer-height 91 | (sv/supported 92 | (i/make-interval 0.3 0.32) 93 | :shadows)) 94 | (p/add-value barometer-shadow 95 | (sv/supported 96 | (i/make-interval 0.36 0.37) 97 | :shadows)) 98 | (p/add-value fall-time 99 | (sv/supported 100 | (i/make-interval 2.9 3.3) 101 | :lousy-fall-time)) 102 | (p/add-value fall-time 103 | (sv/supported 104 | (i/make-interval 2.9 3.1) 105 | :better-fall-time)) 106 | (p/add-value building-height 107 | (sv/supported 108 | 45.0 109 | :superintendent)) 110 | 111 | (are [c v s] (and (is (= v (:value (p/get-value c)))) 112 | (is (= s (:support-set (p/get-value c))))) 113 | 114 | building-height 115 | 45.0 116 | #{:superintendent} 117 | 118 | building-shadow 119 | (i/make-interval 54.9 55.1) 120 | #{:superintendent :shadows} 121 | 122 | barometer-height 123 | (i/make-interval 0.3 0.30327868852459017) 124 | #{:superintendent :shadows :better-fall-time} 125 | 126 | barometer-shadow 127 | (i/make-interval 0.366 0.37) 128 | #{:superintendent :shadows :better-fall-time} 129 | 130 | fall-time 131 | (i/make-interval 3.025522031629098 3.0321598338046556) 132 | #{:superintendent}))))) 133 | -------------------------------------------------------------------------------- /test/propaganda/system_intervals_test.clj: -------------------------------------------------------------------------------- 1 | (ns propaganda.system-intervals-test 2 | (:use clojure.test) 3 | (:require [propaganda.system :as p :refer [add-value get-value]] 4 | [propaganda.intervals.common :as i :refer [make-interval]] 5 | [propaganda.values :as values] 6 | [propaganda.support-values :as sv :refer [supported]] 7 | [propaganda.intervals.system :refer [quadratic product]])) 8 | 9 | (defn fall-duration [system time height] 10 | (let [[g one-half t-squared gt-squared] (repeatedly gensym)] 11 | (-> system 12 | ((p/constant (make-interval 9.789 9.832)) g) 13 | ((p/constant 0.5) one-half) 14 | (quadratic time t-squared) 15 | (product g t-squared gt-squared) 16 | (product one-half gt-squared height)))) 17 | 18 | (defn similar-triangles [system & shadow-height-pairs] 19 | (let [ratio (gensym)] 20 | (reduce (fn [system [s h]] (product system s ratio h)) 21 | system 22 | (partition 2 shadow-height-pairs)))) 23 | 24 | (deftest system-building-height-test 25 | (let [system 26 | (-> (p/make-system (i/extend-merge (values/default-merge)) (values/default-contradictory?)) 27 | (fall-duration :fall-time :building-height) 28 | (similar-triangles :barometer-shadow :barometer-height 29 | :building-shadow :building-height) 30 | (add-value :fall-time (make-interval 2.9 3.1)) 31 | (add-value :building-shadow (make-interval 54.9 55.1)) 32 | (add-value :barometer-height (make-interval 0.3 0.32)) 33 | (add-value :barometer-shadow (make-interval 0.36 0.37)) 34 | (add-value :building-height 45.0))] 35 | (is (= 45.0 (get-value system :building-height))) 36 | (is (= (make-interval 54.9 55.1) (get-value system :building-shadow))) 37 | (is (= (make-interval 0.3 0.30327868852459017) (get-value system :barometer-height))) 38 | (is (= (make-interval 0.366 0.37) (get-value system :barometer-shadow))) 39 | (is (= (make-interval 3.025522031629098 3.0321598338046556) (get-value system :fall-time))))) 40 | 41 | (deftest system-building-height-with-support-test 42 | (let [system 43 | (-> (p/make-system (doto (values/default-merge) i/extend-merge sv/extend-merge) 44 | (doto (values/default-contradictory?) sv/extend-contradictory?)) 45 | (fall-duration :fall-time :building-height) 46 | (similar-triangles :barometer-shadow :barometer-height 47 | :building-shadow :building-height) 48 | (add-value :fall-time (supported (make-interval 2.9 3.3) :lousy-fall-time)) 49 | (add-value :building-shadow (supported (make-interval 54.9 55.1) :shadows)) 50 | (add-value :barometer-height (supported (make-interval 0.3 0.32) :shadows)) 51 | (add-value :barometer-shadow (supported (make-interval 0.36 0.37) :shadows)) 52 | (add-value :fall-time (supported (make-interval 2.9 3.1) :better-fall-time)) 53 | (add-value :building-height (supported 45.0 :superintendent)))] 54 | (are [c v s] (and (is (= v (:value (get-value system c)))) 55 | (is (= s (:support-set (get-value system c))))) 56 | 57 | :building-height 58 | 45.0 59 | #{:superintendent} 60 | 61 | :building-shadow 62 | (i/make-interval 54.9 55.1) 63 | #{:superintendent :shadows} 64 | 65 | :barometer-height 66 | (i/make-interval 0.3 0.30327868852459017) 67 | #{:superintendent :shadows :better-fall-time} 68 | 69 | :barometer-shadow 70 | (i/make-interval 0.366 0.37) 71 | #{:superintendent :shadows :better-fall-time} 72 | 73 | :fall-time 74 | (i/make-interval 3.025522031629098 3.0321598338046556) 75 | #{:superintendent}))) 76 | 77 | --------------------------------------------------------------------------------