├── .gitignore ├── CONTRIBUTING.md ├── DCO.md ├── LICENSE ├── README.md ├── project.clj ├── reporting_bugs.md ├── src └── engine │ ├── core.clj │ ├── runtime.clj │ └── viewer.clj └── test └── engine ├── big_cross_test.clj ├── context_test.clj ├── core_test.clj ├── module_order.clj ├── module_order2.clj ├── moved_not_test.clj ├── multi_ineq.clj ├── negated_conjunction_test.clj ├── negated_no_pos_test.clj ├── negated_wme_removal_test.clj ├── order.clj ├── order2.clj ├── rule_loop_test.clj ├── simple_priority_test.clj ├── speed_test.clj └── type_hierarchy_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | pom.xml.asc 3 | *.jar 4 | *.class 5 | /lib/ 6 | /classes/ 7 | /target/ 8 | /checkouts/ 9 | .lein-deps-sum 10 | .lein-repl-history 11 | .lein-plugins/ 12 | .lein-failures 13 | .nrepl-port 14 | .cpcache/ 15 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Arete 2 | 3 | Welcome! We're excited that you're interested in contributing. 4 | 5 | Below you will find some basic steps required to be able to contribute to the project. If you have any questions about this process or any other aspect of contributing to a Yipee open source project, please open an [issue](https://github.com/yipeeio/arete/issues) and we'll get your questions answered as quickly as we can. 6 | 7 | Pull Requests are always welcome, however they will only be accepted if they provide a reasonable test coverage. 8 | 9 | ## Workflow 10 | 11 | Arete follows a standard GitHub pull request workflow. If you're unfamiliar with this workflow, read the very helpful [Understanding the GitHub flow](https://guides.github.com/introduction/flow/) guide from GitHub. 12 | 13 | ## Getting started 14 | 15 | - Fork the repository on GitHub 16 | - Read the README.md for build instructions 17 | 18 | ## Contribution Licensing 19 | 20 | Since `Arete` is distributed under the terms of the [Apache Version 2 license](LICENSE), contributions that you make are licensed under the same terms. In order for us to be able to accept your contributions, we will need explicit confirmation from you that you are able and willing to provide them under these terms, and the mechanism we use to do this is called a Developer's Certificate of Origin [DCO](DCO.md). This is very similar to the process used by the Linux(R) kernel, Samba, and many other major open source projects. 21 | 22 | To participate under these terms, all that you must do is include a line like the following as the last line of the commit message for *each commit* in your contribution: 23 | 24 | `Signed-Off-By: John Q. Developer ` 25 | 26 | The simplest way to accomplish this is to add `-s` or `--signoff` to your `git commit` command. 27 | 28 | You must use your real name (sorry, no pseudonyms, and no anonymous contributions). 29 | 30 | 31 | Additional information on DCOs located at https://github.com/probot/dco#how-it-works 32 | 33 | ## Reporting bugs and creating issues 34 | 35 | Reporting bugs is one of the best ways to contribute. However, a good bug report has some very specific qualities, so please read over our short document on [reporting bugs](reporting_bugs.md) before submitting a bug report. This document might contain links to known issues, another good reason to take a look there before reporting a bug. 36 | 37 | Thanks for contributing! 38 | 39 | -------------------------------------------------------------------------------- /DCO.md: -------------------------------------------------------------------------------- 1 | Developer Certificate of Origin 2 | Version 1.1 3 | 4 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 5 | 1 Letterman Drive 6 | Suite D4700 7 | San Francisco, CA, 94129 8 | 9 | Everyone is permitted to copy and distribute verbatim copies of this 10 | license document, but changing it is not allowed. 11 | 12 | 13 | Developer's Certificate of Origin 1.1 14 | 15 | By making a contribution to this project, I certify that: 16 | 17 | (a) The contribution was created in whole or in part by me and I 18 | have the right to submit it under the open source license 19 | indicated in the file; or 20 | 21 | (b) The contribution is based upon previous work that, to the best 22 | of my knowledge, is covered under an appropriate open source 23 | license and I have the right under that license to submit that 24 | work with modifications, whether created in whole or in part 25 | by me, under the same open source license (unless I am 26 | permitted to submit under a different license), as indicated 27 | in the file; or 28 | 29 | (c) The contribution was provided directly to me by some other 30 | person who certified (a), (b) or (c) and I have not modified 31 | it. 32 | 33 | (d) I understand and agree that this project and the contribution 34 | are public and that a record of the contribution (including all 35 | personal information I submit with it, including my sign-off) is 36 | maintained indefinitely and may be redistributed consistent with 37 | this project or the open source license(s) involved. 38 | 39 | --- 40 | Original text of the [DCO](https://developercertificate.org/) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Repository Status 2 | **This repository exists here for historical purposes. The active arete repo is now hosted at: https://github.com/yipeeio/arete** 3 | # Arete rule engine (version: 0.6.1) 4 | A Clojure implementation of a simple forward chaining rule engine. An 5 | engine is created by defining rules in one or more modules and 6 | invoking engine.core/engine on keywords defining the modules. Each 7 | working memory element in the engine is a Clojure map. The name 8 | "Arete" is a pun on the greek word and "a-RETE" (i.e. not RETE), since 9 | the engine is based more on the TREAT algorithm than RETE. 10 | 11 | Example: 12 | 13 | *In module foo.bar:* 14 | 15 | (ns foo.bar 16 | (:require [engine.core :refer :all])) 17 | 18 | (defrule rule1 19 | [?service :service] 20 | => 21 | (println (:name ?service))) 22 | 23 | *In another module:* 24 | 25 | (ns another 26 | (:require [engine.core :refer :all])) 27 | 28 | (def eng (engine :foo.bar)) ; loads rules from the foo.bar module 29 | (eng :run [{:type :service :name "s1"}]) 30 | 31 | s1 32 | {:service [{:type :service :name "s1"}]} 33 | 34 | The result of invoking :run [``...] on an engine is to insert the 35 | specified working memory elements (wmes), run rules until no more will 36 | fire and then return a map of wme types to sequences of wmes. 37 | 38 | ## Background 39 | This engine was originally created to help with translating between 40 | different container orchestration formats (Kubernetes and Docker 41 | Compose). Both formats were changing rapidly and they don't have 42 | particularly similar structures. Rules made it easy to express global 43 | constraints and to avoid a lot of complicated and fragile navigation 44 | code. Though there are multiple Java-based rule engines, they are 45 | quite heavyweight, and are mostly oriented more toward expressing 46 | business rules than just providing an additional programming 47 | paradigm. The only Clojure engine we found 48 | ([Clara Rules](http://www.clara-rules.org/)) is a great tool but is aimed at 49 | different use cases. It shares with this engine, however, the 50 | advantage that rules can be expressed directly in a Clojure program 51 | without any new, separate language that needs to be parsed. 52 | 53 | Since this engine was used for translation (and not, say, cluster 54 | management) there is not much support built in for having an engine 55 | instance run forever while taking new inputs and processing them. It 56 | would actually be relatively easy to do and will probably happen at 57 | some point if there's interest. 58 | 59 | ## Install 60 | The Arete engine is available from clojars as `[arete "0.6.1"]` or simply 61 | download the repo, install leiningen if necessary, and run `lein 62 | uberjar`. The main class in the uberjar is the rule viewer for 63 | debugging. The engine itself has no command line. 64 | 65 | ## Usage 66 | Currently the commands supported by an engine are: 67 | 68 | * (`` :run[-map] [``...]) - Run to completion after inserting 69 | wmes. After running, clear the engine state so that a subsequent 70 | call will encounter a fresh engine. Returns a map of wme types to 71 | collections of wme instances. 72 | 73 | * (`` :run-list [``...]) - Run to completion after inserting 74 | wmes. After running, clear the engine state so that a subsequent 75 | call will encounter a fresh engine. Returns a list of wmes. 76 | 77 | * (`` :cycle [``...]) - Run to completion after inserting 78 | wmes. After running, leave the engine alone so subsequent calls add 79 | to the state rather than starting fresh. 80 | 81 | * (`` :configure {`` ``, ...}) - Turn on/off various 82 | settings for the engine: 83 | * :log-rule-firings true/false - Whether or not to print the names 84 | of rules as they fire 85 | * :max-repeated-firings `` - How many times a single rule may 86 | fire consecutively before it's considered stuck. (Defaults to 300). 87 | * :trace-set #{``, ...} - Set of rules whose execution 88 | should be traced 89 | * :stop-before #{``, ...} - Set of rules for which the 90 | engine should stop executing when reached (for testing) 91 | * :stop-after #{``, ...} - Set of rules for which the 92 | engine should stop executing after firing (for testing) 93 | * :enable-perf-mon true/false - Whether or not performance 94 | statistics should be gathered during the run. Requires that the 95 | code was compiled with the NO_PERF_COMPILE environment variable 96 | *unset*. 97 | * :record `` - Record rule firings into a file for 98 | debugging. 99 | 100 | * (`` :timing) - Display timing gathered by _:enable-perf-mon_. 101 | 102 | * (`` :wmes) - Return a map of the wmes in the engine as 103 | returned by _run_ and _run-map_. 104 | 105 | * (`` :wme-list) - Return a list of the wmes in the engine as 106 | returned by _run-list_. 107 | 108 | There is also a separate "viewer" that can be used to step through a 109 | recorded rule session for debugging. 110 | 111 | ## Rule Syntax 112 | Rules are very simple. Here is the complete syntax: 113 | 114 | ``` 115 | RULE ::= '(' 'defrule' ? ? '=>' ')' 116 | 117 | RULE_NAME ::= *string* 118 | 119 | CONFIG_MAP ::= '{' ':priority' '}' 120 | 121 | PRIORITY_VALUE ::= *integer* (can be any expression returning an 122 | integer) 123 | 124 | LHS ::= + 125 | 126 | CONDITION ::= | 127 | 128 | MATCH ::= '[' * ']' 129 | 130 | NAND ::= '[' (':not' | ':nand') + ']' 131 | 132 | OBJ_VAR ::= '?' *string* 133 | 134 | TYPE ::= *keyword* 135 | 136 | TEST_EXP ::= *clojure expression referencing OBJ_VAR* 137 | 138 | RHS ::= *clojure code* 139 | 140 | ``` 141 | 142 | Here is a rule showing the possible syntax: 143 | 144 | ``` clojure 145 | (defrule testrule 146 | {:priority 28} 147 | [?f :foo (= (:val ?f) 6)] 148 | [:not [?b :bar]] 149 | [:nand 150 | [?baz :baz (> (:val ?baz) (:val ?f)) (not= (rem (:val ?baz) 2) 0)] 151 | [?quux :quux]] 152 | => 153 | (remove! ?f) 154 | (insert! {:type :result :objs (collect! :baz #(= (:val %) 100))})) 155 | ``` 156 | 157 | There are three engine operations available for use within rule right 158 | hand sides: 159 | 160 | 1. (insert! ``) - add a wme to the engine 161 | 2. (remove! ``) - remove a wme from the engine 162 | 3. (collect! ``) | (collect! ``) - Collect all 163 | instances for which `` returns true, limited to a particular wme 164 | type if the second form is used. 165 | 166 | It's sometimes tempting to try to use "collect!" in a rule 167 | LHS. DON'T!!! It won't work. 168 | 169 | ## User-defined Conflict Resolution 170 | The basic conflict resolution strategy of the engine is simple 171 | priority. However, there is a declarative means of specifying 172 | preferences. A rule module can contain a "deforder" expression 173 | specifying how conflicts should be resolved: 174 | 175 | ``` clojure 176 | (deforder (:with :x) (:without :y) :oldest) 177 | ``` 178 | 179 | The expression above says that any instantiation containing a wme of 180 | type :x should be preferred over one that does not contain an ":x" and 181 | if neither one contains an ":x", pick the one without a ":y" over one 182 | that does contain it. Finally, if all (or no) instantiations contain 183 | an ":x" and all (or no) instantiations contain a ":y", pick the 184 | instantiation that was created first. The set of currently available 185 | checks is: 186 | 187 | * :with `` - Prefer instantiations containing wme of type 189 | * :without `` - Prefer instantiations not containing wme of 190 | type `` 191 | * :newest - Prefer the most recently created instantiation 192 | * :oldest - Prefer the least recently created instantiation 193 | * :from-module `` - Prefer an instantiation from a rule in 194 | `` over any from other modules 195 | 196 | ## Wme Type Hierarchy 197 | Sometimes it's useful to write rules that operate on abstract 198 | categories of wmes that are otherwise of different types. Maybe you 199 | want to write a rule that deals with all "shapes" instead of specific 200 | "circles", "squares", etc. This is supported in the engine by the use 201 | of "defancestor" expressions. The following: 202 | 203 | ``` clojure 204 | (defancestor [:deployment :daemonset :statefulset :cronjob] :controller) 205 | ``` 206 | 207 | says that any rule that matches a ":controller" should also match a 208 | ":deployment", ":daemonset", ":statefulset", or ":cronjob". The 209 | ancestor relationship is transitive so any ancestor of ":controller" 210 | would also be an ancestor of its descendents. 211 | 212 | ## Rule Viewer 213 | The rule viewer allows post-mortem debugging via a recorded 214 | session. If you configure the engine to record: 215 | 216 | ``` clojure 217 | (eng :configure {:record "/tmp/out"}) 218 | ``` 219 | 220 | you can run the viewer against the file after the fact. Here is a 221 | simple set of rules implementing "factorial" that we can use to 222 | demonstrate: 223 | 224 | ``` clojure 225 | (ns engine.factorial 226 | (:require [engine.core :refer :all])) 227 | 228 | (defrule fact-base 229 | [?arg :factarg (<= (:value ?arg) 0)] 230 | => 231 | (remove! ?arg) 232 | (insert! {:type :factor :value 1})) 233 | 234 | (defrule fact 235 | [?arg :factarg (> (:value ?arg) 0)] 236 | => 237 | (remove! ?arg) 238 | (insert! (update ?arg :value dec)) 239 | (insert! {:type :factor :value (:value ?arg)})) 240 | 241 | (defrule combine 242 | [?factor1 :factor] 243 | [?factor2 :factor (not= ?factor1 ?factor2)] 244 | => 245 | (remove! ?factor1) 246 | (remove! ?factor2) 247 | (insert! {:type :factor :value (* (:value ?factor1) (:value ?factor2))})) 248 | 249 | (defrule result 250 | [?factor :factor] 251 | [:not [?factor2 :factor (not= ?factor ?factor2)]] 252 | [:not [? :factarg]] 253 | => 254 | (remove! ?factor) 255 | (insert! {:type :fact-result :value (:value ?factor)})) 256 | ``` 257 | 258 | We'll run them by hand in the repl: 259 | 260 | lein repl 261 | 262 | engine.viewer=> (require '[engine.core :as e]) 263 | nil 264 | engine.viewer=> (require '[engine.factorial]) 265 | Compiling engine.factorial/fact-base 266 | Compiling engine.factorial/fact 267 | Compiling engine.factorial/combine 268 | Compiling engine.factorial/result 269 | nil 270 | engine.viewer=> (def eng (e/engine :engine.factorial)) 271 | #'engine.viewer/eng 272 | engine.viewer=> (eng :configure {:record "/tmp/out"}) 273 | #object[engine.core$engine$fn__1979 0x3400db7b "engine.core$engine$fn__1979@3400db7b"] 274 | engine.viewer=> (eng :run [{:type :factarg :value 6}]) 275 | {:fact-result [{:type :fact-result, :value 720}]} 276 | ^D 277 | 278 | Now let's run the viewer: 279 | 280 | java -jar target/arete-0.6.1-standalone.jar /tmp/out 281 | 282 | Instantiations: 283 | :engine.factorial/fact (3*) 284 | 285 | Wmes: 286 | :_start (1*) 287 | :factarg (2*) 288 | 289 | (0)==> 290 | 291 | This shows us at step 0 with one rule instantiation and two wmes (the 292 | _start wme used to trigger rules without left hand sides and our 293 | factorial argument). The "*" after each number indicates that the wme 294 | or instantiation was newly created. Let's type in the number of the 295 | argument to get a better look: 296 | 297 | (0)==> 2 298 | 299 | WME - (2):factarg 300 | 301 | value: 6 302 | 303 | (0)==> 304 | 305 | Not _too_ much to see here since it's a very simple wme. A '?' will tell us 306 | all our options: 307 | 308 | (0)==> ? 309 | Usage: 310 | '<': 311 | go to beginning 312 | '>': 313 | go to end 314 | '?': 315 | display this help 316 | '.': 317 | exit the viewer 318 | '': 319 | if at top level, move forward one firing; otherwise return to top level 320 | '[,]*': 321 | display insts or wmes with s as ids 322 | 'ar': 323 | display all rule firings for the run 324 | 'b': 325 | back up one firing 326 | 'e ': 327 | evaluate expression referencing an individual wme as: : and all wmes 328 | as :0 329 | 'g ': 330 | go to step number: 331 | 'h': 332 | display command history 333 | 'pi ': 334 | display partial rule instantiations for rules with name containing 335 | 'r': 336 | display rule firings leading to this point 337 | 'ref ': 338 | display any wmes that reference the specified wme via a UUID link 339 | 'rs ': 340 | display rule with name containing 341 | 'sc ': 342 | find the firing that created the specified wme 343 | 'sd ': 344 | find the firing that deleted the specified wme 345 | 'ss ': 346 | find the next firing containing a wme whose string representation includes 347 | 348 | 'st ': 349 | find the next firing containing a wme whose type name includes the 351 | 'sr ': 352 | find the next firing for a rule whose name includes the 353 | 'si ': 354 | find the next firing whose instantiation references a wme with type 355 | containing the 356 | 'save ': 357 | save the history to a file (when running as ":record true") 358 | 'w': 359 | display all wmes for current firing 360 | 'w ': 361 | display all wmes for current firing with types containing 362 | 'ws ': 363 | display all wmes for current firing whose string representations contain 364 | 365 | 366 | (0)==> 367 | 368 | Let's see all the rules that fired: 369 | 370 | (0)==> ar 371 | 0) :engine.factorial/fact 372 | 1) :engine.factorial/fact 373 | 2) :engine.factorial/combine 374 | 3) :engine.factorial/fact 375 | 4) :engine.factorial/combine 376 | 5) :engine.factorial/fact 377 | 6) :engine.factorial/combine 378 | 7) :engine.factorial/fact 379 | 8) :engine.factorial/combine 380 | 9) :engine.factorial/fact 381 | 10) :engine.factorial/combine 382 | 11) :engine.factorial/fact-base 383 | 12) :engine.factorial/combine 384 | 13) :engine.factorial/result 385 | (0)==> 386 | 387 | Now let's go to the end: 388 | 389 | (0)==> > 390 | 391 | Last Rule: :engine.factorial/result 392 | 393 | Wmes: 394 | :_start (1) 395 | :fact-result (66*) 396 | 397 | (14)==> 398 | 399 | Notice that once you're past the initial step, the previously fired 400 | rule is also displayed. The rest of the viewer functionality will be 401 | clear with a bit of experimentation. 402 | 403 | ## Performance monitoring 404 | Timing of individual rules and more global properties of the engine 405 | can be obtained by setting the environment variable "DEBUG_COMPILE" to 406 | true and configuring the :enable-perf-mon flag to true. This 407 | will cause performance stats to be collected which can be viewed by 408 | invoking :timing on the engine after a run. With no argument or an 409 | argument of false, the timing data will get cleared after being 410 | requested. An argument of true will leave the data intact so it can be 411 | combined with data from other runs. The result of calling :timing is a 412 | CSV file written to stdout that can be imported into a 413 | spreadsheet. Something like: 414 | 415 | finish-beta,29133401,100001,278837,209,291.33109668903313 416 | create-instantiation,234105613,100002,127878,1705,2341.0093098138036 417 | remove-pos-instantiation,280358199,100002,2561909,2142,2803.5259194816103 418 | increment,434698310,200002,600855,297,2173.469815301847 419 | rules,1018306095,400006,3263097,688,2545.727051594226 420 | increment-body,216165513,100000,1865289,1609,2161.65513 421 | body,250362454,100001,1866451,1882,2503.5995040049597 422 | finish-body,53312,1,53312,53312,53312.0 423 | remove-instantiation-inst-remove,60288971,100002,50316,443,602.8776524469511 424 | alpha,179129354,400006,122936,323,447.81666774998376 425 | instantiation-ordering,41489399,200004,42648,127,207.44284614307713 426 | finish,391241373,200004,3196323,300,1956.167741645167 427 | remove-instantiation-wme-loop,76970146,100002,2554643,522,769.6860662786744 428 | beta,63759857,100001,2040271,470,637.5921940780593 429 | 430 | The columns are: 431 | 432 | `Name, Total Time, Number of Invocations, Max Time, Min Time, Mean Time` 433 | 434 | Currently, the engine internal data is mixed in with the data for user 435 | rules. At some point, the perf interface will be made more 436 | user-friendly; however it is already quite useful in its current 437 | state. 438 | 439 | The performance monitoring has very little overhead, particularly if 440 | the engine does not have it enabled and DEBUG_COMPILE was not 441 | set. However, if you want the absolute maximum speed for a deployed 442 | system, set the environment variable NO_PERF_COMPILE to true before 443 | building your application. 444 | 445 | ## Inequality Optimization 446 | As in any non-toy rule engine, equal joins between LHS objects 447 | are turned into hash lookups. This means that the execution of a rule 448 | like: 449 | 450 | (defrule join-example 451 | [?obj1 :some-type] 452 | [?obj2 :some-other-type 453 | (= (:some-field ?obj1) (:some-other-field ?obj2))] 454 | => 455 | (println "Found match:" ?obj1 "and" ?obj2)) 456 | 457 | doesn't need to compare every instance of `:some-type` with every 458 | instance of `:some-other-type`. Instead, the wmes for 459 | `:some-other-type` are stored in a hash map keyed by the value of 460 | `:some-other-field`. When it's time to process an instance of 461 | `:some-type`, it is directly combined with instances of 462 | `:some-other-type` that result from a hash lookup of its `:some-field` 463 | value. In general, this is always worth doing as it completely avoids 464 | the normal cross product comparisons. 465 | 466 | The arete engine also implements a less common optimization that is 467 | not always useful, but _can_ be extremely so. Consider the following 468 | rule: 469 | 470 | (defrule foo 471 | [?ball1 :ball 472 | (= (:pattern ?ball1) :stripe)] 473 | [?ball2 :ball 474 | (= (:pattern ?ball2) :solid) 475 | (= (:color ?ball2) (:color ?ball1)) 476 | (> (:value ?ball2) (:value ?ball1))] 477 | [?gurk :gurk (= (:value ?gurk) (:value ?ball2))] 478 | => 479 | (insert! {:type :triple :ball1 (:value ?ball1) :ball2 (:value ?ball2) 480 | :gurk (:value ?gurk)})) 481 | 482 | and the test: 483 | 484 | (deftest big-cross 485 | (testing "inequality performance" 486 | (let [data (atom []) 487 | eng (engine :engine.big-cross-test)] 488 | (loop [i 0 j -9998] 489 | (when (< i 10000) 490 | (swap! data conj {:type :ball :pattern :stripe :color :red 491 | :value i}) 492 | (swap! data conj {:type :ball :pattern :solid :color :red 493 | :value j}) 494 | (recur (inc i) (inc j)))) 495 | (loop [g 0] 496 | (when (< g 5) 497 | (swap! data conj {:type :gurk :value g}) 498 | (recur (inc g)))) 499 | (time (eng :run-list @data))))) 500 | 501 | This inserts 9999 striped balls, 9999 solid balls, and 5 gurks. The 502 | values for striped and solid balls only overlap in one entry (0). 503 | 504 | When run on my laptop, this test takes nearly two minutes to run because 505 | each insertion of a gurk forces a full cross product evaluation of the 506 | two ball matches. This is something of a worst case scenario for arete 507 | since it does not save intermediate join results between 508 | executions (A RETE-based engine would have a similar problem if a 509 | new wme was added in a match higher in the LHS and would do much more 510 | work if "balls" rather than "gurks" were being added and removed). If we 511 | make one minor change, however: 512 | 513 | (defrule foo 514 | [?ball1 :ball 515 | (= (:pattern ?ball1) :stripe)] 516 | [?ball2 :ball 517 | (= (:pattern ?ball2) :solid) 518 | (= (:color ?ball2) (:color ?ball1)) 519 | (>> (:value ?ball2) (:value ?ball1))] ;; <- replace '>' with '>>' 520 | [?gurk :gurk (= (:value ?gurk) (:value ?ball2))] 521 | => 522 | (insert! {:type :triple :ball1 (:value ?ball1) :ball2 (:value ?ball2) 523 | :gurk (:value ?gurk)})) 524 | 525 | it runs in less than 500 milliseconds. The optimization applied here 526 | inserts entries being joined via an inequality into Java TreeMaps so 527 | that the engine can iterate over the `headMap` of the map containing 528 | entries that match the inequality. The process has a fair bit of 529 | overhead, so it isn't automatically applied. To trigger the 530 | optimization, replace '>' with '>>', '<' with '<<', '>=' with '>>=' 531 | and '<=' with '<<='. To see the worst case for the optimization, 532 | consider: 533 | 534 | (defrule finish 535 | {:priority 10} 536 | [?limit :limit] 537 | [?counter :counter (>= ^long (:value ?counter) ^long (:value ?limit))] 538 | => 539 | (remove! ?limit) 540 | (remove! ?counter) 541 | (insert! {:type :result :value (:value ?counter)})) 542 | 543 | (defrule increment 544 | [?counter :counter] 545 | => 546 | (remove! ?counter) 547 | (insert! (update ?counter :value inc))) 548 | 549 | and: 550 | 551 | (deftest performance-test 552 | (testing "raw simmple rule performance" 553 | (let [eng (engine :engine.speed-test) 554 | _ (eng :configure {:max-repeated-firings 200000}) 555 | result (time (eng :run [{:type :limit :value 100000} 556 | {:type :counter :value 0}]))] 557 | (is (= (:value (first (:result result))) 100000))))) 558 | 559 | (BTW, note the use of `:max-repeated-firings`.) 560 | 561 | When run with '>=', this takes ~1.3 seconds. With '>>=', however, it 562 | takes: ~2.3 seconds. So, there's a tradeoff. If you're operating on 563 | large numbers of objects and you see slow behavior around an 564 | inequality, try replacing the operator with its TreeMap equivalent and 565 | you may see a _significant_ improvement. 566 | 567 | ## Implementation 568 | The engine is loosely based on the TREAT algorithm, though the 569 | handling of negation is different (probably worse...) However, it does 570 | correctly handle negated conjunctions. For rules without negation, the 571 | processing is quite efficient with very little allocation (only the 572 | instantiations and maps to hold wmes). Negation requires maintaining a 573 | much more elaborate tracking structure. Like TREAT, no intermediate 574 | state is saved for beta tests (other than hashes of values so that we 575 | can avoid cross-product performance). 576 | 577 | No attempt is made at making this a purely functional implementation; 578 | Java maps and other data structures are used throughout for maximum 579 | efficiency. If immutable sessions or truth maintenance are important 580 | for your application, check out "Clara Rules" instead. 581 | 582 | ### Details 583 | To explain how the engine works, we'll go through a briew overview and 584 | then build up from the simplest case. Most forward chaining rule 585 | engines use some variation of the RETE algorithm. The RETE algorithm 586 | was originally developed based on the insight that the firing of a 587 | forward chaining rule typically leaves most of the working data 588 | unchanged. This suggests that it's worthwhile to precompute matches 589 | and hold on to them between firings since most of the work will not 590 | need to be redone. The RETE algorithm takes this perspective to the 591 | limit by precomputing and caching everything it can including the 592 | results of comparisons between fields of distinct objects 593 | (i.e. joins). As it turns out, though, there is a significant amount 594 | of bookkeeping overhead associated with maintaining precomputed 595 | joins. TREAT (and this engine) discard join results and recompute them 596 | as necessary. A RETE engine feeds working memory elements into the top 597 | of a discrimination network and "rule instantiations" come out the 598 | bottom. TREAT places working memory elements into maps and then works 599 | from the bottom up to find matches. Compiling the rule: 600 | 601 | ``` clojure 602 | (defrule two-objects 603 | [?ball :ball (> (:radius ?ball) 10)] 604 | [?cube :cube (= (:side ?cube) (:radius ?ball))] 605 | => 606 | (println "Found match: " ?ball " and " ?cube)) 607 | ``` 608 | 609 | will produce one map to hold entries for each object match: 610 | 611 | ``` clojure 612 | {1 {:type :ball :__id 1 :radius 11} 613 | 2 {:type :ball :__id 2 :radius 12} 614 | 3 {:type :ball :__id 3 :radius 28}} 615 | 616 | {4 {:type :cube :__id 4 :side 11} 617 | 5 {:type :cube :__id 5 :side 12} 618 | 6 {:type :cube :__id 6 :side 28}} 619 | ``` 620 | 621 | and two sets of functions, one for managing the alpha maps (adding and 622 | removing wmes) and one to manage rule matching and instantiation. The 623 | functions that manage the maps invoke the root function from the 624 | second set for each associated rule. 625 | 626 | ``` clojure 627 | ;; Managing maps 628 | (defn alpha-ball-1 [wme-var] 629 | (when 630 | (when (empty? ) 631 | (swap! empty-count dec)) 632 | (put (:__id wme-var) wme-var) 633 | (reset! {(:__id wme-var) wme-var}) 634 | (main-fun) 635 | (reset! ))) 636 | 637 | (defn alpha-cube-1 [wme-var] 638 | (let [hash-val ( wme-var)] 639 | (when (empty? ) 640 | (swap! empty-count dec)) 641 | (let [existing (or (.get hash-val) 642 | (let [m (make-map)] 643 | (.put hash-val m) 644 | m))] 645 | (.put ^HashMap existing (:__id ^Wme wme-var) wme-var)) 646 | (reset! {(:__id wme-var) wme-var}) 647 | (main-fun) 648 | (reset! ))) 649 | 650 | ;; Matching and instantiation 651 | (defn op-1 [hash-val result-fun] 652 | (doseq [cube (vals (get @?cube-cur-2 hash-val))] 653 | (result-fun cube))) 654 | 655 | (defn upstream-2 [result-fun] 656 | (doseq [ball (vals @?ball-cur-1)] 657 | (result-fun ball))) 658 | 659 | (defn upstream-1 [result-fun] 660 | (upstream-2 (fn [?ball] 661 | (op-1 (:radius ball) 662 | (fn [?cube] (result-fun ?ball ?cube)))))) 663 | 664 | (defn main-fun [] 665 | (when (= empty-count-1 0) 666 | (upstream-1 (fn [?ball ?cube] 667 | (create-instantiation ...))))) 668 | ``` 669 | 670 | The map functions are pseudocode because they're constructed as 671 | closures programmatically and many of the variables they reference are 672 | defined in the functions that create them. The two map functions look 673 | different because the cube function uses an extra level of hashing to 674 | allow efficient comparison of ball radii with cube sides. 675 | 676 | When a new working memory element is added (e.g. a ball), each alpha 677 | (map) function associated with the wme type is called and, if it 678 | results in adding a new element, the current map for the type is 679 | replaced with a map containing only the new element. Then, the main 680 | function of the rule is called and it performs joint matches which 681 | will only include the one new wme for the type (since all other cross 682 | matches will have already been done when the other values were 683 | added). Afterward, the map is set back to the original map plus the 684 | new element. 685 | 686 | Negated object matches are far more complicated and will be discussed 687 | in detail below. 688 | 689 | Here is a very simple rule module: 690 | 691 | ``` clojure 692 | (ns engine.examples 693 | (:require [engine.core :refer :all])) 694 | 695 | (defrule note-red-ball 696 | [?ball :ball (= (:color ?ball) :red)] 697 | => 698 | (println "Found red ball: " ?ball)) 699 | ``` 700 | 701 | If we set the environment variable: "SHOW_RULES" and compile the 702 | module we can see what the actual code for the rule looks like: 703 | 704 | ``` clojure 705 | (clojure.core/fn 706 | [] 707 | (clojure.core/let 708 | [note-red-ball-2953 709 | (clojure.core/atom nil) 710 | empty-count-2954 711 | (clojure.core/atom 1) 712 | ?ball-2955 713 | (engine.runtime/make-map) 714 | ?ball-cur-2956 715 | (clojure.core/atom ?ball-2955) 716 | op-2959 717 | (clojure.core/fn 718 | op-2959 719 | [beta__2253__auto__] 720 | (clojure.core/doseq 721 | [cur__2254__auto__ (clojure.core/vals @?ball-cur-2956)] 722 | (beta__2253__auto__ cur__2254__auto__))) 723 | upstream-2960 724 | op-2959 725 | note-red-ball-alpha-ball-2957 726 | (engine.runtime/alpha-fun 727 | (clojure.core/fn 728 | [?ball] 729 | (clojure.core/and (= (:color ?ball) :red))) 730 | ?ball-2955 731 | ?ball-cur-2956 732 | empty-count-2954 733 | note-red-ball-2953) 734 | note-red-ball-alpha-rem-ball-2958 735 | (engine.runtime/alpha-rem-fun ?ball-2955 empty-count-2954)] 736 | (.add 737 | engine.runtime/*empty-counts* 738 | [empty-count-2954 @empty-count-2954]) 739 | (clojure.core/reset! 740 | note-red-ball-2953 741 | (clojure.core/fn 742 | [] 743 | (clojure.core/when 744 | (clojure.core/= @empty-count-2954 0) 745 | (upstream-2960 746 | (clojure.core/fn 747 | body-2962 748 | [?ball] 749 | (engine.runtime/create-instantiation 750 | :engine.examples 751 | :engine.examples/note-red-ball 752 | 0 753 | 'note-red-ball-2953 754 | [?ball] 755 | '[] 756 | (clojure.core/fn 757 | [] 758 | (println "Found red ball: " ?ball)))))))) 759 | {:ball 760 | [[note-red-ball-alpha-ball-2957 761 | note-red-ball-alpha-rem-ball-2958 762 | ?ball-2955]]})) 763 | ``` 764 | 765 | If you look closely, you should be able to see the functions that are 766 | analogous to the example ones show above. 767 | 768 | ### Negation 769 | Completely general rule conditions require the ability to express 770 | arbitrary boolean logic. This engine provides that support in the form 771 | of a "negated conjunction" or "nand" match. It's well known that 772 | either "nand" or "nor" by itself is sufficient to express any boolean 773 | logic, so we add the ability to express nested nands on left hand 774 | sides. Consider a loan application rule preventing too many lines of 775 | credit from being allowed against a given mortgage. Along with other 776 | rules preventing too much leverage, we have a rule that says no more 777 | than two lines of credit per mortage: 778 | 779 | ``` clojure 780 | (defrule max-lines-of-credit 781 | [?mortgage :mortgage] 782 | [?loc-request :loc-request (= (:mortgage ?loc-request) (:id ?mortgage))] 783 | [:nand 784 | [?loc1 :loc (= (:mortgage ?loc1) (:id ?mortgage))] 785 | [?loc2 :loc 786 | (= (:mortgage ?loc2) (:id ?mortgage)) 787 | (not= (:id ?loc2) (:id ?loc1))]] 788 | => 789 | (println "Too many lines of credit against: " (:id ?mortgage))) 790 | ``` 791 | 792 | Here is the compiled rule (with debug lines removed): 793 | 794 | ``` clojure 795 | (clojure.core/fn 796 | [] 797 | (clojure.core/let 798 | [max-lines-of-credit-3727 799 | (clojure.core/atom nil) 800 | empty-count-3728 801 | (clojure.core/atom 2) 802 | net-3744 803 | (clojure.core/atom nil) 804 | ?mortgage-3729 805 | (engine.runtime/make-map) 806 | ?mortgage-cur-3730 807 | (clojure.core/atom ?mortgage-3729) 808 | op-3733 809 | (clojure.core/fn 810 | op-3733 811 | [beta__2089__auto__] 812 | (clojure.core/doseq 813 | [cur__2090__auto__ (clojure.core/vals @?mortgage-cur-3730)] 814 | (beta__2089__auto__ cur__2090__auto__))) 815 | upstream-3734 816 | op-3733 817 | max-lines-of-credit-alpha-mortgage-3731 818 | (engine.runtime/alpha-fun-no-tests 819 | ?mortgage-3729 820 | ?mortgage-cur-3730 821 | empty-count-3728 822 | max-lines-of-credit-3727) 823 | max-lines-of-credit-alpha-rem-mortgage-3732 824 | (engine.runtime/alpha-rem-fun ?mortgage-3729 empty-count-3728) 825 | ?loc-request-3736 826 | (engine.runtime/make-map) 827 | ?loc-request-cur-3737 828 | (clojure.core/atom ?loc-request-3736) 829 | op-3740 830 | (clojure.core/fn 831 | op-3740 832 | [hash-val__2086__auto__ beta__2087__auto__] 833 | (clojure.core/doseq 834 | [cur__2088__auto__ 835 | (clojure.core/vals 836 | (.get @?loc-request-cur-3737 hash-val__2086__auto__))] 837 | (beta__2087__auto__ cur__2088__auto__))) 838 | upstream-3741 839 | (clojure.core/fn 840 | upstream-3741 841 | [down3743] 842 | (upstream-3734 843 | (clojure.core/fn 844 | upstream-3741 845 | [?mortgage] 846 | (op-3740 847 | (:id ?mortgage) 848 | (clojure.core/fn 849 | subfun-3742 850 | [?loc-request] 851 | (down3743 ?mortgage ?loc-request)))))) 852 | max-lines-of-credit-alpha-loc-request-3738 853 | (engine.runtime/alpha-hash-fun-no-tests 854 | (clojure.core/fn [?loc-request] (:mortgage ?loc-request)) 855 | ?loc-request-3736 856 | ?loc-request-cur-3737 857 | empty-count-3728 858 | max-lines-of-credit-3727) 859 | max-lines-of-credit-alpha-rem-loc-request-3739 860 | (engine.runtime/alpha-hash-rem-fun 861 | ?loc-request-3736 862 | (clojure.core/fn [?loc-request] (:mortgage ?loc-request)) 863 | empty-count-3728) 864 | empty-count-3746 865 | (clojure.core/atom 2) 866 | ?loc1-3747 867 | (engine.runtime/make-map) 868 | ?loc2-3755 869 | (engine.runtime/make-map) 870 | ?loc1-cur-3748 871 | (clojure.core/atom ?loc1-3747) 872 | ?loc2-cur-3756 873 | (clojure.core/atom ?loc2-3755) 874 | op-3751 875 | (clojure.core/fn 876 | op-3751 877 | [hash-val__2086__auto__ beta__2087__auto__] 878 | (clojure.core/doseq 879 | [cur__2088__auto__ 880 | (clojure.core/vals 881 | (.get @?loc1-cur-3748 hash-val__2086__auto__))] 882 | (beta__2087__auto__ 883 | engine.runtime/*outer-vars* 884 | cur__2088__auto__))) 885 | op-3759 886 | (clojure.core/fn 887 | op-3759 888 | [hash-val__2086__auto__ beta__2087__auto__] 889 | (clojure.core/doseq 890 | [cur__2088__auto__ 891 | (clojure.core/vals 892 | (.get @?loc2-cur-3756 hash-val__2086__auto__))] 893 | (beta__2087__auto__ 894 | engine.runtime/*outer-vars* 895 | cur__2088__auto__))) 896 | upstream-3745 897 | (clojure.core/fn 898 | upstream-3745 899 | [down__2121__auto__] 900 | (clojure.core/case 901 | (clojure.core/get engine.runtime/*nand-modes* 'net-3744) 902 | :pass 903 | (upstream-3741 904 | (clojure.core/fn 905 | neg-3764 906 | [?mortgage ?loc-request] 907 | (clojure.core/binding 908 | [engine.runtime/*outer-vars* [?mortgage ?loc-request]] 909 | (@net-3744) 910 | (clojure.core/let 911 | [record__2122__auto__ 912 | (engine.runtime/get-sub-nand-record 913 | engine.runtime/*nand-records* 914 | 'net-3744 915 | engine.runtime/*outer-vars*)] 916 | (if 917 | record__2122__auto__ 918 | (do 919 | (engine.runtime/put-sub-nand-record 920 | engine.runtime/*nand-records* 921 | 'net-3744 922 | engine.runtime/*outer-vars* 923 | (engine.runtime/->Nand 924 | 'net-3744 925 | engine.runtime/*outer-vars* 926 | (clojure.core/atom #{}) 927 | (clojure.core/atom :live))) 928 | (down__2121__auto__ ?mortgage ?loc-request))))))) 929 | :sub 930 | (clojure.core/let 931 | [nand-records__2123__auto__ 932 | (.get engine.runtime/*nand-records* 'net-3744)] 933 | (clojure.core/doseq 934 | [nr__2124__auto__ 935 | (clojure.core/vals nand-records__2123__auto__)] 936 | (clojure.core/binding 937 | [engine.runtime/*outer-vars* (:wmes nr__2124__auto__)] 938 | (@net-3744) 939 | (clojure.core/let 940 | [record__2122__auto__ 941 | (engine.runtime/get-sub-nand-record 942 | engine.runtime/*nand-records* 943 | 'net-3744 944 | engine.runtime/*outer-vars*)] 945 | (if 946 | record__2122__auto__ 947 | (do 948 | (engine.runtime/put-sub-nand-record 949 | engine.runtime/*nand-records* 950 | 'net-3744 951 | engine.runtime/*outer-vars* 952 | (engine.runtime/->Nand 953 | 'net-3744 954 | engine.runtime/*outer-vars* 955 | (clojure.core/atom #{}) 956 | (clojure.core/atom :live))) 957 | (clojure.core/apply 958 | down__2121__auto__ 959 | engine.runtime/*outer-vars*))))))) 960 | :rem 961 | (clojure.core/let 962 | [nand-records__2123__auto__ 963 | engine.runtime/*nand-records* 964 | nr__2124__auto__ 965 | (engine.runtime/get-sub-nand-record 966 | nand-records__2123__auto__ 967 | 'net-3744 968 | engine.runtime/*outer-vars*)] 969 | (clojure.core/let 970 | [wmes__2125__auto__ (:wmes nr__2124__auto__)] 971 | (clojure.core/apply down__2121__auto__ wmes__2125__auto__))))) 972 | upstream-3752 973 | (clojure.core/fn 974 | upstream-3752 975 | [down3754] 976 | (op-3751 977 | (clojure.core/let 978 | [[?mortgage ?loc-request] engine.runtime/*outer-vars*] 979 | (:id ?mortgage)) 980 | (clojure.core/fn 981 | subfun-3753 982 | [[?mortgage ?loc-request] ?loc1] 983 | (down3754 [?mortgage ?loc-request] ?loc1)))) 984 | upstream-3760 985 | (clojure.core/fn 986 | upstream-3760 987 | [down3762] 988 | (upstream-3752 989 | (clojure.core/fn 990 | upstream-3760 991 | [[?mortgage ?loc-request] ?loc1] 992 | (op-3759 993 | (:id ?mortgage) 994 | (clojure.core/fn 995 | subfun-3761 996 | [[?mortgage ?loc-request] ?loc2] 997 | (clojure.core/when 998 | (clojure.core/and (not= (:id ?loc2) (:id ?loc1))) 999 | (down3762 [?mortgage ?loc-request] ?loc1 ?loc2))))))) 1000 | max-lines-of-credit-alpha-loc-3749 1001 | (engine.runtime/alpha-hash-fun-no-tests 1002 | (clojure.core/fn [?loc1] (:mortgage ?loc1)) 1003 | ?loc1-3747 1004 | ?loc1-cur-3748 1005 | empty-count-3746 1006 | (clojure.core/atom 1007 | (clojure.core/fn 1008 | [] 1009 | (engine.runtime/set-nand-mode 'net-3744 :sub) 1010 | (@max-lines-of-credit-3727) 1011 | (engine.runtime/set-nand-mode 'net-3744 :pass)))) 1012 | max-lines-of-credit-alpha-loc-3757 1013 | (engine.runtime/alpha-hash-fun-no-tests 1014 | (clojure.core/fn [?loc2] (:mortgage ?loc2)) 1015 | ?loc2-3755 1016 | ?loc2-cur-3756 1017 | empty-count-3746 1018 | (clojure.core/atom 1019 | (clojure.core/fn 1020 | [] 1021 | (engine.runtime/set-nand-mode 'net-3744 :sub) 1022 | (@max-lines-of-credit-3727) 1023 | (engine.runtime/set-nand-mode 'net-3744 :pass)))) 1024 | max-lines-of-credit-alpha-rem-loc-3750 1025 | (engine.runtime/alpha-hash-rem-fun 1026 | ?loc1-3747 1027 | (clojure.core/fn [?loc1] (:mortgage ?loc1)) 1028 | empty-count-3746) 1029 | max-lines-of-credit-alpha-rem-loc-3758 1030 | (engine.runtime/alpha-hash-rem-fun 1031 | ?loc2-3755 1032 | (clojure.core/fn [?loc2] (:mortgage ?loc2)) 1033 | empty-count-3746)] 1034 | (.add 1035 | engine.runtime/*empty-counts* 1036 | [empty-count-3728 @empty-count-3728]) 1037 | (.add 1038 | engine.runtime/*empty-counts* 1039 | [empty-count-3746 @empty-count-3746]) 1040 | (clojure.core/reset! 1041 | net-3744 1042 | (clojure.core/fn 1043 | [] 1044 | (clojure.core/when 1045 | (clojure.core/= @empty-count-3746 0) 1046 | (upstream-3760 1047 | (clojure.core/fn 1048 | neg-conj-body-3763 1049 | [[?mortgage ?loc-request] ?loc1 ?loc2] 1050 | (engine.runtime/create-neg-instantiation 1051 | "max-lines-of-credit" 1052 | [?mortgage ?loc-request] 1053 | [?loc1 ?loc2] 1054 | 'net-3744 1055 | 'max-lines-of-credit-3727 1056 | 0)))))) 1057 | (.put engine.runtime/*net-funs* 'net-3744 max-lines-of-credit-3727) 1058 | (.put engine.runtime/*nand-modes* 'net-3744 :pass) 1059 | (clojure.core/reset! 1060 | max-lines-of-credit-3727 1061 | (clojure.core/fn 1062 | [] 1063 | (clojure.core/when 1064 | (clojure.core/= @empty-count-3728 0) 1065 | (upstream-3745 1066 | (clojure.core/fn 1067 | body-3765 1068 | [?mortgage ?loc-request] 1069 | (engine.runtime/create-instantiation 1070 | :engine.examples 1071 | :engine.examples/max-lines-of-credit 1072 | 0 1073 | 'max-lines-of-credit-3727 1074 | [?mortgage ?loc-request] 1075 | '[[net-3744 2]] 1076 | (clojure.core/fn 1077 | [] 1078 | (println 1079 | "Too many lines of credit against: " 1080 | (:id ?mortgage))))))))) 1081 | {:mortgage 1082 | [[max-lines-of-credit-alpha-mortgage-3731 1083 | max-lines-of-credit-alpha-rem-mortgage-3732 1084 | ?mortgage-3729]], 1085 | :loc-request 1086 | [[max-lines-of-credit-alpha-loc-request-3738 1087 | max-lines-of-credit-alpha-rem-loc-request-3739 1088 | ?loc-request-3736]], 1089 | :loc 1090 | [[max-lines-of-credit-alpha-loc-3749 1091 | max-lines-of-credit-alpha-rem-loc-3750 1092 | ?loc1-3747] 1093 | [max-lines-of-credit-alpha-loc-3757 1094 | max-lines-of-credit-alpha-rem-loc-3758 1095 | ?loc2-3755]]})) 1096 | ``` 1097 | 1098 | The wmes flow into the rule this way: 1099 | 1100 | mortgage loc loc * 1101 | \ \ \ / 1102 | \ \ \ / 1103 | \ \ . 1104 | \ \ / 1105 | \ \ / 1106 | \ . 1107 | \ / 1108 | \ / 1109 | \ / 1110 | \ / 1111 | * {+pass, sub, rem} 1112 | \ 1113 | \ 1114 | 1115 | The branch going up to the right represents the nested "nand" with two 1116 | line of credit matches. The "*" is the nand node. It takes action any 1117 | time execution begins from the bottom of the graph and begins in 1118 | "pass" state. If a new mortgage wme is added, the wme is stored in the 1119 | mortgage alpha node for the rule and execution is started from the 1120 | bottom. When execution reaches the nand node (in "pass" mode) it 1121 | passes execution up the left side and does the following for any 1122 | successful upstream matches: 1123 | 1124 | 1. Bind *outer-vars* to all the object match variables in any outer 1125 | network. In this case, that's just one variable: ?mortgage. 1126 | 2. Run the entire inner nand subnetwork and collect any resulting 1127 | negative instantiations. 1128 | 3. If there are any resulting instantiations, store them in a new nand 1129 | record for the nand node keyed by the wmes; otherwise, call the 1130 | downward function with the wmes. 1131 | 1132 | If an outer wme is removed, the nand node will not get triggered as 1133 | all the instantiations, nand-records, and other related data will get 1134 | removed directly without invoking the network. 1135 | 1136 | If a wme is added to the inner network, we have to look for matches 1137 | with each wme combination that made it to the nand node. So, we 1138 | iterate through the nand records and, for each one: 1139 | 1140 | 1. Set the nand node to "sub" mode 1141 | 2. Bind *outer-vars* to the wmes. 1142 | 3. Run the inner network and if there are any resulting instantiations: 1143 | 1144 | If there is already a nand record for the wmes, add the 1145 | instantiation to its instantiation list and stop; otherwise, create a 1146 | new nand-record, add the instantiation, and remove all positive 1147 | instantiations downstream whose wmes include the wmes present at the 1148 | nand node as a prefix. 1149 | 1150 | If a wme is removed from the inner network, we remove all 1151 | instantiations and set the nand node to "rem" mode and, when control 1152 | reaches it from the bottom, we retrieve all nand records that match 1153 | and no longer have any instantiations. The wmes contained in these 1154 | nand records are passed to the downstream function. 1155 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject arete "0.6.1" 2 | :description "Clojure rule engine" 3 | :url "https://github.com/yipee.io/arete.git" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :main engine.viewer 7 | :dependencies [[org.clojure/clojure "1.8.0"] 8 | [org.flatland/ordered "1.5.6"] 9 | [clj-yaml "0.4.0"] 10 | [potemkin "0.4.5"] 11 | [org.clojure/data.json "0.2.6"] 12 | [org.javasimon/javasimon-core "4.1.3"]] 13 | :profiles {:uberjar {:aot :all}} 14 | :deploy-repositories [["releases" 15 | {:sign-releases false :url "https://clojars.org/repo"}] 16 | ["snapshots" 17 | {:sign-releases false :url "https://clojars.org/repo"}]]) 18 | 19 | -------------------------------------------------------------------------------- /reporting_bugs.md: -------------------------------------------------------------------------------- 1 | # Reporting bugs 2 | 3 | If any part of the arete project has bugs or documentation mistakes, please let us know by [opening an issue](https://github.com/yipeeio/arete/issues). We treat bugs and mistakes very seriously and believe no issue is too small. Before creating a bug report, please check that an issue reporting the same problem does not already exist. 4 | 5 | To make the bug report accurate and easy to understand, please try to create bug reports that are: 6 | 7 | - Specific. Include as much details as possible: which version, what environment, what configuration, logs, etc. 8 | 9 | - Reproducible. Include the steps to reproduce the problem. We understand some issues might be hard to reproduce, please includes the steps that might lead to the problem. If possible, please attach the rulesets to the bug report. Note, without the rulesets (or sample ones that illustrate the problem) it will be difficult to reproduce. 10 | 11 | - Isolated. Please try to isolate and reproduce the bug with minimum dependencies. It would significantly slow down the speed to fix a bug if too many dependencies are involved in a bug report. Debugging external systems that rely on arete is out of scope, but we are happy to provide guidance in the right direction or help with using arete itself. 12 | 13 | - Unique. Do not duplicate existing bug reports. 14 | 15 | - Scoped. One bug per report. Do not follow up with another bug inside one report. 16 | 17 | It may be worthwhile to read [Elika Etemad’s article on filing good bug reports](http://fantasai.inkedblade.net/style/talks/filing-good-bugs) before creating a bug report. 18 | 19 | We might ask for further information to locate a bug. A duplicated bug report will be closed. 20 | 21 | --- 22 | Majority of the content comes from the [etcd project](https://github.com/etcd-io/etcd/blob/master/Documentation/reporting_bugs.md) 23 | -------------------------------------------------------------------------------- /src/engine/core.clj: -------------------------------------------------------------------------------- 1 | (ns engine.core 2 | (:gen-class) 3 | (:require [clojure.pprint :as pprint] 4 | [clojure.stacktrace :as st] 5 | [clojure.set :as set] 6 | [clojure.string :as str] 7 | [clojure.walk :as walk] 8 | [flatland.ordered.set :as ordered] 9 | [clojure.java.io :as io] 10 | [potemkin :refer [import-vars]] 11 | [engine.runtime 12 | :refer :all 13 | :exclude [get-stack-trace ppwrap wme-types >> << >>= <<=]] 14 | [engine.viewer :refer [view]]) 15 | (:import [org.javasimon SimonManager Stopwatch] 16 | [java.util HashMap TreeSet TreeMap TreeMap$Entry 17 | TreeMap$DescendingSubMap Comparator ArrayDeque] 18 | clojure.lang.PersistentVector)) 19 | 20 | ;; Variables from runtime that we want to expose from core (using the Potemkin 21 | ;; library's "import-vars") 22 | (import-vars [engine.runtime 23 | get-stack-trace 24 | ppwrap 25 | wme-types 26 | >> 27 | << 28 | >>= 29 | <<=]) 30 | 31 | ;; Whether or not to turn on simon performance monitoring -- assumes 32 | ;; NO_PERF_COMPILE environment variable was not set during compilation 33 | (def enable-perf-mon (atom false)) 34 | 35 | ;; Main API and ruleset construction code for RETE/TREAT based rule 36 | ;; engine. All the macros for defining rules and their support code is 37 | ;; in this file along with the main engine calls available to engine 38 | ;; users: insert!, remove!, collect!, and the calls on the engine 39 | ;; itself (run, run-map, run-list, cycle, configure, timing, wmes, 40 | ;; and wme-list. 41 | 42 | ;; Define conflict resolution ordering for a ruleset. The functions passed 43 | ;; to 'deforder' are applied in order to sort instantiations. So, the 44 | ;; expression: (deforder (:with :x) (:without :y) :oldest) would favor 45 | ;; instantiations containing wmes of type :x followed by those NOT 46 | ;; containing wmes of type :y, followed by older over younger. 47 | (defmacro deforder [& funs] 48 | (let [left (gensym "left") 49 | right (gensym "right")] 50 | `(swap! orderings 51 | #(assoc % (keyword (ns-name *ns*)) 52 | (list (fn [~left ~right] 53 | ~(compile-ordering funs left right))))))) 54 | 55 | (defn update-all [in-map f] 56 | (reduce (fn [m k] (update m k f)) in-map (keys in-map))) 57 | 58 | ;; Search for variables to determine if an expression references multiple 59 | ;; wmes and needs to be treated as a beta node. 60 | (defn find-any [vars sexp] 61 | (cond (or (nil? sexp) (and (seq? sexp) (empty? sexp))) false 62 | (vars sexp) true 63 | (or (seq? sexp) (vector? sexp)) (or (find-any vars (first sexp)) 64 | (find-any vars (rest sexp))) 65 | (map? sexp) (or (find-any vars (keys sexp)) 66 | (find-any vars (vals sexp))) 67 | true false)) 68 | 69 | ;; Every test must reference the wme declared in its match expression. 70 | (defn translate-obj-test [x var] 71 | (if (not (find-any #{var} x)) 72 | (throw (RuntimeException. "Must reference matched wme in tests.")) 73 | x)) 74 | 75 | (defn get-upstream [nodes] 76 | (first (:upstream (last nodes)))) 77 | 78 | (defn node-type [fnode] 79 | (if (= fnode '=>) 80 | nil 81 | (first fnode))) 82 | 83 | 84 | (defn order-sub-exps [test-exp vars] 85 | (let [left (second test-exp) 86 | right (nth test-exp 2) 87 | in-order (find-any vars left)] 88 | (if in-order [left right] [right left]))) 89 | 90 | (defn make-vec-funs [test-exp vars wme-var] 91 | (let [pairs (map #(order-sub-exps % vars) test-exp)] 92 | [(mapv first pairs) `(fn [~wme-var] ~(mapv second pairs))])) 93 | 94 | (defn make-hash-funs [test-exp vars wme-var] 95 | (if (vector? test-exp) 96 | (make-vec-funs test-exp vars wme-var) 97 | (let [pair (order-sub-exps test-exp vars)] 98 | [(first pair) `(fn [~wme-var] ~(second pair))]))) 99 | 100 | (defn make-ie-data [test-exp vars wme-var] 101 | (conj (make-vec-funs test-exp vars wme-var) 102 | (mapv first test-exp))) 103 | 104 | (defn make-add-fun [alpha-tests lhash-fun luie-fun comps alpha-name 105 | rname-string wme-var 106 | oset ocur empty-count-name rule-name main-fun] 107 | ;; Select a function to handle alpha nodes depending on whether: 108 | ;; a) there are single object filtering tests 109 | ;; b) there is a beta equality match requiring hashing 110 | ;; c) we want debug output 111 | (case [(some? alpha-tests) (some? lhash-fun) @compile-with-debug] 112 | ;; Tests, Hashing, Debug 113 | [true true true] `(~alpha-name 114 | (debug-alpha-hash-fun 115 | ~rname-string 116 | '~alpha-name 117 | (fn [~wme-var] 118 | (and ~@(map #(translate-obj-test % wme-var) 119 | alpha-tests))) 120 | ~lhash-fun 121 | ~luie-fun 122 | ~comps 123 | ~oset 124 | ~ocur 125 | ~empty-count-name 126 | '~rule-name 127 | ~main-fun)) 128 | ;; Tests, Hashing, No Debug 129 | [true true false] `(~alpha-name 130 | (alpha-hash-fun 131 | (fn [~wme-var] 132 | (and ~@(map #(translate-obj-test % wme-var) 133 | alpha-tests))) 134 | ~lhash-fun 135 | ~luie-fun 136 | ~comps 137 | ~oset 138 | ~ocur 139 | ~empty-count-name 140 | ~main-fun)) 141 | ;; Tests, No Hashing, Debug 142 | [true false true] `(~alpha-name 143 | (debug-alpha-fun 144 | ~rname-string 145 | '~alpha-name 146 | (fn [~wme-var] 147 | (and ~@(map #(translate-obj-test % wme-var) 148 | alpha-tests))) 149 | ~luie-fun 150 | ~comps 151 | ~oset 152 | ~ocur 153 | ~empty-count-name 154 | '~rule-name 155 | ~main-fun)) 156 | ;; Tests, No Hashing, No Debug 157 | [true false false] `(~alpha-name 158 | (alpha-fun 159 | (fn [~wme-var] 160 | (and ~@(map #(translate-obj-test % wme-var) 161 | alpha-tests))) 162 | ~luie-fun 163 | ~comps 164 | ~oset 165 | ~ocur 166 | ~empty-count-name 167 | ~main-fun)) 168 | ;; No Tests, Hashing, Debug 169 | [false true true] `(~alpha-name 170 | (debug-alpha-hash-fun-no-tests 171 | ~rname-string 172 | '~alpha-name 173 | ~lhash-fun 174 | ~luie-fun 175 | ~comps 176 | ~oset 177 | ~ocur 178 | ~empty-count-name 179 | '~rule-name 180 | ~main-fun)) 181 | ;; No Tests, Hashing, No Debug 182 | [false true false] `(~alpha-name 183 | (alpha-hash-fun-no-tests 184 | ~lhash-fun 185 | ~luie-fun 186 | ~comps 187 | ~oset 188 | ~ocur 189 | ~empty-count-name 190 | ~main-fun)) 191 | ;; No Tests, No Hashing, Debug 192 | [false false true] `(~alpha-name 193 | (debug-alpha-fun-no-tests 194 | ~rname-string 195 | '~alpha-name 196 | ~luie-fun 197 | ~comps 198 | ~oset 199 | ~ocur 200 | ~empty-count-name 201 | '~rule-name 202 | ~main-fun)) 203 | ;; No Tests, No Hashing, No Debug 204 | [false false false] `(~alpha-name 205 | (alpha-fun-no-tests 206 | ~luie-fun 207 | ~comps 208 | ~oset 209 | ~ocur 210 | ~empty-count-name 211 | ~main-fun)))) 212 | 213 | (defn make-upstream-fun-no-beta-tests [op-name uhash-exp uie-exp ocur 214 | outer-vars vars 215 | upstream-node upstream-name 216 | outer-var-sublist sub-fun wme-var] 217 | (let [down (gensym "down")] 218 | (if upstream-node 219 | `(fn ~upstream-name [~down] 220 | (debugf "Running: %s" '~upstream-name) 221 | (~upstream-node 222 | (fn ~upstream-name [~@outer-var-sublist ~@vars] 223 | (~op-name 224 | ~@(when uhash-exp 225 | (if outer-vars 226 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 227 | ~uhash-exp)] 228 | [uhash-exp])) 229 | ~@(when uie-exp 230 | (if outer-vars 231 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 232 | ~uie-exp)] 233 | [uie-exp])) 234 | (fn ~sub-fun 235 | [~@outer-var-sublist ~wme-var] 236 | (~down ~@outer-var-sublist ~@(conj vars wme-var))))))) 237 | `(fn ~upstream-name [~down] 238 | (debugf "Running: %s" '~upstream-name) 239 | (~op-name 240 | ~@(when uhash-exp 241 | (if outer-vars 242 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 243 | ~uhash-exp)] 244 | [uhash-exp])) 245 | ~@(when uie-exp 246 | (if outer-vars 247 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 248 | ~uie-exp)] 249 | [uie-exp])) 250 | (fn ~sub-fun [~@outer-var-sublist ~wme-var] 251 | (~down ~@outer-var-sublist ~@(conj vars wme-var)))))))) 252 | 253 | (defn make-upstream-fun-with-beta-tests [op-name uhash-exp uie-exp ocur 254 | outer-vars vars 255 | beta-tests upstream-node upstream-name 256 | outer-var-sublist sub-fun wme-var 257 | rname-string] 258 | (let [down (gensym "down")] 259 | (if upstream-node 260 | `(fn ~upstream-name [~down] 261 | (debugf "Running: %s" '~upstream-name) 262 | (~upstream-node 263 | (fn ~upstream-name [~@outer-var-sublist ~@vars] 264 | (~op-name 265 | ~@(when uhash-exp 266 | (if outer-vars 267 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 268 | ~uhash-exp)] 269 | [uhash-exp])) 270 | ~@(when uie-exp 271 | (if outer-vars 272 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 273 | ~uie-exp)] 274 | [uie-exp])) 275 | ;; beta tests 276 | ~(if @compile-with-debug 277 | `(fn ~sub-fun [~@outer-var-sublist ~wme-var] 278 | (let [split# (.start (SimonManager/getStopwatch "beta")) 279 | rsplit# (.start (SimonManager/getStopwatch 280 | ~(str rname-string "-beta")))] 281 | (when (and ~@(map #(translate-obj-test % wme-var) 282 | beta-tests)) 283 | (~down ~@outer-var-sublist ~@(conj vars wme-var))) 284 | (simon-stop rsplit#) 285 | (simon-stop split#))) 286 | `(fn ~sub-fun [~@outer-var-sublist ~wme-var] 287 | (when (and ~@(map #(translate-obj-test % wme-var) 288 | beta-tests)) 289 | (~down ~@outer-var-sublist ~@(conj vars wme-var))))))))) 290 | `(fn ~upstream-name [~down] 291 | (debugf "Running: %s" '~upstream-name) 292 | (~op-name 293 | ~@(when uhash-exp 294 | (if outer-vars 295 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 296 | ~uhash-exp)] 297 | [uhash-exp])) 298 | ~@(when uie-exp 299 | (if outer-vars 300 | [`(let [~@outer-var-sublist engine.runtime/*outer-vars*] 301 | ~uie-exp)] 302 | [uie-exp])) 303 | ~(if @compile-with-debug 304 | `(fn ~sub-fun [~@outer-var-sublist ~wme-var] 305 | (let [split# (.start (SimonManager/getStopwatch "beta")) 306 | rsplit# (.start (SimonManager/getStopwatch 307 | ~(str rname-string "-beta")))] 308 | (when (and ~@(map #(translate-obj-test % wme-var) 309 | beta-tests)) 310 | (~down ~@outer-var-sublist ~@(conj vars wme-var))) 311 | (simon-stop rsplit#) 312 | (simon-stop split#))) 313 | `(fn ~sub-fun [~@outer-var-sublist ~wme-var] 314 | (when (and ~@(map #(translate-obj-test % wme-var) beta-tests)) 315 | (~down ~@outer-var-sublist ~@(conj vars wme-var)))))))))) 316 | 317 | (defn- unpack [x] 318 | (let [comparison (first x)] 319 | (if (> (count x) 3) 320 | (cons (list comparison (second x) (third x)) 321 | (unpack (cons comparison (nthnext x 2)))) 322 | (list x)))) 323 | 324 | (defn is-optimizable [upstream-vars] 325 | (fn [x] (or (and (find-any upstream-vars (second x)) 326 | (not (find-any upstream-vars (third x)))) 327 | (and (find-any upstream-vars (third x)) 328 | (not (find-any upstream-vars (second x))))))) 329 | 330 | (defn optimizable-tests [x comparisons upstream-vars] 331 | (filter (is-optimizable upstream-vars) 332 | (mapcat unpack (filter #(comparisons (first %)) x)))) 333 | 334 | ;; Construct a standard object match node for a positive LHS match 335 | (defn make-obj-node [rname-string rule-name net-name outer-names empty-count-name 336 | x nodes vars outer-vars] 337 | (let [wme-var (first x) 338 | set-base (str (first x) "-") 339 | upstream-vars (set (concat vars outer-vars)) 340 | oset (gensym set-base) 341 | ocur (gensym (str set-base "cur-")) 342 | ;; any test containing no variables from previous tests is an alpha test 343 | tests (group-by #(find-any upstream-vars %) (nthnext x 2)) 344 | alpha-tests (tests false) 345 | base-beta-tests (tests true) 346 | find-tests #(optimizable-tests base-beta-tests % upstream-vars) 347 | ;; We handle any equality comparison between the current object 348 | ;; and a previous object as a hash comparison 349 | hash-tests (find-tests #{'=}) 350 | ie-tests (find-tests #{'>> '<< '>>= '<<=}) 351 | all-optimizable (concat hash-tests ie-tests) 352 | beta-tests (if (empty? all-optimizable) 353 | base-beta-tests 354 | (let [otest-set (into #{} all-optimizable)] 355 | (filter #(not (otest-set %)) base-beta-tests))) 356 | [uhash-exp lhash-fun] (if (empty? hash-tests) 357 | [nil nil] 358 | (make-hash-funs 359 | (if (= (count hash-tests) 1) 360 | (first hash-tests) 361 | (vec hash-tests)) 362 | upstream-vars wme-var)) 363 | [uie-exp luie-fun comps] (if (empty? ie-tests) 364 | [nil nil nil] 365 | (make-ie-data (vec ie-tests) upstream-vars 366 | wme-var)) 367 | ;; A negated conjunction acts as a full nested network with its 368 | ;; own main function. We need to tweak the root nodes of all outer 369 | ;; nets before and after running the negated main function so that 370 | ;; we don't move past the outer node containing the nested network 371 | ;; when traveling upstream from the main root node. Since the main 372 | ;; function of a nested network will only get invoked when 373 | ;; changes are made to the wmes referenced in the nested 374 | ;; network, there can't be any new wmes in the maps "above" 375 | ;; the current node containing the nested network in the next outer 376 | ;; network. 377 | main-fun (if (= rule-name (last outer-names)) 378 | rule-name 379 | (if (> (count (rest outer-names)) 1) 380 | `(atom (fn [] 381 | (doseq [oname1# '~(rest outer-names)] 382 | (set-nand-mode oname1# :sub)) 383 | (@~rule-name) 384 | (doseq [oname2# '~(rest outer-names)] 385 | (set-nand-mode oname2# :pass)))) 386 | `(atom (fn [] 387 | (set-nand-mode '~(first (rest outer-names)) 388 | :sub) 389 | (@~rule-name) 390 | (set-nand-mode '~(first (rest outer-names)) 391 | :pass))))) 392 | ntype (name (second x)) 393 | alpha-name (gensym (str rname-string "-alpha-" ntype "-")) 394 | alpha-rem-name (gensym (str rname-string "-alpha-rem-" ntype "-")) 395 | op-name (gensym "op-") 396 | upstream-name (gensym "upstream-") 397 | sub-fun (gensym "subfun-") 398 | upstream-node (get-upstream nodes) 399 | outer-var-sublist (if outer-vars [outer-vars] []) 400 | ;; function to add a new wme to alpha memory 401 | add-fun (make-add-fun alpha-tests lhash-fun luie-fun comps alpha-name 402 | rname-string 403 | wme-var oset ocur empty-count-name rule-name 404 | main-fun) 405 | ;; function to remove a wme from alpha memory 406 | rem-fun (if lhash-fun 407 | (if @compile-with-debug 408 | `(~alpha-rem-name 409 | (debug-alpha-hash-rem-fun ~rname-string '~alpha-name ~oset 410 | ~lhash-fun ~luie-fun 411 | ~empty-count-name)) 412 | `(~alpha-rem-name 413 | (alpha-hash-rem-fun ~oset ~lhash-fun ~luie-fun 414 | ~empty-count-name))) 415 | (if @compile-with-debug 416 | `(~alpha-rem-name 417 | (debug-alpha-rem-fun ~rname-string '~alpha-name ~oset 418 | ~luie-fun ~empty-count-name)) 419 | `(~alpha-rem-name 420 | (alpha-rem-fun ~oset ~luie-fun ~empty-count-name)))) 421 | ;; function to feed alpha values to beta tests 422 | op-fun `(~op-name 423 | ~(if uhash-exp 424 | (if uie-exp 425 | `(fn ~op-name [hash-val# uie-val# beta#] 426 | (debugf "Running: %s" '~op-name) 427 | (let [tree-map# (.get (deref ~ocur) hash-val#)] 428 | (tree-map-apply 429 | tree-map# 430 | ~comps 431 | uie-val# 432 | (fn [cur#] 433 | (beta# ~@(if outer-vars 434 | '[engine.runtime/*outer-vars*] 435 | []) 436 | cur#))))) 437 | `(fn ~op-name [hash-val# beta#] 438 | (debugf "Running: %s" '~op-name) 439 | (doseq [cur# (vals (.get (deref ~ocur) hash-val#))] 440 | (beta# ~@(if outer-vars 441 | '[engine.runtime/*outer-vars*] 442 | []) 443 | cur#)))) 444 | (if uie-exp 445 | `(fn ~op-name [uie-val# beta#] 446 | (debugf "Running: %s" '~op-name) 447 | (let [tree-map# (.get (deref ~ocur) :ie)] 448 | (tree-map-apply 449 | tree-map# 450 | ~comps 451 | uie-val# 452 | (fn [cur#] 453 | (beta# ~@(if outer-vars 454 | '[engine.runtime/*outer-vars*] 455 | []) 456 | cur#))))) 457 | `(fn ~op-name [beta#] 458 | (debugf "Running: %s" '~op-name) 459 | (doseq [cur# (vals (deref ~ocur))] 460 | (beta# ~@(if outer-vars 461 | '[engine.runtime/*outer-vars*] 462 | []) 463 | cur#)))))) 464 | ;; function called to run upstream tests before invoking downward 465 | ;; result function 466 | upstream-fun `(~upstream-name 467 | ~(cond (and (empty? vars) (empty? outer-vars)) 468 | ;; If nothing from earlier nodes, just invoke 469 | ;; the downward function 470 | op-name 471 | 472 | ;; No tests against upstream objects (except 473 | ;; hash equality) 474 | (empty? beta-tests) 475 | (make-upstream-fun-no-beta-tests 476 | op-name uhash-exp uie-exp ocur outer-vars vars 477 | upstream-node upstream-name outer-var-sublist 478 | sub-fun wme-var) 479 | 480 | ;; Full generality; w/ beta tests and hashing 481 | true 482 | (make-upstream-fun-with-beta-tests 483 | op-name uhash-exp uie-exp ocur outer-vars vars 484 | beta-tests upstream-node upstream-name 485 | outer-var-sublist sub-fun wme-var rname-string)))] 486 | [`{:type :obj-node 487 | :wme-type ~(second x) 488 | :oset (~oset (make-map)) 489 | :ocur (~ocur (atom ~oset)) 490 | :add ~add-fun 491 | :rem ~rem-fun 492 | :op ~op-fun 493 | :upstream ~upstream-fun} 494 | wme-var])) 495 | 496 | ;; 497 | ;; Cases 498 | ;; 499 | ;; Add a wme: 500 | ;; when a nand is reached on the way up, run main line, 501 | ;; for each [, , ...] at nand 502 | ;; run nand 503 | ;; [ninst] if any 504 | ;; add an entry > -> 505 | ;; add reference to for each in 506 | ;; for each 507 | ;; add to map for 508 | ;; add reference to for each 509 | ;; remove any outer insts w/ prefix from 510 | ;; else 511 | ;; call with vars from main line 512 | ;; when an instantiation is created (full rule, or nand), 513 | ;; add path for wme prefixes in trie for (sub)net 514 | ;; if created 515 | ;; if matching exists 516 | ;; add to list for 517 | ;; add reference from to 518 | ;; else 519 | ;; [ninst] 520 | 521 | ;; Remove a wme: 522 | ;; for each referenced by wme 523 | ;; [nrem] remove 524 | ;; remove -> entry 525 | ;; for each referencing 526 | ;; remove reference from to 527 | ;; remove references to from each in 528 | ;; for each referenced by wme 529 | ;; remove 530 | ;; remove subtrie for wme 531 | ;; 532 | ;; When are removed: 533 | ;; if list for at least one becomes empty 534 | ;; mark as 535 | ;; call 536 | ;; when nand is reached 537 | ;; for each with empty list 538 | ;; call with from 539 | ;; [nrem] 540 | ;; set back to 541 | ;; 542 | 543 | 544 | ;; Node utility functions 545 | 546 | (defn collect-nands [nodes idx] 547 | (cond (empty? nodes) '() 548 | 549 | (= (:type (first nodes)) :nand-node) 550 | (cons [(:main-fun-name (first nodes)) idx] 551 | (collect-nands (rest nodes) idx)) 552 | 553 | :else (collect-nands (rest nodes) (inc idx)))) 554 | 555 | (declare process-net) 556 | 557 | (defn get-node-fields [sub-net field-name] 558 | (let [nodes (:nodes sub-net)] 559 | (mapcat field-name nodes))) 560 | 561 | (defn get-all-nodes-of-type [sub-net typ] 562 | (let [nodes (:nodes sub-net)] 563 | (concat (filter (fn [node] (= (:type node) typ)) nodes) 564 | (mapcat #(get-all-nodes-of-type % typ) 565 | (map :sub-net 566 | (filter (fn [node] (= (:type node) :nand-node)) 567 | nodes)))))) 568 | 569 | (defn deep-get-all-obj-nodes [sub-net] 570 | (get-all-nodes-of-type sub-net :obj-node)) 571 | 572 | (defn get-all-obj-nodes [sub-net] 573 | (filter (fn [node] (= (:type node) :obj-node)) (:nodes sub-net))) 574 | 575 | (defn get-all-nand-nodes [sub-net] 576 | (filter (fn [node] (= (:type node) :nand-node)) (:nodes sub-net))) 577 | 578 | ;; Create a "nand" (i.e. negated conjunction node). It will act as a full 579 | ;; inner network except that its instantiations will be used to block matches in 580 | ;; outer networks 581 | (defn make-nand [rname-string rule-name outer-names node nodes 582 | outer-vars vars outer-neg-index] 583 | (let [sub-net-name (gensym "net-") 584 | upstream-name (gensym "upstream-") 585 | ;; Create the inner network 586 | sub-net (process-net rname-string 587 | rule-name 588 | (last outer-names) 589 | (conj outer-names sub-net-name) 590 | nil 591 | (gensym "empty-count-") 592 | nil 593 | (rest node) 594 | `[~@outer-vars ~@vars] 595 | outer-neg-index) 596 | sub-obj-nodes (filter (fn [node] (= (:type node) :obj-node)) 597 | (:nodes sub-net)) 598 | empty-count-name (:empty-count-name sub-net) 599 | upstream-node (get-upstream nodes) 600 | neg-fun (gensym "neg-") 601 | outer-vars-list (if outer-vars [outer-vars] []) 602 | upstream-fun 603 | ;; Four cases for nand: 604 | ;; a) Wme added to outermost network - pass request up the network 605 | ;; and for each set of wmes that come back down, run the inner 606 | ;; network and block passage if any instantiations are created 607 | ;; b) Wme removed from outermost network - remove any nand-records 608 | ;; and instantiations from the nand that contain the wme (not shown 609 | ;; as the actual work happens elsewhere) 610 | ;; c) Wme added to inner network - Run inner network and if any 611 | ;; instantiations are created, remove any positive instantiations 612 | ;; from outer networks that include the wme prefix for the nand 613 | ;; d) Wme removed from inner network - Remove any instantiations from 614 | ;; nand records in the nand containing the wme. If any instantiation 615 | ;; lists go empty, pass the matching wmes on downward. 616 | `(~upstream-name 617 | (fn ~upstream-name [down#] 618 | (debugf "%s Running: %s" ~rname-string '~upstream-name) 619 | (case (get *nand-modes* '~sub-net-name) 620 | ;; Case (a) - wme added to outermost network 621 | :pass (~upstream-node 622 | (fn ~neg-fun [~@outer-vars-list ~@vars] 623 | (debugf "Running: %s" '~neg-fun) 624 | (binding [engine.runtime/*outer-vars* 625 | [~@outer-vars ~@vars]] 626 | (@~(:main-fun-name sub-net)) 627 | (let [record# 628 | (get-sub-nand-record 629 | *nand-records* 630 | '~sub-net-name engine.runtime/*outer-vars*)] 631 | (debugf "%s: Pass -- looking up nand record: %s" 632 | ~rname-string 633 | (with-out-str (pprint/pprint record#))) 634 | (debugf "Sub-nands: %s" 635 | (.get *nand-records* 636 | '~sub-net-name)) 637 | (if record# 638 | (debugf 639 | "%s %s/%s: Blocking:\n------\n%s------%s\n\n" 640 | ~rname-string '~neg-fun '~sub-net-name 641 | (with-out-str 642 | (pprint/pprint engine.runtime/*outer-vars*)) 643 | (with-out-str (pprint/pprint record#))) 644 | (do 645 | (debugf 646 | "%s %s/%s: Passing:\n------\n%s------\n\n" 647 | ~rname-string '~neg-fun '~sub-net-name 648 | (with-out-str 649 | (pprint/pprint engine.runtime/*outer-vars*))) 650 | (put-sub-nand-record *nand-records* 651 | '~sub-net-name 652 | engine.runtime/*outer-vars* 653 | (->Nand 654 | '~sub-net-name 655 | engine.runtime/*outer-vars* 656 | (atom #{}) 657 | (atom :live))) 658 | (down# ~@outer-vars-list ~@vars))))))) 659 | ;; Case (c) - wme added to inner "sub" network 660 | :sub (let [nand-records# 661 | (.get ^HashMap 662 | *nand-records* 663 | '~sub-net-name)] 664 | (doseq [nr# (vals nand-records#)] 665 | (binding [engine.runtime/*outer-vars* (:wmes nr#)] 666 | (@~(:main-fun-name sub-net)) 667 | (let [record# 668 | (get-sub-nand-record 669 | *nand-records* 670 | '~sub-net-name engine.runtime/*outer-vars*)] 671 | (debugf "%s: Sub -- looking up nand record: %s" 672 | ~rname-string 673 | (with-out-str (pprint/pprint record#))) 674 | (debugf "Sub-nands: %s" 675 | (.get *nand-records* '~sub-net-name)) 676 | (if record# 677 | (debugf 678 | "%s %s/%s: Blocking:\n------\n%s------%s\n\n" 679 | ~rname-string '~neg-fun '~sub-net-name 680 | (with-out-str 681 | (pprint/pprint engine.runtime/*outer-vars*)) 682 | (with-out-str (pprint/pprint record#))) 683 | (do 684 | (debugf 685 | "%s %s/%s: Passing:\n------\n%s------\n\n" 686 | ~rname-string '~neg-fun '~sub-net-name 687 | (with-out-str 688 | (pprint/pprint engine.runtime/*outer-vars*))) 689 | (put-sub-nand-record *nand-records* 690 | '~sub-net-name 691 | engine.runtime/*outer-vars* 692 | (->Nand 693 | '~sub-net-name 694 | engine.runtime/*outer-vars* 695 | (atom #{}) 696 | (atom :live))) 697 | (apply down# engine.runtime/*outer-vars*))))))) 698 | ;; Case (d) - wme removed from inner "sub" network 699 | :rem (let [nand-records# *nand-records* 700 | nr# ^Nand (get-sub-nand-record 701 | nand-records# 702 | '~sub-net-name engine.runtime/*outer-vars*)] 703 | (debugf "%s Rem -- looking up nand record: %s - %s" 704 | ~rname-string (cons '~sub-net-name 705 | engine.runtime/*outer-vars*) 706 | @(:state nr#)) 707 | (let [wmes# (:wmes nr#)] 708 | (debugf "%s %s/%s: Releasing:\n------\n%s------\n\n" 709 | ~rname-string '~neg-fun '~(last outer-names) 710 | (with-out-str 711 | (pprint/pprint wmes#))) 712 | (apply down# wmes#))))))] 713 | {:type :nand-node 714 | :upstream (concat upstream-fun (get-node-fields sub-net :upstream)) 715 | :sub-empty-count-name (concat 716 | `(~empty-count-name (atom ~(count sub-obj-nodes))) 717 | (mapcat :sub-empty-count-name 718 | (get-all-nand-nodes sub-net))) 719 | :empty-count-reset (cons `(.add *empty-counts* 720 | [~empty-count-name @~empty-count-name]) 721 | (mapcat :empty-count-reset 722 | (get-all-nand-nodes sub-net))) 723 | :sub-net-names (concat `((reset! ~sub-net-name ~(:main-fun sub-net))) 724 | (mapcat :sub-net-names 725 | (get-all-nand-nodes sub-net))) 726 | :sub-net-placeholders (concat `(~sub-net-name (atom nil)) 727 | (mapcat :sub-net-placeholders 728 | (get-all-nand-nodes sub-net))) 729 | :net-funs (concat `((.put *net-funs* '~sub-net-name 730 | ~(last outer-names))) 731 | (mapcat :net-funs (get-all-nand-nodes sub-net))) 732 | :nand-modes (concat `((.put *nand-modes* '~sub-net-name :pass)) 733 | (mapcat :nand-modes (get-all-nand-nodes sub-net))) 734 | :sub-net sub-net 735 | :main-fun-name (:main-fun-name sub-net) 736 | :main-fun (:main-fun sub-net) 737 | :oset (get-node-fields sub-net :oset) 738 | :ocur (get-node-fields sub-net :ocur) 739 | :op (get-node-fields sub-net :op) 740 | :add (get-node-fields sub-net :add) 741 | :rem (get-node-fields sub-net :rem) 742 | :subnet-groups (let [groups (group-by :wme-type 743 | (deep-get-all-obj-nodes sub-net))] 744 | (reduce 745 | (fn [m k] 746 | (update m k 747 | (fn [vals] 748 | (mapv #(vector (first (:add %)) 749 | (first (:rem %)) 750 | (first (:oset %))) 751 | vals)))) 752 | groups 753 | (keys groups)))})) 754 | 755 | ;; Create a network, either outermost positive or inner negated 756 | (defn process-net [rname-str rule-name main-name outer-names priority empty-count 757 | rule-output-name rule-body outer-vars outer-neg-index] 758 | (loop [nodes [] vars [] net rule-body neg-index 0] 759 | (let [node (first net) 760 | ntype (node-type node)] 761 | (cond (nil? ntype) 762 | (if (empty? nodes) 763 | (recur nodes vars (cons '[?_s :_start] net) neg-index) 764 | (let [nands (vec (collect-nands nodes 0)) 765 | body (if priority 766 | ;; Only the outermost network has a priority 767 | `(fn ~(gensym "body-") [~@(and outer-vars [outer-vars]) 768 | ~@vars] 769 | ;; create a positive instantiation 770 | (create-instantiation 771 | ~(keyword (ns-name *ns*)) 772 | ~(keyword rule-output-name) 773 | ~priority 774 | '~(last outer-names) 775 | ~vars 776 | '~nands 777 | (fn [] 778 | ~@(if @compile-with-debug 779 | `((let [split# 780 | (simon-start "body") 781 | rsplit# 782 | (simon-start 783 | ~(str rname-str "-body"))] 784 | (firing-debug ~rule-output-name ~vars) 785 | ~@(rest net) 786 | (simon-stop rsplit#) 787 | (simon-stop split#))) 788 | (rest net))))) 789 | `(fn ~(gensym "neg-conj-body-") 790 | ;; In an inner network 791 | ;; outer vars come from surrounding networks 792 | [~@(and outer-vars [outer-vars]) ~@vars] 793 | (create-neg-instantiation 794 | ~rname-str 795 | ~outer-vars 796 | ~vars 797 | '~(last outer-names) 798 | '~main-name 799 | ~(if (> (count outer-names) 2) 800 | outer-neg-index 801 | 0))))] 802 | {:nodes nodes 803 | :vars vars 804 | :empty-count-name empty-count 805 | :main-fun `(fn [] 806 | (when (= @~empty-count 0) 807 | (debugf "Running %s" '~(last outer-names)) 808 | (~(first (:upstream (last nodes))) ~body))) 809 | :main-fun-name (last outer-names)})) 810 | 811 | ;; NAND node 812 | (or (= ntype :nand) (= ntype :not)) 813 | (if (empty? nodes) 814 | (recur nodes vars (cons '[?_s :_start] net) neg-index) 815 | (recur (conj nodes 816 | (make-nand rname-str rule-name 817 | outer-names node nodes outer-vars 818 | vars neg-index)) 819 | vars 820 | (rest net) 821 | neg-index)) 822 | 823 | ;; Object match node 824 | (= (nth (str ntype) 0) \?) 825 | (let [[onode avar] (make-obj-node rname-str 826 | rule-name 827 | (or main-name (last outer-names)) 828 | outer-names 829 | empty-count 830 | node nodes vars outer-vars)] 831 | (recur (conj nodes onode) (conj vars avar) (rest net) 832 | (inc neg-index))) 833 | 834 | true {:n nodes :v vars :net net})))) 835 | 836 | ;; Extract pieces of a rule 837 | 838 | (defn get-priority [rule] 839 | (let [ruletail (rest rule)] 840 | (cond (string? (first ruletail)) (get-priority ruletail) 841 | (map? (first ruletail)) (or (:priority (first ruletail)) 0) 842 | true 0))) 843 | 844 | (defn get-rule-body [rule] 845 | (let [ruletail (rest rule) 846 | ruletailhead (first ruletail)] 847 | (if (or (string? ruletailhead) (map? ruletailhead)) 848 | (get-rule-body ruletail) 849 | ruletail))) 850 | 851 | (defn extract-network [rule] 852 | (let [rname-str (str (nth rule 0)) 853 | rule-name (gensym (str rname-str "-")) 854 | empty-count (gensym "empty-count-") 855 | rule-output-name (str (ns-name *ns*) "/" rname-str)] 856 | (process-net rname-str rule-name nil [rule-name] 857 | (get-priority rule) 858 | empty-count 859 | rule-output-name (get-rule-body rule) nil 0))) 860 | 861 | (defn node-defs [node] 862 | (let [base-defs 863 | (concat 864 | (:oset node) 865 | (:ocur node) 866 | (:op node) 867 | (:upstream node) 868 | (:add node) 869 | (:rem node))] 870 | (if (= (:type node) :nand-node) 871 | (concat (:sub-empty-count-name node) base-defs) 872 | base-defs))) 873 | 874 | (defn collect-single-match-vars [omatch] 875 | (case (first omatch) 876 | (:nand :not) (mapcat collect-single-match-vars (rest omatch)) 877 | [((juxt first second) omatch)])) 878 | 879 | (defn collect-vars-by-type [lhs] 880 | (if (empty? lhs) 881 | '() 882 | (concat (collect-single-match-vars (first lhs)) 883 | (collect-vars-by-type (rest lhs))))) 884 | 885 | (defn get-match-exp [omatch] 886 | (case (first omatch) 887 | (:nand :not) `(and ~@(mapcat get-match-exp (rest omatch))) 888 | (let [tests (nthrest omatch 2)] 889 | (if (empty? tests) 890 | '() 891 | `((and ~@tests)))))) 892 | 893 | (defn get-lhs-exp [lhs] 894 | (let [tests (mapcat get-match-exp lhs)] 895 | (if (empty? tests) 896 | true 897 | `(and ~@tests)))) 898 | 899 | (defn build-lhs-exp [rule] 900 | (let [body (get-rule-body rule) 901 | lhs (take-while (partial not= '=>) body) 902 | vars-by-type (collect-vars-by-type lhs) 903 | lhs-exp (get-lhs-exp lhs)] 904 | {:fun `(fn [~@(map first vars-by-type)] ~lhs-exp) 905 | :var-types (map second vars-by-type)})) 906 | 907 | ;; Construct a live rule instance from a network of LHS nodes and RHS body. 908 | ;; The resulting function will get invoked at engine creation time to create 909 | ;; a set of variables and functions invokable from the engine. 910 | (defn build-rule [network] 911 | (let [all-nodes (filter (fn [node] (or (= (:type node) :obj-node) 912 | (= (:type node) :nand-node))) 913 | (:nodes network)) 914 | obj-nodes (filter (fn [node] (= (:type node) :obj-node)) 915 | (:nodes network)) 916 | nand-nodes (filter (fn [node] (= (:type node) :nand-node)) 917 | (:nodes network)) 918 | main-fun-name (:main-fun-name network) 919 | empty-count-name (:empty-count-name network)] 920 | `(fn [] 921 | (let [~main-fun-name (atom nil) 922 | ~empty-count-name (atom ~(count obj-nodes)) 923 | ~@(mapcat :sub-net-placeholders nand-nodes) 924 | ~@(mapcat node-defs all-nodes)] 925 | (.add *empty-counts* [~empty-count-name @~empty-count-name]) 926 | ~@(mapcat :empty-count-reset nand-nodes) 927 | ~@(mapcat :sub-net-names nand-nodes) 928 | ~@(mapcat :net-funs nand-nodes) 929 | ~@(mapcat :nand-modes nand-nodes) 930 | (reset! ~main-fun-name ~(:main-fun network)) 931 | ~(let [obj-groups (group-by :wme-type obj-nodes)] 932 | (apply merge-with 933 | into 934 | (reduce 935 | (fn [m k] 936 | (update m k 937 | (fn [vals] 938 | (mapv #(vector (first (:add %)) 939 | (first (:rem %)) 940 | (first (:oset %))) 941 | vals)))) 942 | obj-groups 943 | (keys obj-groups)) 944 | (map :subnet-groups nand-nodes))))))) 945 | 946 | ;; Support for defining type hierarchies. If a type is specified as 947 | ;; an "ancestor" of other types, any rule that matches the ancestor type will 948 | ;; also match the descendent types. 949 | (defn type-and-descendents [wme-type] 950 | (conj (filter (fn [wtype] (some #{wme-type} (ancestor-types wtype))) 951 | (keys @wme-type-hierarchy)) 952 | wme-type)) 953 | 954 | (defn defancestor [wme-type-seq ancestor] 955 | (doseq [wme-type (mapcat 956 | type-and-descendents 957 | (if (vector? wme-type-seq) wme-type-seq [wme-type-seq]))] 958 | (reset! wme-type-hierarchy 959 | (assoc @wme-type-hierarchy 960 | wme-type 961 | (conj 962 | (into (ancestor-types ancestor) 963 | (ancestor-types wme-type)) 964 | wme-type))))) 965 | 966 | ;; Support for rule execution contexts (not currently being used -- see 967 | ;; rule tests for example) 968 | (defmacro defcontext [{data :data before :before after :after 969 | :or {data {} 970 | before (constantly true) 971 | after (constantly true)}}] 972 | `(swap! contexts #(assoc % 973 | (keyword (ns-name *ns*)) 974 | {:data ~data :before ~before :after ~after}))) 975 | 976 | (defmacro context-value [key] 977 | `(~key (~(keyword (ns-name *ns*)) *context*))) 978 | 979 | 980 | ;; Macro providing 'defrule' syntax 981 | (defmacro defrule [& body] 982 | (let [rule (build-rule (extract-network body)) 983 | ruleset-name (keyword (ns-name *ns*)) 984 | priority (get-priority body)] 985 | (binding [*out* *err*] 986 | (println (str "Compiling " (ns-name *ns*) "/" (first body)))) 987 | (when @show-rule-bodies (pprint/pprint rule)) 988 | `(let [ruleset# (or (@rulesets ~ruleset-name) []) 989 | rule-name# (str (ns-name *ns*) "/" '~(first body))] 990 | (swap! rulesets #(assoc % ~ruleset-name (conj ruleset# ~rule))) 991 | (swap! rules-by-name #(assoc % rule-name# '~(cons 'defrule body))) 992 | (swap! rule-left-sides #(assoc % rule-name# '~(build-lhs-exp body))) 993 | @rulesets))) 994 | 995 | ;; Code to construct rule functions at engine creation time 996 | (defn alphas-by-wme-type [rule-alpha-list] 997 | (apply merge-with concat (map (fn [f] (f)) rule-alpha-list))) 998 | 999 | (defn extract-alphas [rulesets] 1000 | (reduce 1001 | (fn [result-map rule-alpha-list] 1002 | (let [rule-alpha-map (alphas-by-wme-type rule-alpha-list) 1003 | ;; {:ball1 } 1004 | funs {:alphas (update-all rule-alpha-map #(map first %)) 1005 | :alpha-rems (update-all rule-alpha-map #(map second %)) 1006 | :osets (update-all rule-alpha-map #(map third %))}] 1007 | (merge-with #(merge-with concat %1 %2) result-map funs))) 1008 | {} 1009 | rulesets)) 1010 | 1011 | ;; Main engine API below 1012 | 1013 | (defn insert! [input-wme] 1014 | (insert-wmes-impl [input-wme] *actions*)) 1015 | 1016 | (defn remove! [wme] 1017 | (.add ^ArrayDeque *actions* [:remove wme])) 1018 | 1019 | (defn collect! 1020 | ([fun] 1021 | (for [[_ wme] *wmes* :when (fun wme)] wme)) 1022 | ([wme-type fun] 1023 | (for [[_ wme] *wmes* 1024 | :when (and (some #(identical? % wme-type) (wme-types ^Wme wme)) 1025 | (fun wme))] 1026 | wme))) 1027 | 1028 | ;; Creating and running engines. A call to 'engine' with a set of 1029 | ;; keywordized module names representing sets of rules. All the rule 1030 | ;; modules will get loaded into the newly created engine. Then, the 1031 | ;; engine can be manipulated using its command set to run rules, check 1032 | ;; wme states or timing, etc. 1033 | ;; 1034 | (defn engine [& modules] 1035 | (when (< (count modules) 1) 1036 | (throw (RuntimeException. "Engine must include at least one rule module."))) 1037 | (binding [*current-id* (atom 0) 1038 | ;; we initially bind values here because they need to be referenced 1039 | ;; during rule module processing. The full engine gets created 1040 | ;; later 1041 | *net-funs* (make-map) 1042 | *nand-modes* (make-map) 1043 | *empty-counts* (make-set)] 1044 | ;; Engine data -- at runtime, data that needs to be referenced from rules, 1045 | ;; etc. is bound to dynamic variables that can be seen anywhere in the thread 1046 | (let [current-id (atom 0) 1047 | logging-set (atom #{}) 1048 | trace-set (atom nil) 1049 | echo-firings (atom false) 1050 | stop-before (atom nil) 1051 | stop-after (atom nil) 1052 | run-before (atom nil) 1053 | run-after (atom nil) 1054 | history (atom []) 1055 | record (atom nil) 1056 | ;; Rule ordering for the modules used by the engine 1057 | inst-set-fun (let [ordering 1058 | (combine-orders (mapcat (fn [mod] (mod @orderings)) 1059 | modules))] 1060 | (fn [] (make-ordered-set ordering))) 1061 | ;; Construct all rule functions 1062 | rsets (map (fn [mod] 1063 | (let [rset (@rulesets (keyword mod))] 1064 | (if (empty? rset) 1065 | (throw (RuntimeException. 1066 | (str mod " contains no rules."))) 1067 | rset))) 1068 | modules) 1069 | ;; Core data for engine runtime 1070 | rule-alpha-map (extract-alphas rsets) 1071 | alphas (:alphas rule-alpha-map) 1072 | alpha-rems (:alpha-rems rule-alpha-map) 1073 | omap (:osets rule-alpha-map) 1074 | wmes (make-map) 1075 | actions (make-queue) 1076 | instantiations (make-priority-map) 1077 | insts-by-wme-id (make-map) 1078 | rule-insts (make-map) 1079 | nand-records (make-map) 1080 | nand-records-by-wme-id (make-map) 1081 | max-identical (atom max-identical-rule-firings) 1082 | nand-modes ^HashMap *nand-modes* 1083 | net-funs ^HashMap *net-funs* 1084 | empty-counts *empty-counts* 1085 | ;; Function to configure the rule engine based on a configuration 1086 | ;; map argument 1087 | configure (fn [config-map] 1088 | (reset! record (:record config-map)) 1089 | (when (:debug config-map) 1090 | (reset! logging-set (conj @logging-set :debug))) 1091 | (reset! echo-firings (or (:log-rule-firings config-map) 1092 | (:debug config-map))) 1093 | (reset! trace-set (:trace-set config-map)) 1094 | (reset! stop-before (:stop-before config-map)) 1095 | (reset! stop-after (:stop-after config-map)) 1096 | (reset! run-before (:run-before config-map)) 1097 | (reset! run-after (:run-after config-map)) 1098 | (reset! enable-perf-mon (:enable-perf-mon config-map)) 1099 | (when-let [val (:max-repeated-firings config-map)] 1100 | (reset! max-identical val))) 1101 | ;; Init the rule engine with a start action for rules w/o LHSs 1102 | init-wmes (fn [] (insert-wmes-impl [{:type :_start}] actions)) 1103 | ;; Reset the rule engine state; done before each new "run" 1104 | clear (fn [] 1105 | (doseq [[_ v] omap] 1106 | (doseq [oset v] 1107 | (.clear ^HashMap oset))) 1108 | (.clear wmes) 1109 | (.clear actions) 1110 | (.clear instantiations) 1111 | (.clear insts-by-wme-id) 1112 | (.clear rule-insts) 1113 | (.clear nand-records) 1114 | (.clear nand-records-by-wme-id) 1115 | (reset! history []) 1116 | (doseq [[k _] nand-modes] (.put nand-modes k :pass)) 1117 | (doseq [[ecatom val] empty-counts] 1118 | (reset! ecatom val)) 1119 | (binding [*current-id* (atom 0)] 1120 | (init-wmes) 1121 | (reset! current-id @*current-id*))) 1122 | ;; Should we record output? 1123 | maybe-dump #(when-let [recording-file @record] 1124 | (swap! 1125 | history 1126 | conj 1127 | {:wmes 1128 | (group-by 1129 | :type 1130 | (mapv to-map (vals *wmes*)))}) 1131 | (if (= recording-file true) 1132 | (view @history) 1133 | (dump-recording @history @rules-by-name 1134 | @rule-left-sides 1135 | recording-file))) 1136 | ;; Main function run to process rules; used by run, run-map, run-list. 1137 | ;; If called directly, does not clear engine between calls and can 1138 | ;; be used to maintain intermediate state. 1139 | cycle-action 1140 | (fn [input-wmes] 1141 | (binding [*current-id* (atom ^long @current-id) 1142 | *logging-set* ^set @logging-set 1143 | *trace-set* ^set @trace-set 1144 | *echo-firings* @echo-firings 1145 | *stop-before* @stop-before 1146 | *stop-after* @stop-after 1147 | *run-before* @run-before 1148 | *run-after* @run-after 1149 | *alpha-rems* alpha-rems 1150 | *wmes* ^HashMap wmes 1151 | *actions* ^ArrayDeque actions 1152 | *instantiations* ^TreeMap$DescendingSubMap instantiations 1153 | *insts-by-wme-id* ^HashMap insts-by-wme-id 1154 | *rule-insts* rule-insts 1155 | *nand-modes* nand-modes 1156 | *nand-records* nand-records 1157 | *nand-records-by-wme-id* ^HashMap nand-records-by-wme-id 1158 | *net-funs* ^HashFun net-funs 1159 | *inst-set-fun* inst-set-fun 1160 | *empty-counts* ^set empty-counts 1161 | *history* history 1162 | *record* record 1163 | *context* (into {} 1164 | (map (fn [mod] 1165 | (let [kmod (keyword mod)] 1166 | [kmod (:data (@contexts kmod))])) 1167 | modules))] 1168 | (if @enable-perf-mon 1169 | (SimonManager/enable) 1170 | (SimonManager/disable)) 1171 | (cond (= @record true) (io/delete-file default-record-file true) 1172 | (not (nil? @record)) (io/delete-file @record true)) 1173 | ;; Beginning of real execution 1174 | (insert-top-level-wmes input-wmes) 1175 | (doseq [mod modules] 1176 | (when-let [before (:before (@contexts (keyword mod)))] 1177 | (before))) 1178 | (let [rule-just-run (atom nil) 1179 | loop-counter (atom 0)] 1180 | ;; Main rule loop 1181 | (loop [] 1182 | (if (and (empty? actions) (empty? instantiations)) 1183 | (do (reset! current-id @*current-id*) 1184 | (doseq [mod (reverse modules)] 1185 | (when-let [after (:after (@contexts (keyword mod)))] 1186 | (after))) 1187 | (maybe-dump) 1188 | (get-wme-state wmes)) 1189 | (let [stop (atom false)] 1190 | ;; Process any changes to wmes made during last rule 1191 | (process-pending-wme-actions alphas actions wmes) 1192 | (when-let [after-fun @run-after] 1193 | (when @rule-just-run 1194 | (after-fun @rule-just-run (vals wmes)))) 1195 | ;; Find the highest priority instantiation and execute it 1196 | (when-not (empty? instantiations) 1197 | (let [inst (get-an-instantiation instantiations) 1198 | rule (:rule inst)] 1199 | (if (= rule @rule-just-run) 1200 | (when (> (swap! loop-counter inc) 1201 | @max-identical) 1202 | (throw (RuntimeException. 1203 | (str "Rule: '" 1204 | (subs (str rule) 1) 1205 | "' is stuck in a loop.")))) 1206 | (reset! loop-counter 0)) 1207 | (reset! rule-just-run rule) 1208 | (remove-pos-instantiation inst) 1209 | (debugf "Running instantiation: %s" 1210 | [(:rule inst) (:net-name int) 1211 | (:wmes inst)]) 1212 | (reset! stop (run-instantiation inst)))) 1213 | (if @stop 1214 | (reset! current-id @*current-id*) 1215 | (recur))))))))] 1216 | (init-wmes) 1217 | (let [eng (atom nil)] 1218 | (reset! eng 1219 | ;; Actual engine API 1220 | (fn ([action arg] 1221 | (try 1222 | (case action 1223 | (:run :run-map) (let [result (cycle-action arg)] 1224 | (clear) 1225 | result) 1226 | :run-list (do (cycle-action arg) 1227 | (let [result (get-wme-list wmes)] 1228 | (clear) 1229 | result)) 1230 | :cycle (cycle-action arg) 1231 | :configure (do (configure arg) 1232 | @eng) 1233 | :timing (display-timing arg)) 1234 | (catch Exception e 1235 | (maybe-dump) 1236 | (throw e)))) 1237 | ([action] 1238 | (case action 1239 | :timing (display-timing) 1240 | :wmes (get-wme-state wmes) 1241 | :wme-list (get-wme-list wmes))))) 1242 | (reset! current-id @*current-id*) 1243 | @eng)))) 1244 | -------------------------------------------------------------------------------- /src/engine/runtime.clj: -------------------------------------------------------------------------------- 1 | (ns engine.runtime 2 | (:gen-class) 3 | (:require [clojure.pprint :as pprint] 4 | [clojure.stacktrace :as st] 5 | [clojure.set :as set] 6 | [clojure.string :as str] 7 | [clojure.walk :as walk] 8 | [flatland.ordered.set :as ordered] 9 | [clojure.java.io :as io]) 10 | (:import [org.javasimon SimonManager Stopwatch] 11 | [java.util Map HashMap TreeSet TreeMap TreeMap$Entry 12 | TreeMap$DescendingSubMap Comparator ArrayDeque] 13 | clojure.lang.PersistentVector)) 14 | 15 | (def default-record-file "/tmp/_engine_fail_output_") 16 | 17 | ;; Make sure we don't leave any performance on the table by accidentally 18 | ;; making a call using reflection 19 | (set! *warn-on-reflection* true) 20 | 21 | ;; All engine record definitions 22 | 23 | ;; Tracking information stored for a particular wme combination in 24 | ;; a negated conjunction node 25 | (defrecord Nand [^clojure.lang.Keyword net-name 26 | wmes 27 | insts 28 | ^clojure.lang.Keyword state]) 29 | 30 | ;; A rule instantiation that represents a potential rule firing 31 | (defrecord PosInst [module rule ^long priority net-name ^PersistentVector wmes 32 | nands fun ^long id]) 33 | 34 | ;; A rule instantiation from a nested negated conjunction 35 | (defrecord NegInst [rule ^PersistentVector wmes net-name ^long id ^Nand nand]) 36 | 37 | ;; The engine's data stores 38 | 39 | (def ^:dynamic *logging-set* nil) 40 | (def ^:dynamic *trace-set* nil) 41 | (def ^:dynamic *echo-firings* nil) 42 | (def ^:dynamic *stop-before* nil) 43 | (def ^:dynamic *stop-after* nil) 44 | (def ^:dynamic *run-before* nil) 45 | (def ^:dynamic *run-after* nil) 46 | (def ^:dynamic *alpha-rems* nil) 47 | (def ^:dynamic *wmes* nil) 48 | (def ^:dynamic *actions* nil) 49 | (def ^:dynamic *instantiations* nil) 50 | (def ^:dynamic *insts-by-wme-id* nil) 51 | (def ^:dynamic *rule-insts* nil) 52 | (def ^:dynamic *nand-records* nil) 53 | (def ^:dynamic *nand-records-by-wme-id* nil) 54 | (def ^:dynamic *nand-modes* nil) 55 | (def ^:dynamic *net-funs* nil) 56 | (def ^:dynamic *inst-set-fun* nil) 57 | (def ^:dynamic *empty-counts* nil) 58 | (def ^:dynamic *history* nil) 59 | (def ^:dynamic *record* nil) 60 | 61 | ;; Each wme *must* contain at least __id and type 62 | (defrecord Wme [^long __id ^clojure.lang.Keyword type]) 63 | 64 | ;; Holds the set of variables bound by object matches farther up the 65 | ;; left-hand side so that they can be plugged in during execution of a 66 | ;; nested negated conjunction 67 | (def ^:dynamic *outer-vars* nil) 68 | 69 | ;; The id of the next wme 70 | (def ^:dynamic *current-id* (atom 0)) 71 | 72 | ;; Support for running a rule execution in a "context" which provides 73 | ;; "before" and "after" functions and a map of data which is 74 | ;; accessible at runtime 75 | (def ^:dynamic *context* (atom nil)) 76 | 77 | ;; Map of rulesets so that engines can look them up when passed their 78 | ;; names as arguments 79 | (def rulesets (atom {})) 80 | 81 | ;; Set of data contexts (w/ before and after functions) associated with rulesets 82 | (def contexts (atom {})) 83 | 84 | ;; Rule definitions displayed by rule viewer 85 | (def rules-by-name (atom {})) 86 | 87 | ;; Expressions representing rule left hand sides used to evaluate expressions 88 | ;; in the viewer 89 | (def rule-left-sides (atom {})) 90 | 91 | 92 | ;; Configuration variables 93 | 94 | (declare ppwrap) 95 | 96 | (defn env-var-set [env-var] 97 | (let [env-var (System/getenv env-var)] 98 | (and (not (nil? env-var)) 99 | (not= env-var "")))) 100 | 101 | ;; Whether or not to compile in support for debugging the engine 102 | ;; (not for debugging rulesets) 103 | (def compile-with-debug (atom (env-var-set "DEBUG_COMPILE"))) 104 | 105 | ;; Whether or not to include "simon" performance monitoring code -- useful 106 | ;; to find badly performing rules 107 | (def compile-with-perf (atom (not (env-var-set "NO_PERF_COMPILE")))) 108 | 109 | ;; If true, display the clojure code generated for rules during compilation 110 | (def show-rule-bodies (atom (env-var-set "SHOW_RULES"))) 111 | 112 | ;; Whether or not to turn off ppwrap output. "ppwrap" is used to 113 | ;; display the value of any expression without interfering with normal 114 | ;; control flow. If you have a lot of ppwrap calls in your system 115 | ;; while debugging, you can turn them all off temporarily via this 116 | ;; variable. 117 | (def silent-ppwrap (atom (env-var-set "SILENT_PPWRAP"))) 118 | 119 | ;; How many times a single rule can fire consecutively before raising an 120 | ;; exception 121 | (def max-identical-rule-firings 300) 122 | 123 | ;; Pretty-print a value during debugging but also return it so that the 124 | ;; code behaves normally 125 | (defn ppwrap [tag val] (when-not @silent-ppwrap (pprint/pprint (list tag val))) 126 | val) 127 | 128 | ;; Macros used to generate engine debugging and performance output 129 | ;; when debug compilation is turned on 130 | (defmacro debugf [& args] 131 | (if @compile-with-debug 132 | `(when (*logging-set* :debug) 133 | ((fn [] (printf ~@args) (println)))) 134 | true)) 135 | 136 | (defmacro simon-start [name] 137 | (if @compile-with-perf 138 | `(.start (SimonManager/getStopwatch ~name)) 139 | true)) 140 | 141 | (defmacro simon-stop [simon] 142 | (if @compile-with-perf 143 | `(.stop ~simon) 144 | true)) 145 | 146 | ;; Generate a stack trace on demand 147 | (defn get-stack-trace [] 148 | (try (throw (RuntimeException. "STACK TRACE")) 149 | (catch Exception e (with-out-str (st/print-stack-trace e))))) 150 | 151 | ;; Look up a value in an engine configuration 152 | (defn config-contains [set-or-nil val] 153 | (and set-or-nil (set-or-nil val))) 154 | 155 | ;; Whether or not a particular rule is currently being traced (having its 156 | ;; firings displayed) 157 | (defn traced [name] (config-contains *trace-set* name)) 158 | 159 | (defn third [x] (nth x 2)) 160 | 161 | ;; Functions to create useful Java data structures 162 | (defn make-map ^HashMap [] (HashMap.)) 163 | 164 | (defn make-queue ^ArrayDeque [] (ArrayDeque.)) 165 | 166 | (defn make-set [] ^java.util.HashSet (java.util.HashSet.)) 167 | 168 | (defn make-priority-map ^TreeMap$DescendingSubMap [] (.descendingMap (TreeMap.))) 169 | 170 | (defn make-ordered-set ^TreeSet [comp] (TreeSet. ^Comparator comp)) 171 | 172 | ;; Get an id for a new working memory element 173 | (defn new-id [] (swap! *current-id* inc)) 174 | 175 | ;; Associate an id with a newly inserted wme and turn it into a Wme record 176 | (defn add-id [wme] 177 | (let [updated (assoc wme :__id (new-id))] 178 | (if (= (type wme) Wme) 179 | updated 180 | (map->Wme updated)))) 181 | 182 | (defn get-sub-nand-record [^HashMap nrmap netname path] 183 | (debugf "get-sub-nand-record: %s" [nrmap netname path]) 184 | (when-let [submap (.get nrmap netname)] 185 | (.get ^HashMap submap path))) 186 | 187 | (defn put-sub-nand-record [^HashMap nrmap netname path val] 188 | (debugf "put-sub-nand-record: %s" [nrmap netname path val]) 189 | (let [nand-map ^HashMap *nand-records-by-wme-id*] 190 | (doseq [wme path] 191 | (let [id (:__id ^Wme wme) 192 | wme-nand-map-entry (or (.get nand-map id) #{})] 193 | (.put nand-map id (conj wme-nand-map-entry val)))) 194 | (let [submap (atom (.get nrmap netname))] 195 | (when-not @submap 196 | (reset! submap (make-map)) 197 | (.put ^HashMap nrmap netname @submap)) 198 | (.put ^HashMap @submap path val)))) 199 | 200 | (defn remove-sub-nand-record [^HashMap nrmap ^Nand nr] 201 | (debugf "remove-sub-nand-record: %s and %s" nrmap (into {} nr)) 202 | (let [nand-map ^HashMap *nand-records-by-wme-id* 203 | netname (:net-name nr) 204 | wmes (:wmes nr)] 205 | (doseq [wme wmes] 206 | (.remove nand-map (:__id ^Wme wme))) 207 | (if-let [submap (.get nrmap netname)] 208 | (.remove ^HashMap submap wmes)))) 209 | 210 | (defmacro with-simon [tag & exp] 211 | (if @compile-with-perf 212 | `(let [split# (.start (SimonManager/getStopwatch ~tag)) 213 | result# (do ~@exp)] 214 | (.stop split#) 215 | result#) 216 | `(do ~@exp))) 217 | 218 | (defn get-prefix-ref [trie prefix] 219 | (get-in trie prefix)) 220 | 221 | (defn add-prefix-ref [trie prefix val] 222 | (with-simon "add-prefix-ref" (assoc-in trie (conj prefix 0) val))) 223 | 224 | (defn remove-prefix-ref [trie prefix] 225 | (with-simon "remove-prefix-ref" 226 | (if (= (count prefix) 1) 227 | (dissoc trie (first prefix)) 228 | (update-in trie (pop prefix) dissoc (last prefix))))) 229 | 230 | (def orderings (atom {})) 231 | 232 | (defn newest [inst1 inst2] 233 | (let [id1 (:id ^PosInst inst1) id2 (:id ^PosInst inst2)] 234 | (cond (> id1 id2) -1 235 | (< id1 id2) 1 236 | ;; only here because tree map compares an entry with itself when empty 237 | :else 0))) 238 | 239 | (def ^HashMap order-funs (make-map)) 240 | 241 | (.put order-funs :without 242 | (fn [[wme-type] left right] 243 | `(let [lwmes# ^PersistentVector (:wmes ^PosInst ~left) 244 | lmax# (count lwmes#) 245 | leftval# (loop [idx# 0] 246 | (cond (>= idx# lmax#) false 247 | (= (:type ^Wme 248 | (nth ^PersistentVector lwmes# idx#)) 249 | ~wme-type) true 250 | :else (recur (long (inc idx#))))) 251 | rwmes# ^PersistentVector (:wmes ^PosInst ~right) 252 | rmax# (count rwmes#) 253 | rightval# (loop [idx# 0] 254 | (cond (>= idx# rmax#) false 255 | (= (:type ^Wme 256 | (nth ^PersistentVector 257 | rwmes# idx#)) 258 | ~wme-type) true 259 | :else (recur (long (inc idx#)))))] 260 | (cond leftval# (if rightval# 0 1) 261 | rightval# -1 262 | :else 0)))) 263 | 264 | (.put order-funs :with 265 | (fn [[wme-type] left right] 266 | `(let [lwmes# ^PersistentVector (:wmes ^PosInst ~left) 267 | lmax# (count lwmes#) 268 | leftval# (loop [idx# 0] 269 | (cond (>= idx# lmax#) false 270 | (= (:type ^Wme 271 | (nth ^PersistentVector lwmes# idx#)) 272 | ~wme-type) true 273 | :else (recur (long (inc idx#))))) 274 | rwmes# ^PersistentVector (:wmes ^PosInst ~right) 275 | rmax# (count rwmes#) 276 | rightval# (loop [idx# 0] 277 | (cond (>= idx# rmax#) false 278 | (= (:type ^Wme (nth ^PersistentVector 279 | rwmes# idx#)) 280 | ~wme-type) true 281 | :else (recur (long (inc idx#)))))] 282 | (cond leftval# (if rightval# 0 -1) 283 | rightval# 1 284 | :else 0)))) 285 | 286 | (.put order-funs :newest 287 | (fn [left right] 288 | `(let [left-id# (:id ^PosInst ~left) 289 | right-id# (:id ^PosInst ~right)] 290 | (cond (> left-id# right-id#) -1 291 | (< left-id# right-id#) 1 292 | ;; only here because tree map compares an entry with 293 | ;; itself when empty 294 | :else 0)))) 295 | 296 | (.put order-funs :oldest 297 | (fn [left right] 298 | `(let [left-id# (:id ^PosInst ~left) 299 | right-id# (:id ^PosInst ~right)] 300 | (cond (> left-id# right-id#) 1 301 | (< left-id# right-id#) -1 302 | ;; only here because tree map compares an entry with 303 | ;; itself when empty 304 | :else 0)))) 305 | 306 | (.put order-funs :from-module 307 | (fn [[module] left right] 308 | `(let [left-module# (:module ^PosInst ~left) 309 | right-module# (:module ^PosInst ~right)] 310 | (if (= left-module# ~module) 311 | (if (= right-module# ~module) 0 -1) 312 | (if (= right-module# ~module) 1 0))))) 313 | 314 | (defn invalid-order-exp-error [exp] 315 | (throw (RuntimeException. (str "Invalid order expression: " exp)))) 316 | 317 | (defn compile-ordering-fun [exp left right] 318 | (cond (list? exp) (let [ofun (.get order-funs (first exp))] 319 | (if ofun 320 | (ofun (rest exp) left right) 321 | (invalid-order-exp-error exp))) 322 | (keyword? exp) (let [ofun (.get order-funs exp)] 323 | (if ofun 324 | (ofun left right) 325 | (invalid-order-exp-error exp))) 326 | :else (invalid-order-exp-error exp))) 327 | 328 | (defn combine-orders-aux [funs] 329 | (if (empty? funs) 330 | newest 331 | (let [first-fun (first funs) 332 | tail (combine-orders-aux (rest funs))] 333 | (fn ^long [left right] 334 | (let [result (long (first-fun left right))] 335 | (case result 336 | (-1 1) result 337 | 0 (tail left right))))))) 338 | 339 | (defn combine-orders [funs] 340 | (let [f (combine-orders-aux funs)] 341 | (if @compile-with-perf 342 | (fn [left right] 343 | (with-simon "instantiation-ordering" (f left right))) 344 | f))) 345 | 346 | (defn compile-ordering [funs left right] 347 | (cond (empty? funs) nil 348 | ;; so we know to just use the default ordering function directly 349 | (= (count funs) 1) (compile-ordering-fun (first funs) left right) 350 | :else (let [res (gensym "result")] 351 | `(let [~res (long 352 | ~(compile-ordering-fun (first funs) left right))] 353 | (case ~res 354 | (-1 1) ~res 355 | 0 ~(compile-ordering (rest funs) left right) 356 | (throw 357 | (RuntimeException. 358 | (str "Order function must return -1, 0, or 1 -- got: " 359 | ~res)))))))) 360 | 361 | (def wme-type-hierarchy (atom {})) 362 | 363 | (defn ancestor-types ^PersistentVector [wme-type] 364 | (or (get ^map @wme-type-hierarchy wme-type) 365 | (let [types (ordered/ordered-set wme-type :wme)] 366 | (swap! wme-type-hierarchy #(assoc % wme-type types)) 367 | types))) 368 | 369 | (defmacro wme-types [wme] 370 | `(ancestor-types (:type ^Wme ~wme))) 371 | 372 | (defn dump-recording [history rules left-sides filename] 373 | (with-open [rec-file (io/writer filename)] 374 | (binding [*out* rec-file] 375 | (printf "%s\n" [history rules left-sides]) 376 | (flush)))) 377 | 378 | (defn to-map [rec] (into {} rec)) 379 | 380 | (defn get-instantiations [] 381 | (mapcat 382 | #(into [] (set/project % [:id :rule :priority :wmes])) 383 | (mapv #(mapv (fn [inst] (update inst :wmes (fn [wmes] (mapv to-map wmes)))) %) 384 | (into [] (.values ^TreeMap$DescendingSubMap *instantiations*))))) 385 | 386 | (defn add-step [state-vector inst] 387 | (let [config @*record* 388 | filename (if (= config true) 389 | default-record-file 390 | config)] 391 | (loop [idx (dec (count state-vector)) num-matches 0] 392 | (cond (and (> num-matches 100) 393 | (not (.exists (io/as-file filename)))) 394 | (dump-recording state-vector @rules-by-name @rule-left-sides 395 | filename) 396 | 397 | (and (>= idx 0) 398 | (= (:rule inst) (:rule (get state-vector idx)))) 399 | (recur (dec idx) (inc num-matches)))) 400 | (conj state-vector 401 | {:instantiations 402 | (concat [(update (select-keys inst [:id :rule :priority :wmes]) 403 | :wmes 404 | #(mapv to-map %))] 405 | (get-instantiations)) 406 | :wmes (let [w (group-by :type (mapv to-map (.values ^HashMap *wmes*)))] 407 | (when (some (fn [[_ wmes]] (some #(instance? Wme %) wmes)) w) 408 | (println (get-stack-trace))) 409 | w) 410 | :rule (:rule inst)}))) 411 | 412 | ;; Special versions of inequality operators for inequalities across 413 | ;; large numbers of wmes 414 | (def >> >) 415 | (def >>= >=) 416 | (def << <) 417 | (def <<= <=) 418 | 419 | (defn tcomp-for [comp] 420 | (condp = comp 421 | >> > 422 | >>= > 423 | << < 424 | <<= < 425 | comp)) 426 | 427 | (defn is-inclusive? [comp] 428 | (or (= comp >>=) (= comp <<=))) 429 | 430 | (defn tree-map-apply [tmap comps keys op] 431 | (when tmap 432 | (let [[key & rest-keys] keys 433 | [comp & rest-comps] comps 434 | it (.iterator 435 | (.values 436 | (.headMap ^TreeMap tmap key (is-inclusive? comp))))] 437 | (if rest-keys 438 | (loop [] 439 | (when (.hasNext it) 440 | (tree-map-apply (.next it) rest-comps rest-keys op) 441 | (recur))) 442 | (loop [] 443 | (when (.hasNext it) 444 | (doseq [[_ val] (.next it)] (op val)) 445 | (recur))))))) 446 | 447 | (defn tree-map-get [tmap comps keys] 448 | (let [results (atom [])] 449 | (tree-map-apply tmap comps keys #(swap! results conj %)) 450 | @results)) 451 | 452 | (defn tree-map-insert [^TreeMap tmap comps keys val] 453 | (let [[key & rest-keys] keys] 454 | (if tmap 455 | (let [existing (.get tmap key)] 456 | (if existing 457 | (if (seq rest-keys) 458 | (tree-map-insert existing (rest comps) rest-keys val) 459 | (.put ^HashMap existing (:__id val) val)) 460 | (if (seq rest-keys) 461 | (.put tmap key (tree-map-insert nil (rest comps) rest-keys val)) 462 | (let [new-map (make-map)] 463 | (.put tmap key new-map) 464 | (.put new-map (:__id val) val)))) 465 | tmap) 466 | (let [newmap (TreeMap. ^Comparator (tcomp-for (first comps)))] 467 | (if (seq rest-keys) 468 | (.put newmap key (tree-map-insert nil (rest comps) rest-keys val)) 469 | (let [sub-map (make-map)] 470 | (.put newmap key sub-map) 471 | (.put sub-map (:__id val) val))) 472 | newmap)))) 473 | 474 | (defn tree-map-remove [^TreeMap tmap keys id] 475 | (let [[key & rest-keys] keys] 476 | (when tmap 477 | (let [existing (.get tmap key)] 478 | (when existing 479 | (if (seq rest-keys) 480 | (tree-map-remove existing rest-keys id) 481 | (.remove ^HashMap existing id)) 482 | (when (.isEmpty ^Map existing) 483 | (.remove tmap key))))))) 484 | 485 | (defn alpha-hash-fun-no-tests [hash-fun ie-fun comps ^HashMap main-hmap 486 | current-hmap empty-count net-fun] 487 | (fn [^Wme wme-var] 488 | (let [hash-val (hash-fun wme-var)] 489 | (when (.isEmpty main-hmap) 490 | (reset! empty-count (dec @empty-count))) 491 | (let [ie-val (and ie-fun (ie-fun wme-var))] 492 | (let [existing (or (.get main-hmap hash-val) 493 | (and (not ie-fun) 494 | (let [m (make-map)] 495 | (.put main-hmap hash-val m) 496 | m)))] 497 | (if ie-fun 498 | (.put main-hmap hash-val 499 | (tree-map-insert existing comps ie-val wme-var)) 500 | (.put ^HashMap existing (:__id wme-var) wme-var))) 501 | (if ie-fun 502 | (reset! current-hmap 503 | {hash-val (tree-map-insert nil comps ie-val wme-var)}) 504 | (reset! current-hmap {hash-val {(:__id wme-var) wme-var}})) 505 | (@net-fun) 506 | (reset! current-hmap main-hmap))))) 507 | 508 | (defn debug-alpha-hash-fun-no-tests [rname-string alpha-name hash-fun ie-fun comps 509 | ^HashMap main-hmap current-hmap 510 | empty-count net-name net-fun] 511 | (fn [^Wme wme-var] 512 | (let [split (simon-start "rules") 513 | asplit (simon-start "alpha") 514 | rulesplit (simon-start rname-string) 515 | hash-val (hash-fun wme-var)] 516 | (when (.isEmpty main-hmap) 517 | (reset! empty-count (dec @empty-count))) 518 | (debugf "Adding:\n------\n%s------\n\nto:\n------\n%s\n------\n" 519 | (with-out-str 520 | (pprint/pprint wme-var)) 521 | (name alpha-name)) 522 | (let [ie-val (and ie-fun (ie-fun wme-var))] 523 | (let [existing (or (.get main-hmap hash-val) 524 | (and (not ie-fun) 525 | (let [m (make-map)] 526 | (.put main-hmap hash-val m) 527 | m)))] 528 | (if ie-fun 529 | (.put main-hmap hash-val 530 | (tree-map-insert existing comps ie-val wme-var)) 531 | (.put ^HashMap existing (:__id wme-var) wme-var))) 532 | (debugf "Empty count: %s" @empty-count) 533 | (if ie-fun 534 | (reset! current-hmap 535 | {hash-val (tree-map-insert nil comps ie-val wme-var)}) 536 | (reset! current-hmap {hash-val {(:__id wme-var) wme-var}})) 537 | (debugf "About to invoke main fun: %s" net-name) 538 | (simon-stop asplit) 539 | (@net-fun) 540 | (debugf "Finished invoking main fun %s" net-name) 541 | (reset! current-hmap main-hmap) 542 | (simon-stop rulesplit) 543 | (simon-stop split))))) 544 | 545 | (defn alpha-fun-no-tests [ie-fun comps ^HashMap main-hmap current-map empty-count 546 | net-fun] 547 | (fn [^Wme wme-var] 548 | (when (.isEmpty main-hmap) (reset! empty-count (dec @empty-count))) 549 | (if ie-fun 550 | (let [ie-val (ie-fun wme-var)] 551 | (.put main-hmap 552 | :ie 553 | (tree-map-insert (.get main-hmap :ie) comps ie-val wme-var)) 554 | (reset! current-map {:ie (tree-map-insert nil comps ie-val wme-var)})) 555 | (do (.put main-hmap (:__id wme-var) wme-var) 556 | (reset! current-map {(:__id wme-var) wme-var}))) 557 | (@net-fun) 558 | (reset! current-map main-hmap))) 559 | 560 | (defn debug-alpha-fun-no-tests [rname-string alpha-name ie-fun comps 561 | ^HashMap main-hmap 562 | current-map empty-count net-name net-fun] 563 | (fn [^Wme wme-var] 564 | (let [split (simon-start "rules") 565 | asplit (simon-start "alpha") 566 | rulesplit (simon-start rname-string)] 567 | (when (.isEmpty main-hmap) 568 | (reset! empty-count (dec @empty-count))) 569 | (debugf "Adding:\n------\n%s------\n\nto:\n------\n%s\n------\n" 570 | (with-out-str 571 | (pprint/pprint wme-var)) 572 | (name alpha-name)) 573 | (if ie-fun 574 | (let [ie-val (ie-fun wme-var)] 575 | (.put main-hmap 576 | :ie 577 | (tree-map-insert (.get main-hmap :ie) comps ie-val wme-var)) 578 | (reset! current-map {:ie (tree-map-insert nil comps ie-val wme-var)})) 579 | (do (.put main-hmap (:__id wme-var) wme-var) 580 | (reset! current-map {(:__id wme-var) wme-var}))) 581 | (debugf "Empty count: %s" @empty-count) 582 | (debugf "About to invoke main fun: %s" net-name) 583 | (simon-stop asplit) 584 | (@net-fun) 585 | (debugf "Finished invoking main fun %s" net-name) 586 | (reset! current-map main-hmap) 587 | (simon-stop rulesplit) 588 | (simon-stop split)))) 589 | 590 | (defn alpha-hash-fun [test-fun hash-fun ie-fun comps ^HashMap main-hmap 591 | current-hmap empty-count net-fun] 592 | (fn [^Wme wme-var] 593 | (let [hash-val (hash-fun wme-var)] 594 | (when (test-fun wme-var) 595 | (when (.isEmpty main-hmap) 596 | (reset! empty-count (dec @empty-count))) 597 | (let [ie-val (and ie-fun (ie-fun wme-var))] 598 | (let [existing (or (.get main-hmap hash-val) 599 | (and (not ie-fun) 600 | (let [m (make-map)] 601 | (.put main-hmap hash-val m) 602 | m)))] 603 | (if ie-fun 604 | (.put main-hmap hash-val 605 | (tree-map-insert existing comps ie-val wme-var)) 606 | (.put ^HashMap existing (:__id wme-var) wme-var))) 607 | (if ie-fun 608 | (reset! current-hmap 609 | {hash-val (tree-map-insert nil comps ie-val wme-var)}) 610 | (reset! current-hmap {hash-val {(:__id wme-var) wme-var}})) 611 | (@net-fun) 612 | (reset! current-hmap main-hmap)))))) 613 | 614 | (defn debug-alpha-hash-fun [rname-string alpha-name test-fun hash-fun ie-fun comps 615 | ^HashMap main-hmap current-hmap empty-count net-name 616 | net-fun] 617 | (fn [^Wme wme-var] 618 | (let [split (simon-start "rules") 619 | asplit (simon-start "alpha") 620 | rulesplit (simon-start rname-string) 621 | hash-val (hash-fun wme-var)] 622 | (when (test-fun wme-var) 623 | (when (.isEmpty main-hmap) 624 | (reset! empty-count (dec @empty-count))) 625 | (debugf "Adding:\n------\n%s------\n\nto:\n------\n%s\n------\n" 626 | (with-out-str 627 | (pprint/pprint wme-var)) 628 | (name alpha-name)) 629 | (let [ie-val (and ie-fun (ie-fun wme-var))] 630 | (let [existing (or (.get main-hmap hash-val) 631 | (and (not ie-fun) 632 | (let [m (make-map)] 633 | (.put main-hmap hash-val m) 634 | m)))] 635 | (if ie-fun 636 | (.put main-hmap hash-val 637 | (tree-map-insert existing comps ie-val wme-var)) 638 | (.put ^HashMap existing (:__id wme-var) wme-var))) 639 | (debugf "Empty count: %s" @empty-count) 640 | (if ie-fun 641 | (reset! current-hmap 642 | {hash-val (tree-map-insert nil comps ie-val wme-var)}) 643 | (reset! current-hmap {hash-val {(:__id wme-var) wme-var}})) 644 | (debugf "About to invoke main fun: %s" net-name) 645 | (simon-stop asplit) 646 | (@net-fun) 647 | (debugf "Finished invoking main fun %s" net-name) 648 | (reset! current-hmap main-hmap)) 649 | (simon-stop rulesplit) 650 | (simon-stop split))))) 651 | 652 | (defn alpha-fun [test-fun ie-fun comps ^HashMap main-hmap current-map empty-count 653 | net-fun] 654 | (fn [^Wme wme-var] 655 | (when (test-fun wme-var) 656 | (when (.isEmpty main-hmap) (reset! empty-count (dec @empty-count))) 657 | (if ie-fun 658 | (let [ie-val (ie-fun wme-var)] 659 | (.put main-hmap 660 | :ie 661 | (tree-map-insert (.get main-hmap :ie) comps ie-val wme-var)) 662 | (reset! current-map {:ie (tree-map-insert nil comps ie-val wme-var)})) 663 | (do (.put main-hmap (:__id wme-var) wme-var) 664 | (reset! current-map {(:__id wme-var) wme-var}))) 665 | (@net-fun) 666 | (reset! current-map main-hmap)))) 667 | 668 | (defn debug-alpha-fun [rname-string alpha-name test-fun ie-fun comps 669 | ^HashMap main-hmap 670 | current-map empty-count net-name net-fun] 671 | (fn [^Wme wme-var] 672 | (let [split (simon-start "rules") 673 | asplit (simon-start "alpha") 674 | rulesplit (simon-start rname-string)] 675 | (when (test-fun wme-var) 676 | (when (.isEmpty main-hmap) 677 | (reset! empty-count (dec @empty-count))) 678 | (debugf "Adding:\n------\n%s------\n\nto:\n------\n%s\n------\n" 679 | (with-out-str 680 | (pprint/pprint wme-var)) 681 | (name alpha-name)) 682 | (if ie-fun 683 | (let [ie-val (ie-fun wme-var)] 684 | (.put main-hmap 685 | :ie 686 | (tree-map-insert (.get main-hmap :ie) comps ie-val wme-var)) 687 | (reset! current-map {:ie (tree-map-insert nil comps ie-val wme-var)})) 688 | (do (.put main-hmap (:__id wme-var) wme-var) 689 | (reset! current-map {(:__id wme-var) wme-var}))) 690 | (debugf "Empty count: %s" @empty-count) 691 | (debugf "About to invoke main fun: %s" net-name) 692 | (simon-stop asplit) 693 | (@net-fun) 694 | (debugf "Finished invoking main fun %s" net-name) 695 | (reset! current-map main-hmap)) 696 | (simon-stop rulesplit) 697 | (simon-stop split)))) 698 | 699 | (defn alpha-hash-rem-fun [^HashMap main-hmap hash-fun ie-fun empty-count] 700 | (fn [^Wme wme-var] 701 | (let [hash-val (hash-fun wme-var) 702 | existing (.get main-hmap hash-val) 703 | removed (and existing 704 | (if ie-fun 705 | (tree-map-remove existing (ie-fun wme-var) 706 | (:__id wme-var)) 707 | (.remove ^HashMap existing (:__id wme-var))))] 708 | (when (empty? existing) 709 | (.remove main-hmap hash-val)) 710 | (when (and removed (.isEmpty main-hmap)) 711 | (reset! empty-count (inc @empty-count)))))) 712 | 713 | (defn debug-alpha-hash-rem-fun [rname-string alpha-name ^HashMap main-hmap 714 | hash-fun ie-fun empty-count] 715 | (fn [^Wme wme-var] 716 | (let [split (simon-start "rules") 717 | asplit (simon-start "alpha") 718 | rulesplit (simon-start rname-string)] 719 | (debugf "%s: Removing:\n------\n%s\n------\n\nfrom:\n------\n%s\n------\n" 720 | rname-string 721 | [(:type wme-var) (:__id wme-var)] 722 | (name alpha-name)) 723 | (let [hash-val (hash-fun wme-var) 724 | existing (.get main-hmap hash-val) 725 | removed (and existing 726 | (if ie-fun 727 | (tree-map-remove existing (ie-fun wme-var) 728 | (:__id wme-var)) 729 | (.remove ^HashMap existing (:__id wme-var))))] 730 | (when (empty? existing) 731 | (.remove main-hmap hash-val)) 732 | (when (and removed 733 | (.isEmpty main-hmap)) 734 | (reset! empty-count (inc @empty-count)))) 735 | (debugf "Removed leaving: %s\n" (vec (keys main-hmap))) 736 | (simon-stop asplit) 737 | (simon-stop rulesplit) 738 | (simon-stop split)))) 739 | 740 | (defn alpha-rem-fun [^HashMap main-hmap ie-fun empty-count] 741 | (fn [^Wme wme-var] 742 | (when (and (if ie-fun 743 | (let [submap (.get main-hmap :ie) 744 | removed (tree-map-remove submap (ie-fun wme-var) 745 | (:__id wme-var))] 746 | (when (and submap (.isEmpty ^TreeMap submap)) 747 | (.remove main-hmap :ie)) 748 | removed) 749 | (.remove main-hmap (:__id wme-var))) 750 | (.isEmpty main-hmap)) 751 | (reset! empty-count (inc @empty-count))))) 752 | 753 | (defn debug-alpha-rem-fun [rname-string alpha-name ^HashMap main-hmap ie-fun 754 | empty-count] 755 | (fn [^Wme wme-var] 756 | (let [split (simon-start "rules") 757 | asplit (simon-start "alpha") 758 | rulesplit (simon-start rname-string)] 759 | (debugf "%s: Removing:\n------\n%s\n------\n\nfrom:\n------\n%s\n------\n" 760 | rname-string 761 | [(get wme-var :type) (get wme-var :__id)] 762 | (name alpha-name)) 763 | (when (and (if ie-fun 764 | (let [submap (.get main-hmap :ie) 765 | removed (tree-map-remove submap (ie-fun wme-var) 766 | (:__id wme-var))] 767 | (when (and submap (.isEmpty ^TreeMap submap)) 768 | (.remove main-hmap :ie)) 769 | removed) 770 | (.remove main-hmap (:__id wme-var))) 771 | (.isEmpty main-hmap)) 772 | (reset! empty-count (inc @empty-count))) 773 | (debugf "Removed leaving: %s\n" (vec (keys main-hmap))) 774 | (simon-stop asplit) 775 | (simon-stop rulesplit) 776 | (simon-stop split)))) 777 | 778 | (defn outer-net-fun [nand-name] 779 | (.get ^HashMap *net-funs* nand-name)) 780 | 781 | (defn set-nand-mode [sub-net-name mode] 782 | (.put ^HashMap *nand-modes* sub-net-name mode)) 783 | 784 | (defn remove-nand-record [nr] 785 | (debugf "Removing nand record: %s" (to-map nr)) 786 | (doseq [inst @(:insts nr)] (reset! (:nand inst) nil)) 787 | (remove-sub-nand-record ^HashMap *nand-records* nr)) 788 | 789 | (defn remove-neg-instantiation [^NegInst inst] 790 | (debugf "Removing neg instantiation: %s" (to-map inst)) 791 | (let [split (simon-start "remove-neg-instantiation")] 792 | (let [inst-map ^HashMap *insts-by-wme-id* 793 | sub-net-name (:net-name inst)] 794 | (doseq [wme (:wmes inst)] 795 | (let [id (:__id ^Wme wme) 796 | new-wme-inst-map-entry (dissoc (.get inst-map id) (:id inst))] 797 | (if (empty? new-wme-inst-map-entry) 798 | (.remove inst-map id) 799 | (.put inst-map id new-wme-inst-map-entry)))) 800 | (when-let [nand-record ^Nand @(:nand inst)] 801 | (reset! (:nand inst) nil) 802 | (when-not (identical? @(:state nand-record) :dead) 803 | (let [insts (:insts nand-record)] 804 | (reset! insts (disj @insts inst)) 805 | (when (empty? @insts) 806 | (set-nand-mode sub-net-name :rem) 807 | (binding [*outer-vars* (:wmes nand-record)] 808 | (@(outer-net-fun sub-net-name))) 809 | (set-nand-mode sub-net-name :pass)))))) 810 | (simon-stop split))) 811 | 812 | (defn add-instantiation [^PosInst inst] 813 | (let [inst-map ^HashMap *insts-by-wme-id* 814 | instantiations ^TreeMap$DescendingSubMap *instantiations* 815 | priority (:priority inst) 816 | net-name (:net-name inst) 817 | wmes (:wmes inst) 818 | rule-insts ^HashMap *rule-insts* 819 | entry (.get ^TreeMap$DescendingSubMap instantiations priority)] 820 | (doseq [wme wmes] 821 | (let [id (:__id ^Wme wme) 822 | wme-inst-map-entry (or (.get inst-map id) {})] 823 | (.put inst-map id (assoc wme-inst-map-entry (:id inst) inst)))) 824 | ;; Add to insts for network 825 | (when-not (empty? (:nands inst)) 826 | (let [imap (.get rule-insts net-name) 827 | existing (or (get (get-prefix-ref imap (:wmes inst)) 0) [])] 828 | (.put rule-insts net-name 829 | (add-prefix-ref imap (:wmes inst) (conj existing inst))))) 830 | (if entry 831 | (.add ^TreeSet entry inst) 832 | (let [new-set (*inst-set-fun*)] 833 | (.add ^TreeSet new-set inst) 834 | (.put instantiations priority new-set))))) 835 | 836 | (defn remove-pos-instantiation [^PosInst inst] 837 | (let [split (simon-start "remove-pos-instantiation") 838 | inst-map ^HashMap *insts-by-wme-id* 839 | instantiations ^TreeMap$DescendingSubMap *instantiations* 840 | rule-insts ^HashMap *rule-insts* 841 | priority (:priority inst) 842 | net-name (:net-name inst) 843 | wmes (:wmes inst) 844 | entry ^TreeSet (.get instantiations priority)] 845 | (debugf "Removing instantiation: %s" [(:rule inst) net-name wmes]) 846 | (with-simon "remove-instantiation-wme-loop" 847 | (doseq [wme wmes] 848 | (let [id (:__id ^Wme wme) 849 | new-wme-inst-map-entry (dissoc (.get inst-map id) 850 | (:id inst))] 851 | (if (empty? new-wme-inst-map-entry) 852 | (.remove inst-map id) 853 | (.put inst-map id new-wme-inst-map-entry))))) 854 | (with-simon "remove-instantiation-put-rule-insts" 855 | (when-not (empty? (:nands inst)) 856 | (.put rule-insts net-name 857 | (remove-prefix-ref (.get rule-insts net-name) (:wmes inst))))) 858 | (with-simon "remove-instantiation-inst-remove" 859 | (when (and entry (.remove entry inst) (.isEmpty entry)) 860 | (.remove instantiations priority))) 861 | (simon-stop split))) 862 | 863 | (defn remove-instantiation [inst] 864 | (if (instance? NegInst inst) 865 | (remove-neg-instantiation inst) 866 | (remove-pos-instantiation inst))) 867 | 868 | (defn remove-sub-insts [insts] 869 | (cond (instance? PosInst insts) 870 | (remove-pos-instantiation insts) 871 | 872 | (instance? NegInst insts) 873 | (remove-neg-instantiation insts) 874 | 875 | (map? insts) 876 | (doseq [val (vals insts)] (remove-sub-insts val)) 877 | 878 | :else 879 | (doseq [i insts] (remove-sub-insts i)))) 880 | 881 | (defn outer-rem-fun [net-name wmes] 882 | (debugf "Calling outer-rem-fun: %s/%s" net-name (vec wmes)) 883 | (with-simon "outer-rem-fun" 884 | (let [insts (get-prefix-ref (.get ^HashMap *rule-insts* net-name) 885 | wmes)] 886 | (when insts 887 | (with-simon "remove-sub-insts" 888 | (remove-sub-insts insts))))) 889 | (with-simon "outer-nested-rem-fun" 890 | (when-let [insts-atom 891 | (:insts (get-sub-nand-record *nand-records* 892 | net-name 893 | wmes))] 894 | (debugf "Calling outer-rem-fun for neg insts: %s/%s -- %s" net-name wmes 895 | @insts-atom) 896 | (let [insts @insts-atom] 897 | (when insts 898 | (with-simon "remove-nested-sub-insts" 899 | (remove-sub-insts insts))))))) 900 | 901 | (defn create-neg-instantiation [rname-string outer-wmes inner-wmes net-name 902 | outer-name neg-index] 903 | (let [split (simon-start "create-neg-instantiation")] 904 | (debugf "Creating negative instantiation for: %s - %s" 905 | [net-name outer-name outer-wmes] 906 | [rname-string net-name outer-wmes inner-wmes]) 907 | (let [nand-records ^HashMap *nand-records* 908 | inst-map ^HashMap *insts-by-wme-id* 909 | existing-record ^Nand (get-sub-nand-record 910 | nand-records net-name outer-wmes) 911 | existing-insts (and existing-record @(:insts existing-record)) 912 | inst ^NegInst (->NegInst rname-string inner-wmes net-name (new-id) 913 | (atom nil)) 914 | new-record ^Nand (or existing-record 915 | (->Nand net-name outer-wmes (atom #{inst}) 916 | (atom :live)))] 917 | ;; add to inst map for each contained wme 918 | (doseq [wme inner-wmes] 919 | (let [id (:__id ^Wme wme) 920 | wme-inst-map-entry (or (.get inst-map id) {})] 921 | (.put inst-map id (assoc wme-inst-map-entry (:id inst) inst)))) 922 | (if existing-record 923 | (let [insts (:insts existing-record)] 924 | (reset! insts (conj existing-insts inst))) 925 | (do (debugf "Inserting nand-record: %s/%s" (conj outer-wmes net-name) 926 | new-record) 927 | (put-sub-nand-record nand-records net-name outer-wmes new-record))) 928 | (reset! (:nand inst) new-record) 929 | (when-not (and existing-record 930 | (or (not (empty? existing-insts)) 931 | (identical? @(:state existing-record) :dead))) 932 | (debugf "Calling outer-rem-fun for: %s" 933 | (with-out-str (pprint/pprint existing-record))) 934 | ;; New blocking instantiation -- remove matching mainline instantiations 935 | ;; and nand records for downstream nands 936 | (outer-rem-fun outer-name (subvec outer-wmes 937 | 0 938 | (- (count outer-wmes) neg-index))))) 939 | (simon-stop split))) 940 | 941 | (defn make-inst [module rule priority net-name wmes nands fun] 942 | (->PosInst module rule priority net-name wmes nands fun (new-id))) 943 | 944 | (defn create-instantiation [module rule priority net-name wmes nands fun] 945 | (let [split (simon-start "create-instantiation")] 946 | (debugf "Creating instantiation: %s" [rule net-name nands wmes]) 947 | (let [inst (make-inst module rule priority net-name wmes nands fun)] 948 | (add-instantiation inst)) 949 | (simon-stop split))) 950 | 951 | (defn get-wme-state [^HashMap wmes] 952 | (dissoc (group-by :type (map #(dissoc ^Wme % :__id) (.values wmes))) :_start)) 953 | 954 | (defn get-wme-list [^HashMap wmes] 955 | (vec (filter #(not= (:type ^Wme %) :_start) 956 | (map #(dissoc ^Wme % :__id) (.values wmes))))) 957 | 958 | (defmacro firing-debug [rule-output-name vars] 959 | `(do 960 | (when *echo-firings* 961 | (println (str "Firing: " ~rule-output-name))) 962 | ~@(when @compile-with-debug 963 | `((when (traced ~rule-output-name) 964 | (pprint/pprint [~rule-output-name ~vars])))))) 965 | 966 | (defn remove-wme-from-alphas-and-insts [^Wme wme] 967 | (let [id (:__id wme) 968 | insts ^map (.get ^HashMap *insts-by-wme-id* id) 969 | nand-records (.get ^HashMap *nand-records-by-wme-id* id) 970 | types ^PersistentVector (wme-types wme)] 971 | (doseq [wme-type types] 972 | (doseq [alpha-rem (wme-type *alpha-rems*)] 973 | (alpha-rem wme))) 974 | (doseq [nr nand-records] 975 | (remove-nand-record nr)) 976 | (doseq [inst (vals insts)] 977 | (remove-instantiation inst)))) 978 | 979 | (defn process-pending-wme-actions [alphas ^ArrayDeque actions ^HashMap wme-map] 980 | (loop [] 981 | (when-not (.isEmpty actions) 982 | (let [[action ^Wme wme] (.remove actions) 983 | types (wme-types wme) 984 | id (:__id wme)] 985 | (try 986 | (case action 987 | :add (do (.put wme-map id wme) 988 | (doseq [wme-type types] 989 | (doseq [addfun (wme-type alphas)] (addfun wme)))) 990 | :remove (do 991 | (remove-wme-from-alphas-and-insts wme) 992 | (.remove wme-map id))) 993 | (catch Exception e 994 | (binding [*out* *err*] 995 | (println (str "Error processing wme: " (to-map wme))) 996 | (.printStackTrace e)) 997 | (throw e)))) 998 | (recur)))) 999 | 1000 | (defn run-instantiation [^PosInst inst] 1001 | (let [rule (:rule inst)] 1002 | (when @*record* 1003 | (swap! *history* #(add-step % inst))) 1004 | (if (config-contains *stop-before* rule) 1005 | true 1006 | (let [nands (:nands inst)] 1007 | (when-let [before-fun *run-before*] 1008 | (before-fun (.values ^HashMap *wmes*))) 1009 | (when-not (empty? nands) 1010 | (let [nand-records *nand-records*] 1011 | (doseq [nand nands] 1012 | (when-let [nr ^Nand (get-sub-nand-record 1013 | nand-records (first nand) 1014 | (subvec (:wmes inst) 0 (second nand)))] 1015 | (debugf "Marking: %s dead" 1016 | (with-out-str (pprint/pprint nr))) 1017 | (reset! (:state nr) :dead))))) 1018 | ((:fun inst)) 1019 | (config-contains *stop-after* rule))))) 1020 | 1021 | ;; Retrieve the next instantiation in priority order 1022 | (defn get-an-instantiation [^TreeMap$DescendingSubMap insts] 1023 | (.first ^TreeSet (.get insts (.firstKey insts)))) 1024 | 1025 | ;; Add "add" actions for a set of wmes to the action queue; they will 1026 | ;; be added when we process pending actions. 1027 | (defn insert-wmes-impl [wme-list ^ArrayDeque actions] 1028 | (doseq [input-wme wme-list] 1029 | (.add actions [:add (add-id input-wme)]))) 1030 | 1031 | ;; Insert initial argument wmes into the current engine for this thread 1032 | (defn insert-top-level-wmes [wme-list] 1033 | (doseq [wme wme-list] 1034 | (let [typ (get wme :type)] 1035 | (if (not (keyword? typ)) 1036 | (throw (RuntimeException. 1037 | (str "Working memory element must contain :type field: " 1038 | (vec wme))))))) 1039 | (insert-wmes-impl wme-list *actions*)) 1040 | 1041 | ;; Display the results of performance monitoring in csv format for 1042 | ;; spreadsheet analysis 1043 | (defn display-timing 1044 | ([] 1045 | (display-timing false)) 1046 | ([keep-simons] 1047 | (let [simons (SimonManager/getSimons 1048 | (proxy [org.javasimon.SimonFilter] [] 1049 | (accept [simon] (instance? org.javasimon.Stopwatch simon))))] 1050 | (doseq [^Stopwatch simon simons] 1051 | (printf "%s,%s,%s,%s,%s,%s\n" 1052 | (.getName simon) 1053 | (.getTotal simon) 1054 | (.getCounter simon) 1055 | (.getMax simon) 1056 | (.getMin simon) 1057 | (.getMean simon)) 1058 | (when-not keep-simons 1059 | (SimonManager/destroySimon (.getName simon))))))) 1060 | -------------------------------------------------------------------------------- /src/engine/viewer.clj: -------------------------------------------------------------------------------- 1 | (ns engine.viewer 2 | (:gen-class) 3 | (:require [clojure.pprint :as pprint] 4 | [clojure.stacktrace :as st] 5 | [clojure.set :as set] 6 | [clojure.string :as str] 7 | [clojure.walk :as walk] 8 | [flatland.ordered.set :as ordered] 9 | [clojure.java.io :as io] 10 | [engine.runtime :refer :all]) 11 | (:import [org.javasimon SimonManager Stopwatch] 12 | [java.util HashMap TreeSet TreeMap TreeMap$Entry 13 | TreeMap$DescendingSubMap Comparator ArrayDeque] 14 | clojure.lang.PersistentVector)) 15 | 16 | ;; This file contains support for post-mortem rule debugging. If a rule engine 17 | ;; is configured to record to a file, this program can be run against the 18 | ;; file to walk through rule firings and examine wme state. 19 | 20 | ;; Match UUIDs 21 | (def hexdigitre "[\\da-f]") 22 | (def uuid-regexp (re-pattern (str hexdigitre "{8}-" 23 | hexdigitre "{4}-" 24 | hexdigitre "{4}-" 25 | hexdigitre "{4}-" 26 | hexdigitre "{12}"))) 27 | 28 | (defn is-uuid? [x] (and (string? x) (re-matches uuid-regexp x))) 29 | 30 | ;; Code to partially evaluate LHS expressions so we can show partial 31 | ;; matches 32 | (defn more-specific? [seen comb] 33 | (let [len (count comb)] 34 | (some (fn [sval] 35 | (loop [s sval c comb] 36 | (cond (empty? s) (empty? c) 37 | (empty? c) true 38 | (= (first s) (first c)) (recur (rest s) (rest c)) 39 | :else false))) 40 | seen))) 41 | 42 | (defn already-executed? [history end-idx rule comb] 43 | (loop [srecs history idx 0] 44 | (if (>= idx end-idx) 45 | false 46 | (let [inst (first (:instantiations (first srecs)))] 47 | (or (and inst 48 | (= (:rule inst) rule) 49 | (= (into {} (filter identity comb)) 50 | (into {} (:wmes inst)))) 51 | (recur (rest srecs) (inc idx))))))) 52 | 53 | (defn state-record-wmes [srec] 54 | (apply concat (vals (:wmes srec)))) 55 | 56 | (defn get-lhs [left-sides rule] 57 | (left-sides rule)) 58 | 59 | (defn bucketize [wmes wme-types] 60 | (loop [types wme-types result []] 61 | (if (empty? types) 62 | result 63 | (recur (rest types) (conj result ((first types) wmes)))))) 64 | 65 | (defn cart [colls] 66 | (if (empty? colls) 67 | '(()) 68 | (for [x (first colls) 69 | more (cart (rest colls))] 70 | (cons x more)))) 71 | 72 | (defn find-wme [id wmes] 73 | (some #(= (:__id %) id) wmes)) 74 | 75 | (defn short-wme [wme] 76 | (format "(%d)%s" (:__id wme) (:type wme))) 77 | 78 | ;; Evaluate a left hand side and return partial matches 79 | (defn eval-lhs [history rules end-idx rule] 80 | (let [wmes (state-record-wmes (get history end-idx)) 81 | {fun :fun var-types :var-types} (get-lhs rules rule) 82 | typed (group-by :type wmes) 83 | sorted-wme-types (bucketize typed var-types) 84 | combs (cart (map #(conj % nil) sorted-wme-types))] 85 | (loop [combs (sort-by #(count (filter identity %)) > combs) 86 | seen [] 87 | matches []] 88 | (if (empty? combs) 89 | matches 90 | (let [comb (first combs)] 91 | (if (and (some identity comb) 92 | (not (more-specific? seen comb)) 93 | (not (already-executed? history end-idx rule comb))) 94 | (let [eres (try (eval `(apply ~fun '~comb)) 95 | (catch Exception _ true))] 96 | (if eres 97 | (recur (rest combs) 98 | (conj seen comb) 99 | (conj matches 100 | (str/join 101 | ", " 102 | (map short-wme 103 | (filter identity 104 | (sort-by :__id comb)))))) 105 | (recur (rest combs) (conj seen comb) matches))) 106 | (recur (rest combs) seen matches))))))) 107 | 108 | (defn out-of-bounds? [history index] 109 | (or (< index 0) (>= index (count history)))) 110 | 111 | (def output-width 80) 112 | 113 | (defn too-big? [k v] 114 | (let [fieldlen (- output-width (+ (count (name k)) (count ": ")))] 115 | (> (count (str v)) fieldlen))) 116 | 117 | ;; Generate a string representing a group of wmes, instantiations, etc. 118 | (defn group-string [grouped previous id] 119 | (let [new-marker #(when (every? (fn [pre] (not= (id pre) (id %))) previous) "*") 120 | item-str #(str (id %) (new-marker %))] 121 | (when-not (empty? grouped) 122 | (str/join "\n" 123 | (vec (map (fn [[key vals]] 124 | (str " " 125 | key 126 | " (" 127 | (str/join ", " (map item-str vals)) 128 | ")")) 129 | grouped)))))) 130 | 131 | (defn instantiations-string [history index] 132 | (when-not (out-of-bounds? history index) 133 | (group-string (vec (group-by :rule (:instantiations (get history index)))) 134 | (if (> index 0) 135 | (:instantiations (get history (dec index))) 136 | []) 137 | :id))) 138 | 139 | (defn wmes-string [history index] 140 | (when-not (out-of-bounds? history index) 141 | (let [wmes-by-type (vec (:wmes (get history index)))] 142 | (group-string (sort wmes-by-type) 143 | (if (> index 0) 144 | (mapcat second (vec (:wmes (get history (dec index))))) 145 | []) 146 | :__id)))) 147 | 148 | (defn display-str [history index] 149 | (str "\n" 150 | (str/triml 151 | (str (when-let [lr (:rule (get history (dec index)))] 152 | (str "\n\nLast Rule: " lr)) 153 | (when-let [insts (instantiations-string history index)] 154 | (str "\n\nInstantiations:\n" insts)) 155 | (when-let [wmes (wmes-string history index)] 156 | (str "\n\nWmes:\n" wmes)) 157 | "\n\n(" index ")==> ")))) 158 | 159 | (defn link-string [link history index] 160 | (or (when-let [srec (get history index)] 161 | (loop [wmes (state-record-wmes srec)] 162 | (when-let [wme (first wmes)] 163 | (if (= link (:id wme)) 164 | (str "----> " (short-wme wme)) 165 | (recur (rest wmes)))))) 166 | (str "----> (" link ") "))) 167 | 168 | (defn short-inst [inst] 169 | (format "(%d)%s" (:id inst) (:rule inst))) 170 | 171 | (defn display-inst [inst rules pp] 172 | (when pp 173 | (pprint/pprint (rules (subs (str (:rule inst)) 1))) 174 | (printf "\n")) 175 | (printf "INST - %s\n\npriority: %s\n wmes: %s\n\n" 176 | (short-inst inst) 177 | (:priority inst) 178 | (str/join ", " (map short-wme (sort-by :type (:wmes inst)))))) 179 | 180 | (defn field-val-fun [history index] 181 | (fn [k v] 182 | (let [base-v 183 | (cond (and (is-uuid? v) (not= k :id)) (link-string v history index) 184 | (seq? v) (str (vec v)) 185 | (string? v) (str "\"" v "\"") 186 | :else (str v))] 187 | (if (too-big? k base-v) 188 | (str (str/trimr 189 | (str/replace 190 | (binding [clojure.pprint/*print-right-margin* 76] 191 | (with-out-str 192 | (println) 193 | (pprint/pprint v))) 194 | #"[\n]" 195 | #(str % " "))) 196 | "\n") 197 | (str base-v "\n"))))) 198 | 199 | (defn body-display-string [item history index] 200 | (let [field-val-rep (field-val-fun history index)] 201 | (cond (string? item) 202 | [(field-val-rep "" item)] 203 | 204 | (or (instance? engine.runtime.Wme item) 205 | (and (map? item) (:type item) (:__id item))) 206 | (map (fn [[k v]] (format "%s: %s" (name k) (field-val-rep k v))) 207 | (sort-by str (vec (dissoc item :type :__id)))) 208 | 209 | (map? item) 210 | (map (fn [[k v]] (format "%s: %s" (name k) (field-val-rep k v))) 211 | (sort-by str (vec item))) 212 | 213 | :else 214 | [(field-val-rep "" (str item))]))) 215 | 216 | (defn empty-wme-for-disp? [wme] (and (:__id wme) (= (count wme) 2))) 217 | 218 | (defn display-wme [history index] 219 | (fn [wme] 220 | (println 221 | (apply str 222 | "WME - " 223 | (short-wme wme) 224 | (if (empty-wme-for-disp? wme) "\n" "\n\n") 225 | (body-display-string wme history index))))) 226 | 227 | ;; Actions available in the viewer 228 | (defn usage [idx] 229 | (pprint/cl-format 230 | true 231 | "Usage: ~%~:{ '~a':~% ~{~<~% ~1,81:; ~a~>~}~%~}~%(~s)==> " 232 | (map 233 | (fn [[key val]] [key (str/split val #"[\s]")]) 234 | [["<" "go to beginning"] 235 | [">" "go to end"] 236 | ["?" "display this help"] 237 | ["." "exit the viewer"] 238 | ["" 239 | (str "if at top level, move forward one firing; " 240 | "otherwise return to top level")] 241 | ["[,]*" 242 | "display insts or wmes with s as ids"] 243 | ["ar" "display all rule firings for the run"] 244 | ["b" "back up one firing"] 245 | ["e " 246 | (str "evaluate expression referencing an individual wme as: : " 247 | "and all wmes as :0")] 248 | ["g " "go to step number: "] 249 | ["h" "display command history"] 250 | ["pi " (str "display partial rule instantiations for rules " 251 | "with name containing ")] 252 | ["r" "display rule firings leading to this point"] 253 | ["ref " 254 | (str "display any wmes that reference the " 255 | "specified wme via a UUID link")] 256 | ["rs " "display rule with name containing "] 257 | ["sc " "find the firing that created the specified wme"] 258 | ["sd " "find the firing that deleted the specified wme"] 259 | ["ss " 260 | (str "find the next firing containing a wme whose string " 261 | "representation includes ")] 262 | ["st " 263 | (str "find the next firing containing a wme whose " 264 | "type name includes the ")] 265 | ["sr " 266 | (str "find the next firing for a rule whose " 267 | "name includes the ")] 268 | ["si " 269 | (str "find the next firing whose instantiation " 270 | "references a wme with type containing the ")] 271 | ["save " 272 | "save the history to a file (when running as \":record true\")"] 273 | ["w" "display all wmes for current firing"] 274 | ["w " 275 | (str "display all wmes for current firing with types " 276 | "containing ")] 277 | ["ws " 278 | (str "display all wmes for current firing whose string representations " 279 | "contain ")]]) 280 | idx)) 281 | 282 | (defn fully-instantiate [x] 283 | (into {} (walk/postwalk #(if (seq? %) (vec %) %) x))) 284 | 285 | (defn real-typename [typeref] 286 | (subs typeref 0 (dec (count typeref)))) 287 | 288 | (defn filter-fun [typeref] 289 | (let [typename #(name (:type %))] 290 | (if (.endsWith ^String typeref ".") 291 | (let [actual-typeref (real-typename typeref)] 292 | (fn [wme] (= (typename wme) actual-typeref))) 293 | (fn [wme] (.contains ^String (typename wme) typeref))))) 294 | 295 | (def ^:dynamic *item-map* {}) 296 | (def ^:dynamic *wme-items* []) 297 | 298 | (defn instantiate-exp [exp] 299 | (let [vals (atom {}) 300 | changed (atom true) 301 | current (atom exp)] 302 | (loop [] 303 | (when @changed 304 | (reset! changed false) 305 | (reset! current 306 | (walk/postwalk 307 | (fn [x] 308 | (cond (and (symbol? x) 309 | (not (special-symbol? x)) 310 | (not (re-matches #"^.*[#]$" (name x)))) 311 | (cond (resolve x) x 312 | (@vals x) (@vals x) 313 | :else (do (reset! changed true) 314 | (print (str x " = ")) 315 | (flush) 316 | (let [val (read-string 317 | (read-line))] 318 | (swap! vals assoc x val) 319 | val))) 320 | 321 | (keyword? x) 322 | (let [val (try (Integer/parseInt (name x)) 323 | (catch Exception _ false))] 324 | (if val 325 | (do (reset! changed true) 326 | (if (= val 0) 327 | 'engine.core/*wme-items* 328 | `(engine.core/*item-map* ~val))) 329 | x)) 330 | :else x)) 331 | @current)) 332 | (recur))) 333 | @current)) 334 | 335 | ;; Main viewer that provides an interactive repl 336 | (defn view [history-spec] 337 | (let [[history rules left-sides] (if (string? history-spec) 338 | (with-in-str (slurp history-spec) (read)) 339 | history-spec) 340 | index (atom 0) 341 | at-top (atom true) 342 | disp #(do (reset! at-top true) 343 | (print (display-str history @index)) 344 | (flush)) 345 | items (atom {}) 346 | command-history (atom []) 347 | done (atom false) 348 | add-to-history (fn [line & actual-line] 349 | (swap! command-history conj 350 | [@index line (if actual-line 351 | (first actual-line) 352 | line)])) 353 | next-command (atom nil) 354 | prompt #(do (print (str "(" @index ")==> ")) (flush))] 355 | (doseq [state-record history] 356 | (doseq [inst (:instantiations state-record)] 357 | (swap! items #(assoc % (:id inst) inst))) 358 | (doseq [wme (state-record-wmes state-record)] 359 | (swap! items #(assoc % (:__id wme) wme)))) 360 | (disp) 361 | (loop [input-line (read-line)] 362 | (when input-line 363 | (try 364 | (condp re-matches (str/trim input-line) 365 | ;; go to beginning 366 | #"([<]+)" :>> (fn [& _] (reset! index 0) (disp)) 367 | ;; go to end 368 | #"([>]+)" :>> (fn [& _] (reset! index (dec (count history))) (disp)) 369 | ;; show a set of wmes based on ids 370 | #"[\d]+([,][\s]*[\d]+)*" :>> 371 | #(let [first-time (atom true)] 372 | (do (println) 373 | (let [items (vec (map (fn [num] 374 | (@items (read-string (str/trim num)))) 375 | (str/split (first %) #"[,]")))] 376 | (add-to-history 377 | (str/join ", " 378 | (map (fn [item] 379 | (str "(" (or (:__id item) (:id item)) ")" 380 | (or (:type item) "INST"))) 381 | items)) 382 | input-line) 383 | (doseq [item items] 384 | (if @first-time 385 | (reset! first-time false) 386 | (println "----------------\n")) 387 | (if (:__id item) 388 | ((display-wme history @index) item) 389 | (display-inst item rules (= (count items) 1))))) 390 | (reset! at-top false) 391 | (prompt))) 392 | ;; go to a specific step 393 | #"[g][\s]+([\d]+)" :>> 394 | #(do (reset! index (read-string (second %))) 395 | (disp)) 396 | ;; show history 397 | #"[h]" :>> 398 | (fn [& _] 399 | (loop [commands @command-history item 1] 400 | (when (seq commands) 401 | (let [[idx disp-command _] (first commands)] 402 | (println (str item ": (" idx ") - " disp-command)) 403 | (recur (rest commands) (inc item))))) 404 | (reset! at-top false) 405 | (prompt)) 406 | ;; specific history 407 | #"[h][\s]+([^\s]+.*)" :>> 408 | (fn [command-index-match] 409 | (let [[idx _ command] 410 | (@command-history 411 | (dec (read-string 412 | (second command-index-match))))] 413 | (reset! index idx) 414 | (reset! next-command command))) 415 | ;; evaluate an expression 416 | #"[e][\s]+([^\s]+.*)" :>> 417 | #(do (pprint/pprint 418 | (let [wmes (state-record-wmes (get history @index))] 419 | (binding [*wme-items* wmes 420 | *item-map* (into {} (map (fn [w] [(:__id w) w]) 421 | wmes))] 422 | (let [exp (instantiate-exp (read-string (second %)))] 423 | (add-to-history (str "e " exp)) 424 | (walk/postwalk 425 | (fn [res] 426 | (if (seq? res) 427 | (doall res) 428 | res)) 429 | (eval exp)))))) 430 | (reset! at-top false) 431 | (prompt)) 432 | ;; show wmes 433 | #"[w]" :>> 434 | (fn [& _] 435 | (println) 436 | (let [first-time (atom true)] 437 | (doseq [item (sort-by 438 | :type 439 | (state-record-wmes (get history @index)))] 440 | (if @first-time 441 | (reset! first-time false) 442 | (println "----------------\n")) 443 | ((display-wme history @index) item))) 444 | (add-to-history input-line) 445 | (reset! at-top false) 446 | (prompt)) 447 | ;; show wmes by type 448 | #"[w][\s]+([^\s]+)" :>> 449 | #(let [first-time (atom true) 450 | typ (second %)] 451 | (println) 452 | (doseq [item (filter (filter-fun typ) 453 | (state-record-wmes (get history @index)))] 454 | (if @first-time 455 | (reset! first-time false) 456 | (println "----------------\n")) 457 | ((display-wme history @index) item)) 458 | (add-to-history input-line) 459 | (reset! at-top false) 460 | (prompt)) 461 | ;; show wmes that match a string 462 | #"[w][s][\s]+([^\s]+)" :>> 463 | #(let [first-time (atom true) 464 | st (second %)] 465 | (println) 466 | (doseq [item (filter 467 | (fn [wme] 468 | (.contains ^String 469 | (str (fully-instantiate wme)) 470 | st)) 471 | (state-record-wmes (get history @index)))] 472 | (if @first-time 473 | (reset! first-time false) 474 | (println "----------------\n")) 475 | ((display-wme history @index) item)) 476 | (add-to-history input-line) 477 | (reset! at-top false) 478 | (prompt)) 479 | ;; show wmes that reference an id 480 | #"[r][e][f][\s]+([\d]+)" :>> 481 | (fn [id-val] 482 | (let [id (read-string (second id-val))] 483 | (let [srec (get history @index) 484 | wmes (state-record-wmes srec)] 485 | (add-to-history input-line) 486 | (if-let [ref-id (:id (@items id))] 487 | (let [referring 488 | (filterv #(some (fn [[k v]] 489 | (and (not= k :id) (= v ref-id))) 490 | %) 491 | wmes)] 492 | (if (empty? referring) 493 | (do (println "No referencing wmes") 494 | (disp)) 495 | (do (reset! at-top false) 496 | (let [first-time (atom true)] 497 | (doseq [item (sort-by :type referring)] 498 | (if @first-time 499 | (reset! first-time false) 500 | (println "----------------\n")) 501 | ((display-wme history @index) item)))))) 502 | (do (println "No referencing wmes") 503 | (disp)))))) 504 | ;; show all rules that fired 505 | #"[a][r]" :>> 506 | (fn [& _] 507 | (loop [idx 0] 508 | (when (< idx (count history)) 509 | (let [srec (get history idx) 510 | inst (first (:instantiations srec)) 511 | rule (:rule inst)] 512 | (when rule (printf "%s) %s\n" idx rule)) 513 | (recur (inc idx))))) 514 | (add-to-history input-line) 515 | (reset! at-top false) 516 | (prompt)) 517 | ;; show rules that fires up to this point 518 | #"[r]" :>> 519 | (fn [& _] 520 | (loop [idx 0] 521 | (when (< idx @index) 522 | (let [srec (get history idx) 523 | inst (first (:instantiations srec)) 524 | rule (:rule inst)] 525 | (when rule (printf "%s) %s\n" idx rule)) 526 | (recur (inc idx))))) 527 | (add-to-history input-line) 528 | (reset! at-top false) 529 | (prompt)) 530 | ;; display a rule whose name includes a string 531 | #"[r][s][\s]+([^\s]+)" :>> 532 | #(let [first-time (atom true) 533 | st (second %)] 534 | (doseq [[name rule] 535 | (filter (fn [[k _]] (.contains ^String k st)) 536 | (vec rules))] 537 | (println) 538 | (if @first-time 539 | (reset! first-time false) 540 | (println "----------------\n")) 541 | (pprint/pprint rule)) 542 | (add-to-history input-line) 543 | (reset! at-top false) 544 | (println) 545 | (prompt)) 546 | ;; show partial instantiations 547 | #"[p][i][\s]+([^\s]+)" :>> 548 | #(let [first-time (atom true) 549 | st (second %)] 550 | (doseq [[name rule] 551 | (filter (fn [[k _]] (.contains ^String k st)) 552 | (vec rules))] 553 | (let [result 554 | (eval-lhs history left-sides @index name)] 555 | (when-not (empty? result) 556 | (println) 557 | (if @first-time 558 | (reset! first-time false) 559 | (println "----------------\n")) 560 | (doseq [res result] 561 | (println (str name ":\n")) 562 | (println res))))) 563 | (add-to-history input-line) 564 | (reset! at-top false) 565 | (println) 566 | (prompt)) 567 | ;; go back one step 568 | #"[b]" :>> (fn [& _] 569 | (when (>= @index 1) (swap! index dec)) 570 | (disp)) 571 | ;; go to top 572 | #"" :>> (fn [& _] 573 | (when (and @at-top (< @index (dec (count history)))) 574 | (swap! index inc)) 575 | (disp)) 576 | ;; go to wme creation step 577 | #"[s][c][\s]+([\d]+)" :>> 578 | #(let [id (read-string (second %))] 579 | (add-to-history input-line) 580 | (loop [idx 0] 581 | (if (>= idx (count history)) 582 | (println (str "No such wme: " id)) 583 | (let [srec (get history idx) 584 | wmes (state-record-wmes srec)] 585 | (if (and (find-wme id wmes) 586 | (or (= idx 0) 587 | (not (find-wme 588 | id 589 | (state-record-wmes 590 | (get history (dec idx))))))) 591 | (reset! index idx) 592 | (recur (inc idx)))))) 593 | (disp)) 594 | ;; go to wme deletion step 595 | #"[s][d][\s]+([\d]+)" :>> 596 | #(let [id (read-string (second %))] 597 | (add-to-history input-line) 598 | (loop [idx @index] 599 | (if (>= idx (count history)) 600 | (println (str "No such wme: " id)) 601 | (let [srec (get history idx) 602 | wmes (state-record-wmes srec)] 603 | (if (and (not (find-wme id wmes)) 604 | (or (= idx 0) 605 | (find-wme 606 | id 607 | (state-record-wmes 608 | (get history (dec idx)))))) 609 | (reset! index idx) 610 | (recur (inc idx)))))) 611 | (disp)) 612 | ;; find next firing with a wme containing string 613 | #"[s][s][\s]+([^\s]+)" :>> 614 | #(let [st (second %)] 615 | (add-to-history input-line) 616 | (loop [idx @index] 617 | (if (>= idx (count history)) 618 | (println (str "No wme containing string: " st)) 619 | (let [srec (get history idx) 620 | wmes (state-record-wmes srec)] 621 | (if (some (fn [wme] 622 | (.contains ^String 623 | (str (fully-instantiate wme)) 624 | st)) 625 | wmes) 626 | (reset! index idx) 627 | (recur (inc idx)))))) 628 | (disp)) 629 | ;; find next firing containing wme type 630 | #"[s][t][\s]+([^\s]+)" :>> 631 | #(let [typ (second %)] 632 | (add-to-history input-line) 633 | (loop [idx @index] 634 | (if (>= idx (count history)) 635 | (println (str "No wme of type: " (real-typename typ))) 636 | (let [srec (get history idx) 637 | wmes (state-record-wmes srec)] 638 | (if (some (filter-fun typ) wmes) 639 | (reset! index idx) 640 | (recur (inc idx)))))) 641 | (disp)) 642 | ;; find next firing containing rule whose name includes string 643 | #"[s][r][\s]+([^\s]+)" :>> 644 | #(let [chunk (second %)] 645 | (add-to-history input-line) 646 | (loop [idx @index] 647 | (if (>= idx (count history)) 648 | (println (str "Rule containing '" chunk "' not found.")) 649 | (let [srec (get history idx) 650 | inst (first (:instantiations srec)) 651 | rule (:rule inst)] 652 | (ppwrap :rule [rule (name rule) chunk]) 653 | (if (and rule (.contains (name rule) chunk)) 654 | (reset! index idx) 655 | (recur (inc idx)))))) 656 | (disp)) 657 | ;; find next firing whose instantiation contains a wme matching 658 | ;; string 659 | #"[s][i][\s]+([^\s]+)" :>> 660 | #(let [typ (second %) 661 | done (atom false)] 662 | (add-to-history input-line) 663 | (loop [idx @index] 664 | (if (>= idx (count history)) 665 | (println (str "Instantiation containing '" 666 | (real-typename typ) "' not found.")) 667 | (let [srec (get history idx)] 668 | (loop [insts (:instantiations srec)] 669 | (when (not (empty? insts)) 670 | (if (some (filter-fun typ) (:wmes (first insts))) 671 | (do (reset! index idx) 672 | (reset! done true)) 673 | (recur (rest insts))))) 674 | (when-not @done (recur (inc idx)))))) 675 | (disp)) 676 | ;; explicitly save to file 677 | #"[s][a][v][e][\s]+([^\s]+)" 678 | :>> #(do (dump-recording history rules left-sides (second %)) (disp)) 679 | #"[?]" :>> (fn [& _] (usage @index) (reset! at-top false)) 680 | #"[.]" :>> (fn [& _] (reset! done true))) 681 | (catch Exception e 682 | (printf "%s\n\n" (with-out-str (st/print-stack-trace e))) 683 | (disp))) 684 | (when-not @done 685 | (let [nc @next-command] 686 | (reset! next-command nil) 687 | (recur (or nc (read-line))))))))) 688 | 689 | (def -main view) 690 | -------------------------------------------------------------------------------- /test/engine/big_cross_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.big-cross-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule foo 5 | [?ball1 :ball 6 | (= (:pattern ?ball1) :stripe)] 7 | [?ball2 :ball 8 | (= (:pattern ?ball2) :solid) 9 | (= (:color ?ball2) (:color ?ball1)) 10 | (>> (:value ?ball2) (:value ?ball1))] 11 | [?gurk :gurk (= (:value ?gurk) (:value ?ball2))] 12 | => 13 | (insert! {:type :triple :ball1 (:value ?ball1) :ball2 (:value ?ball2) 14 | :gurk (:value ?gurk)})) 15 | 16 | 17 | -------------------------------------------------------------------------------- /test/engine/context_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.context-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (def foo (atom 6)) 5 | 6 | (defrule dummy 7 | => 6) 8 | 9 | (defcontext {:before (fn [] (swap! foo #(+ % (context-value :to-add)))) 10 | :after #(if (= @foo 28) 11 | (reset! foo 496) 12 | (throw (RuntimeException. "Context failed"))) 13 | :data {:to-add 22}}) 14 | 15 | 16 | -------------------------------------------------------------------------------- /test/engine/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.core-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.java.io :as io] 4 | [clj-yaml.core :as yaml] 5 | [engine.core :refer :all] 6 | [engine.context-test :as ctxt])) 7 | 8 | (deftest big-cross 9 | (testing "inequality performance" 10 | (let [data (atom []) 11 | eng (engine :engine.big-cross-test)] 12 | (loop [i 0 j -9998] 13 | (when (< i 10000) 14 | (swap! data conj {:type :ball :pattern :stripe :color :red 15 | :value i}) 16 | (swap! data conj {:type :ball :pattern :solid :color :red 17 | :value j}) 18 | (recur (inc i) (inc j)))) 19 | (loop [g 0] 20 | (when (< g 5) 21 | (swap! data conj {:type :gurk :value g}) 22 | (recur (inc g)))) 23 | (time (eng :run-list @data))))) 24 | 25 | (deftest simple-priority 26 | (testing "Simple rule, two priorities w/ deletion" 27 | (is (= ((engine :engine.simple-priority-test) 28 | :run 29 | [{:type :thing} {:type :thing} {:type :thing} {:type :counter}]) 30 | {:tally [{:type :tally} {:type :tally} {:type :tally}]})))) 31 | 32 | (deftest multiple-rule-modules 33 | (testing "Same priority test with multiple rule sets loaded into engine" 34 | (is (= ((engine :engine.simple-priority-test :engine.big-cross-test) 35 | :run 36 | [{:type :thing} {:type :thing} {:type :thing} {:type :counter}]) 37 | {:tally [{:type :tally} {:type :tally} {:type :tally}]})))) 38 | 39 | (deftest type-hierarchy 40 | (testing "Ancestor types work correctly" 41 | (let [result ((engine :engine.type-hierarchy-test) :run 42 | [{:type :descendant} {:type :parent} {:type :unrelated} 43 | {:type :a}])] 44 | (is (nil? (:descendent result))) 45 | (is (nil? (:parent result))) 46 | (is (= (:unrelated result) [{:type :unrelated}])) 47 | (is (= (count (:relative result)) 2)) 48 | (is (nil? (:f result))) 49 | (is (= (count (:z result)) 1))))) 50 | 51 | (deftest negated-conjunctions 52 | (testing "Support for NAND1" 53 | (is (= (:tally 54 | ((engine :engine.negated-conjunction-test) 55 | :run 56 | [{:type :eto :val 6} {:type :eto :val 4}])) 57 | [{:type :tally}]))) 58 | (testing "Support for NAND2" 59 | (is (= (:tally 60 | ((engine :engine.negated-conjunction-test) 61 | :run 62 | [{:type :eto :val 6} {:type :eto :val 5}])) 63 | nil))) 64 | (testing "Support for NAND3" 65 | (is (= (:tally 66 | ((engine :engine.negated-conjunction-test) 67 | :run 68 | [{:type :eto :val 6} {:type :eto :val 5} {:type :other}])) 69 | [{:type :tally}]))) 70 | (testing "Remove instantiations on blocker creation" 71 | (let [eng (engine :engine.negated-conjunction-test)] 72 | (is (= (count (:product 73 | (eng :run [{:type :item :val 10} {:type :item :val 10}]))) 74 | 1)))) 75 | (testing "Multiple wmes with same blocking wmes" 76 | (let [eng (engine :engine.negated-conjunction-test)] 77 | (is (= (count (:result 78 | (eng :run [{:type :x} {:type :x} {:type :x} {:type :x}]))) 79 | 4)))) 80 | (testing "Multiple hash tests" 81 | (let [eng (engine :engine.negated-conjunction-test)] 82 | (is (= (count (:multi 83 | (eng :run [{:type :z :lav 6 :oog 28} 84 | {:type :z :lav 496 :oog 8128} 85 | {:type :q :val 6 :goo 28} 86 | {:type :q :val 496 :goo 8128} 87 | {:type :q :val 6 :goo 4} 88 | {:type :q :val 4 :goo 28}]))) 89 | 2)))) 90 | (testing "upstream not" 91 | (let [eng (engine :engine.negated-conjunction-test)] 92 | (is (= (count (:feebrak 93 | (eng :run [{:type :beep :value 6 :blerj 28} 94 | {:type :beep :value 6 :blerj 28} 95 | {:type :borp :value 28}]))) 96 | 2)))) 97 | (testing "not not" 98 | (let [eng (engine :engine.negated-conjunction-test)] 99 | (is (= (count (:gonzo 100 | (eng :run [{:type :smorg :value 6} 101 | {:type :skoolj :value 6}]))) 102 | 0)))) 103 | (testing "not not2" 104 | (let [eng (engine :engine.negated-conjunction-test)] 105 | (is (= (count (:gonzo2 106 | (eng :run [{:type :smorg2 :value 6}]))) 107 | 1)))) 108 | (testing "not not again" 109 | (let [eng (engine :engine.negated-conjunction-test)] 110 | (is (= (count (:gonzo-again 111 | (eng :run [{:type :smorg-again :value 6} 112 | {:type :skoolj-again :value 6}]))) 113 | 1)))) 114 | (testing "nested not not" 115 | (let [eng (engine :engine.negated-conjunction-test)] 116 | (is (= (count (:ngonzo 117 | (eng :run [{:type :nsmorg :value 6} 118 | {:type :nfoo} 119 | {:type :nskoolj :value 6}]))) 120 | 1)))) 121 | (testing "nested not not not" 122 | (let [eng (engine :engine.negated-conjunction-test)] 123 | (is (= (count (:ngonzo3 124 | (eng :run [{:type :nsmorg3 :value 6} 125 | {:type :nfoo3} 126 | {:type :nskoolj3 :value 6}]))) 127 | 1)))) 128 | ) 129 | 130 | (deftest removing-wme-from-negated-conjunction 131 | (testing "removing a wme from nand unlocks blocked instantiations" 132 | (let [eng (engine :engine.negated-wme-removal-test) 133 | interim-result (eng :cycle 134 | [{:type :eto :val 6} 135 | {:type :eto :val 5} 136 | {:type :other}])] 137 | (is (nil? (:tally interim-result))) 138 | (is (= (count (:foobar interim-result)) 1)) 139 | (is (= (count (:other interim-result)) 1)) 140 | (let [final-result (eng :cycle [{:type :update}])] 141 | (is (= (count (:foobar final-result)) 0)) 142 | (is (= (count (:tally final-result)) 1)) 143 | (is (= (count (:updated final-result)) 1)) 144 | (is (= (count (:other final-result)) 0)))))) 145 | 146 | (deftest clearing-engine 147 | (testing "Clearing state from engine" 148 | (let [eng (engine :engine.negated-conjunction-test)] 149 | (is (= (:tally 150 | (eng 151 | :run 152 | [{:type :eto :val 6} {:type :eto :val 5} {:type :other}])) 153 | [{:type :tally}])) 154 | (is (empty? (eng :wmes))) 155 | (is (= (:tally 156 | (eng 157 | :cycle 158 | [{:type :eto :val 6} {:type :eto :val 5} {:type :other}])) 159 | [{:type :tally}])) 160 | (is (= (:tally (eng :wmes)) 161 | [{:type :tally}])) 162 | (is (= (count (:eto (eng :wmes))) 2))))) 163 | 164 | (deftest no-pos 165 | (testing "Negated condition without a positive condition" 166 | (let [eng (engine :engine.negated-no-pos-test)] 167 | (is (= (:val (eng :run [])) 168 | [{:type :val}]))))) 169 | 170 | (deftest ordering 171 | (testing "Instantiation ordering is working" 172 | (doseq [eng [(engine :engine.order) (engine :engine.order2)]] 173 | (let [result (eng :run [{:type :x} {:type :y} {:type :z} 174 | {:type :counter :value 1}])] 175 | (is (= (:value (first (:rule1 result))) 1)) 176 | (is (= (:value (first (:rule2 result))) 2)) 177 | (is (= (:value (first (:rule3 result))) 3)) 178 | (is (= (:value (first (:rule4 result))) 4)) 179 | (is (= (:value (first (:rule5 result))) 5)))) 180 | (let [modeng (engine :engine.module-order2 :engine.module-order) 181 | result (modeng :run [{:type :x} {:type :x}])] 182 | (is (= (count (:order result)) 2)) 183 | (is (= (count (:order2 result)) 0))))) 184 | 185 | (deftest empty-modules 186 | (testing "Creating an engine with a module containing no rules raises an error" 187 | (is (thrown-with-msg? RuntimeException #":engine.core-test contains no rules." 188 | (engine :engine.core-test))))) 189 | 190 | (deftest context 191 | (testing "Rule module context - before function, after function, bound data" 192 | (let [result ((engine :engine.context-test) :run [])] 193 | (is (= @ctxt/foo 496))))) 194 | 195 | (deftest rule-loop 196 | (testing "Looping rule causes engine exit" 197 | (is (thrown-with-msg? 198 | RuntimeException 199 | #"Rule: 'engine.rule-loop-test/looper' is stuck in a loop." 200 | ((engine :engine.rule-loop-test) :run [{:type :x}]))))) 201 | 202 | (deftest multi-optimized-inequality 203 | (testing "Chained optimized inequalities" 204 | (let [data (atom []) 205 | eng (engine :engine.multi-ineq)] 206 | (loop [i 0 j -10] 207 | (when (< i 20) 208 | (swap! data conj {:type :ball :pattern :stripe :color :red 209 | :value i :other-value j}) 210 | (swap! data conj {:type :ball :pattern :solid :color :red 211 | :value j :other-value i}) 212 | (recur (inc i) (inc j)))) 213 | (loop [b 0] 214 | (when (< b 5) 215 | (swap! data conj {:type :brong :value b}) 216 | (recur (inc b)))) 217 | (is (= (count (:triple (eng :run @data))) 175))))) 218 | -------------------------------------------------------------------------------- /test/engine/module_order.clj: -------------------------------------------------------------------------------- 1 | (ns engine.module-order 2 | (:require [engine.core :refer :all])) 3 | 4 | (deforder (:from-module :engine.module-order)) 5 | 6 | (defrule rule1 7 | [?x :x] 8 | => 9 | (remove! ?x) 10 | (insert! {:type :order})) 11 | -------------------------------------------------------------------------------- /test/engine/module_order2.clj: -------------------------------------------------------------------------------- 1 | (ns engine.module-order2 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule rule2 5 | [?x :x] 6 | => 7 | (remove! ?x) 8 | (insert! {:type :order2})) 9 | -------------------------------------------------------------------------------- /test/engine/moved_not_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.moved-not-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule initrule 5 | => 6 | (insert! {:type :foobar :val 6}) 7 | (insert! {:type :bazquux :val 28}) 8 | (insert! {:type :other :val 4})) 9 | 10 | (defrule remove-other4 11 | [?f :foobar] 12 | [?b :bazquux] 13 | [?other :other (= (:val ?other) 4)] 14 | => 15 | (remove! ?f) 16 | (remove! ?b) 17 | (remove! ?other) 18 | (insert! (assoc ?other :val 15)) 19 | (insert! (assoc ?f :val 3)) 20 | (insert! (assoc ?b :val 3))) 21 | 22 | (defrule update-other 23 | [?other :other (> (:val ?other) 4)] 24 | => 25 | (remove! ?other) 26 | (insert! (assoc ?other :val 3))) 27 | 28 | (defrule mainrule 29 | [?f :foobar] 30 | [:not [?other :other (= (:val ?other) (:val ?f))]] 31 | [?b :bazquux (= (:val ?b) (:val ?f))] 32 | => 33 | (insert! {:type :correct})) 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /test/engine/multi_ineq.clj: -------------------------------------------------------------------------------- 1 | (ns engine.multi-ineq 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule multi1 5 | [?ball1 :ball 6 | (= (:pattern ?ball1) :stripe)] 7 | [?ball2 :ball 8 | (= (:pattern ?ball2) :solid) 9 | (= (:color ?ball2) (:color ?ball1)) 10 | (<< (:value ?ball2) (:value ?ball1)) 11 | (>> (:other-value ?ball2) (:other-value ?ball1))] 12 | [?brong :brong (= (:value ?brong) (:value ?ball2))] 13 | => 14 | (insert! {:type :triple :ball1 (:value ?ball1) :ball2 (:value ?ball2) 15 | :brong (:value ?brong)})) 16 | 17 | (defrule multi2 18 | [?ball1 :ball 19 | (= (:pattern ?ball1) :stripe)] 20 | [?ball2 :ball 21 | (= (:pattern ?ball2) :solid) 22 | (= (:color ?ball2) (:color ?ball1)) 23 | (<<= (:value ?ball2) (:value ?ball1)) 24 | (>>= (:other-value ?ball2) (:other-value ?ball1))] 25 | [?brong :brong (= (:value ?brong) (:value ?ball2))] 26 | => 27 | (insert! {:type :triple :ball1 (:value ?ball1) :ball2 (:value ?ball2) 28 | :brong (:value ?brong)})) 29 | 30 | -------------------------------------------------------------------------------- /test/engine/negated_conjunction_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.negated-conjunction-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule initrule 5 | => 6 | (insert! {:type :foobar :val 3})) 7 | 8 | (defrule testrule 9 | [?f :foobar (= (:val ?f) 3)] 10 | [:nand 11 | [?eto :eto (> (:val ?eto) (:val ?f)) (not= (rem (:val ?eto) 2) 0)] 12 | [:not [?other :other]]] 13 | => 14 | (insert! {:type :tally})) 15 | 16 | (defrule removeinst 17 | [?item :item] 18 | [:not [?prod :product (= (:pval ?prod) (:val ?item))]] 19 | => 20 | (insert! {:type :product :pval (:val ?item)})) 21 | 22 | (defrule x-when-not-y 23 | [?x :x] 24 | [:not [?y :y]] 25 | => 26 | (remove! ?x) 27 | (insert! {:type :y})) 28 | 29 | (defrule y-to-result 30 | [?y :y] 31 | => 32 | (remove! ?y) 33 | (insert! {:type :result})) 34 | 35 | (defrule multi-hash 36 | [?z :z] 37 | [?q :q (= (:val ?q) (:lav ?z)) (= (:oog ?z) (:goo ?q))] 38 | => 39 | (insert! {:type :multi})) 40 | 41 | (defrule upstream-neg 42 | [?beep :beep] 43 | [:not [?boop :boop (= (:value ?boop) (:value ?beep))]] 44 | [?borp :borp (= (:value ?borp) (:blerj ?beep))] 45 | => 46 | (insert! {:type :boop :value (:value ?beep)}) 47 | (insert! {:type :feebrak})) 48 | 49 | (defrule upstream 50 | [? :feebrak] 51 | [?boop :boop] 52 | => 53 | (remove! ?boop)) 54 | 55 | ;; Problem: 56 | 57 | ;; a negation of a wme type that IS PRESENT is bypassed by a 58 | ;; non-matching previous negation (higher on the LHS) 59 | (defrule not-not 60 | [?smorg :smorg] 61 | [:not [?smoop :smoop (= (:value ?smoop) (:value ?smorg))]] 62 | [:not [?skoolj :skoolj (= (:value ?skoolj) (:value ?smorg))]] 63 | => 64 | (insert! {:type :smoop :value (:value ?smorg)}) 65 | (insert! {:type :gonzo})) 66 | 67 | (defrule not-not2 68 | [?smorg :smorg2] 69 | [:not [?smoop :smoop2 (= (:value ?smoop) (:value ?smorg))]] 70 | [:not [?skoolj :skoolj2 (= (:value ?skoolj) (:value ?smorg))]] 71 | => 72 | (insert! {:type :smoop2 :value (:value ?smorg)}) 73 | (insert! {:type :gonzo2})) 74 | 75 | (defrule one-step 76 | [?skoolj :skoolj-again] 77 | => 78 | (remove! ?skoolj)) 79 | 80 | (defrule not-not-again 81 | [?smorg :smorg-again] 82 | [:not [?smoop :smoop-again (= (:value ?smoop) (:value ?smorg))]] 83 | [:not [?skoolj :skoolj-again (= (:value ?skoolj) (:value ?smorg))]] 84 | => 85 | (insert! {:type :smoop-again :value (:value ?smorg)}) 86 | (insert! {:type :gonzo-again})) 87 | 88 | 89 | ;; nested not-not 90 | 91 | (defrule nested-not-not 92 | [?nsmorg :nsmorg] 93 | [:nand 94 | [?nfoo :nfoo] 95 | [:not [?nsmoop :nsmoop (= (:value ?nsmoop) (:value ?nsmorg))]] 96 | [:not [?nskoolj :nskoolj (= (:value ?nskoolj) (:value ?nsmorg))]]] 97 | => 98 | (insert! {:type :nsmoop :value (:value ?nsmorg)}) 99 | (insert! {:type :ngonzo})) 100 | 101 | ;; nested not-not-not 102 | 103 | (defrule nested-not-not-not 104 | [?nsmorg :nsmorg3] 105 | [:nand 106 | [?nfoo :nfoo3] 107 | [:not [?nsmoop :nsmoop3 (= (:value ?nsmoop) (:value ?nsmorg))]] 108 | [:not [?nstoop :nstoop3 (= (:value ?nstoop) (:value ?nsmorg))]] 109 | [:not [?nskoolj :nskoolj3 (= (:value ?nskoolj) (:value ?nsmorg))]]] 110 | => 111 | (insert! {:type :nsmoop3 :value (:value ?nsmorg)}) 112 | (insert! {:type :ngonzo3})) 113 | -------------------------------------------------------------------------------- /test/engine/negated_no_pos_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.negated-no-pos-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule testrule 5 | [:not [? :val]] 6 | => 7 | (insert! {:type :val})) 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /test/engine/negated_wme_removal_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.negated-wme-removal-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule initrule 5 | => 6 | (insert! {:type :foobar :val 3})) 7 | 8 | (defrule update-rule 9 | [?u :update] 10 | [?f :foobar] 11 | [?other :other] 12 | => 13 | (remove! ?other) 14 | (insert! {:type :updated})) 15 | 16 | (defrule testrule 17 | {:priority 28} 18 | [?f :foobar (= (:val ?f) 3)] 19 | [:not [?t :tally]] 20 | [:nand 21 | [?eto :eto (> (:val ?eto) (:val ?f)) (not= (rem (:val ?eto) 2) 0)] 22 | [?other :other]] 23 | => 24 | (remove! ?f) 25 | (insert! {:type :tally})) 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /test/engine/order.clj: -------------------------------------------------------------------------------- 1 | (ns engine.order 2 | (:require [engine.core :refer :all])) 3 | 4 | (deforder (:with :x) (:without :y) :oldest) 5 | 6 | (def inst-counter (atom 0)) 7 | 8 | (defn tally [rulekey] 9 | (insert! {:type rulekey :value (swap! inst-counter inc)})) 10 | 11 | (defrule rule1 12 | [?x :x] 13 | => 14 | (tally :rule1)) 15 | 16 | (defrule rule2 17 | [?x :x] 18 | [?y :y] 19 | => 20 | (tally :rule2)) 21 | 22 | (defrule rule3 23 | [?z :z] 24 | => 25 | (tally :rule3) 26 | (insert! {:type :a})) 27 | 28 | (defrule rule4 29 | [?z :z] 30 | [?y :y] 31 | => 32 | (tally :rule4)) 33 | 34 | (defrule rule5 35 | [?z :z] 36 | [?y :y] 37 | [?a :a] 38 | => 39 | (tally :rule5)) 40 | -------------------------------------------------------------------------------- /test/engine/order2.clj: -------------------------------------------------------------------------------- 1 | (ns engine.order2 2 | (:require [engine.core :refer :all])) 3 | 4 | (deforder (:with :x) (:without :y) :newest) 5 | 6 | (def inst-counter (atom 0)) 7 | 8 | (defn tally [rulekey] 9 | (insert! {:type rulekey :value (swap! inst-counter inc)})) 10 | 11 | (defrule rule1 12 | [?x :x] 13 | => 14 | (tally :rule1)) 15 | 16 | (defrule rule2 17 | [?x :x] 18 | [?y :y] 19 | => 20 | (tally :rule2)) 21 | 22 | (defrule rule3 23 | [?z :z] 24 | => 25 | (tally :rule3) 26 | (insert! {:type :a})) 27 | 28 | (defrule rule4 29 | [?z :z] 30 | [?y :y] 31 | [?a :a] 32 | => 33 | (tally :rule4)) 34 | 35 | (defrule rule5 36 | [?z :z] 37 | [?y :y] 38 | => 39 | (tally :rule5)) 40 | -------------------------------------------------------------------------------- /test/engine/rule_loop_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.rule-loop-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule looper 5 | [?x :x] 6 | => 7 | (remove! ?x) 8 | (insert! ?x)) 9 | -------------------------------------------------------------------------------- /test/engine/simple_priority_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.simple-priority-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defrule shutoff 5 | [?counter :counter] 6 | => 7 | (remove! ?counter)) 8 | 9 | (defrule increment 10 | {:priority 10} 11 | [?thing :thing] 12 | [?counter :counter] 13 | => 14 | (remove! ?thing) 15 | (insert! {:type :tally})) 16 | 17 | 18 | -------------------------------------------------------------------------------- /test/engine/speed_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.speed-test 2 | (:require [clojure.test :refer :all] 3 | [engine.core :refer :all])) 4 | 5 | (defrule finish 6 | {:priority 10} 7 | [?limit :limit] 8 | [?counter :counter (>= ^long (:value ?counter) ^long (:value ?limit))] 9 | => 10 | (remove! ?limit) 11 | (remove! ?counter) 12 | (insert! {:type :result :value (:value ?counter)})) 13 | 14 | (defrule increment 15 | [?counter :counter] 16 | => 17 | (remove! ?counter) 18 | (insert! (update ?counter :value inc))) 19 | 20 | (deftest performance-test 21 | (testing "raw simmple rule performance" 22 | (let [eng (engine :engine.speed-test) 23 | _ (eng :configure {:max-repeated-firings 200000}) 24 | result (time (eng :run [{:type :limit :value 100000} 25 | {:type :counter :value 0}]))] 26 | (is (= (:value (first (:result result))) 100000))))) 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /test/engine/type_hierarchy_test.clj: -------------------------------------------------------------------------------- 1 | (ns engine.type-hierarchy-test 2 | (:require [engine.core :refer :all])) 3 | 4 | (defancestor :ancestor :relative) 5 | (defancestor :parent :ancestor) 6 | (defancestor :descendant :parent) 7 | 8 | (defancestor [:a :b :c] :d) 9 | (defancestor [:d :e] :f) 10 | 11 | (defrule hierarchy 12 | [?person :ancestor] 13 | => 14 | (remove! ?person) 15 | (insert! {:type :relative})) 16 | 17 | (defrule hierarchy2 18 | [?f :f] 19 | => 20 | (remove! ?f) 21 | (insert! {:type :z})) 22 | 23 | 24 | --------------------------------------------------------------------------------