├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── architecture.md ├── deps.edn ├── docstrings.clj ├── src └── clolog │ └── core.clj └── test └── clolog ├── core_test.clj └── leash-tests.txt /.gitignore: -------------------------------------------------------------------------------- 1 | .calva/output-window 2 | .clj-kondo/.cache 3 | .cpcache 4 | .lein-failures 5 | .lsp/.cache 6 | .nrepl-port 7 | .portal/vs-code.edn 8 | target/ 9 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a 6 | Changelog](https://keepachangelog.com/en/1.0.0/), and this project 7 | adheres to [Semantic 8 | Versioning](https://semver.org/spec/v2.0.0.html). 9 | 10 | ## [0.4.0]: 2023-09-08 11 | 12 | - Make bindings of anonymous ?vars accessible where 13 | appropriate---by materializing corresponding, distingusihed 14 | `?anon...` ?vars at assertion and (for query goals) at query time. 15 | 16 | - Add built-in predicate `different` (and drop related example 17 | transform predicate). 18 | 19 | - Repair i?var-to-i?var de-referencing. 20 | 21 | - Repair one-empty sequential unification. 22 | 23 | - Add Zebra puzzle to tests. 24 | 25 | - Drop this property of matching... 26 | *Seqs match only seqs, vecs only vecs.* 27 | ...inconsistent with this property: *Constants match equal (Clojure `=`) constants.* 28 | 29 | - Repair body goal indexing. 30 | 31 | - Add `*pprint-leash-statements*` to help make more verbose 32 | statements more easily read by humans. 33 | 34 | ## [0.3.0]: 2023-08-14 35 | 36 | - Important bug fixes (mediated by improved index integrity checking) 37 | - Improved documentation 38 | - Improved leashing distinguishing string predicates 39 | 40 | ## [0.2.0]: 2023-07-29 41 | 42 | - Rename... 43 | 44 | `get-matching-assertions` `get-matching-head-assertions` 45 | `get-subsumed-assertions` `get-subsumed-headassertions` 46 | `get-subsuming-assertions` `get-subsuming-head-assertions` 47 | 48 | - Add... 49 | 50 | `get-matching-assertions` 51 | `get-subsumed-assertions` 52 | `get-subsuming-assertions` 53 | `retract-subsumed-assertions` 54 | `assert<-_` 55 | `<-_` 56 | 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 2.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION 5 | OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial content 12 | Distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | i) changes to the Program, and 16 | ii) additions to the Program; 17 | where such changes and/or additions to the Program originate from 18 | and are Distributed by that particular Contributor. A Contribution 19 | "originates" from a Contributor if it was added to the Program by 20 | such Contributor itself or anyone acting on such Contributor's behalf. 21 | Contributions do not include changes or additions to the Program that 22 | are not Modified Works. 23 | 24 | "Contributor" means any person or entity that Distributes the Program. 25 | 26 | "Licensed Patents" mean patent claims licensable by a Contributor which 27 | are necessarily infringed by the use or sale of its Contribution alone 28 | or when combined with the Program. 29 | 30 | "Program" means the Contributions Distributed in accordance with this 31 | Agreement. 32 | 33 | "Recipient" means anyone who receives the Program under this Agreement 34 | or any Secondary License (as applicable), including Contributors. 35 | 36 | "Derivative Works" shall mean any work, whether in Source Code or other 37 | form, that is based on (or derived from) the Program and for which the 38 | editorial revisions, annotations, elaborations, or other modifications 39 | represent, as a whole, an original work of authorship. 40 | 41 | "Modified Works" shall mean any work in Source Code or other form that 42 | results from an addition to, deletion from, or modification of the 43 | contents of the Program, including, for purposes of clarity any new file 44 | in Source Code form that contains any contents of the Program. Modified 45 | Works shall not include works that contain only declarations, 46 | interfaces, types, classes, structures, or files of the Program solely 47 | in each case in order to link to, bind by name, or subclass the Program 48 | or Modified Works thereof. 49 | 50 | "Distribute" means the acts of a) distributing or b) making available 51 | in any manner that enables the transfer of a copy. 52 | 53 | "Source Code" means the form of a Program preferred for making 54 | modifications, including but not limited to software source code, 55 | documentation source, and configuration files. 56 | 57 | "Secondary License" means either the GNU General Public License, 58 | Version 2.0, or any later versions of that license, including any 59 | exceptions or additional permissions as identified by the initial 60 | Contributor. 61 | 62 | 2. GRANT OF RIGHTS 63 | 64 | a) Subject to the terms of this Agreement, each Contributor hereby 65 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 66 | license to reproduce, prepare Derivative Works of, publicly display, 67 | publicly perform, Distribute and sublicense the Contribution of such 68 | Contributor, if any, and such Derivative Works. 69 | 70 | b) Subject to the terms of this Agreement, each Contributor hereby 71 | grants Recipient a non-exclusive, worldwide, royalty-free patent 72 | license under Licensed Patents to make, use, sell, offer to sell, 73 | import and otherwise transfer the Contribution of such Contributor, 74 | if any, in Source Code or other form. This patent license shall 75 | apply to the combination of the Contribution and the Program if, at 76 | the time the Contribution is added by the Contributor, such addition 77 | of the Contribution causes such combination to be covered by the 78 | Licensed Patents. The patent license shall not apply to any other 79 | combinations which include the Contribution. No hardware per se is 80 | licensed hereunder. 81 | 82 | c) Recipient understands that although each Contributor grants the 83 | licenses to its Contributions set forth herein, no assurances are 84 | provided by any Contributor that the Program does not infringe the 85 | patent or other intellectual property rights of any other entity. 86 | Each Contributor disclaims any liability to Recipient for claims 87 | brought by any other entity based on infringement of intellectual 88 | property rights or otherwise. As a condition to exercising the 89 | rights and licenses granted hereunder, each Recipient hereby 90 | assumes sole responsibility to secure any other intellectual 91 | property rights needed, if any. For example, if a third party 92 | patent license is required to allow Recipient to Distribute the 93 | Program, it is Recipient's responsibility to acquire that license 94 | before distributing the Program. 95 | 96 | d) Each Contributor represents that to its knowledge it has 97 | sufficient copyright rights in its Contribution, if any, to grant 98 | the copyright license set forth in this Agreement. 99 | 100 | e) Notwithstanding the terms of any Secondary License, no 101 | Contributor makes additional grants to any Recipient (other than 102 | those set forth in this Agreement) as a result of such Recipient's 103 | receipt of the Program under the terms of a Secondary License 104 | (if permitted under the terms of Section 3). 105 | 106 | 3. REQUIREMENTS 107 | 108 | 3.1 If a Contributor Distributes the Program in any form, then: 109 | 110 | a) the Program must also be made available as Source Code, in 111 | accordance with section 3.2, and the Contributor must accompany 112 | the Program with a statement that the Source Code for the Program 113 | is available under this Agreement, and informs Recipients how to 114 | obtain it in a reasonable manner on or through a medium customarily 115 | used for software exchange; and 116 | 117 | b) the Contributor may Distribute the Program under a license 118 | different than this Agreement, provided that such license: 119 | i) effectively disclaims on behalf of all other Contributors all 120 | warranties and conditions, express and implied, including 121 | warranties or conditions of title and non-infringement, and 122 | implied warranties or conditions of merchantability and fitness 123 | for a particular purpose; 124 | 125 | ii) effectively excludes on behalf of all other Contributors all 126 | liability for damages, including direct, indirect, special, 127 | incidental and consequential damages, such as lost profits; 128 | 129 | iii) does not attempt to limit or alter the recipients' rights 130 | in the Source Code under section 3.2; and 131 | 132 | iv) requires any subsequent distribution of the Program by any 133 | party to be under a license that satisfies the requirements 134 | of this section 3. 135 | 136 | 3.2 When the Program is Distributed as Source Code: 137 | 138 | a) it must be made available under this Agreement, or if the 139 | Program (i) is combined with other material in a separate file or 140 | files made available under a Secondary License, and (ii) the initial 141 | Contributor attached to the Source Code the notice described in 142 | Exhibit A of this Agreement, then the Program may be made available 143 | under the terms of such Secondary Licenses, and 144 | 145 | b) a copy of this Agreement must be included with each copy of 146 | the Program. 147 | 148 | 3.3 Contributors may not remove or alter any copyright, patent, 149 | trademark, attribution notices, disclaimers of warranty, or limitations 150 | of liability ("notices") contained within the Program from any copy of 151 | the Program which they Distribute, provided that Contributors may add 152 | their own appropriate notices. 153 | 154 | 4. COMMERCIAL DISTRIBUTION 155 | 156 | Commercial distributors of software may accept certain responsibilities 157 | with respect to end users, business partners and the like. While this 158 | license is intended to facilitate the commercial use of the Program, 159 | the Contributor who includes the Program in a commercial product 160 | offering should do so in a manner which does not create potential 161 | liability for other Contributors. Therefore, if a Contributor includes 162 | the Program in a commercial product offering, such Contributor 163 | ("Commercial Contributor") hereby agrees to defend and indemnify every 164 | other Contributor ("Indemnified Contributor") against any losses, 165 | damages and costs (collectively "Losses") arising from claims, lawsuits 166 | and other legal actions brought by a third party against the Indemnified 167 | Contributor to the extent caused by the acts or omissions of such 168 | Commercial Contributor in connection with its distribution of the Program 169 | in a commercial product offering. The obligations in this section do not 170 | apply to any claims or Losses relating to any actual or alleged 171 | intellectual property infringement. In order to qualify, an Indemnified 172 | Contributor must: a) promptly notify the Commercial Contributor in 173 | writing of such claim, and b) allow the Commercial Contributor to control, 174 | and cooperate with the Commercial Contributor in, the defense and any 175 | related settlement negotiations. The Indemnified Contributor may 176 | participate in any such claim at its own expense. 177 | 178 | For example, a Contributor might include the Program in a commercial 179 | product offering, Product X. That Contributor is then a Commercial 180 | Contributor. If that Commercial Contributor then makes performance 181 | claims, or offers warranties related to Product X, those performance 182 | claims and warranties are such Commercial Contributor's responsibility 183 | alone. Under this section, the Commercial Contributor would have to 184 | defend claims against the other Contributors related to those performance 185 | claims and warranties, and if a court requires any other Contributor to 186 | pay any damages as a result, the Commercial Contributor must pay 187 | those damages. 188 | 189 | 5. NO WARRANTY 190 | 191 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 192 | PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" 193 | BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 194 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF 195 | TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR 196 | PURPOSE. Each Recipient is solely responsible for determining the 197 | appropriateness of using and distributing the Program and assumes all 198 | risks associated with its exercise of rights under this Agreement, 199 | including but not limited to the risks and costs of program errors, 200 | compliance with applicable laws, damage to or loss of data, programs 201 | or equipment, and unavailability or interruption of operations. 202 | 203 | 6. DISCLAIMER OF LIABILITY 204 | 205 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT 206 | PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS 207 | SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 208 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST 209 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 210 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 211 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 212 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE 213 | POSSIBILITY OF SUCH DAMAGES. 214 | 215 | 7. GENERAL 216 | 217 | If any provision of this Agreement is invalid or unenforceable under 218 | applicable law, it shall not affect the validity or enforceability of 219 | the remainder of the terms of this Agreement, and without further 220 | action by the parties hereto, such provision shall be reformed to the 221 | minimum extent necessary to make such provision valid and enforceable. 222 | 223 | If Recipient institutes patent litigation against any entity 224 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 225 | Program itself (excluding combinations of the Program with other software 226 | or hardware) infringes such Recipient's patent(s), then such Recipient's 227 | rights granted under Section 2(b) shall terminate as of the date such 228 | litigation is filed. 229 | 230 | All Recipient's rights under this Agreement shall terminate if it 231 | fails to comply with any of the material terms or conditions of this 232 | Agreement and does not cure such failure in a reasonable period of 233 | time after becoming aware of such noncompliance. If all Recipient's 234 | rights under this Agreement terminate, Recipient agrees to cease use 235 | and distribution of the Program as soon as reasonably practicable. 236 | However, Recipient's obligations under this Agreement and any licenses 237 | granted by Recipient relating to the Program shall continue and survive. 238 | 239 | Everyone is permitted to copy and distribute copies of this Agreement, 240 | but in order to avoid inconsistency the Agreement is copyrighted and 241 | may only be modified in the following manner. The Agreement Steward 242 | reserves the right to publish new versions (including revisions) of 243 | this Agreement from time to time. No one other than the Agreement 244 | Steward has the right to modify this Agreement. The Eclipse Foundation 245 | is the initial Agreement Steward. The Eclipse Foundation may assign the 246 | responsibility to serve as the Agreement Steward to a suitable separate 247 | entity. Each new version of the Agreement will be given a distinguishing 248 | version number. The Program (including Contributions) may always be 249 | Distributed subject to the version of the Agreement under which it was 250 | received. In addition, after a new version of the Agreement is published, 251 | Contributor may elect to Distribute the Program (including its 252 | Contributions) under the new version. 253 | 254 | Except as expressly stated in Sections 2(a) and 2(b) above, Recipient 255 | receives no rights or licenses to the intellectual property of any 256 | Contributor under this Agreement, whether expressly, by implication, 257 | estoppel or otherwise. All rights in the Program not expressly granted 258 | under this Agreement are reserved. Nothing in this Agreement is intended 259 | to be enforceable by any entity that is not a Contributor or Recipient. 260 | No third-party beneficiary rights are created under this Agreement. 261 | 262 | Exhibit A - Form of Secondary Licenses Notice 263 | 264 | "This Source Code may also be made available under the following 265 | Secondary Licenses when the conditions for such availability set forth 266 | in the Eclipse Public License, v. 2.0 are satisfied: {name license(s), 267 | version(s), and exceptions or additional permissions here}." 268 | 269 | Simply including a copy of this Agreement, including this Exhibit A 270 | is not sufficient to license the Source Code under Secondary Licenses. 271 | 272 | If it is not possible or desirable to put the notice in a particular 273 | file, then You may include the notice in a location (such as a LICENSE 274 | file in a relevant directory) where a recipient would be likely to 275 | look for such a notice. 276 | 277 | You may add additional accurate notices of copyright ownership. 278 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # clolog 2 | 3 | Full-featured logic programming (AKA "Prolog") embedded in/callable 4 | from and supporting calls to Clojure. In the spirit of LogLisp, Lisp 5 | Machine Prolog, and Franz Inc.'s Allegro Prolog, with some extra 6 | goodies. Emphasis on expressive power and execution transparency, 7 | supporting rapid prototyping, proof-of-concept development, and 8 | outer-loop reasoning (i.e., not real fast, so far). 9 | 10 | ## Highlights, with examples 11 | 12 | - **Clojure-based, Lispy (i.e., homoiconic) syntax, e.g., ...** 13 | 14 | ```clojure 15 | (do 16 | ;; Set up, clear knowledge base. 17 | (initialize-prolog) 18 | ;; Create unit assertion. 19 | (<- (has-subtype vertebrate mammal)) 20 | ;; Execute query. 21 | (? ?x ; Answer template 22 | (has-subtype vertebrate ?x) ; Goal. 23 | ) 24 | ) 25 | [mammal] ; Answer(s) in vector (perhaps empty). 26 | ``` 27 | 28 | - **Logical variable- ("?var")-containing Clojure seqs (so, lists) and 29 | vectors as "complex" terms---in assertion statements and answer templates** 30 | 31 | ```clojure 32 | > (? (?a ?b) 33 | (same [?a 2] [1 ?b])) 34 | [(1 2)] 35 | ``` 36 | 37 | - **Clojure calling predicates** 38 | 39 | - Truthiness check: `truthy?` 40 | 41 | ```clojure 42 | > (? true (truthy? (+ 1 2))) 43 | [true] 44 | ``` 45 | 46 | - ?var-bearing term unification: `evals-from?` 47 | 48 | ```clojure 49 | > (? ?x (evals-from? ?x (+ 1 2))) 50 | [3] 51 | ``` 52 | 53 | - Side effect: `do` 54 | 55 | ```clojure 56 | > (? nil (do (println "Hello"))) 57 | Hello 58 | [nil] 59 | ``` 60 | 61 | - **Access to ?var bindings in Clojure calls---even within quoted 62 | expressions** 63 | 64 | ```clojure 65 | > (do (<-- (male laban)) 66 | (? ?y (male ?x) (evals-from? ?y (list '?x)))) 67 | [(laban)] 68 | ``` 69 | 70 | - **Negation as failure: `not`** 71 | 72 | ```clojure 73 | > (do (initialize-prolog) ; Clear knowledge base. 74 | (? :nothing (not (Huh?)))) 75 | [:nothing] 76 | ``` 77 | 78 | - **Facilitated access to Clojure values (`evals-from?` shorthand 79 | `->?`) in goals with Clojure-calling predicates** 80 | 81 | ```clojure 82 | > (binding [*leash* true] 83 | (? true (same (->? (+ 0 1)) 1))) 84 | 0. Processing query: ((same (->? (+ 0 1)) 1)) 85 | Applied ->? transform 86 | (evals-from?): Entering (evals-from? ??-0:0 (+ 0 1)) 87 | (evals-from?): Succeeded (evals-from? 1 (+ 0 1)) 88 | (same): Entering (same 1 1) 89 | (same): Succeeded (same 1 1) 90 | Recorded answer: true 91 | Answer limit reached. ; Because answer template `true` has no ?vars. 92 | [true] 93 | ``` 94 | 95 | - **Built-in term [non-]matching predicates: `same`, `different`** 96 | 97 | ```clojure 98 | > (? (?a ?b) 99 | (same [?a 2] [1 ?b])) 100 | [(1 2)] 101 | 102 | > (? (?a ?b) 103 | (different [?a 2] [1 ?b])) 104 | [] 105 | ``` 106 | 107 | - **Built-in term inspection predicates: `var`, `ground`** 108 | 109 | ```clojure 110 | > (? ?y (var ?x)) 111 | [?y] 112 | ``` 113 | 114 | ```clojure 115 | > (? ?x (same ?x 1) (ground ?x)) 116 | [1] 117 | ``` 118 | 119 | - **Built-in unconditional predicates: `true`, `false`** 120 | 121 | ```clojure 122 | > (? true (true)) 123 | [true] 124 | ``` 125 | 126 | ```clojure 127 | (? true (false)) 128 | [] 129 | ``` 130 | 131 | - **Nestable built-in logical operators: `and`, `or`, `not`, `if`** 132 | 133 | ```clojure 134 | > (? ?x (and (if (false) 135 | (same ?x :succeed) 136 | (same ?x :fail)) 137 | (evals-from? ?x :fail) 138 | (or (true) (false)))) 139 | [:fail] 140 | ``` 141 | 142 | - **"Cut" operator: `first`** 143 | 144 | ```clojure 145 | > (do (initialize-prolog) 146 | (<- (sister laban rebecca)) 147 | (<- (sister rachel leah)) 148 | (? [?sibling ?sister] 149 | (first (sister ?sibling ?sister)))) 150 | [[laban rebecca]] 151 | ``` 152 | 153 | - **User-custom predicate transforms, supporting (e.g.) 154 | varieties of `if`, `cond`, `optional`** 155 | 156 | ```clojure 157 | > (create-predicate-transform '((if% ?if ?then ?else) 158 | (if (first ?if) ?then ?else))) 159 | ``` 160 | 161 | - **Full leashing of predicates, including operators** 162 | 163 | ```clojure 164 | > (binding [*leash* true] 165 | (? [?sibling ?sister ?x] 166 | (if% (sister ?sibling ?sister) 167 | (evals-from? ?x true) 168 | (evals-from? ?x false)))) 169 | 0. Processing query: ((if% (sister ?sibling ?sister) (evals-from? ?x true) (evals-from? ?x false))) 170 | (if%): Applying logic transform (if% ?if ?then ?else) 171 | (if): Entering (if (first (sister ?sibling:0 ?sister:0)) (evals-from? ?x:0 true) (evals-from? ?x:0 false)) 172 | (if): Checking 'if' condition (if (first (sister ?sibling:0 ?sister:0)) (evals-from? ?x:0 true) (evals-from? ?x:0 false)) 173 | (if first): Entering first (first (sister ?sibling:0 ?sister:0)) 174 | 1. Entering "sister/2": (sister ?sibling:0 ?sister:0) 175 | 1. Matched head (sister laban rebecca): (sister laban rebecca) 176 | 1. Succeeded "sister/2": (sister laban rebecca) 177 | (if first): Succeeded, cutting (first (sister laban rebecca)) 178 | (if): Taking 'then' branch of (if (first (sister laban rebecca)) (evals-from? ?x:0 true) (evals-from? ?x:0 false)) 179 | (if evals-from?): Entering (evals-from? ?x:0 true) 180 | (if evals-from?): Succeeded (evals-from? true true) 181 | (if): Succeeded (if (first (sister laban rebecca)) (evals-from? true true) (evals-from? true false)) 182 | Recorded answer: [laban rebecca true] 183 | (if first): Failed (first (sister ?sibling:0 ?sister:0)) 184 | (if): Failed (if (first (sister ?sibling:0 ?sister:0)) (evals-from? ?x:0 true) (evals-from? ?x:0 false)) 185 | 0. Exhausted query: ((if% (sister ?sibling ?sister) (evals-from? ?x true) (evals-from? ?x false))) 186 | [[laban rebecca true]] 187 | ``` 188 | 189 | - **Symbols interpreted as logic terms or predicates, regardless of their Clojure values** 190 | 191 | ```clojure 192 | > (do (<- (false true)) 193 | (? ?x (false ?x))) 194 | [true] 195 | 196 | > (do (<- (neg? 3)) 197 | (? true (neg? 3))) 198 | [true] 199 | ``` 200 | 201 | - **Arbitrary Clojure things as terms or predicates, e.g., ...** 202 | 203 | - Strings (supporting, e.g., RDF URIs) 204 | 205 | ```clojure 206 | > (do (<- ("false" true)) 207 | (? ?x ("false" ?x))) 208 | [true] 209 | ``` 210 | 211 | - Numbers 212 | 213 | ```clojure 214 | > (do (<- (3 neg?)) 215 | (? ?x (3 ?x))) 216 | [neg?] 217 | ``` 218 | 219 | - Complex terms 220 | 221 | ```clojure 222 | > (do (initialize-prolog) 223 | (<- ([treasure] (buried ?x))) 224 | (? ?r ([treasure] ?r))) 225 | [(buried ?unbound-0)] 226 | ``` 227 | 228 | - **Predicates that are ?var-bearing complex terms** 229 | 230 | ```clojure 231 | > (do (initialize-prolog) 232 | (<- ([treasure chest] (buried ?x))) 233 | (? [?r ?thing] ([treasure ?thing] ?r))) 234 | [[(buried ?unbound-0) chest]] 235 | ``` 236 | 237 | - **Predicates that are ?vars** 238 | 239 | ```clojure 240 | > (do (initialize-prolog) 241 | (<- (male jacob)) 242 | (? ?pred (?pred jacob))) 243 | [male] 244 | ``` 245 | 246 | - **Variadic (variable-tail/arity) predicates and complex terms** 247 | 248 | ```clojure 249 | > (do (initialize-prolog) 250 | (<- (variadic)) 251 | (<- (variadic 1)) 252 | (<- (variadic 1 2)) 253 | (? ?rest (variadic & ?rest))) 254 | [() (1) (1 2)] 255 | 256 | > (do (initialize-prolog) 257 | (<- (variadic-term [1])) 258 | (<- (variadic-term [1 2])) 259 | (? ?rest (variadic-term [1 & ?rest]))) 260 | [[] [2]] 261 | ``` 262 | 263 | - **Goals that are ?vars** 264 | 265 | ```clojure 266 | > (do (initialize-prolog) 267 | (<- (male jacob)) 268 | (? ?goal ?goal)) ; Tell me everything you can prove. 269 | [(male jacob)] 270 | ``` 271 | 272 | ```clojure 273 | > (do (initialize-prolog) 274 | (<- (male jacob)) 275 | (? ?goal (unasserted) ?goal)) ; ...with what you know so far. 276 | [] 277 | ``` 278 | 279 | - **Anonymous ?vars** 280 | 281 | ```clojure 282 | > (do (initialize-prolog) 283 | (<- (sister laban rebecca)) 284 | (<- (sister rachel leah)) 285 | (? true (sister ?_person ?_person))) 286 | [true] 287 | 288 | > (? true (sister ? ?)) 289 | [true] 290 | ``` 291 | 292 | - **Suppression of answers that are (under ?var renaming) duplicates** 293 | 294 | ```clojure 295 | > (do (initialize-prolog) 296 | (<- (male laban)) 297 | (<- (male jacob)) 298 | (binding [*leash* true] 299 | (? ?x (or (male ?x) (male ?x))))) 300 | 0. Processing query: ((or (male ?x) (male ?x))) 301 | (or): Entering (or (male ?x:0) (male ?x:0)) 302 | 1. Entering "male/1": (male laban) 303 | 1. Matched head (male laban): (male laban) 304 | 1. Succeeded "male/1": (male laban) 305 | Recorded answer: laban 306 | 1. Backtracking into "male/1": (male ?x:0) 307 | 1. Succeeded "male/1": (male jacob) 308 | Recorded answer: jacob 309 | 1. Backtracking into "male/1": (male ?x:0) 310 | 1. Failed "male/1": (male ?x:0) 311 | (or): Backtracking into (or (male ?x:0) (male ?x:0)) 312 | 1. Entering "male/1": (male laban) 313 | 1. Matched head (male laban): (male laban) 314 | 1. Succeeded "male/1": (male laban) 315 | Duplicate answer (not recorded): laban 316 | 1. Backtracking into "male/1": (male ?x:0) 317 | 1. Succeeded "male/1": (male jacob) 318 | Duplicate answer (not recorded): jacob 319 | 1. Backtracking into "male/1": (male ?x:0) 320 | 1. Failed "male/1": (male ?x:0) 321 | (or): Failed (or (male ?x:0) (male ?x:0)) 322 | 0. Exhausted query: ((or (male ?x) (male ?x))) 323 | [laban jacob] 324 | ``` 325 | 326 | - **Optional suppression of answers subsumed by other answers** 327 | 328 | ```clojure 329 | > (do (initialize-prolog) 330 | (<- (sister laban rebecca)) 331 | (<- (sister ?x ?y)) 332 | (binding [*leash* true] 333 | (? [?x ?y] (sister ?x ?y)))) 334 | 0. Processing query: ((sister ?x ?y)) 335 | 1. Entering "sister/2": (sister laban rebecca) 336 | 1. Matched head (sister laban rebecca): (sister laban rebecca) 337 | 1. Succeeded "sister/2": (sister laban rebecca) 338 | Recorded answer: [laban rebecca] 339 | 1. Backtracking into "sister/2": (sister ?x:0 ?y:0) 340 | 1. Succeeded "sister/2": (sister ?x:0 ?y:0) 341 | Recorded subsuming answer (discarded 1 subsumed answer(s)): [?x ?y] 342 | 1. Backtracking into "sister/2": (sister ?x:0 ?y:0) 343 | 1. Failed "sister/2": (sister ?x:0 ?y:0) 344 | 0. Exhausted query: ((sister ?x ?y)) 345 | [[?x ?y]] 346 | ``` 347 | 348 | - **Failure (i.e., not system error) when no assertions have been 349 | defined for a called logic predicate and arity** 350 | 351 | ```clojure 352 | > (do (initialize-prolog) 353 | (binding [*leash* true] 354 | (? answer (undefined ?arity-1)))) 355 | 0. Processing query: ((undefined ?arity-1)) 356 | 1. Entering "undefined/1": (undefined ?arity-1:0) 357 | 1. Failed "undefined/1": (undefined ?arity-1:0) 358 | 0. Exhausted query: ((undefined ?arity-1)) 359 | [] 360 | ``` 361 | 362 | ## Grammar 363 | 364 | In production rules below, ... 365 | - Angle brackets surround a grammar \. 366 | - \+ denotes one or more of \. 367 | - \* denotes zero or more of \. 368 | - ":-" separates rules' left- and right-hand sides. 369 | - "|" separates right-hand sides' alternatives. 370 | 371 | \: `(`\+ \*`)` 372 | 373 | \ :- \ 374 | 375 | \ :- \ 376 | 377 | \ :- \ | \ 378 | 379 | \ :- `(`\+ \\*`)` 380 | 381 | \ :- \ 382 | 383 | \ :- `(`\+ \* `&` \`)` 384 | 385 | \ :- \ | \ 386 | 387 | \ :- \ | \ 388 | 389 | \ :- \ | \ | `same` | `different` | `var` | `ground` | `true` | `false` 390 | 391 | \ :- `and` | `or` | `if` | `not` | `first` 392 | 393 | \ :- `truthy?` | `evals-from?` | `do` 394 | 395 | \: A predicate constant registered using `create-predicate-transform` 396 | 397 | \: A predicate all of whose assertions (if any) are from calls to one of the `<-`... macros or `assert<-`... functions 398 | 399 | \ :- \ | \ 400 | 401 | \ :- \ | \ 402 | 403 | \ :- \ | \ 404 | 405 | \ :- `(`\\*`)` | `[`\\*`]` 406 | 407 | \ :- `(`\\* `&` \`)` | `[`\\* `&` \`]` 408 | 409 | \ :- Any Clojure value supporting Clojure `=` (so, not a regex) that is not a transparent term 410 | 411 | \ :- \ | \ 412 | 413 | \ :- `?` | \<`_`-anonymous-?var\> 414 | 415 | \<`_`-anonymous-?var\>: Symbol whose name begins with `"?_"` 416 | 417 | \: An opaque term or a ?var-free complex term 418 | 419 | \ :- \ 420 | 421 | Note: 422 | 423 | - All predicates are terms. 424 | 425 | - All ?vars are symbols. 426 | 427 | - Statements and assertions, being lists, are terms. 428 | 429 | - The arguments of operators are statements. See our Built-in predicates 430 | section. 431 | 432 | - Outside of Clojure-calling predicates' Clojure form arguments: 433 | Symbols appearing in statements are taken at face value, not evaluated. 434 | A symbol used in Prolog otherwise has no relationship to its value 435 | (or the lack thereof) in Clojure. 436 | 437 | ## Additional terminology and conventions 438 | 439 | Considering for the moment only assertion (not special) predicates, 440 | logic programming **search** processes (or **calls**), in turn from 441 | left to right, each **goal** in an (implicitly) conjunctive **query** 442 | by... 443 | 444 | - Identifying assertions whose head statement matches the goal 445 | 446 | - Prepending a matching assertion's body statements (AKA the assertion's 447 | **goals**) to the query's remaining goals, after applying the 448 | match's ?var bindings to each such goal 449 | 450 | - Processing remaining goals, recursively, ... 451 | 452 | - **Backtracking** to remaining matching assertions, when matching a 453 | given assertion **fails** 454 | 455 | - When no goals remain, **succeed** by... 456 | 457 | - Recording an **answer** that realizes the query's **answer 458 | template** according to ?var matches made along the search path 459 | 460 | - Backtracking to search for any additional answers. 461 | 462 | Search generally proceeds depth-first and from left to right. 463 | 464 | We **match** two statements or transparent terms by associating their 465 | respective terms and ?vars, position by position, with consistent 466 | matching for non-anonymous ?vars. In matching (AKA "unification"), 467 | ... 468 | 469 | - A ?var matches a ?var, a transparent term, or a constant. 470 | 471 | - Constants match equal (Clojure `=`) constants. 472 | 473 | - Complex terms match recursively. 474 | 475 | - A **tail ?var** (last in a statement or complex term, and preceded by 476 | `&`) matches the (possibly empty) seq or vector of terms remaining in 477 | the parallel traversal of its opposing complex term. 478 | 479 | One term **subsumes** another if the two terms match and---considering 480 | ?var occurrences---the former is at least as general as the latter. 481 | 482 | A **ground** term has no ?vars (none outside of any opaque included 483 | terms, where they are not treated as ?vars). 484 | 485 | Here---and in leash (execution tracing) reports---the notation 486 | \/\ (e.g., `sibling/2`) refers to the 487 | \ arity of \. 488 | 489 | By convention, we take the first argument of a 2-ary statement to be the 490 | predicate's **subject**, the second to be its **object**. Thus, in 491 | `(brother Jane John)`, we take `Jane` to be the subject (or agent), 492 | `John` to be the object (or patient). ("A brother of Jane is John.") 493 | 494 | A **unit** assertion has only a head statement, no body statements. 495 | 496 | ## API 497 | 498 | ### Initialization 499 | 500 | Clear the knowledge base and any existing special predicate 501 | transforms, then execute the transform definitions in function 502 | `create-predicate-transforms`. 503 | 504 | ```clojure 505 | (initialize-prolog) 506 | ``` 507 | 508 | ### Knowledge base and predicate transform contexts 509 | 510 | Bind `*assertions*` and/or `*predicate-transforms*`, per their doc 511 | strings, to set up contexts for different knowledge bases and/or 512 | transform definitions. 513 | 514 | ### Creating assertions---macros and functions 515 | 516 | We provide four assertion creation functions and four corresponding 517 | macros. The macros, which don't require quoting arguments, so are 518 | simpler to use at the REPL or from top level in a file, take their 519 | statement arguments at top-level. The functions take theirs in a list. 520 | 521 | An assertion's head statement... 522 | 523 | - May not be a ?var. 524 | 525 | - May be variadic, but must require arity >= 1 (i.e., must not start 526 | with `&`). 527 | 528 | - Must not have a built-in special predicate in its predicate 529 | position. We don't flag assertions to transform predicates; 530 | however, once a predicate has been used on the left-hand side of a 531 | transform's defining production rule, we refrain from exercising 532 | same-predicate assertions. 533 | 534 | See the functions' doc strings for other fine points. 535 | 536 | The following forms have equivalent effect: Add the assertion with 537 | head statement `(sibling ?x ?y)` and lone goal statement `(brother ?x ?y)` 538 | to the knowledge base. 539 | 540 | ```clojure 541 | (<- (sibling ?x ?y) (brother ?x ?y)) ; Macro. 542 | 543 | (assert<- '((sibling ?x ?y) (brother ?x ?y))) ; Function. 544 | ``` 545 | 546 | The following place their constant-predicate, fixed-arity assertion 547 | first for consideration in search. We provide no explicit control 548 | over the order in which (less conventional) assertions with variadic, 549 | variable, or non-ground complex head statement predicates are examined 550 | during backtracking search. 551 | 552 | ```clojure 553 | (<-0 (sibling ?x ?y) (brother ?x ?y)) ; Macro. 554 | 555 | (assert<-0 '((sibling ?x ?y) (brother ?x ?y))) ; Function. 556 | ``` 557 | 558 | The following clear `sibling/2` before making their assertion. 559 | 560 | ```clojure 561 | (<-- (sibling ?x ?y) (brother ?x ?y)) ; Macro. 562 | 563 | (assert<-- '((sibling ?x ?y) (brother ?x ?y))) ; Function. 564 | ``` 565 | 566 | The following clear the entire knowledge base of all but special 567 | transforms before making their assertion. 568 | 569 | ```clojure 570 | (<--- (sibling ?x ?y) (brother ?x ?y)) ; Macro. 571 | 572 | (assert<--- '((sibling ?x ?y) (brother ?x ?y))) ; Function. 573 | ``` 574 | 575 | The following---when employed systematically---avoid 576 | subsumed-subsuming assertion pairs in the knowledge base, by declining 577 | to add would-be-subsumed assertions and by retracting subsumed 578 | assertions. 579 | 580 | ```clojure 581 | (<-_ (sibling ?x ?y) (brother ?x ?y)) ; Macro. 582 | 583 | (assert<-_ '((sibling ?x ?y) (brother ?x ?y))) ; Function. 584 | ``` 585 | 586 | We retrieve assertions once upon calling a predicate, and assertion or 587 | retraction operations otherwise relevant to that predicate will be 588 | reflected during the call. 589 | 590 | ### Retrieving assertions 591 | 592 | We provide three functions for retrieving assertions by matching their 593 | heads against a statement pattern. Each returns a vector containing the 594 | knowledge base's assertions whose head statements exhibit the function's 595 | required relationship to `statement-pattern`. 596 | 597 | Get assertions whose head matches `statement-pattern`. 598 | ```clojure 599 | (get-matching-head-assertions statement-pattern) 600 | ``` 601 | 602 | Get assertions whose head is subsumed by `statement-pattern`. 603 | ```clojure 604 | (get-subsumed-head-assertions statement-pattern) 605 | ``` 606 | 607 | Get assertions whose head subsumes `statement-pattern`. 608 | ```clojure 609 | (get-subsuming-head-assertions statement-pattern) 610 | ``` 611 | 612 | We provide two similar functions that match assertions against a 613 | full assertion pattern. 614 | 615 | Get assertions entirely subsumed by `assertion-pattern`. 616 | ```clojure 617 | (get-subsumed-assertions assertion-pattern) 618 | ``` 619 | 620 | Get assertions entirely subsuming `assertion-pattern`. 621 | ```clojure 622 | (get-subsuming-assertions assertion-pattern) 623 | ``` 624 | 625 | ### Retracting assertions 626 | 627 | We provide two functions, and two corresponding macros, for retracting 628 | assertions by matching their head statements against a pattern and 629 | one function to retract assertions entirely matching an assertion pattern. 630 | 631 | The following have equivalent effect. As in the assertion retrieval 632 | functions, `statement-pattern` refers to assertions' head statements. 633 | 634 | ```clojure 635 | (retract-subsumed-head-assertions statement-pattern) 636 | 637 | (--- statement-pattern) 638 | ``` 639 | 640 | The following have equivalent effect. Here, `assertion` must be equal 641 | (Clojure `=`, including equal ?var symbols) to an assertion in the 642 | knowledge base, for the latter to be retracted. 643 | 644 | ```clojure 645 | (retract-specific-assertion assertion) ; Function. 646 | 647 | (-- statement-pattern) ; Macro. 648 | ``` 649 | 650 | ```clojure 651 | (retract-subsumed-assertions '((?pred deceased-person))) 652 | ``` 653 | 654 | ## Querying 655 | 656 | The following macro and function are equivalent---except that the 657 | macro does not support keyword arguments (instead, bind the 658 | default-value globals). With a truthy limit, terminate search upon 659 | having recorded so many answers. 660 | 661 | ```clojure 662 | (? answer-template & goals) ; Macro. 663 | 664 | (query answer-template goals ; Function. 665 | :limit *answer-count-limit* 666 | :discard-subsumed *discard-subsumed-answers*) 667 | ``` 668 | 669 | ## Leashing 670 | 671 | For now, leashing is an all-or-nothing proposition. Perform any query 672 | with `*leash*` bound truthy, for goal-by-goal reports describing 673 | execution. 674 | 675 | ```clojure 676 | (binding [*leash* true] 677 | ;; Query form(s) in here. 678 | ) 679 | ``` 680 | 681 | As demonstrated in our Highlights section and in 682 | `test/prolog/leash-tests.txt`, leashing reports... 683 | 684 | - Entry into and success or failure of goals 685 | - Backtracking into... 686 | - Remaining matching assertions of goals with assertion predicates 687 | - Remaining disjuncts (remaining alternatives goals) of `or` goals 688 | - `first` operator-induced cuts 689 | - Application of predicate transforms 690 | - The discovery of answers and their disposition 691 | - Search termination upon reaching an answer count limit. 692 | 693 | Leashing also... 694 | 695 | - Indexes reports per depth of assertion nesting 696 | - Indicates the nesting of built-in predicates for the current assertion 697 | - Left-pads reports per nesting of assertion and built-in predicate goals. 698 | 699 | When `*pprint-leash-statements*` is truthy, ...`"Entering"`, ... 700 | 701 | - `"Matched head"` leash reports are omitted. 702 | - `"Succeeded"`, and `"Failed"` leash reports pprint (vs. print) 703 | statement content, starting on a new line, with indentation, as in... 704 | 705 | ```clojure 706 | clolog.core> (binding [*leash* true 707 | *pprint-leash-statements* true] 708 | (query '[?h ?w ?z] '((zebra ?h ?w ?z)) :limit 1)) 709 | 0. Processing query: ((zebra ?h ?w ?z)) 710 | 1. Entering `zebra`/3: 711 | (zebra ?h:0 ?w:0 ?z:0) 712 | 713 | 1. (same): Entering... 714 | (same 715 | ?h:0 716 | ((house norwegian ?anon-0:1 ?anon-1:1 ?anon-2:1 ?anon-3:1) 717 | ?anon-4:1 718 | (house ?anon-5:1 ?anon-6:1 ?anon-7:1 milk ?anon-8:1) 719 | ?anon-9:1 720 | ?anon-10:1)) 721 | 722 | 1. (same): Succeeded... 723 | (same 724 | ((house norwegian ?anon-0:1 ?anon-1:1 ?anon-2:1 ?anon-3:1) 725 | ?anon-4:1 726 | (house ?anon-5:1 ?anon-6:1 ?anon-7:1 milk ?anon-8:1) 727 | ?anon-9:1 728 | ?anon-10:1) 729 | ((house norwegian ?anon-0:1 ?anon-1:1 ?anon-2:1 ?anon-3:1) 730 | ?anon-4:1 731 | (house ?anon-5:1 ?anon-6:1 ?anon-7:1 milk ?anon-8:1) 732 | ?anon-9:1 733 | ?anon-10:1)) 734 | 735 | 2. Entering `member`/2: 736 | (member 737 | (house englishman ?anon-11:1 ?anon-12:1 ?anon-13:1 red) 738 | ((house norwegian ?anon-0:1 ?anon-1:1 ?anon-2:1 ?anon-3:1) 739 | ?anon-4:1 740 | (house ?anon-5:1 ?anon-6:1 ?anon-7:1 milk ?anon-8:1) 741 | ?anon-9:1 742 | ?anon-10:1)) 743 | ``` 744 | 745 | ## Built-in predicates 746 | 747 | We support the following built-in predicates. We borrow some notation 748 | from our Grammar section and allow ourselves to introduce types via 749 | obvious naming (e.g., a \ is a 750 | \---distinguished merely by its role/argument position in the 751 | built-in predicate `if`). We invoke the exclued middle: If a goal 752 | does not succeed, then it fails. 753 | 754 | - `(and` \*`)` succeeds if, proceeding from left to right, 755 | every conjunct statement succeeds. 756 | 757 | - `(or` \*`)` succeeds if, proceeding from left to 758 | right, some disjunct statement succeeds (and remaining disjuncts are 759 | ignored). Backtracking will explore first alternative ways to 760 | satisfy a failing statement, then subsequent statements. 761 | 762 | - `(if` \ \ \`)` 763 | succeeds if either: 764 | 765 | - The condition statement succeeds and the then statement succeeds (in which 766 | case we do not examine the else statement under the bindings for 767 | the condition statement's ?vars) 768 | 769 | - The condition statement fails and the else statement succeeds (in which 770 | case we do not examine `then-statement`). 771 | 772 | Backtracking will explore alternative ways to satisfy the argument 773 | statements. 774 | 775 | - `(not` \`)` succeeds if the wrapped statement fails. 776 | 777 | - `(first` \`)` succeeds if the argument statement succeeds. This 778 | form (AKA Prolog "cut") skips backtracking to explore other ways of 779 | satisfying the statement, upon its first success. 780 | 781 | - `(same` \ \`)` succeeds if the two terms match. 782 | 783 | - `(true)` succeeds unconditionally. 784 | 785 | - `(false)` fails unconditionally. 786 | 787 | - `(var` \`)` succeeds if the argument term is a ?var. 788 | 789 | - `(ground \)` succeeds if the argument term is ground. 790 | 791 | - `(truthy?` \`)` succeeds if the argument form is ground and 792 | the result of its evaluation (in Clojure) is truthy. 793 | 794 | - `(evals-from?` \ \`)` succeeds if the argument form is 795 | ground and the result of its evaluation (in Clojure) matches the 796 | argument term (often a ?var). 797 | 798 | - `(do` \*`)` succeeds if the whole `do` expression is ground, 799 | evaluating it (in Clojure) for side effect, only. 800 | 801 | ## Creating special transforms 802 | 803 | The function call below---performed by `initialize-prolog`---seeds 804 | Clolog with some transforms for predicates we have found useful in 805 | other Lisp-based Prologs. As we intend this facility to support 806 | customization, you may wish to copy our version of 807 | `create-predicate-transforms` and edit it to your liking. 808 | 809 | ```clojure 810 | (create-predicate-transforms) 811 | ``` 812 | 813 | `create-predicate-transforms` includes calls to 814 | `create-predicate-transform`. Each call is a production rule. During 815 | search, a goal matching `source-statement` is transformed---via 816 | de-referencing---into `target-statement`. 817 | 818 | ```clojure 819 | (create-predicate-transform source-statement target-statement) 820 | ``` 821 | 822 | The execution machinery for transform predicates applies the first 823 | matching transform irrevocably, with no backtracking in case of 824 | failure. Compared to an assertion predicate defined using using one 825 | assertion per transform and the same statements in each 826 | transform-assertion pair, it is as if the transform predicate's goal 827 | always were wrapped with `first`. We consider predicate transforms to 828 | be "macros" for Prolog, affording us cleaner leashing than would 829 | similar assertion predicates. Assertion predicatess more verbose 830 | leashing may nonetheless be helpful in prototyping and debugging 831 | prospective transforms. It may help to call 832 | `create-predicate-transforms` with optional argument `debugging?` 833 | truthy---and either disregard any effects resulting from backtracking 834 | into prospective transform predicates ultimately intended or (as in 835 | `tests/clolog/core_tests.clj`) avoid backtracking by limiting the 836 | count of answers found. 837 | 838 | ## Potential future enhancements 839 | 840 | We might pursue some of the following ideas towards increasing 841 | expressivity/leashing, robustness/scale, and efficiency, given 842 | motivating use cases. 843 | 844 | - Potential enhancements to expressiveness and leashing: 845 | 846 | - Accommodate non-ground Clojure expressions in Clojure-calling 847 | forms---in case a called form would use these in crafting 848 | subsequent goal (e.g.). 849 | 850 | - Make the local/lexical environment accessible within called 851 | Clojure forms. 852 | 853 | - Support RDF, RDFS, selected aspects of OWL (e.g., inverses, 854 | functional dependencies). 855 | 856 | - Selective leashing, considering (e.g.) predicate, arity, 857 | report type (e.g., answer disposition). 858 | 859 | - Selective detail in leashing, e.g., re `if` subgoals 860 | 861 | - Greater precision in leash report prefixes for n-ary operators 862 | `and`, `or` (e.g., indexing potentially like-predicate conjuncts, 863 | disjuncts). 864 | 865 | - Potential enhancements to robustness and scale 866 | 867 | - Error-check user/application inputs more pervasively. 868 | 869 | - Support Prolog stack limits, breakpoints, stepping/debugger 870 | integration. 871 | 872 | - Support database integration---access to unit ground assertions. 873 | 874 | - Potential efficiency enhancements 875 | 876 | - Perform further indexing, including trie-based indexing. 877 | 878 | - Qualify seq/vector matching with early check for compatible 879 | lengths of candidate-matching seqs and vectors. 880 | 881 | - Decline to explore alternative satisfactions of a ground goal. 882 | 883 | - Skirt search branches that cannot instantiate an answer template 884 | ?var. 885 | 886 | - Support parallelism and/or laziness. 887 | 888 | ## License 889 | 890 | Copyright © 2023 Robert Carl Schrag 891 | 892 | This program and the accompanying materials are made available under 893 | the terms of the Eclipse Public License 2.0 which is available at 894 | http://www.eclipse.org/legal/epl-2.0. 895 | 896 | This Source Code may also be made available under the following 897 | Secondary Licenses when the conditions for such availability set forth 898 | in the Eclipse Public License, v. 2.0 are satisfied: GNU General 899 | Public License as published by the Free Software Foundation, either 900 | version 2 of the License, or (at your option) any later version, with 901 | the GNU Classpath Exception which is available at 902 | https://www.gnu.org/software/classpath/license.html. 903 | -------------------------------------------------------------------------------- /architecture.md: -------------------------------------------------------------------------------- 1 | # clolog design 2 | 3 | ## Matching, bindings, de-referencing 4 | 5 | We have two different representations for the bindings that result 6 | from matching one expression against another---unindexed and indexed. 7 | Depending on values of optional keyword arguments, core matching and 8 | de-referencing functions exercise one representation or the other. 9 | (To **de-reference** a ?var is to retrieve its (most) concrete value, 10 | following chains of ?var-?var bindings as necessary. To de-reference 11 | a term is to return a version of the term in which all ?vars have been 12 | de-referenced.) 13 | 14 | ### Unindexed bindings 15 | 16 | The unindexed representation covers single-level matching 17 | needs---retrieving assertions for knowledge base management 18 | operations, comparing answers. Unindexed bindings, resulting from 19 | unindexed matching, are pairs of complementary ?var-value maps, one 20 | from the perspective of each of the two match arguments. This 21 | representation facilitates computing subsumption relationships. 22 | 23 | ### Indexed bindings 24 | 25 | This representation indexes ?vars by search depth, to distinguish 26 | (potentially clashing) different assertions' ?vars. We start at index 27 | 0 for query goals, then index 1 for an assertion called by a query 28 | goal, index 2 for an assertion called by a first-level assertion's 29 | goal, etc. We call an index-?var pair an i?var. In leashing (and for 30 | discussion here), i?vars are rendered as \`:`\ (e.g., 31 | `?x:3`). 32 | 33 | We maintain i?var bindings in a map (usually referred to locally as 34 | `bindings`) whose keys are indices and whose values are maps of ?vars 35 | (the i?vars at that search level) to matching values. 36 | 37 | When we need to exhibit a value---for a leash report or for an 38 | answer---we extract it from `bindings`. 39 | 40 | Note: 41 | 42 | - When matching an i?var to an i?var, ... 43 | 44 | - We will enter a lower-indexed i?var as a higher- one's value (so 45 | that, e.g., `?x:2` may have value `?x:1`)---never vice versa. 46 | This prevents i?var-value cycles in `bindings`. (Same-indexed 47 | i?vars are matched only per a hack in processing calls to built-in 48 | predicate `same`---not ordinarily.) 49 | 50 | - If, during above matching, the lower-indexed i?var already has as 51 | its value a yet-lower-indexed i?var (e.g., `?x:1` has value 52 | `?x:0`), we will use the latter as the higher- one's (so, 53 | `?x:2`'s) value. Thus, we push unbound i?vars "up" (index-wise) 54 | the search stack. We call this the "push-up" strategy. 55 | 56 | - When matching an i?var to a non-i?var, ... 57 | 58 | - If the i?var does not already have as its value another i?var, 59 | we install the non-i?var as its value. 60 | 61 | - If the i?var has as its value another (lesser-indexed) i?var, we 62 | install the non-i?var as the latter's value. Thus, we push a 63 | non-i?var value to its least search level (lowest index in 64 | `bindings`). Call this the "reference" level. Since, per the 65 | above, all intermediate i?vars in any i?var chain also point to 66 | this level, de-referencing a given i?var (for a leash report, say) 67 | requires at most one hop of indirect look-up. 68 | 69 | - Instantiating an answer template requires merely looking up the 70 | template's ?var values (if any) at index 0. 71 | 72 | A nuance arises when a lower-indexed ?var becomes bound to a complex 73 | term containing a higher-indexed ?var that remains unbound, as in the 74 | following example (from `tests/clolog/core_tests.clj`). 75 | 76 | ```clojure 77 | > (do (initialize-prolog) 78 | (<- (treasure (buried ?x))) 79 | (<- (marks-the-spot X))) 80 | > (? ?r (treasure ?r) (marks-the-spot ?x)) 81 | [[(buried ?unbound-0) X]] 82 | ``` 83 | 84 | When exiting the successful assertion call, we must "export" the 85 | assertion's ?var `?x`, renaming it uniquely (here, as `?unbound-0`) to 86 | prevent clashes with a same-named query ?var (such as `?x`, that we 87 | index here as `?x:0`). We can't keep referring to the exported ?var 88 | as `?x:1`, either, in case ?var `?x` might occur in another matching 89 | assertion for `treasure/1` (e.g., with head `(treasure (buried (twice 90 | ?x)))`). In our "push-up" scheme, we index such a renamed, exported 91 | ?var at the reference level (here, 0). 92 | 93 | ## Stack machine 94 | 95 | Our Prolog interpreter is a stack machine. Each goal to be processed 96 | is associated with a stack frame, and each type of goal---as 97 | distinguished by its predicate---has an appropriate stack frame 98 | handler. We have one handler for assertion predicates, another 99 | handler for each public special predicate, and still more handlers for 100 | private special predicates that ("under the hood") facilitate leashing 101 | and special control for processing of goals with predicates `if` and 102 | `first`. We dispatch to these specialized handlers via the 103 | general-purpose handler `process-stack-frame`. Each handler (also a 104 | couple of other key functions) is named `process-...`. Our 105 | search-launching function, `query`, calls `trampoline` directly on 106 | `process-stack-frame`. Then every other call to a a `process-...` 107 | function is accordingly anonymized. Prolog continuations 108 | (representing backtrack points) are passed in (and as) stack frames. 109 | Clojure stack depth for stack machine execution is effectively a 110 | non-issue, regardless of Prolog search depth. 111 | 112 | Prolog bindings (also passed in stack frames) track Prolog search 113 | depth. 114 | 115 | ## Potential future enhancements 116 | 117 | Beyond enhancements suggested in `README.md`, we might support... 118 | 119 | - Prolog tail recursion 120 | 121 | - Prolog compilation---e.g., per-assn partial evaluation of 122 | unification and assertion exit operations. 123 | 124 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:aliases 2 | {:test {:extra-paths ["test"] 3 | :extra-deps {io.github.cognitect-labs/test-runner 4 | {:git/tag "v0.5.1" :git/sha "dfb30dd"}} 5 | :main-opts ["-m" "cognitect.test-runner"]}}} 6 | -------------------------------------------------------------------------------- /docstrings.clj: -------------------------------------------------------------------------------- 1 | (ns clolog.core 2 | (:require [clojure.pprint :refer [cl-format]] 3 | [clojure.string :as str] 4 | [clojure.set :refer [difference]] 5 | [clojure.walk :refer [postwalk]] 6 | )) 7 | 8 | (def ^:dynamic *assertions* 9 | "The repository of assertions (AKA knowledge base) defined by the user 10 | or using application. Bind this (and possibly 11 | `*predicate-transforms*`) to manage separate knowledge bases 12 | simultaneously, or to checkpoint a knowledge base." 13 | (atom {})) 14 | 15 | (def ^:dynamic *predicate-transforms* 16 | "The repository of predicate transforms defined by the user or using 17 | application. Bind this to manage alternative transform 18 | definitions." 19 | (atom {})) 20 | 21 | (defn initialize-prolog [] 22 | "Reset/clear the knowledge base, clear and re-define transforms." 23 | ;; ... 24 | ) 25 | 26 | (defn assert<- [assertion] 27 | "Add `assertion` to the knowledge base. If the assertion's head 28 | statement has a constant predicate and fixed arity, place `assertion's` 29 | last for consideration in search." 30 | ;; ... 31 | ) 32 | 33 | (defmacro <- [& assertion] 34 | "The macro version of function `assert<--`." 35 | `(assert<- (quote ~assertion))) 36 | 37 | (defn assert<-- [assertion] 38 | "Add `assertion` to the knowledge base---after clearing its 39 | required-constant head statement predicate at its required-fixed 40 | arity." 41 | ;; ... 42 | ) 43 | 44 | (defmacro <-- [& assertion] 45 | "The macro version of function `assert<--`." 46 | `(assert<-- (quote ~assertion))) 47 | 48 | (defn assert<--- [assertion] 49 | "Add `assertion` to the knowledge base---after clearing the entire 50 | knowledge base." 51 | ;; ... 52 | ) 53 | 54 | (defmacro <--- [& assertion] 55 | "The macro version of function `assert<---`." 56 | `(assert<--- (quote ~assertion))) 57 | 58 | (defn assert<-0 [assertion] 59 | "Add `assertion` to the knowledge base---after clearing its 60 | required-constant head statement predicate at its required-fixed 61 | arity." 62 | ;; ... 63 | ) 64 | 65 | (defmacro <-0 [& assertion] 66 | "The macro version of function `assert<-0`." 67 | `(assert<-0 (quote ~assertion))) 68 | 69 | (defn assert<-_ [assertion] 70 | "Add `assertion` to the knowledge base, unless it is subsumed by an 71 | existing assertion. Retract existing assertions subsumed by 72 | `assertion`, if adding `assertion` (if `assertion` is not subsumed). 73 | Does not check that the knowledge base is already minimal with 74 | respect to `assertion`, so (if you use this at all) you may want to 75 | use it pervasively, or at least consistently with respect to a given 76 | predicate and arity." 77 | ;; ... 78 | ) 79 | 80 | (defmacro <-_ [& assertion] 81 | "The macro version of function `assert<-_`." 82 | `(assert<-least (quote ~assertion))) 83 | 84 | ;;; Predicate transform (AKA logic macro) facility: 85 | 86 | (defn create-predicate-transform [transform] 87 | "Create one of the production rules used in transforming a statement 88 | with given predicate." 89 | ;; ... 90 | ) 91 | 92 | (defn create-predicate-transforms 93 | "Define the predicate transforms included here." 94 | ([] 95 | (create-predicate-transforms false)) 96 | ([debugging?] 97 | (reset! *predicate-transforms* {}) 98 | (let [create-predicate-transform (if debugging? 99 | assert<- 100 | create-predicate-transform)] 101 | ;; Designing to unique assertion head arity can be appropriate. 102 | ;; 103 | ;; `if*` (as in Allegro Prolog) 104 | (create-predicate-transform '((if* ?if ?then ?else) (if ?if ?then ?else))) 105 | ;; `if%` (Allegro Prolog `if`) 106 | (create-predicate-transform '((if% ?if ?then ?else) (if (first ?if) ?then ?else))) 107 | ;; `cond*` 108 | (create-predicate-transform '((cond*) (or))) ; Handled so in Clojure. 109 | (create-predicate-transform '((cond* ?if ?then :else ?else) (if* ?if ?then ?else))) 110 | (create-predicate-transform '((cond* ?if1 ?then1 ?if2 ?then2 & ?rest) ; `& ?rest` in input form. 111 | (if* ?if1 ?then1 (cond* ?if2 ?then2 & ?rest)))) 112 | ;; `cond%` 113 | (create-predicate-transform '((cond%) (or))) 114 | (create-predicate-transform '((cond% ?if ?then :else ?else) (if% ?if ?then ?else))) 115 | (create-predicate-transform '((cond% ?if1 ?then1 ?if2 ?then2 & ?rest) 116 | (if% ?if1 ?then1 (cond% ?if2 ?then2 & ?rest)))) 117 | ;; Consider `when`, `when-not`, `when%`, `when%-not`. 118 | ;; `optional` (as in SPARQL) 119 | (create-predicate-transform '((optional ?goal) (if ?goal (true) (true)))) 120 | ;; `different` 121 | (create-predicate-transform '((different ?a ?b) (not (same ?a ?b)))) 122 | ;; `is` 123 | (create-predicate-transform '((is ?a ?b) (same ?a ?b))) 124 | ;; Norvig `lisp`, `lispp` 125 | (create-predicate-transform '((lisp ?form) (do ?form))) 126 | (create-predicate-transform '((lisp ?logic ?form) (evals-from? ?logic ?form))) 127 | (create-predicate-transform '((lispp ?form) (truthy? ?form))) 128 | ))) 129 | 130 | (defn get-matching-head-assertions [statement-pattern] 131 | "Return a vector of the assertions whose heads match 132 | `statement-pattern`." 133 | ;; ... 134 | ) 135 | 136 | (declare subsumes?) 137 | 138 | (defn get-subsumed-head-assertions [statement-pattern] 139 | "Return a vector of the assertions whose heads are subsumed by 140 | `statement-pattern`." 141 | ;; ... 142 | ) 143 | 144 | (defn get-subsuming-head-assertions [statement-pattern] 145 | "Return a vector of the assertions whose heads subsume 146 | `statement-pattern`." 147 | ;; ... 148 | ) 149 | 150 | (defn get-subsuming-assertions [assertion-pattern] 151 | "Return a vector of the assertions entirely subsuming 152 | `assertion-pattern`." 153 | ;; ... 154 | ) 155 | 156 | (defn get-subsumed-assertions [assertion-pattern] 157 | "Return a vector of the assertions entirely subsumed by 158 | `assertion-pattern`." 159 | ;; ... 160 | ) 161 | 162 | (defn retract-subsumed-head-assertions [statement-pattern] 163 | "Retract the assertions subsumed by `statement-pattern`." 164 | ;; ... 165 | ) 166 | 167 | (defn retract-subsumed-assertions [assertion-pattern] 168 | "Retract the assertions entirely subsumed by `assertion-pattern`." 169 | ;; ... 170 | ) 171 | 172 | (defmacro --- [statement-pattern] 173 | "The macro version of function `retract-subsumed-assertions`." 174 | `(retract-subsumed-assertions (quote ~statement-pattern))) 175 | 176 | (defn retract-specific-assertion [assertion] 177 | "Retract `assertion`, using `=` (so, respecting ?var symbols)." 178 | ;; ... 179 | ) 180 | 181 | (defmacro -- [& statements] 182 | "The macro version of function `retract-specific-assertion`." 183 | `(retract-specific-assertion (quote ~statements))) 184 | 185 | (defn unprint-i?vars [expr] 186 | "Convert i?vars' print representations in `expr` to actual 187 | i?vars---making it easier to execute expressions copied from 188 | Clojure execution traces." 189 | ;; ... 190 | ) 191 | 192 | (def ^:dynamic *answer-count-limit* 193 | "When truthy, terminate query execution upon having recorded (positive 194 | integer) `*answer-count-limit*` answers." 195 | nil) 196 | 197 | (def ^:dynamic *discard-subsumed-answers* 198 | "When truthy, during query execution discard answers subsumed by other 199 | answers." 200 | true) 201 | 202 | (def ^:dynamic *leash* 203 | "When truthy, during query execution, write informative reports to 204 | standard output." 205 | false) 206 | 207 | (defn query [answer-template goals 208 | & {:keys [limit 209 | discard-subsumed 210 | ;; For negation as failure (private): 211 | stack-index 212 | special-form-stack 213 | special-form-depth] 214 | :or {limit *answer-count-limit* 215 | discard-subsumed *discard-subsumed-answers* 216 | ;; Private: 217 | stack-index 0 218 | special-form-stack () 219 | special-form-depth 0}}] 220 | "Perform (depth-first, pre-order) logic programming search over 221 | goals, instantiating `answer-template` upon each success, and return 222 | a vector of such answers. Discard (and/or do not record) subsumed 223 | answers, per `discard-subsumed`. Terminate search upon having 224 | recorded `limit` answers." 225 | ;; ... 226 | ) 227 | 228 | (defmacro ? [answer-template & goals] ; Does not support keyword args. 229 | "The macro version of function `query`." 230 | `(query (quote ~answer-template) (quote ~goals))) 231 | 232 | -------------------------------------------------------------------------------- /src/clolog/core.clj: -------------------------------------------------------------------------------- 1 | (ns clolog.core 2 | (:require [clojure.pprint :as pprint :refer [pprint cl-format]] 3 | [clojure.string :as str] 4 | [clojure.set :as set] 5 | [clojure.walk :refer [postwalk]] 6 | )) 7 | 8 | ;;; We provide a richly featured Prolog interpreter that can be called 9 | ;;; by and call Clojure. 10 | 11 | ;;;;; ---------------------------------------------------------------- 12 | ;;;;; Knowledge base: 13 | 14 | ;;; We repersent an assertion---i,e., a Prolog rule or fact, as a 15 | ;;; list of statements ( *), where each statement is a list 16 | ;;; ( *). 17 | 18 | ;;; A term can be just about any Clojure object possessing 19 | ;;; identity/supporting equality (so, not a regex). 20 | 21 | ;;; In matching (e.g.) goals and assertion heads, we look inside only 22 | ;;; seqs and lists. 23 | 24 | ;;; A predicate can be anything you like---not necessarily a 25 | ;;; symbol (so if you like go wild with RDF). (And you can use 26 | ;;; multi-word strings.) 27 | 28 | ;;; And (apart from Prolog-reserved symbols) there is nothing 29 | ;;; semantically special about the "predicate" position in a "statement" 30 | ;;; tuple. We do index it more aggressively (so far, exclusively) 31 | ;;; than the other positions, but a ?var in the predicate position 32 | ;;; also is completely acceptable. 33 | 34 | ;;; The variable below is dynamic---so that using applications 35 | ;;; can stash a value when done compiling a model, then bind the 36 | ;;; value afresh when they'd like to augment it. 37 | ;;; 38 | ;;; Keys are predicates. 39 | ;;; Within a predicate, keys are arities. 40 | ;;; Within an arity, assertions are ordered (even under any indexing). 41 | ;;; For separate models, bind these and any other globals. 42 | (def ^:dynamic *assertions* 43 | "The repository of assertions (AKA knowledge base) defined by the user 44 | or using application. Bind this (and possibly 45 | `*predicate-transforms*`) to manage separate knowledge bases 46 | simultaneously, or to checkpoint a knowledge base." 47 | (atom {})) 48 | 49 | ;;; The assertions defining predicate transforms. 50 | (def ^:dynamic *predicate-transforms* 51 | "The repository of predicate transforms defined by the user or using 52 | application. Bind this to manage alternative transform 53 | definitions." 54 | (atom {})) 55 | 56 | (declare ?var?) 57 | (declare indexify) 58 | (declare built-in-special-head?) 59 | 60 | (defn- check-assertion [assertion] 61 | (assert (not (?var? (first assertion))) 62 | "Head statements may not productively match all goals.") 63 | (let [goal (first assertion) 64 | head (first goal)] 65 | (assert (not (= head '&)) 66 | "Head statements may not productively match all goals.") 67 | (assert (not (built-in-special-head? head)) 68 | "No assertions may be added to built-in special forms."))) 69 | 70 | ;;; Find out some things to store assertions appropriately. 71 | (defn- complex? [head] 72 | ;; (or (seq? head) (vector? head)) 73 | (sequential? head)) 74 | 75 | (declare ground?) 76 | 77 | (defn- non-ground-complex? [head] 78 | (and (complex? head) 79 | (not (ground? head)))) 80 | 81 | (declare unindexify) 82 | (declare i?var?) 83 | 84 | (defn- get-predicate 85 | ([head unindexed?] 86 | (unindexify (get-predicate (indexify head 0)) 87 | 0)) 88 | ([head] 89 | (if (i?var? (first head)) 90 | 'variable 91 | (if (non-ground-complex? (first head)) 92 | ;; For now, a single bucket. FUTURE: A trie. 93 | 'non-ground-complex 94 | (first head))))) 95 | 96 | ;;; "Anonymous" ?vars must be distinguishable, to support 97 | ;;; de-referencing. (See the Zebra test.) 98 | (def ^:private ^:dynamic *anon-?var-counter* (atom 0)) 99 | 100 | (defn- new-anon-?var [root-?var] 101 | (let [counter @*anon-?var-counter* 102 | root-string (subs (name root-?var) 1)] 103 | (swap! *anon-?var-counter* inc) 104 | (read-string (cl-format nil "?anon~a-~d" root-string counter)))) 105 | 106 | (declare walk-walkable) 107 | (declare anonymous-?var?) 108 | 109 | (defn- distinguish-anons [thing] ; Query goals or assertion. 110 | (binding [*anon-?var-counter* (atom 0)] 111 | (walk-walkable anonymous-?var? #(new-anon-?var %) thing))) 112 | 113 | (defn assert<- [assertion] 114 | "Add `assertion` to the knowledge base. If the assertion's head 115 | statement has a constant predicate and fixed arity, place `assertion` 116 | last for consideration in search." 117 | (check-assertion assertion) 118 | (let [assertion (distinguish-anons assertion) 119 | head (first assertion) 120 | predicate (get-predicate head :unindexed) 121 | arity (if (some #{'&} head) 122 | 'variadic 123 | (count (rest head))) 124 | predicate-assertions (or (get @*assertions* predicate) 125 | ;; Initialize with the empty map of arities. 126 | {}) 127 | arity-assertions (or (get predicate-assertions arity) 128 | ;; Initialize with this assertion. 129 | []) 130 | arity-assertions (conj arity-assertions assertion) 131 | predicate-assertions (assoc predicate-assertions arity arity-assertions)] 132 | (swap! *assertions* assoc predicate predicate-assertions) 133 | assertion)) 134 | 135 | (defmacro <- [& assertion] 136 | "The macro version of function `assert<--`." 137 | `(assert<- (quote ~assertion))) 138 | 139 | (defn assert<-- [assertion] 140 | "Add `assertion` to the knowledge base---after clearing its 141 | required-constant head statement predicate at its required-fixed 142 | arity." 143 | (check-assertion assertion) 144 | (let [assertion (distinguish-anons assertion) 145 | head (first assertion) 146 | predicate (get-predicate head :unindexed) 147 | arity (if (some #{'&} head) 148 | 'variadic 149 | (count (rest head)))] 150 | (assert (not= predicate 'variable) 151 | "Retract variable-predicate assertions more particularly.") 152 | (assert (not= predicate 'non-ground-complex) 153 | "Retract assertions with non-ground-complex head statement predicates more particularly.") 154 | (assert (not= arity 'variadic) 155 | "Retract variadic assertions more particularly.") 156 | (swap! *assertions* update-in [predicate] assoc arity [assertion]))) 157 | 158 | (defmacro <-- [& assertion] 159 | "The macro version of function `assert<--`." 160 | `(assert<-- (quote ~assertion))) 161 | 162 | (defn assert<--- [assertion] 163 | "Add `assertion` to the knowledge base---after clearing the entire 164 | knowledge base." 165 | (check-assertion assertion) 166 | (reset! *assertions* {}) 167 | (assert<- assertion)) 168 | 169 | (defmacro <--- [& assertion] 170 | "The macro version of function `assert<---`." 171 | `(assert<--- (quote ~assertion))) 172 | 173 | (declare retract-subsumed-assertions) 174 | (declare get-subsuming-assertions) 175 | 176 | (defn assert<-_ [assertion] 177 | "Add `assertion` to the knowledge base, unless it is subsumed by an 178 | existing assertion. Retract existing assertions subsumed by 179 | `assertion`, if adding `assertion` (if `assertion` is not subsumed). 180 | Does not check that the knowledge base is already minimal with 181 | respect to `assertion`, so (if you use this at all) you may want to 182 | use it pervasively, or at least consistently with respect to a given 183 | predicate and arity." 184 | ;; FUTURE: Provide more feedback. 185 | (let [head (first assertion) 186 | assertable (not (seq (get-subsuming-assertions assertion)))] 187 | (when assertable 188 | (retract-subsumed-assertions assertion) 189 | (assert<- assertion)))) 190 | 191 | (defmacro <-_ [& assertion] 192 | "The macro version of function `assert<-_`." 193 | `(assert<-_ (quote ~assertion))) 194 | 195 | (declare predicate-arity-assertions) 196 | 197 | (defn assert<-0 [assertion] 198 | "Add `assertion` to the knowledge base---after clearing its 199 | required-constant head statement predicate at its required-fixed 200 | arity." 201 | (check-assertion assertion) 202 | (let [assertion (distinguish-anons assertion) 203 | head (first assertion) 204 | predicate (get-predicate head :unindexed) 205 | arity (if (some #{'&} head) 206 | 'variadic 207 | (count (rest head)))] 208 | (assert (not= predicate 'non-ground-complex) 209 | "Non-ground-complex-predicate assertion order control not supported.") 210 | (assert (not= predicate 'variable) 211 | "Variable-predicate assertion order control not supported.") 212 | (assert (not= arity 'variadic) 213 | "Variadic assertion order control not supported.") 214 | (let [assertions (apply list (predicate-arity-assertions predicate arity)) 215 | assertions (vec (cons assertion assertions))] 216 | (swap! *assertions* update-in [predicate] assoc arity assertions)))) 217 | 218 | (defmacro <-0 [& assertion] 219 | "The macro version of function `assert<-0`." 220 | `(assert<-0 (quote ~assertion))) 221 | 222 | ;;; Predicate transform (AKA logic macro) facility: 223 | 224 | (defn create-predicate-transform [transform] 225 | "Create one of the production rules used in transforming a statement 226 | with given predicate." 227 | (let [goal (first transform) 228 | head (first goal) 229 | head-transforms (or (get @*predicate-transforms* head) 230 | []) 231 | head-transforms (conj head-transforms transform)] 232 | (assert (not (built-in-special-head? head))) 233 | (swap! *predicate-transforms* assoc head head-transforms))) 234 | 235 | (defn create-predicate-transforms 236 | "Define the predicate transforms included here." 237 | ([] 238 | (create-predicate-transforms false)) 239 | ([debugging?] 240 | (reset! *predicate-transforms* {}) 241 | (let [create-predicate-transform (if debugging? 242 | assert<- 243 | create-predicate-transform)] 244 | ;; Designing to unique assertion head arity can be appropriate. 245 | ;; 246 | ;; `if*` (as in Allegro Prolog) 247 | (create-predicate-transform '((if* ?if ?then ?else) (if ?if ?then ?else))) 248 | ;; `if%` (Allegro Prolog `if`) 249 | (create-predicate-transform '((if% ?if ?then ?else) (if (first ?if) ?then ?else))) 250 | ;; `cond*` 251 | (create-predicate-transform '((cond*) (or))) ; Handled so in Clojure. 252 | (create-predicate-transform '((cond* ?if ?then :else ?else) (if* ?if ?then ?else))) 253 | (create-predicate-transform '((cond* ?if1 ?then1 ?if2 ?then2 & ?rest) ; `& ?rest` in input form. 254 | (if* ?if1 ?then1 (cond* ?if2 ?then2 & ?rest)))) 255 | ;; `cond%` 256 | (create-predicate-transform '((cond%) (or))) 257 | (create-predicate-transform '((cond% ?if ?then :else ?else) (if% ?if ?then ?else))) 258 | (create-predicate-transform '((cond% ?if1 ?then1 ?if2 ?then2 & ?rest) 259 | (if% ?if1 ?then1 (cond% ?if2 ?then2 & ?rest)))) 260 | ;; Consider `when`, `when-not`, `when%`, `when%-not`. 261 | ;; `optional` (as in SPARQL) 262 | (create-predicate-transform '((optional ?goal) (if ?goal (true) (true)))) 263 | ;; `is` 264 | (create-predicate-transform '((is ?a ?b) (same ?a ?b))) 265 | ;; Norvig `lisp`, `lispp` 266 | (create-predicate-transform '((lisp ?form) (do ?form))) 267 | (create-predicate-transform '((lisp ?logic ?form) (evals-from? ?logic ?form))) 268 | (create-predicate-transform '((lispp ?form) (truthy? ?form))) 269 | ))) 270 | 271 | (defn initialize-prolog [] 272 | "Reset/clear the knowledge base, clear and re-define transforms." 273 | (reset! *assertions* {}) 274 | (create-predicate-transforms)) 275 | 276 | (defn- predicate-arity-assertions [predicate arity] 277 | (get (get @*assertions* predicate) 278 | arity)) 279 | 280 | ;;; In case of ?var in predicate position, return candidate assertions 281 | ;;; of `arity` (perhaps `variadic`) for all predicates. 282 | (defn- arity-assertions [arity] 283 | (mapcat (fn [predicate-assertions] 284 | (get predicate-assertions arity)) 285 | (vals @*assertions*))) 286 | 287 | (defn- all-assertions [] 288 | (mapcat (fn [predicate-assertions] 289 | (let [arity-assertions (vals predicate-assertions)] 290 | (apply concat arity-assertions))) 291 | (vals @*assertions*))) 292 | 293 | ;;; Duplicate: 294 | ;;; (defn- all-assertions [] 295 | ;;; (vec (apply concat (mapcat vals (vals @*assertions*))))) 296 | 297 | ;;; Check whether a term symbol is a Prolog ?var (variable). 298 | (defn- ?var? [thing] 299 | (and (symbol? thing) 300 | (= \? (first (name thing))))) 301 | 302 | (def ^:private public-built-in-special-heads '#{truthy? do evals-from? 303 | var ground 304 | and or not if 305 | first 306 | same different 307 | true false}) 308 | 309 | (defn- public-built-in-special-head? [head] 310 | (contains? public-built-in-special-heads head)) 311 | 312 | (def ^:private private-built-in-special-heads 313 | '#{and... or... ; Non-leashed. 314 | sys-and ; Non-leashed, does not inc/dec `*special-form-depth*`. 315 | if-then then else drop-else fail-if succeed-if 316 | fail-first succeed-first}) 317 | 318 | (defn- private-built-in-special-head? [head] 319 | (contains? private-built-in-special-heads head)) 320 | 321 | (defn- built-in-special-head? [head] 322 | (or (public-built-in-special-head? head) 323 | (private-built-in-special-head? head))) 324 | 325 | ;;; We distinguish the first/source/whole occurrence of a multi-arity 326 | ;;; special form (`and`, `or`) by ellipsis-suffixing (`and...`, 327 | ;;; `or...`) its subsequent occurrences that we introduce as we work 328 | ;;; down its list (of conjuncts, disjuncts). 329 | 330 | (defn- non-transformable-predicate? [goal] 331 | (and (seq? goal) 332 | (let [head (first goal)] 333 | (built-in-special-head? head)))) 334 | 335 | (defn- transformable-predicate? [goal] 336 | (and (seq? goal) 337 | (let [head (first goal)] 338 | (contains? @*predicate-transforms* head)))) 339 | 340 | (defn- special-goal? [goal] 341 | (or (non-transformable-predicate? goal) 342 | (transformable-predicate? goal))) 343 | 344 | (defn- candidate-variadic-assertions-predicate [predicate &-position] 345 | (vec (mapcat #(predicate-arity-assertions predicate %) 346 | (filter #(>= % (dec &-position)) 347 | ;; This will include `variadic`. 348 | (keys (get @*assertions* predicate)))))) 349 | 350 | (defn- candidate-variadic-assertions [goal] 351 | (let [goal (vec goal) 352 | &-position (.indexOf goal '&)] 353 | (if (= &-position 0) 354 | (all-assertions) 355 | (let [predicate (get-predicate goal) 356 | predicate-assns (candidate-variadic-assertions-predicate predicate &-position)] 357 | (if (= predicate 'variable) 358 | predicate-assns 359 | (vec (concat predicate-assns 360 | (candidate-variadic-assertions-predicate 'variable &-position)))))))) 361 | 362 | (declare i?var?) 363 | 364 | (defn- candidate-assertions [goal] 365 | (when goal 366 | (if (or (i?var? goal) (= goal '(&))) 367 | (all-assertions) 368 | (if (some #{'&} goal) ; `&` at top level. 369 | (candidate-variadic-assertions goal) 370 | ;; Not variadic (but could match variadic). 371 | (let [predicate (get-predicate goal) 372 | arity (count (rest goal))] 373 | (if (= predicate 'variable) 374 | ;; Covers `variable`. 375 | (vec (concat (arity-assertions 'variadic) 376 | ;; Includes `non-ground-complex`. 377 | (arity-assertions arity))) 378 | ;; Not`(= predicate 'variable)`. 379 | (if (or (= predicate 'non-ground-complex) 380 | ;; Covers ground-complex. 381 | (complex? predicate)) 382 | ;; We need everything. 383 | (vec (concat (predicate-arity-assertions 'variable 'variadic) 384 | (predicate-arity-assertions predicate 'variadic) 385 | ;; Our future trie will facilitate 386 | ;; retrieval of assertions headed by 387 | ;; complex predicates. For now, we grab 388 | ;; everything of like arity (and let 389 | ;; unification sort it out). 390 | (arity-assertions arity))) 391 | ;; Not complex. 392 | (vec (concat (predicate-arity-assertions predicate arity) 393 | (predicate-arity-assertions predicate 'variadic) 394 | (predicate-arity-assertions 'variable arity) 395 | (predicate-arity-assertions 'variable 'variadic)))))))))) 396 | 397 | (declare i?var-unify) 398 | (declare unify) 399 | (declare de-reference) 400 | 401 | (defn- goal-assertion-matches [assn-index goal bindings] 402 | (when-not (or (nil? goal) 403 | (special-goal? goal)) 404 | (mapcat (fn [assertion] 405 | (let [assertion (if assn-index 406 | (indexify assertion assn-index) 407 | assertion) 408 | unindexed? (if assn-index false :unindexed) 409 | match (if unindexed? unify i?var-unify) 410 | head (first assertion) 411 | goals (rest assertion) 412 | ;; If not for our fancy predicate notions (e.g., 413 | ;; predicates that are ?vars), we might here pass 414 | ;; to `i?var-unify` just the `rest` of `goal-form` 415 | ;; and of `head`. 416 | bindings? (and goal head 417 | (match (de-reference bindings goal unindexed?) 418 | head 419 | bindings))] 420 | (when bindings? 421 | (list [assertion bindings?])))) 422 | ;; Indexifying an already-indexified goal is a no-op (but 423 | ;; in future we might clean this up). 424 | (candidate-assertions (indexify goal 0))))) 425 | 426 | (defn get-matching-head-assertions [statement-pattern] 427 | "Return a vector of the assertions whose heads match 428 | `statement-pattern`." 429 | (vec (map first (goal-assertion-matches nil statement-pattern [{} {}])))) 430 | 431 | (declare subsumes?) 432 | 433 | (defn get-subsumed-head-assertions [statement-pattern] 434 | "Return a vector of the assertions whose heads are subsumed by 435 | `statement-pattern`." 436 | (vec (map first 437 | (filter (fn [match] 438 | (let [[pattern-env assn-env] (second match)] 439 | (subsumes? pattern-env assn-env))) 440 | (goal-assertion-matches nil statement-pattern [{} {}]))))) 441 | 442 | (defn get-subsuming-head-assertions [statement-pattern] 443 | "Return a vector of the assertions whose heads subsume 444 | `statement-pattern`." 445 | (vec (map first 446 | (filter (fn [match] 447 | (let [[pattern-env assn-env] (second match)] 448 | (subsumes? assn-env pattern-env))) 449 | (goal-assertion-matches nil statement-pattern [{} {}]))))) 450 | 451 | ;;; FUTURE: Consider versions of these two functions that treat an 452 | ;;; assertion as "subsuming" if all of its statements are subsuming to 453 | ;;; corresponding opposite statements, but there exist more (so, 454 | ;;; superfluous) opposite statements. 455 | (defn get-subsuming-assertions [assertion-pattern] 456 | "Return a vector of the assertions entirely subsuming 457 | `assertion-pattern`." 458 | (let [pattern-head (first assertion-pattern)] 459 | (filter (fn [assertion] 460 | (when-let [result (unify assertion-pattern assertion)] 461 | (let [[pattern-env assn-env] result] 462 | (subsumes? assn-env pattern-env)))) 463 | ;; This will return assertions of any length---we perform 464 | ;; no length-related indexing. 465 | (candidate-assertions (indexify pattern-head 0))))) 466 | 467 | (defn get-subsumed-assertions [assertion-pattern] 468 | "Return a vector of the assertions entirely subsumed by 469 | `assertion-pattern`." 470 | (let [pattern-head (first assertion-pattern)] 471 | (filter (fn [assertion] 472 | (when-let [result (unify assertion-pattern assertion)] 473 | (let [[pattern-env assn-env] result] 474 | (subsumes? pattern-env assn-env)))) 475 | ;; This will return assertions of any length---we perform 476 | ;; no length-related indexing. 477 | (candidate-assertions (indexify pattern-head 0))))) 478 | 479 | (declare retract-specific-assertion) 480 | 481 | (defn retract-subsumed-assertions [assertion-pattern] 482 | "Retract the assertions entirely subsumed by `assertion-pattern`." 483 | (let [subsumed (get-subsumed-assertions assertion-pattern)] 484 | (doseq [assn subsumed] 485 | (retract-specific-assertion assn)) 486 | subsumed)) 487 | 488 | (comment ; Roll your own... 489 | (defn listing [statement-pattern] 490 | (doseq [assn (get-matching-head-assertions statement-pattern)] 491 | (pprint assn)))) 492 | 493 | (defn- retract-subsumed-head-predicate-arity-assertions [predicate arity statement-pattern] 494 | (let [predicate-assns (or (get @*assertions* predicate) {}) 495 | arity-assns (set (or (get predicate-assns arity) [])) 496 | retracted-assns (set (get-subsumed-head-assertions statement-pattern)) 497 | remaining-assns (set/difference arity-assns retracted-assns) 498 | actually-retracted-assns (vec (set/difference arity-assns remaining-assns)) 499 | remaining-assns (vec remaining-assns)] 500 | ;; FUTURE: Provide some useful feedback? 501 | (if-not (seq remaining-assns) 502 | (swap! *assertions* update-in [predicate] dissoc arity) 503 | (swap! *assertions* update-in [predicate] assoc arity remaining-assns)) 504 | (when-not (seq (get @*assertions* predicate)) 505 | (swap! *assertions* dissoc predicate)))) 506 | 507 | (defn- retract-subsumed-head-assertions-variadic [statement-pattern] 508 | (let [statement-pattern (vec statement-pattern) 509 | &-position (.indexOf statement-pattern '&)] 510 | (if (= &-position 0) 511 | ;; So, `(and (= arity 0) (?var? (second statement-pattern)))`. 512 | (reset! *assertions* {}) 513 | ;; Else we have a predicate. 514 | (let [predicate (get-predicate statement-pattern :unindexed)] 515 | (if (= predicate 'variable) 516 | (if (= &-position 1) 517 | (reset! *assertions* {}) 518 | ;; Drop greater arities of all predicates. 519 | (doseq [predicate (keys @*assertions*)] 520 | (retract-subsumed-head-assertions-variadic `(~predicate ~@(rest statement-pattern))))) 521 | (if (= &-position 1) 522 | ;; Drop all arities. 523 | (swap! *assertions* dissoc predicate) 524 | ;; Drop greater arities. 525 | (doseq [arity (filter #(>= % (dec &-position)) 526 | (keys (get @*assertions* predicate)))] 527 | (retract-subsumed-head-predicate-arity-assertions predicate arity statement-pattern)))))))) 528 | 529 | ;;; `statement-pattern` here is for assertions' head statements (only). 530 | (defn retract-subsumed-head-assertions [statement-pattern] 531 | "Retract the assertions subsumed by `statement-pattern`." 532 | ;; (println (cl-format nil "retract-subsumed-head-assertions: [~s]" statement-pattern)) 533 | (if (?var? statement-pattern) 534 | (reset! *assertions* {}) 535 | (if (some #{'&} statement-pattern) 536 | (retract-subsumed-head-assertions-variadic statement-pattern) 537 | (let [predicate (get-predicate statement-pattern :unindexed) 538 | arity (count (rest statement-pattern))] 539 | (if (or (= predicate 'variable) 540 | ;; Later, store complex-predicate assertions in a 541 | ;; trie. Now, this is our way to cover all the ground 542 | ;; ones. 543 | (= predicate 'non-ground-complex)) 544 | ;; Drop all subsumed statements of exhibited arity. 545 | (do (doseq [predicate (keys @*assertions*)] 546 | (let [statement-pattern `(~predicate ~@(rest statement-pattern))] 547 | (retract-subsumed-head-predicate-arity-assertions predicate arity statement-pattern))) 548 | ;; Handle an input non-ground-complex `statement-pattern`. 549 | (retract-subsumed-head-predicate-arity-assertions predicate arity statement-pattern)) 550 | (retract-subsumed-head-predicate-arity-assertions predicate arity statement-pattern)))))) 551 | 552 | ;;; Compare to Prolog "abolish". 553 | (defmacro --- [statement-pattern] 554 | "The macro version of function `retract-subsumed-head-assertions`." 555 | `(retract-subsumed-head-assertions (quote ~statement-pattern))) 556 | 557 | ;;; The above will retract any assertion whose head matches 558 | ;;; `statement-pattern`. To retract just a specific assertion, use 559 | ;;; `retract-specific-assertion`. 560 | 561 | ;;; Compare to Prolog "retract". 562 | (defn- retract-specific-assertion-predicate-arity [predicate arity assertion] 563 | (let [predicate-assns (or (get @*assertions* predicate) {}) 564 | arity-assns (or (get predicate-assns arity) []) 565 | ;; FUTURE: Warn, when appropriate, if `assertion` is missing. 566 | remaining-assns (remove #{assertion} arity-assns)] 567 | (if-not (seq remaining-assns) 568 | (swap! *assertions* update-in [predicate] dissoc arity) 569 | (swap! *assertions* update-in [predicate] assoc arity remaining-assns)) 570 | (when-not (seq (get @*assertions* predicate)) 571 | (swap! *assertions* dissoc predicate)))) 572 | 573 | (comment ; No productive use case. 574 | (defn- retract-specific-assertion-variable-head [assertion] 575 | ;; Variable-head assertions are not refined by arity (cover all arities). 576 | (let [assertions (or (get @*assertions* 'variable-head) {}) 577 | remaining-assns (remove assertions assertion)] 578 | (when-not (seq remaining-assns) 579 | (swap! *assertions* dissoc 'variable-head))))) 580 | 581 | (defn- retract-specific-assertion-variadic-head [assertion] 582 | (let [head (first assertion) 583 | predicate (get-predicate head :unindexed) 584 | &-position (.indexOf head '&)] 585 | (map (fn [arity] 586 | (retract-specific-assertion-predicate-arity predicate arity assertion)) 587 | (filter #(>= % (dec &-position)) 588 | (keys (get @*assertions* predicate)))))) 589 | 590 | (defn retract-specific-assertion [assertion] 591 | "Retract `assertion`, using `=` (so, respecting ?var symbols)." 592 | (let [head (first assertion)] 593 | (cond 594 | ;; No productive use case. 595 | ;; (or (?var? head) 596 | ;; (= '& (first head))) 597 | ;; (retract-specific-assertion-variable-head assertion)) 598 | 599 | (some #{'&} head) 600 | (retract-specific-assertion-variadic-head assertion) 601 | 602 | :else 603 | (let [predicate (get-predicate head :unindexed) 604 | arity (if (some #{'&} head) 605 | 'variadic 606 | (count (rest head)))] 607 | (retract-specific-assertion-predicate-arity predicate arity assertion))))) 608 | 609 | (defmacro -- [& statements] 610 | "The macro version of function `retract-specific-assertion`." 611 | `(retract-specific-assertion (quote ~statements))) 612 | 613 | ;;;;; Knowledge base ^^ 614 | ;;;;; ---------------------------------------------------------------- 615 | ;;;;; Matching (AKA unification), de-referencing, exporting i?vars: 616 | 617 | ;;; We need our own type here, to distinguish Prolog's [index ?var] 618 | ;;; pair from a user's similarly structured pair. (We don't need to 619 | ;;; do the same thing for our goals, exclusively internal to Prolog.) 620 | ;;; 621 | ;;; Indexed ?var: 622 | (defrecord ^:private I?var [index ?var]) 623 | 624 | ;;; To trace the full namespace, comment out these print functions. 625 | (defn- format-i?var [x] 626 | (read-string (cl-format nil "~a:~d" (:?var x) (:index x)))) 627 | 628 | (defmethod print-method I?var [x ^java.io.Writer writer] 629 | (print-method (format-i?var x) writer)) 630 | 631 | (defmethod print-dup I?var [x ^java.io.Writer writer] 632 | (print-dup (format-i?var x) writer)) 633 | 634 | (defmethod clojure.pprint/simple-dispatch I?var [x] 635 | (print (format-i?var x))) 636 | 637 | (defn- i?var? [expr] 638 | (= (type expr) clolog.core.I?var)) 639 | 640 | (defn unprint-i?var [e] 641 | "Convert an i?var's print representations to an actual i?var." 642 | (or (when (symbol? e) 643 | (let [e-name (name e)] 644 | (and (= \? (first e-name)) ; It's a ?var (should be an i?var). 645 | (when-let [pos (str/index-of e-name \:)] 646 | (let [index (read-string (subs e-name (inc pos))) 647 | ?var (read-string (subs e-name 0 pos))] 648 | (->I?var index ?var)))))) 649 | e)) 650 | 651 | (defn unprint-i?vars [expr] 652 | "Convert i?vars' print representations in `expr` to actual 653 | i?vars---making it easier to execute expressions copied from 654 | Clojure execution traces." 655 | (postwalk unprint-i?var expr)) 656 | 657 | ;;; Matches anything, binds nothing. 658 | (defn- anonymous-i?var? [e] 659 | (and (i?var? e) 660 | (let [var-string (name (:?var e))] 661 | (or (= "?" var-string) 662 | (= \_ (second var-string)))))) 663 | 664 | (defn- anonymous-?var? [e] 665 | (and (?var? e) 666 | (let [var-string (name e)] 667 | (or (= "?" var-string) 668 | (= \_ (second var-string)))))) 669 | 670 | ;;; Let's just use `(->I?var index ?var)`. 671 | ;;; (defn- make-I?var [index ?var] 672 | ;;; (->I?var index ?var)) 673 | 674 | (def ^:private none 'clolog.core/none) 675 | 676 | (defn- ?var-binding [bindings index ?var] 677 | (let [env (get bindings index)] 678 | (get env ?var none))) 679 | 680 | ;;; De-reference a ?var or a term (or a statement, ...). 681 | (defn- de-reference 682 | ([bindings term] 683 | (de-reference bindings term false)) 684 | ([bindings term unindexed?] 685 | (de-reference bindings term unindexed? 686 | (and (not unindexed?) 687 | (i?var? term) 688 | :de-referencing-i?var))) 689 | ([bindings term unindexed? de-referencing-i?var?] 690 | ;; Stop when you get to a non-?var or to a ?var with no binding. 691 | ;; Per the "push-up" strategy, we should never have to traverse 692 | ;; more than one hop of indirection here. 693 | (let [is-?var? (if unindexed? ?var? i?var?) 694 | var-binding (fn [the-var] 695 | (if unindexed? 696 | (get bindings the-var none) 697 | (let [[index ?var] (vals the-var)] 698 | (?var-binding bindings index ?var)))) 699 | val (if (is-?var? term) 700 | (var-binding term) 701 | term)] 702 | (cond (= val none) 703 | term 704 | 705 | (is-?var? val) 706 | (do 707 | ;; #dbg 708 | (if de-referencing-i?var? 709 | ;; In our "push-up" design, if you de-reference an 710 | ;; i?var to another i?var and the latter has a value, 711 | ;; that's the value you want. If no value, you just 712 | ;; want the i?var. 713 | (let [val-val (var-binding val)] 714 | (if (= val-val none) 715 | val 716 | val-val)) 717 | (de-reference bindings val unindexed?))) 718 | 719 | (and (or (seq? val) (vector? val)) 720 | (not (empty? val))) 721 | ;; `&` never is bound, directly, could be nested. 722 | (let [seq-result (if (= '& (first val)) 723 | (let [twoth (second val)] 724 | (if (is-?var? twoth) 725 | (let [twoth-binding (var-binding twoth)] 726 | (if (= twoth-binding none) 727 | `(~'& ~twoth) 728 | (if-not (is-?var? twoth-binding) 729 | ;; Get the value. 730 | (de-reference bindings twoth-binding unindexed?) 731 | ;; Retain `&`. 732 | `(~'& ~@(de-reference bindings twoth-binding unindexed?))))) 733 | ;; `(not (is-?var? twoth))` 734 | ;; De-reference, in case of transparent term. 735 | `(~(de-reference bindings twoth unindexed?)))) 736 | ;; `(not= '& (first val))`: Map normally. 737 | `(~(de-reference bindings (first val) unindexed?) 738 | ~@(de-reference bindings (rest val) unindexed?)))] 739 | (if (seq? val) seq-result (vec seq-result))) 740 | 741 | :else 742 | ;; We have hit a non-?var thing we don't traverse. 743 | val)))) 744 | 745 | ;;; Used in logic transform application. 746 | (defn- de-reference-unindexed [bindings term] 747 | (de-reference bindings term :unindexed)) 748 | 749 | ;;; We want to look inside only seqs and vectors---so can't use 750 | ;;; generic `walk-exprs` based on `postwalk`. 751 | (comment 752 | (defmacro walk-exprs [predicate handler expr] 753 | `(postwalk (fn [~'expr] 754 | (if (~predicate ~'expr) 755 | (~handler ~'expr) 756 | ~'expr)) 757 | ~expr))) 758 | 759 | (defn- walk-walkable [predicate handler expr] 760 | (if (or (seq? expr) (vector? expr)) 761 | (if (empty? expr) 762 | expr 763 | (if (predicate expr) 764 | (handler expr) 765 | (let [seq-result `(~(walk-walkable predicate handler (first expr)) 766 | ~@(walk-walkable predicate handler (rest expr)))] 767 | (if (seq? expr) seq-result (vec seq-result))))) 768 | (if (predicate expr) 769 | (handler expr) 770 | expr))) 771 | 772 | (defn- collect-terminals-if 773 | ;; `pred` is responsible for qualifying the type of `expr`. 774 | ([pred expr] 775 | (collect-terminals-if pred expr #{})) 776 | ([pred expr terminals] 777 | (pred expr) 778 | (conj terminals expr) 779 | 780 | (if (or (seq? expr) (vector? expr)) 781 | (if (empty? expr) 782 | terminals 783 | (set/union (collect-terminals-if pred (first expr) terminals) 784 | (collect-terminals-if pred (rest expr) terminals))) 785 | (if (pred expr) 786 | (conj terminals expr) 787 | terminals)))) 788 | 789 | (defn- i?vars-of [expr] 790 | (collect-terminals-if i?var? expr)) 791 | 792 | (defn- ?vars-of [expr] 793 | (collect-terminals-if ?var? expr)) 794 | 795 | (comment ; From an aborted/discarded indexing idea. 796 | ;; Unindexed. 797 | (defn- constants-of [expr] 798 | ;; Result includes the head constants of complex terms (not full 799 | ;; ground complex terms). 800 | (collect-terminals-if #(not (?var? %)) expr)) 801 | ) 802 | 803 | (defn- ground? 804 | ([expr] 805 | (not (seq (i?vars-of expr)))) 806 | ([expr unindexed?] 807 | (if unindexed? 808 | (not (seq (?vars-of expr))) 809 | (ground? expr)))) 810 | 811 | ;;; When exiting a successful assertion (see Search section), we need 812 | ;;; to process any exported ?vars (as defined in `architecture.md`). 813 | 814 | ;;; FUTURE: Support multiple parallel threads. 815 | (def ^:private ^:dynamic *unbound-?var-counter* (atom 0)) 816 | 817 | (defn- new-unbound-?var 818 | ([] 819 | (new-unbound-?var '?unbound)) 820 | ([root-symbol] 821 | (let [counter @*unbound-?var-counter*] 822 | (swap! *unbound-?var-counter* inc) 823 | (read-string (cl-format nil "~a-~d" root-symbol counter))))) 824 | 825 | (defn- register-unbound-?var [?var-renamings index term-?var] 826 | (let [renamed-i?var (if (re-matches #"\?unbound-\d*" (name term-?var)) 827 | ;; Respect existing (unique) name, update 828 | ;; index. 829 | (->I?var index (:?var term-?var)) 830 | (or (get ?var-renamings term-?var) 831 | (->I?var index (new-unbound-?var)))) 832 | ?var-renamings (assoc ?var-renamings term-?var renamed-i?var)] 833 | ?var-renamings)) 834 | 835 | (defn- update-?var-renamings [index term-i?vars ?var-renamings] 836 | (if (empty? term-i?vars) 837 | ?var-renamings 838 | (let [term-i?var (first term-i?vars) 839 | term-i?vars (rest term-i?vars) 840 | term-?var (:?var term-i?var) 841 | ?var-renamings (register-unbound-?var ?var-renamings 842 | index 843 | term-?var)] 844 | (update-?var-renamings index term-i?vars ?var-renamings)))) 845 | 846 | (defn- get-i?var-value [bindings i?var] 847 | (let [[index ?var] (vals i?var) 848 | env (get bindings index {}) 849 | binding (get env ?var none)] 850 | binding)) 851 | 852 | (defn- assoc-i?var-binding 853 | ([bindings i?var val?] 854 | (assoc-i?var-binding bindings i?var val? false)) 855 | ([bindings i?var val overwrite?] 856 | (let [[index ?var] (vals i?var) 857 | env (or (get bindings index) {}) 858 | env (let [existing (get env ?var none)] 859 | (if (or (= existing none) ; Respect (don't overwrite) user `nil`. 860 | (i?var? existing) 861 | overwrite?) 862 | (assoc env ?var val) 863 | env))] 864 | (assoc bindings index env)))) 865 | 866 | (defn- rename-exported-?vars 867 | [bindings reference-i?var assn-index update-val ?var-renamings] 868 | (if (or (seq? update-val) (vector? update-val)) 869 | ;; Replace i?vars at `reference-index` that are contained in complex 870 | ;; assertion terms and left unbound upon successful assertion 871 | ;; exit. (Any assertion ?vars that were bound matched the goal, 872 | ;; so can be ignored, as can any that were left unbound but were 873 | ;; not contained in complex terms.) 874 | (let [term update-val 875 | term-i?vars (i?vars-of term) 876 | ;; Retain only ?vars at assn-index. 877 | term-i?vars (filter #(= assn-index (:index %)) term-i?vars) 878 | reference-index (:index reference-i?var) 879 | ?var-renamings (update-?var-renamings reference-index 880 | term-i?vars 881 | ?var-renamings) 882 | renamed-term (walk-walkable i?var? 883 | #(or (get ?var-renamings (:?var %)) 884 | %) 885 | (de-reference bindings term))] 886 | (assoc-i?var-binding bindings reference-i?var renamed-term 887 | :overwrite)) 888 | bindings)) 889 | 890 | (defn- rename-unbound-?vars 891 | ([assn-index bindings] 892 | (let [goal-index (dec assn-index) 893 | goal-env (get bindings goal-index {}) 894 | ;; Ensure consistent renamings across exported ?var 895 | ;; occurrences, by recording these in `?var-renamings`. 896 | ?var-renamings {} 897 | bindings (rename-unbound-?vars assn-index 898 | goal-index 899 | bindings goal-env 900 | ?var-renamings)] 901 | bindings)) 902 | ([assn-index goal-index bindings goal-env ?var-renamings] 903 | (if (empty? goal-env) 904 | bindings 905 | (let [goal-binding (first goal-env) ; [?var val] 906 | goal-env (rest goal-env) 907 | goal-?var (first goal-binding) 908 | goal-val (second goal-binding) 909 | ;; Handle the i?var "push-up" strategy. 910 | reference-i?var (if (i?var? goal-val) 911 | goal-val 912 | (->I?var goal-index goal-?var)) 913 | update-val (if (i?var? goal-val) 914 | (get-i?var-value bindings goal-val) 915 | goal-val)] 916 | (let [bindings (rename-exported-?vars bindings 917 | reference-i?var 918 | assn-index 919 | update-val 920 | ?var-renamings)] 921 | (rename-unbound-?vars assn-index goal-index bindings goal-env 922 | ?var-renamings)))))) 923 | 924 | ;;; Goals always have indices lesser by 1 than the assertions they're 925 | ;;; unified with. Not so for `same` forms... 926 | ;;; 927 | ;;; In `evals?-from` form, we unify left- (reference) and 928 | ;;; right-hand (evaluated) subforms---not `goal-form`, 929 | ;;; `assn-form`. (misnomers, strictly) 930 | ;;; 931 | ;;; Called when at least one of `goal-form`, `assn-form` is an i?var. 932 | (defn- i?var-updated-bindings [bindings goal-form assn-form] 933 | (if (i?var? assn-form) 934 | (if-not (i?var? goal-form) 935 | ;; Write concrete `goal-form` to `assn-form` i?var. 936 | (assoc-i?var-binding bindings assn-form goal-form) 937 | ;; `(i?var? goal-form)` 938 | (let [goal-value (get-i?var-value bindings goal-form)] 939 | (if (= goal-value none) 940 | ;; Write the goal i?var to the assn i?var. 941 | ;; (Leave the goal i?var blank. We know nothing concrete, 942 | ;; yet.) 943 | (assoc-i?var-binding bindings assn-form goal-form) 944 | ;; For clarity, leaving this as an `if` with identical 945 | ;; actions, different comments. 946 | (if (i?var? goal-value) 947 | ;; There is already a (lesser-indexed) "reference" i?var 948 | ;; pointed to by the goal i?var. Push our value up the 949 | ;; stack by recording the reference i?var as our value. 950 | (assoc-i?var-binding bindings assn-form goal-value) 951 | ;; `(not (i?var? goal-value))` 952 | ;; Push a concrete value up, also. 953 | (assoc-i?var-binding bindings assn-form goal-value))))) 954 | ;; `(not (i?var? assn-form))` 955 | ;; We must have `(i?var? goal-form)`, to have been called. 956 | (let [goal-value (get-i?var-value bindings goal-form)] 957 | (if (= goal-value none) 958 | (assoc-i?var-binding bindings goal-form assn-form) 959 | ;; `(not= goal-value none)` 960 | ;; We must have `(i?var? goal-value)`. 961 | ;; Write assn-form to (lesser-indexed) goal i?var. 962 | (assoc-i?var-binding bindings goal-value assn-form))))) 963 | 964 | ;;; The symmetry here supports subsumption operations over the results 965 | ;;; of unindexed unification. 966 | (defn- updated-bindings [[env-a env-b] a b] 967 | (let [env-a (if (?var? a) 968 | (assoc env-a a b) 969 | env-a) 970 | env-b (if (?var? b) 971 | (assoc env-b b a) 972 | env-b)] 973 | [env-a env-b])) 974 | 975 | (defn- like-rest [seq-or-vec] 976 | (if (vector? seq-or-vec) 977 | (vec (rest seq-or-vec)) 978 | (rest seq-or-vec))) 979 | 980 | (comment 981 | ;;; Integrity check: 982 | (def check-indices? false) 983 | ) 984 | 985 | ;;; This has been helpful for simpler debugging, but it doesn't work 986 | ;;; with the Zebra test (or generally). 987 | (comment 988 | ;;; We always have a:goal b:assertion-head (both indexified), so we 989 | ;;; should have the asserted condition. 990 | (defn- check-unify-indices [a b] 991 | (let [a-i?vars (i?vars-of a) 992 | a-max-index (when (seq a-i?vars) 993 | (apply max (map :index a-i?vars))) 994 | b-i?vars (when a-max-index (i?vars-of b)) 995 | ;; We expect these indices all to be the same (`assn-index`). 996 | b-min-index (when (seq b-i?vars) 997 | (apply min (map :index b-i?vars)))] 998 | (when b-min-index 999 | (assert (<= a-max-index b-min-index))))) 1000 | ) 1001 | 1002 | (defn- unify 1003 | ([a b] ; Terms (or statements, assertions, ...). 1004 | (unify a b [{} {}])) 1005 | ([a b bindings] 1006 | (unify a b bindings false)) 1007 | ([a b bindings indexed?] 1008 | (let [is-?var? (if indexed? i?var? ?var?) 1009 | is-anonymous-?var? (if indexed? anonymous-i?var? anonymous-?var?) 1010 | updated (if indexed? i?var-updated-bindings updated-bindings)] 1011 | (comment 1012 | ;; Remove, upon QA. (Needed for `(same ?x ?x)` etc.) 1013 | (when (and indexed? check-indices?) 1014 | (check-unify-indices a b))) 1015 | ;; (do (pprint "unify:") (pprint bindings) (pprint a) (pprint b)) 1016 | (cond 1017 | ;; Discard any ?vars anonymous in input patterns (e.g., in 1018 | ;; `get-matching-head-assertions`). 1019 | (and (not indexed?) 1020 | (or (is-anonymous-?var? a) (is-anonymous-?var? b))) 1021 | bindings 1022 | 1023 | ;; Bind any ?vars. 1024 | (or (is-?var? a) (is-?var? b)) 1025 | (updated bindings a b) 1026 | 1027 | ;; Look inside vectors and sequences. Clojure considers 1028 | ;; like-content seqs and vectors to be =, so we unify them. 1029 | (and (sequential? a) (sequential? b)) ; Lists and vectors are sequential. 1030 | (let [[a-head a-tail] [(first a) (like-rest a)] 1031 | [b-head b-tail] [(first b) (like-rest b)]] 1032 | (cond 1033 | (and (= a []) (= b [])) ; Equivalently (e.g.): `(and (= a ()) (= b []))`. 1034 | bindings 1035 | 1036 | (and (= a-head '&) (= b-head '&)) 1037 | (unify a-tail b-tail bindings indexed?) 1038 | 1039 | (= a-head '&) 1040 | (unify (first a-tail) ; `(& ?rest)` ==> `?rest` 1041 | b bindings indexed?) 1042 | 1043 | (= b-head '&) 1044 | (unify a (first b-tail) bindings indexed?) 1045 | 1046 | (or (= a []) (= b [])) 1047 | nil 1048 | 1049 | :else 1050 | (let [bindings (unify a-head b-head bindings indexed?)] 1051 | (when bindings 1052 | (unify (de-reference bindings a-tail (not indexed?)) 1053 | (de-reference bindings b-tail (not indexed?)) 1054 | bindings indexed?))))) 1055 | 1056 | ;; Treat anything else as atomic. 1057 | :else 1058 | (when (= a b) 1059 | bindings))))) 1060 | 1061 | (defn- i?var-unify [a b bindings] 1062 | (unify a b bindings :indexed)) 1063 | 1064 | ;;;;; Unification ^^ 1065 | ;;;;; ---------------------------------------------------------------- 1066 | ;;;;; Answer processing: 1067 | 1068 | (def ^:private ^:dynamic *answers*) 1069 | (def ^:private ^:dynamic *answer-template*) 1070 | (def ^:private ^:dynamic *query-i?vars*) 1071 | (def ^:dynamic *answer-count-limit* 1072 | "When truthy, terminate query execution upon having recorded (positive 1073 | integer) `*answer-count-limit*` answers." 1074 | nil) 1075 | (def ^:private ^:dynamic *answers-countdown*) 1076 | (def ^:dynamic *discard-subsumed-answers* 1077 | "When truthy, during query execution discard answers subsumed by other 1078 | answers." 1079 | true) 1080 | 1081 | ;;; The following checks won't work on answers including ?var-bearing 1082 | ;;; maps or sets. They all assume that `a` and `b` unify, per `env-a` 1083 | ;;; and `env-b` (which considers only seqs and vecs). 1084 | 1085 | ;;; You're subsumed if every one of your ?vars binds a ?var that binds 1086 | ;;; you. (There could be other ?vars binding your non-?var parts.) 1087 | (defn- subsumes? [env-a env-b] ; Unindexed. 1088 | (every? (fn [[?var-b val-b]] 1089 | (= (get env-a val-b) ?var-b)) 1090 | env-b)) 1091 | 1092 | (defn- duplicates? [env-a env-b] 1093 | (and (subsumes? env-a env-b) 1094 | (subsumes? env-b env-a))) 1095 | 1096 | (defn- adjudication-status [new existing] 1097 | (let [envs (unify new existing)] 1098 | (if-not envs 1099 | :different 1100 | ;; Else they match. 1101 | (let [[env-new env-existing] envs 1102 | new-subsumes? (subsumes? env-new env-existing) 1103 | existing-subsumes? (subsumes? env-existing env-new) 1104 | duplicates? (and new-subsumes? existing-subsumes?)] 1105 | (if duplicates? 1106 | :equivalent 1107 | (if existing-subsumes? 1108 | :subsumes 1109 | (if new-subsumes? 1110 | :subsumed 1111 | ;; Else they unify, without subsumption. 1112 | :disjoint))))))) 1113 | 1114 | (defn- remove-subsumed-answers [answers adjudications] 1115 | (vec (mapcat (fn [answer adjudication] 1116 | (if (= adjudication :subsumed) 1117 | [] 1118 | [answer])) 1119 | answers 1120 | adjudications))) 1121 | 1122 | (defn- record-answer [answer] 1123 | (swap! *answers* conj answer) 1124 | (when *answers-countdown* 1125 | (swap! *answers-countdown* dec))) 1126 | 1127 | (defn- adjudicate-answer [answer] 1128 | ;; Does `answer` unify with any existing answer? If so, then... 1129 | ;; 1130 | ;; - Duplicate answer if ?vars get bound to ?vars, only (technicaly, 1131 | ;; subsumes both ways). 1132 | ;; 1133 | ;; - One-way ?var binding is strict subsumption. If by new answer, 1134 | ;; how many existing answers are subsumed? 1135 | ;; 1136 | ;; - Unique answer if ?vars get bound to non-?vars in both 1137 | ;; directions. 1138 | ;; 1139 | ;; If not, then answer is unique. 1140 | ;; 1141 | ;; We must check existing answers one at a time. (Consider 1142 | ;; standardizing answers' ?vars, storing all existing answers in a 1143 | ;; trie? This would work for duplicate checking, not for strict 1144 | ;; subsumption.) 1145 | (let [answers @*answers*] 1146 | (if (empty? answers) 1147 | (do (record-answer answer) 1148 | :different) 1149 | (let [adjudications (map #(adjudication-status answer %) 1150 | answers)] 1151 | (if (some #(= % :equivalent) adjudications) 1152 | :equivalent ; Discard (leave *answers* as is). 1153 | (if-not *discard-subsumed-answers* 1154 | ;; Not a duplicate and not checking subsumption. 1155 | (record-answer answer) 1156 | ;; Else check subsumption. 1157 | (if (some #(= % :subsumes) adjudications) 1158 | :subsumed ; Discard subsumed answer. 1159 | (if (some #(= % :subsumed) adjudications) 1160 | ;; Remove subsumed existing answers... 1161 | (let [former-count (count answers) 1162 | answers (remove-subsumed-answers answers 1163 | adjudications) 1164 | present-count (count answers) 1165 | count-reduction (- former-count present-count) 1166 | ;; ...and add the new one. 1167 | answers (conj answers answer)] 1168 | (reset! *answers* answers) 1169 | (when *answers-countdown* 1170 | (swap! *answers-countdown* - count-reduction)) 1171 | ;; Return the number subsumed. 1172 | count-reduction) 1173 | ;; Else nothing to report. (Treat `:disjoint` like 1174 | ;; `:different`.) 1175 | (do (record-answer answer) 1176 | :different))))))))) 1177 | 1178 | (def ^:dynamic *leash* 1179 | "When truthy, during query execution, write informative reports to 1180 | standard output." 1181 | false) 1182 | 1183 | (defn- handle-answer [bindings] 1184 | ;; Not penetrating sets, maps, ... Consider walking? 1185 | (let [answer (de-reference bindings *answer-template*) 1186 | answer (unindexify answer 0)] 1187 | (let [adjudication (adjudicate-answer answer)] 1188 | ;; Display answer info. 1189 | (when *leash* 1190 | (case adjudication 1191 | nil (println "Recorded answer:" answer) ; Happens when not discarding subsumed. 1192 | :different (println "Recorded answer:" answer) 1193 | :equivalent (println "Duplicate answer (not recorded):" answer) 1194 | :subsumed (println "Subsumed answer (not recorded):" answer) 1195 | ;; FUTURE: Say which answers were discarded? Store them somewhere? 1196 | (println (cl-format nil 1197 | "Recorded subsuming answer (discarded ~d subsumed answer(s)): " 1198 | adjudication) 1199 | answer)))))) 1200 | 1201 | ;;;;; Answer extraction ^^ 1202 | ;;;;; ---------------------------------------------------------------- 1203 | ;;;;; Search---leashing, stack machine, querying: 1204 | 1205 | (comment ; When we were using Riddley, before replacing that with 1206 | ; `walk-walkable`: 1207 | ;; In order to quote symbols (or whatever) for export from logic to 1208 | ;; Lisp, we need a version of `quote` that our walker will traverse 1209 | ;; and (per specs in the next two functions) not macroexpand. 1210 | (defmacro kwote [x] (list 'quote x))) 1211 | 1212 | (defn- indexify [thing index] 1213 | ;; It's nice for us that Riddley won't penetrate our i?vars. 1214 | ;; It's not so nice that Riddley expands all except specified macros. 1215 | (walk-walkable ?var? #(->I?var index %) thing)) 1216 | 1217 | (defn- unindexify [thing index] 1218 | (walk-walkable (fn [expr] 1219 | (and (i?var? expr) 1220 | (= (:index expr) index))) 1221 | #(:?var %) 1222 | thing)) 1223 | 1224 | (defn- leash-pad [special-form-depth index] 1225 | (apply str (repeat (+ index special-form-depth) 1226 | \space))) 1227 | 1228 | (defn- leash-prefix [special-form-depth index] 1229 | (let [pad (leash-pad special-form-depth index) 1230 | prefix (str pad index \.)] 1231 | prefix)) 1232 | 1233 | (defn- goal-signature 1234 | ([goal] 1235 | (if-not (?var? goal) 1236 | (cl-format nil "`~s`/~d:" (first goal) (dec (count goal))) 1237 | (cl-format nil "`~s`:" goal))) 1238 | ([goal remaining-assertion-count] 1239 | (if-not (?var? goal) 1240 | (cl-format nil "`~s`/~d (~d matching assertions remain):" 1241 | (first goal) (dec (count goal)) remaining-assertion-count) 1242 | (cl-format nil "`~s` (~d matching assertions remain):" 1243 | goal remaining-assertion-count)))) 1244 | 1245 | (defn- leash-->?-transform [special-form-depth index] 1246 | (when *leash* 1247 | (let [pad (leash-pad special-form-depth index)] 1248 | (println pad "Applied ->? transform")))) 1249 | 1250 | (def ^:dynamic *pprint-leash-statements* 1251 | "When truthy, `\"Entering\"`, `\"Succeeded\"`, and `\"Failed\"` leash 1252 | reports pprint (vs. print) statement content, starting on a new 1253 | line." 1254 | false) 1255 | 1256 | (defn- pprinted-indented [expr indentation] 1257 | ;; Edit indentation into pprinted statement. Adpated from... 1258 | ;; `https://ask.clojure.org/index.php/11796/there-pprint-start-initial-indentation-whole-output-indented`. 1259 | (let [indent-str (apply str (repeat indentation \space)) 1260 | ;; Temporarily add opening newline. 1261 | pprinted-expr (cl-format nil "~%~a" (with-out-str (pprint expr))) 1262 | new-margin (- pprint/*print-right-margin* indentation) 1263 | pprinted-expr (binding [pprint/*print-right-margin* new-margin] 1264 | (apply str (map #(if (= \newline %) (str \newline indent-str) %) 1265 | pprinted-expr))) 1266 | ;; Lose opening and trailing newlines. 1267 | pprinted-expr (subs pprinted-expr 1) 1268 | pprinted-expr (subs pprinted-expr 0 (- (count pprinted-expr) 1269 | indentation))] 1270 | pprinted-expr)) 1271 | 1272 | (defn- print-leash-report [prefix message signature statement] 1273 | (if *pprint-leash-statements* 1274 | (let [pprinted-statement (pprinted-indented statement (inc (count prefix)))] 1275 | (println prefix message signature) 1276 | (println pprinted-statement)) 1277 | (println prefix message signature 1278 | (cl-format nil "~s" statement)))) 1279 | 1280 | (defn- leash-assertion-success [special-form-depth index head bindings] 1281 | (when (and head *leash*) ; Top-level query has no head. 1282 | (let [prefix (leash-prefix special-form-depth index) 1283 | head (de-reference bindings head) 1284 | signature (goal-signature head)] 1285 | (print-leash-report prefix "Succeeded" signature head)))) 1286 | 1287 | ;;; Disabled (not maintained). 1288 | (defn- leash-assertion-body [special-form-depth assn-index head body goal bindings] 1289 | (comment ; Disable. 1290 | (when (and goal *leash*) 1291 | (let [[bindings> bindings<] bindings 1292 | ;; goal-prefix (leash-prefix (inc assn-index)) 1293 | assn-prefix (leash-prefix special-form-depth assn-index)] 1294 | ;; (println assn-prefix "bindings>:" bindings>) 1295 | ;; (println assn-prefix "bindings<:" bindings<) 1296 | (if head 1297 | (println assn-prefix "Working on goal" 1298 | (cl-format nil "~s:" goal) 1299 | (de-reference bindings goal)) 1300 | ;; Nothing to de-reference at top level. 1301 | (println assn-prefix "Working on goal" goal)) 1302 | (println assn-prefix "Remaining goals:" 1303 | ;; Filter out private goals. 1304 | (remove #(private-built-in-special-head? (first %)) 1305 | (de-reference bindings body))))))) 1306 | 1307 | (defn- leash-assertion-head [special-form-depth assn-index head goal bindings] 1308 | (when (and head goal *leash*) 1309 | (let [; goal-prefix (leash-prefix (inc assn-index)) 1310 | assn-prefix (leash-prefix special-form-depth assn-index)] 1311 | ;; (println goal-prefix "bindings>:" bindings>) 1312 | ;; (println goal-prefix "bindings<:" bindings<) 1313 | (println assn-prefix "Matched head" 1314 | (cl-format nil "~s:" head) 1315 | (cl-format nil "~s" (de-reference bindings head)))))) 1316 | 1317 | (defn- leash-assertion-backtracking [special-form-depth index goal bindings 1318 | remaining-assertion-count] 1319 | (when *leash* 1320 | (let [prefix (leash-prefix special-form-depth index) 1321 | goal (de-reference bindings goal) 1322 | signature (goal-signature goal remaining-assertion-count)] 1323 | (print-leash-report prefix "Backtracking into" signature goal)))) 1324 | 1325 | (defn- leash-failure [special-form-depth index goal bindings] 1326 | (when *leash* 1327 | (let [prefix (leash-prefix special-form-depth index) 1328 | goal (de-reference bindings goal) 1329 | signature (goal-signature goal)] 1330 | (print-leash-report prefix "Failed" signature goal)))) 1331 | 1332 | (defn- leash-goal [special-form-depth index goal bindings] 1333 | (when (and goal *leash*) 1334 | (let [prefix (leash-prefix special-form-depth index) 1335 | goal (de-reference bindings goal) 1336 | signature (goal-signature goal)] 1337 | (print-leash-report prefix "Entering" signature goal)))) 1338 | 1339 | (defn- standard-split 1340 | "Split `s` at whitespace chars, returning a vec of (unnormalized) 1341 | tokens." 1342 | [s] 1343 | (str/split (str/triml s) #"\s+")) 1344 | 1345 | (defn- backtracking-leash-report? [leash-report index] 1346 | (and (string? leash-report) 1347 | (.contains leash-report (str index ". " "Backtracking")))) 1348 | 1349 | ;;; A "special" stack frame (for a goal headed by a special predicate) 1350 | ;;; will not have assertions. 1351 | 1352 | (defrecord ^:private 1353 | StackFrame [leash-report ; String. 1354 | head ; The statement head associated (via statement) with `goals`. 1355 | goal-index 1356 | goal 1357 | assertion-matches ; Remaining assertion matches. 1358 | special-form-stack ; Per assertion (or query) goals. 1359 | special-form-depth ; Global/stack-wide.* 1360 | body-remainders ; Body continuations. FIFO. 1361 | bindings 1362 | ;; Next assertion, or (if none) previous goal, or (if none) see caller. 1363 | continuation ; For failure. 1364 | ]) 1365 | ;;; * This accounts for depth across all frames (including 1366 | ;;; parents)---not just within an assertion. Consider `(or (and 1367 | ;;; *)*)`, where any embedded may in its body invoke 1368 | ;;; a similar conditional. 1369 | 1370 | ;;; We have some macros that let us avoid a lot of typing/source code 1371 | ;;; repetition. The functions that use these macros all respect the 1372 | ;;; local names established here. 1373 | 1374 | (defmacro ^:private with-stack-frame [stack-frame & body] 1375 | `(let [~'leash-report (:leash-report ~stack-frame) 1376 | ~'head (:head ~stack-frame) 1377 | ~'goal-index (:goal-index ~stack-frame) 1378 | ~'goal (:goal ~stack-frame) 1379 | ~'assn-index (inc (:goal-index ~stack-frame)) 1380 | ~'assertion-matches (:assertion-matches ~stack-frame) 1381 | ~'special-form-stack (:special-form-stack ~stack-frame) 1382 | ~'special-form-depth (:special-form-depth ~stack-frame) 1383 | ~'body-remainders (:body-remainders ~stack-frame) 1384 | ~'bindings (:bindings ~stack-frame) 1385 | ~'continuation (:continuation ~stack-frame)] 1386 | ~@body)) 1387 | 1388 | (defmacro ^:private gather-stack-frame [] 1389 | '(->StackFrame leash-report 1390 | head 1391 | goal-index 1392 | goal 1393 | assertion-matches 1394 | special-form-stack 1395 | special-form-depth 1396 | body-remainders 1397 | bindings 1398 | continuation)) 1399 | 1400 | (defrecord ^:private 1401 | BodyRemainder [capos ; Tells us which `process-...` functions have written here. 1402 | head ; The head associated (via statement) with this body. 1403 | body-index 1404 | goals ; Remaining goals. 1405 | ;; A stack of the (complete) logic forms 1406 | ;; we've visited up to this point, in 1407 | ;; processing the present assertion. 1408 | special-form-stack 1409 | special-form-depth]) 1410 | 1411 | (defmacro ^:private with-body-remainder [body-remainder & body] 1412 | `(let [~'capos (:capos ~body-remainder) 1413 | ~'head (:head ~body-remainder) 1414 | ~'body-index (:body-index ~body-remainder) 1415 | ;; Drop (stale) entries in `bindings` beyond `body-index`. 1416 | ~'bindings (into {} (filter #(<= (first %) ~'body-index) ~'bindings)) 1417 | ~'goals (:goals ~body-remainder) 1418 | ~'special-form-stack (:special-form-stack ~body-remainder) 1419 | ~'special-form-depth (:special-form-depth ~body-remainder)] 1420 | ~@body)) 1421 | 1422 | (defmacro ^:private gather-body-remainder [] 1423 | '(->BodyRemainder capos head body-index goals special-form-stack special-form-depth)) 1424 | 1425 | ;;; This requires `body-remainders` and `goals` to have values. 1426 | (defmacro ^:private gathering-body-remainder [& body] 1427 | `(let [~'capos (cons ~'capo ~'capos) 1428 | ~'body-remainder (when (seq ~'goals) 1429 | (gather-body-remainder)) 1430 | ~'body-remainders (if ~'body-remainder 1431 | (cons ~'body-remainder ~'body-remainders) 1432 | ~'body-remainders)] 1433 | ~@body)) 1434 | 1435 | ;;; Should be private in production. 1436 | (def ^:private debugging-stack? nil) 1437 | 1438 | (declare process-stack-frame) 1439 | 1440 | ;;; FUTURE: Add indices within open-arity forms: `and`, `or`, `case[*, !]`. 1441 | (defn- operator-leash-prefix [special-form-depth index special-form-stack] 1442 | (let [logic-path (reverse (map first special-form-stack)) 1443 | pad (leash-pad special-form-depth index)] 1444 | (str pad (cl-format nil "~d. ~s:" index logic-path)))) 1445 | 1446 | (defn- leash-special [special-form-depth index verb special-form-stack bindings] 1447 | (when *leash* 1448 | (let [prefix (operator-leash-prefix special-form-depth index special-form-stack) 1449 | logic-form (de-reference bindings (first special-form-stack))] 1450 | (if *pprint-leash-statements* 1451 | (let [indentation (inc (count prefix)) 1452 | pprinted-logic-form (pprinted-indented logic-form indentation)] 1453 | (println prefix (cl-format nil "~a..." verb)) 1454 | (println pprinted-logic-form)) 1455 | (println prefix verb (cl-format nil "~s" logic-form)))))) 1456 | 1457 | ;;; We don't need `leash-special "Backtracking into"` for `and`. We'll 1458 | ;;; backtrack on the conjuncts, individually (when these have `or` or 1459 | ;;; assertion predicates). 1460 | 1461 | ;;; In arriving here, we've not disturbed `body-remainders`. So, we 1462 | ;;; could just append the conjuncts. However, for leashing purposes, 1463 | ;;; we'd like to know when we're done with the `and`. Such 1464 | ;;; considerations are pervasive among these `process-...` functions. 1465 | (defn- process-and-frame [stack-frame] 1466 | (when debugging-stack? 1467 | (pprint ["process-and-frame" stack-frame])) 1468 | (with-stack-frame stack-frame 1469 | (let [and-form goal 1470 | operator (first and-form) 1471 | capo (cons operator (map first (rest and-form))) 1472 | and-goals (rest and-form) ; Lose operator. 1473 | goal (first and-goals) ; Gathered into stack frame. 1474 | ;; Ok, even if not looking at a predicate goal: 1475 | assertion-matches (goal-assertion-matches assn-index goal bindings) 1476 | and-goals (rest and-goals) 1477 | stack-frame-special-form-stack special-form-stack 1478 | stack-frame-special-form-depth special-form-depth 1479 | continuation (if (= operator 'and) 1480 | (assoc continuation :leash-report 1481 | (str (with-out-str (leash-special special-form-depth 1482 | goal-index "Failed" 1483 | special-form-stack 1484 | bindings)) 1485 | (:leash-report continuation))) 1486 | continuation)] 1487 | (when (= operator 'and) 1488 | ;; Original source form---not our repetition (`and...`). 1489 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings)) 1490 | (let [body-remainder (or (first body-remainders) 1491 | (let [capos () 1492 | goals nil 1493 | body-index goal-index] 1494 | (gather-body-remainder))) 1495 | body-remainders (rest body-remainders)] 1496 | (if (seq goal) ; `and-form` was not degenerate, on entry. 1497 | ;; Add conjunction remainder to this assertion's body 1498 | ;; remainder. 1499 | (with-body-remainder body-remainder 1500 | (let [operator (if (= operator 'and) 1501 | 'and... 1502 | operator) ; Works for `sys-and`. 1503 | and-form `(~operator ~@and-goals) 1504 | goals `(~and-form ~@goals) 1505 | special-form-stack stack-frame-special-form-stack 1506 | special-form-depth stack-frame-special-form-depth] 1507 | (gathering-body-remainder 1508 | #(process-stack-frame (gather-stack-frame))))) 1509 | ;; Empty conjunction---degenerate on entry. Forget this 1510 | ;; `and` form and move on to other goals of assertion. 1511 | ;; Compare to `succeed-simple-special-form`... 1512 | (do (when-not (= operator 'sys-and) 1513 | (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings)) 1514 | (if (seq body-remainder) 1515 | (with-body-remainder body-remainder 1516 | (let [capos (cons capo capos) 1517 | goal (first goals) 1518 | goal-index body-index 1519 | assn-index (inc goal-index) 1520 | assertion-matches (goal-assertion-matches assn-index goal bindings) 1521 | goals (rest goals) ; Gathered into body remainder. 1522 | ;; FYI: continuation continuation 1523 | special-form-stack (if (= operator 'and...) 1524 | (rest special-form-stack) 1525 | special-form-stack) 1526 | special-form-depth (if (= operator 'and...) 1527 | (dec special-form-depth) 1528 | special-form-depth) 1529 | body-remainder (gather-body-remainder) 1530 | body-remainders (cons body-remainder body-remainders)] 1531 | #(process-stack-frame (gather-stack-frame)))) 1532 | #(process-stack-frame continuation)))))))) 1533 | 1534 | (defn- process-or-frame [stack-frame] 1535 | (when debugging-stack? 1536 | (pprint ["process-or-frame" stack-frame])) 1537 | (with-stack-frame stack-frame 1538 | (let [or-form goal 1539 | operator (first or-form) 1540 | capo (cons operator (map first (rest or-form))) 1541 | or-goals (rest or-form) ; Lose operator. 1542 | goal (first or-goals) ; Gathered into stack frame. 1543 | ;; `nil`, if not looking at a predicate goal: 1544 | assertion-matches (when-not assertion-matches ; Respect an empty coll. 1545 | (goal-assertion-matches assn-index goal bindings)) 1546 | or-goals (rest or-goals) 1547 | outer-special-form-stack special-form-stack 1548 | outer-special-form-depth special-form-depth 1549 | or-form (when goal 1550 | ;; Restore `or...` (our repetition). 1551 | (cons 'or... or-goals)) 1552 | continuation (if or-form 1553 | (let [goal or-form 1554 | assertion-matches nil] 1555 | (gather-stack-frame)) 1556 | continuation)] 1557 | (if (= operator 'or) 1558 | ;; Original source form---not our repetition (`or...`). 1559 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1560 | (when (seq goal) 1561 | (leash-special special-form-depth goal-index "Backtracking into" special-form-stack bindings))) 1562 | (if (seq goal) 1563 | (if (seq body-remainders) 1564 | (let [body-remainder (first body-remainders) 1565 | body-remainders (rest body-remainders) 1566 | leash-report (if (= operator 'or) 1567 | (str (with-out-str 1568 | (leash-special 1569 | outer-special-form-depth 1570 | goal-index "Succeeded" 1571 | outer-special-form-stack bindings)) 1572 | leash-report) 1573 | leash-report) 1574 | body-remainder (assoc body-remainder :leash-report leash-report) 1575 | body-remainders (cons body-remainder body-remainders)] 1576 | #(process-stack-frame (gather-stack-frame))) 1577 | #(process-stack-frame (gather-stack-frame))) 1578 | ;; We have an empty disjunction. Fail. 1579 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1580 | #(process-stack-frame continuation)))))) 1581 | 1582 | (defmacro ^:private process-answer-and-continue [] 1583 | `(do (handle-answer ~'bindings) 1584 | #(process-stack-frame ~'continuation))) 1585 | 1586 | ;;; `and`, `or` are too idiomatic for this. 1587 | (defmacro ^:private succeed-simple-special-form [] 1588 | `(let [~'body-remainder (first ~'body-remainders)] 1589 | (if (seq ~'body-remainder) 1590 | (with-body-remainder ~'body-remainder 1591 | (let [~'body-remainders (rest ~'body-remainders) 1592 | ~'goal (first ~'goals) 1593 | ~'goals (rest ~'goals)] 1594 | (gathering-body-remainder 1595 | #(process-stack-frame (gather-stack-frame))))) 1596 | #(process-answer-and-continue)))) 1597 | 1598 | (defn- process-fail-first-frame [stack-frame] 1599 | (when debugging-stack? 1600 | (pprint ["process-fail-first-frame" stack-frame])) 1601 | (with-stack-frame stack-frame 1602 | (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1603 | #(process-stack-frame continuation))) 1604 | 1605 | (defn- process-succeed-first-frame [stack-frame] 1606 | (when debugging-stack? 1607 | (pprint ["process-succeed-first-frame" stack-frame])) 1608 | (with-stack-frame stack-frame 1609 | (leash-special special-form-depth goal-index "Succeeded, cutting" special-form-stack bindings) 1610 | (let [capo 'succeed-first 1611 | ;; leash-report "" 1612 | continuation (second goal)] 1613 | ;; Specialization of... 1614 | ;; (succeed-simple-special-form) 1615 | (let [body-remainder (first body-remainders)] 1616 | (if (seq body-remainder) 1617 | (with-body-remainder body-remainder 1618 | (let [special-form-stack (rest special-form-stack) 1619 | ;; ^^ Lose the `if` form we're succeeding from. vv 1620 | special-form-depth (dec special-form-depth) 1621 | body-remainders (rest body-remainders) 1622 | goal (first goals) 1623 | goals (rest goals)] 1624 | (gathering-body-remainder 1625 | #(process-stack-frame (gather-stack-frame))))) 1626 | #(process-answer-and-continue)))))) 1627 | 1628 | ;;; FUTURE: Document: Note that "cut" renders ineffective (at least, 1629 | ;;; potentially wasteful---ultimately disregarded) "or" parallelism 1630 | ;;; within the scope of its choice point. 1631 | (defn- process-first-frame [stack-frame] 1632 | (when debugging-stack? 1633 | (pprint ["process-first-frame" stack-frame])) 1634 | (with-stack-frame stack-frame 1635 | (let [capo 'first 1636 | first-goal (second goal) 1637 | ;; `first` continuation frame: 1638 | goal '(fail-first) 1639 | ;; Already so: assertion-matches nil 1640 | continuation (gather-stack-frame) 1641 | ;; `first` content frame: 1642 | goal first-goal 1643 | assertion-matches (goal-assertion-matches (inc goal-index) goal bindings) 1644 | body-remainder (first body-remainders) 1645 | capos (:capos body-remainder) 1646 | goals `((~'succeed-first ~continuation) 1647 | ~@(:goals body-remainder)) 1648 | body-index goal-index 1649 | body-remainders (cons (gather-body-remainder) (rest body-remainders)) 1650 | body-index goal-index] 1651 | (leash-special special-form-depth goal-index "Entering first" special-form-stack bindings) 1652 | #(process-stack-frame (gather-stack-frame))))) 1653 | 1654 | ;;; We employ several pseudo-frames for `if`, towards managing 1655 | ;;; leashing. Perhaps simpler (idea): Make process-stack-frame deal 1656 | ;;; with leash messages directly, rather than embedding them in stack 1657 | ;;; frames. 1658 | 1659 | (defn- process-fail-if-frame [stack-frame] 1660 | (when debugging-stack? 1661 | (pprint ["process-fail-if-frame" stack-frame])) 1662 | (with-stack-frame stack-frame 1663 | (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1664 | #(process-stack-frame continuation))) 1665 | 1666 | (defn- process-succeed-if-frame [stack-frame] 1667 | (when debugging-stack? 1668 | (pprint ["process-succeed-if-frame" stack-frame])) 1669 | (with-stack-frame stack-frame 1670 | (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1671 | (let [capo 'succeed-if] 1672 | ;; Specialization of... 1673 | ;; (succeed-simple-special-form) 1674 | (let [body-remainder (first body-remainders)] 1675 | (if (seq body-remainder) 1676 | (with-body-remainder body-remainder 1677 | (let [special-form-stack (rest special-form-stack) 1678 | ;; ^^ Lose the `if` form we're succeeding from. vv 1679 | special-form-depth (dec special-form-depth) 1680 | body-remainders (rest body-remainders) 1681 | goal (first goals) 1682 | goals (rest goals)] 1683 | (gathering-body-remainder 1684 | #(process-stack-frame (gather-stack-frame))))) 1685 | #(process-answer-and-continue)))))) 1686 | 1687 | ;;; Unpile piled continuations, post-slice. 1688 | (defn- process-else-frame [stack-frame] 1689 | (when debugging-stack? 1690 | (pprint ["process-else-frame" stack-frame])) 1691 | (with-stack-frame stack-frame 1692 | ;; FUTURE: Have leash print at most the else branch. 1693 | (leash-special special-form-depth goal-index "Taking 'else' branch of" special-form-stack bindings) 1694 | (let [capo 'else 1695 | goal (second goal) ; Lose `else`. 1696 | assertion-matches (goal-assertion-matches (inc goal-index) goal bindings) 1697 | body-remainder (first body-remainders) 1698 | capos (:capos body-remainder) 1699 | goals (cons '(succeed-if) (:goals body-remainder)) 1700 | body-remainders (rest body-remainders) 1701 | body-index goal-index] 1702 | (gathering-body-remainder 1703 | #(process-stack-frame (gather-stack-frame)))))) 1704 | 1705 | (defn- unpile-continuations [pile stack-frame] 1706 | (if (not (seq pile)) 1707 | stack-frame 1708 | (unpile-continuations (pop pile) 1709 | (assoc (peek pile) :continuation stack-frame)))) 1710 | 1711 | (comment 1712 | "FUTURE: Better idea (?): 1713 | [Optional: Start using vec (rather than nested linked list) for continuations. 1714 | We will be conjing to vec end.] 1715 | Store cut-frame index in `drop-else` statement. 1716 | If you don't find it there, it's already gone. 1717 | If you do find it, slice it out. 1718 | Constant time---no more searching.") 1719 | (defn- splice-out-continuation 1720 | ([continuation cut-frame] 1721 | (let [dropped (splice-out-continuation continuation cut-frame [])] 1722 | (if (= dropped :missing) 1723 | continuation ; The cut frame already was dropped. 1724 | dropped))) ; We've just cut it here. 1725 | ;; Toss stack frames on a pile, until we find the one that has our 1726 | ;; continuation we want to drop. 1727 | ([continuation 1728 | cut-frame 1729 | pile] ; Reversed vec of visited stack frames. 1730 | (if (:final continuation) 1731 | ;; FUTURE: This treatment is inefficient. Use "better idea," 1732 | ;; above, to avoid memory leak exposure in a TRO situation. 1733 | :missing ; We've already dropped this continuation. 1734 | (if (identical? continuation cut-frame) 1735 | ;; Reverse the pile, stacking back onto continuation after 1736 | ;; slicing out the one dropped. 1737 | (unpile-continuations 1738 | pile 1739 | ;; Slice out the `else` continuation. 1740 | (:continuation continuation)) 1741 | (splice-out-continuation (:continuation continuation) 1742 | cut-frame 1743 | (conj pile continuation)))))) 1744 | 1745 | (defn- process-drop-else-frame [stack-frame] 1746 | (when debugging-stack? 1747 | (pprint ["process-drop-else-frame" stack-frame])) 1748 | (with-stack-frame stack-frame 1749 | (let [capo 'drop-else 1750 | else-frame (second goal) 1751 | ;; Unnecessary: assertion-matches nil 1752 | continuation (splice-out-continuation continuation else-frame) 1753 | body-remainder (first body-remainders) ; Has at least `(succeed-if)`. 1754 | capos (:capos body-remainder) 1755 | goal '(succeed-if) ; Simplify `(sys-and (succeed-if))`. 1756 | goals (rest (:goals body-remainder)) 1757 | body-remainders (rest body-remainders) 1758 | body-index goal-index] 1759 | (gathering-body-remainder 1760 | #(process-stack-frame (gather-stack-frame)))))) 1761 | 1762 | (defn- process-then-frame [stack-frame] 1763 | (when debugging-stack? 1764 | (pprint ["process-then-frame" stack-frame])) 1765 | (with-stack-frame stack-frame 1766 | ;; FUTURE: Have leash print at most the then branch. 1767 | (leash-special special-form-depth goal-index "Taking 'then' branch of" special-form-stack bindings) 1768 | (let [capo 'then 1769 | goal (second goal) ; Lose `then`. 1770 | assertion-matches (goal-assertion-matches (inc goal-index) goal bindings) 1771 | body-remainder (first body-remainders) ; Has at least `(drop-else ...)`. 1772 | capos (:capos body-remainder) 1773 | goals (:goals body-remainder) 1774 | body-remainders (rest body-remainders) 1775 | body-index goal-index] 1776 | (gathering-body-remainder 1777 | #(process-stack-frame (gather-stack-frame)))))) 1778 | 1779 | (defn- process-if-then-frame [stack-frame] 1780 | (when debugging-stack? 1781 | (pprint ["process-if-then-frame" stack-frame])) 1782 | (with-stack-frame stack-frame 1783 | ;; FUTURE: Have leash print at most the condition. 1784 | (leash-special special-form-depth goal-index "Checking 'if' condition" special-form-stack bindings) 1785 | (let [capo 'if-then 1786 | condition-form (nth goal 1) ; Lose `if-then`. 1787 | then-form (nth goal 2) 1788 | then-goal `(~'then ~then-form) 1789 | goal condition-form 1790 | assertion-matches (goal-assertion-matches (inc goal-index) goal bindings) 1791 | else-frame continuation 1792 | body-remainder (first body-remainders) 1793 | capos (:capos body-remainder) 1794 | goals `((~'sys-and ; System-level `and`. 1795 | ~then-goal 1796 | ;; Throw (private) system-level `else-frame` into 1797 | ;; system-level special predicate `drop-else`. 1798 | (~'drop-else ~else-frame) 1799 | (~'succeed-if)) 1800 | ~@(:goals body-remainder)) 1801 | body-remainders (rest body-remainders) 1802 | body-index goal-index] 1803 | (gathering-body-remainder 1804 | #(process-stack-frame (gather-stack-frame)))))) 1805 | 1806 | (defn- process-if-frame [stack-frame] 1807 | (when debugging-stack? 1808 | (pprint ["process-if-frame" stack-frame])) 1809 | (with-stack-frame stack-frame 1810 | (let [if-form (nth goal 1) ; (second goal) 1811 | then-form (nth goal 2) 1812 | else-form (nth goal 3) 1813 | ;; We chain some continuation frames here. 1814 | goal '(fail-if) 1815 | fail-if-frame (gather-stack-frame) 1816 | ;; Another frame: 1817 | goal `(~'else ~else-form) 1818 | continuation fail-if-frame 1819 | else-frame (gather-stack-frame) 1820 | ;; Now our initial stack frame: 1821 | goal `(~'if-then ~if-form ~then-form) 1822 | continuation else-frame 1823 | if-then-frame (gather-stack-frame)] 1824 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1825 | ;; Ok here to bypass `process-stack-frame`, as this is 1826 | ;; deterministic. 1827 | #(process-if-then-frame if-then-frame)))) 1828 | 1829 | (declare query) 1830 | 1831 | ;;; Note: The answer template in the recursive `query` call is 1832 | ;;; ?var-free. Given that this is the only way `query` ever is called 1833 | ;;; recursively, we can get away with assuming any template's index is 1834 | ;;; 0. See `handle-answer`. 1835 | (defn- process-not-frame [stack-frame] 1836 | (when debugging-stack? 1837 | (pprint ["process-not-frame" stack-frame])) 1838 | (with-stack-frame stack-frame 1839 | (let [capo 'not 1840 | not-goal (second goal) ; Lose `not`. 1841 | goal nil ; Gathered. 1842 | not-goal (de-reference bindings not-goal) 1843 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1844 | success? (not (seq (query true `(~not-goal) 1845 | :stack-index goal-index 1846 | :special-form-stack special-form-stack 1847 | :special-form-depth special-form-depth)))] 1848 | (if success? 1849 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1850 | (succeed-simple-special-form)) 1851 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1852 | #(process-stack-frame continuation)))))) 1853 | 1854 | (defn- process-true-frame [stack-frame] 1855 | (when debugging-stack? 1856 | (pprint ["process-true-frame" stack-frame])) 1857 | (with-stack-frame stack-frame 1858 | (let [capo 'true 1859 | goal nil] 1860 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1861 | (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1862 | (succeed-simple-special-form)))) 1863 | 1864 | (defn- process-false-frame [stack-frame] 1865 | (when debugging-stack? 1866 | (pprint ["process-false-frame" stack-frame])) 1867 | (with-stack-frame stack-frame 1868 | (let [goal nil] 1869 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1870 | (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1871 | #(process-stack-frame continuation)))) 1872 | 1873 | (defn- process-truthy?-frame [stack-frame] 1874 | (when debugging-stack? 1875 | (pprint ["process-truthy?-frame" stack-frame])) 1876 | (with-stack-frame stack-frame 1877 | (let [capo 'truthy? 1878 | clojure-form (second goal) ; Lose `truthy?`. 1879 | goal nil ; Gathered. 1880 | clojure-form (de-reference bindings clojure-form) 1881 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1882 | grounded? (ground? clojure-form) 1883 | success? (and grounded? (eval clojure-form))] 1884 | (if success? 1885 | (do 1886 | (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1887 | (succeed-simple-special-form)) 1888 | (let [leash-verb (if grounded? 1889 | "Failed" 1890 | "Failed, not ground")] 1891 | (leash-special special-form-depth goal-index leash-verb special-form-stack bindings) 1892 | #(process-stack-frame continuation)))))) 1893 | 1894 | (defn- process-var-frame [stack-frame] 1895 | (when debugging-stack? 1896 | (pprint ["process-var-frame" stack-frame])) 1897 | (with-stack-frame stack-frame 1898 | (let [capo 'var 1899 | clojure-form (second goal) ; Lose `var`. 1900 | goal nil ; Gathered. 1901 | clojure-form (de-reference bindings clojure-form) 1902 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings)] 1903 | (if (i?var? clojure-form) 1904 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1905 | (succeed-simple-special-form)) 1906 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1907 | #(process-stack-frame continuation)))))) 1908 | 1909 | (defn- process-ground-frame [stack-frame] 1910 | (when debugging-stack? 1911 | (pprint ["process-ground-frame" stack-frame])) 1912 | (with-stack-frame stack-frame 1913 | (let [capo 'var 1914 | clojure-form (second goal) ; Lose `ground`. 1915 | goal nil ; Gathered. 1916 | clojure-form (de-reference bindings clojure-form) 1917 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings)] 1918 | (if (ground? clojure-form) 1919 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1920 | (succeed-simple-special-form)) 1921 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1922 | #(process-stack-frame continuation)))))) 1923 | 1924 | (defn- process-do-frame [stack-frame] 1925 | (when debugging-stack? 1926 | (pprint ["process-do-frame" stack-frame])) 1927 | (with-stack-frame stack-frame 1928 | (let [capo 'do 1929 | clojure-form goal ; Keep `do`. 1930 | goal nil ; Gathered. 1931 | clojure-form (de-reference bindings clojure-form)] 1932 | (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1933 | (if (ground? clojure-form) 1934 | (do (eval clojure-form) 1935 | (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 1936 | (succeed-simple-special-form)) 1937 | (do (leash-special special-form-depth goal-index "Failed, not ground" special-form-stack bindings) 1938 | #(process-stack-frame continuation)))))) 1939 | 1940 | (defn- process-evals-from?-frame [stack-frame] 1941 | (when debugging-stack? 1942 | (pprint ["process-evals-from?-frame" stack-frame])) 1943 | (with-stack-frame stack-frame 1944 | (let [capo 'evals-from? 1945 | logic-form (second goal) 1946 | clojure-form (nth goal 2) ; (third goal) 1947 | goal nil ; Gathered. 1948 | logic-form (de-reference bindings logic-form) 1949 | clojure-form (de-reference bindings clojure-form) 1950 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings)] 1951 | (if (ground? clojure-form) 1952 | (let [clojure-result (eval clojure-form) 1953 | ;; In case we introduce any ?vars. Because we've 1954 | ;; required `clojure-form` to be ground, we needn't 1955 | ;; worry that we'll indexify an i?var. FUTURE: Consider 1956 | ;; means to rename any ?vars introduced here, as needed. 1957 | clojure-result (indexify clojure-result goal-index) 1958 | bindings? (i?var-unify logic-form clojure-result bindings)] 1959 | (if bindings? 1960 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings?) 1961 | (let [bindings bindings?] 1962 | (succeed-simple-special-form))) 1963 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1964 | #(process-stack-frame continuation)))) 1965 | (do (leash-special special-form-depth goal-index "Failed, not ground" special-form-stack bindings) 1966 | #(process-stack-frame continuation)))))) 1967 | 1968 | (defn- process-same-frame [stack-frame] 1969 | (when debugging-stack? 1970 | (pprint ["process-same-frame" stack-frame])) 1971 | (with-stack-frame stack-frame 1972 | (let [capo 'same 1973 | a-form (second goal) 1974 | b-form (nth goal 2) ; (third goal) 1975 | goal nil ; Gathered. 1976 | a-form (de-reference bindings a-form) 1977 | b-form (de-reference bindings b-form) 1978 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1979 | bindings? (i?var-unify a-form b-form bindings)] 1980 | (if bindings? 1981 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings?) 1982 | (let [bindings bindings?] 1983 | (succeed-simple-special-form))) 1984 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 1985 | #(process-stack-frame continuation)))))) 1986 | 1987 | (defn- process-different-frame [stack-frame] 1988 | (when debugging-stack? 1989 | (pprint ["process-different-frame" stack-frame])) 1990 | (with-stack-frame stack-frame 1991 | (let [capo 'different 1992 | a-form (second goal) 1993 | b-form (nth goal 2) ; (third goal) 1994 | goal nil ; Gathered. 1995 | a-form (de-reference bindings a-form) 1996 | b-form (de-reference bindings b-form) 1997 | _side-effect (leash-special special-form-depth goal-index "Entering" special-form-stack bindings) 1998 | bindings? (i?var-unify a-form b-form bindings)] 1999 | (if (nil? bindings?) 2000 | (do (leash-special special-form-depth goal-index "Succeeded" special-form-stack bindings) 2001 | (succeed-simple-special-form)) 2002 | (do (leash-special special-form-depth goal-index "Failed" special-form-stack bindings) 2003 | #(process-stack-frame continuation)))))) 2004 | 2005 | (defn- apply-predicate-transform [transform form leash-args] 2006 | (let [input-pattern (first transform) 2007 | output-pattern (second transform) 2008 | bindings>< (unify input-pattern form)] 2009 | (if bindings>< 2010 | (let [[bindings> _bindings<] bindings>< 2011 | [special-form-depth assn-index special-form-stack leash-bindings] leash-args 2012 | output-pattern (de-reference-unindexed bindings> output-pattern)] 2013 | (leash-special special-form-depth assn-index "Applying logic transform" 2014 | (cons input-pattern special-form-stack) 2015 | ;; leash-bindings ; Don't de-reference... 2016 | [{} {}]) 2017 | output-pattern) 2018 | 'nope))) 2019 | 2020 | ;;; TODO: Consider de-referencing form, first (in case some logic 2021 | ;;; element is there per a ?var binding). 2022 | (defn- transform-predicate 2023 | ([form leash-args] 2024 | (let [head (first form) 2025 | transforms (get @*predicate-transforms* head)] 2026 | (transform-predicate form transforms leash-args))) 2027 | ;; Take the first successful transform, or (error, 2028 | ;; really---warn---FUTURE) just return input form. 2029 | ([form transforms leash-args] 2030 | (if-not (seq transforms) 2031 | 'no-matching-transform ; Avoid stack overflow. 2032 | (let [transformed (apply-predicate-transform 2033 | (first transforms) form leash-args)] 2034 | (if (not= transformed 'nope) 2035 | transformed 2036 | (transform-predicate form (rest transforms) leash-args)))))) 2037 | 2038 | ;;; Ensure `(not (transformable-predicate? (first goal)))`. I.e., 2039 | ;;; apply transforms until you can't (so `process-special-frame` can 2040 | ;;; exercise its `case` form. 2041 | (defn- recursively-transform-predicate [form leash-args] 2042 | (if (not (transformable-predicate? form)) 2043 | form 2044 | (let [form (transform-predicate form leash-args)] 2045 | (recursively-transform-predicate form leash-args)))) 2046 | 2047 | (defn- process-special-frame [stack-frame] 2048 | (with-stack-frame stack-frame 2049 | (let [leash-args [special-form-depth assn-index special-form-stack bindings] 2050 | goal (recursively-transform-predicate goal leash-args) 2051 | special-head (first goal) 2052 | special-form-stack (if-not (private-built-in-special-head? special-head) 2053 | (cons goal special-form-stack) 2054 | special-form-stack) 2055 | special-form-depth (if-not (private-built-in-special-head? special-head) 2056 | (inc special-form-depth) 2057 | special-form-depth) 2058 | leash-report "" ; Clear incoming report. 2059 | stack-frame (gather-stack-frame)] 2060 | (case special-head 2061 | ;; Goal-nesting forms: 2062 | first #(process-first-frame stack-frame) 2063 | fail-first #(process-fail-first-frame stack-frame) 2064 | succeed-first #(process-succeed-first-frame stack-frame) 2065 | and #(process-and-frame stack-frame) 2066 | and... #(process-and-frame stack-frame) 2067 | sys-and #(process-and-frame stack-frame) 2068 | or #(process-or-frame stack-frame) 2069 | or... #(process-or-frame stack-frame) 2070 | not #(process-not-frame stack-frame) 2071 | if #(process-if-frame stack-frame) 2072 | if-then #(process-if-then-frame stack-frame) 2073 | then #(process-then-frame stack-frame) 2074 | else #(process-else-frame stack-frame) 2075 | drop-else #(process-drop-else-frame stack-frame) 2076 | fail-if #(process-fail-if-frame stack-frame) 2077 | succeed-if #(process-succeed-if-frame stack-frame) 2078 | ;; Non-nesting forms: 2079 | truthy? #(process-truthy?-frame stack-frame) 2080 | do #(process-do-frame stack-frame) 2081 | evals-from? #(process-evals-from?-frame stack-frame) 2082 | var #(process-var-frame stack-frame) 2083 | ground #(process-ground-frame stack-frame) 2084 | same #(process-same-frame stack-frame) 2085 | different #(process-different-frame stack-frame) 2086 | true #(process-true-frame stack-frame) 2087 | false #(process-false-frame stack-frame))))) 2088 | 2089 | (defn- check-assertion-indices [goal-index goal assn-index assn bindings] 2090 | (let [bindings-indices (keys bindings) 2091 | bindings-max-index (when (seq bindings-indices) 2092 | (apply max bindings-indices)) 2093 | goal-i?vars (i?vars-of goal) 2094 | goal-max-index (when (seq goal-i?vars) 2095 | (apply max (map :index goal-i?vars))) 2096 | assn-i?vars (when goal-max-index (i?vars-of assn)) 2097 | ;; We expect these indices all to be the same (`assn-index`). 2098 | assn-min-index (when (seq assn-i?vars) 2099 | (apply min (map :index assn-i?vars)))] 2100 | (when bindings-max-index 2101 | (assert (<= bindings-max-index assn-index)) 2102 | (assert (= assn-index (inc goal-index))) 2103 | (when goal-max-index 2104 | (assert (<= goal-max-index goal-index)))) 2105 | (when assn-min-index 2106 | ;; Some redundancy here... 2107 | (assert (= assn-min-index assn-index)) 2108 | (when goal-max-index 2109 | (assert (> assn-min-index goal-max-index)) 2110 | (assert (<= goal-max-index assn-min-index)))))) 2111 | 2112 | (defn- process-predicate-frame [stack-frame] 2113 | (when debugging-stack? 2114 | (pprint ["process-predicate-frame:" stack-frame])) 2115 | (with-stack-frame stack-frame 2116 | (if-not (seq assertion-matches) 2117 | (do (when-not (backtracking-leash-report? (:leash-report stack-frame) 2118 | assn-index) 2119 | (leash-goal special-form-depth assn-index goal bindings)) 2120 | (leash-failure special-form-depth assn-index goal bindings) 2121 | ;; Backtrack. 2122 | #(process-stack-frame continuation)) 2123 | (let [[assertion match-bindings] (first assertion-matches) 2124 | assertion-matches (rest assertion-matches) 2125 | remaining-assertion-count (count assertion-matches) 2126 | ;; For failure continuation: 2127 | leash-report (with-out-str 2128 | (leash-assertion-backtracking 2129 | special-form-depth assn-index goal bindings 2130 | remaining-assertion-count)) 2131 | ;; Use the above backtracking leash report. 2132 | continuation (gather-stack-frame) 2133 | bindings match-bindings 2134 | head (first assertion)] 2135 | (comment 2136 | (when check-indices? 2137 | (check-assertion-indices goal-index goal assn-index assertion bindings))) 2138 | (when-not (backtracking-leash-report? (:leash-report stack-frame) 2139 | assn-index) 2140 | (leash-goal special-form-depth assn-index goal bindings) 2141 | (when-not *pprint-leash-statements* ; Gets too cluttered. 2142 | (leash-assertion-head special-form-depth assn-index head goal bindings))) 2143 | ;; Compare to `succeed-simple-special-form`: 2144 | (let [goals (rest assertion) 2145 | goal (first goals) 2146 | capo (first goal) ; Diagnostic. 2147 | capos () ; Diagnostic. 2148 | goals (rest goals) 2149 | goal-index assn-index ; Gathered into stack frame. 2150 | body-index goal-index ; Gathered into body remainder. 2151 | assertion-matches (goal-assertion-matches assn-index goal bindings) 2152 | leash-report (with-out-str 2153 | ;; (leash-assertion-head assn-index head goals goal bindings) 2154 | (leash-assertion-body 2155 | special-form-depth assn-index head goals goal bindings))] 2156 | (gathering-body-remainder 2157 | #(process-stack-frame (gather-stack-frame)))))))) 2158 | 2159 | ;;; Only standard predicates should call this. 2160 | ;;; (So, we're not accommodating ?vars introduced by `evals-from?` 2161 | ;;; forms---which would require `rename-unbound-?vars`). 2162 | (defn- process-assertion-success [stack-frame] 2163 | (when debugging-stack? 2164 | (pprint ["process-assertion-success:" stack-frame])) 2165 | (with-stack-frame stack-frame 2166 | (leash-assertion-success special-form-depth goal-index head bindings) 2167 | (let [capo 'process-assertion-success 2168 | bindings (rename-unbound-?vars goal-index bindings)] 2169 | (if (empty? body-remainders) 2170 | #(process-answer-and-continue) 2171 | ;; From the first remainder, pop off one goal for the stack 2172 | ;; frame. 2173 | (let [body-remainder (first body-remainders) 2174 | body-remainders (rest body-remainders)] 2175 | (with-body-remainder body-remainder 2176 | (let [goal-index body-index ; Gathered into stack frame. 2177 | assn-index (inc goal-index) 2178 | ;; Lose succeeded assertion's now-stale entries. 2179 | bindings (dissoc bindings assn-index) 2180 | goal (first goals) 2181 | goals (rest goals) 2182 | assertion-matches (when-not assertion-matches ; Respect an empty coll. 2183 | (goal-assertion-matches assn-index goal bindings)) 2184 | leash-report (str (with-out-str 2185 | (when-not (private-built-in-special-head? (first goal)) 2186 | (leash-assertion-body special-form-depth 2187 | goal-index 2188 | head goals goal 2189 | bindings))) 2190 | leash-report)] 2191 | (gathering-body-remainder 2192 | #(process-stack-frame (gather-stack-frame)))))))))) 2193 | 2194 | ;;; Return either its input or `sys-and` of (first) as many 2195 | ;;; `evals-from?` goals as necessary and (then) a `(->? ...)`-free 2196 | ;;; version of the input goal. We keep `evals-from?` forms in 2197 | ;;; their `(->? ...)` order, in case there are any side 2198 | ;;; effects. Nested `(->? ...)` forms are not supported. 2199 | (defn- transform-->?s [stack-frame] 2200 | (with-stack-frame stack-frame 2201 | (if-not (or (not (special-goal? goal)) ; * See below. 2202 | ('#{same different} (first goal))) 2203 | goal 2204 | (let [evals-from?-goals (atom []) 2205 | ->?-free-goal ; ... 2206 | (walk-walkable #(and (seq? %) (= '->? (first %))) 2207 | (fn [->?-form] 2208 | (let [clojure-form (second ->?-form) 2209 | ??-i?var (indexify (new-unbound-?var '??) goal-index)] 2210 | (swap! evals-from?-goals conj 2211 | `(~'evals-from? ~??-i?var ~clojure-form)) 2212 | ;; Replace in goal with... 2213 | ??-i?var)) 2214 | goal)] 2215 | (if (= ->?-free-goal goal) 2216 | goal 2217 | (do (leash-->?-transform special-form-depth goal-index) 2218 | `(~'sys-and ~@(apply list @evals-from?-goals) ~->?-free-goal))))))) 2219 | ;;; Note : Lispy goals (`do`, `truthy`, `evals-from?`) don't need 2220 | ;;; it. (Not doing this transform on `second` of an `evals-from?` 2221 | ;;; goal.*) Other special forms all have subgoals, to whose terminal 2222 | ;;; forms---user predicates---the transform will be applied directly. 2223 | ;;; Among built-in special forms, we subject only `same` and 2224 | ;;; `different` to the transform. 2225 | ;;; 2226 | ;;; * We might take this on by recognizing our auto-generated `->?-` 2227 | ;;; ?var as a signal that such a form alreay had been processed. 2228 | 2229 | (comment ; No help, so far. 2230 | ;; Clojure stack is limiting us adequately, considering bindings. 2231 | ;; Revisit under future logic tail recursion. 2232 | (def ^:dynamic *stack-index-limit* 1000)) 2233 | 2234 | (defn- process-stack-frame [stack-frame] 2235 | (when debugging-stack? 2236 | (pprint ["process-stack-frame" stack-frame])) 2237 | (with-stack-frame stack-frame 2238 | ;; Not working as expected. 2239 | ;; #dbg ^{:break/when (> goal-index *stack-index-limit*)} 2240 | (let [answer-limit-reached (and *answers-countdown* 2241 | (= @*answers-countdown* 0))] 2242 | (when (and *leash* answer-limit-reached) 2243 | (println "Answer limit reached.")) 2244 | (when (and *leash* 2245 | (:final stack-frame) 2246 | (not answer-limit-reached)) 2247 | (print (:leash-report stack-frame))) 2248 | (if (or answer-limit-reached (:final stack-frame)) 2249 | @*answers* 2250 | ;; Else keep working. 2251 | (do (when *leash* 2252 | (print leash-report) 2253 | (when (public-built-in-special-head? (first goal)) 2254 | (let [goals (or (:goals (first body-remainders)) 2255 | ())] 2256 | ;; Handled separately in `process-predicate-frame`: 2257 | (leash-assertion-body special-form-depth goal-index head goals goal bindings)))) 2258 | (if (nil? goal) ; So, also `(nil? assertion-matches)`. 2259 | #(process-assertion-success stack-frame) 2260 | ;; Else, we have a goal. 2261 | (let [goal (transform-->?s stack-frame) 2262 | goal (de-reference bindings goal)] 2263 | (if (special-goal? goal) 2264 | #(process-special-frame (gather-stack-frame)) 2265 | ;; Else we have a standard, predicate stack frame. 2266 | (let [assertion-matches (if (nil? assertion-matches) 2267 | ;; If we've gotten here from a special 2268 | ;; stack frame, we won't yet have 2269 | ;; fetched our assertion matches. 2270 | (goal-assertion-matches (inc goal-index) 2271 | goal bindings) 2272 | assertion-matches)] 2273 | #(process-predicate-frame (gather-stack-frame))))))))))) 2274 | 2275 | (defn- leash-query [special-form-depth index verb input-goals] 2276 | (when *leash* 2277 | (let [prefix (leash-prefix special-form-depth index)] 2278 | (println prefix verb "query:" (cl-format nil "~s" input-goals))))) 2279 | 2280 | ;;; For creation of tests/clolog/leash-tests.txt. 2281 | (def ^:private ^:dynamic *transcribe-query-info* false) 2282 | 2283 | ;;; Implement standard depth-first backtracking search. 2284 | (defn query [answer-template goals 2285 | & {:keys [limit 2286 | discard-subsumed 2287 | ;; For negation as failure (private): 2288 | stack-index 2289 | special-form-stack 2290 | special-form-depth] 2291 | :or {limit *answer-count-limit* 2292 | discard-subsumed *discard-subsumed-answers* 2293 | ;; Private: 2294 | stack-index 0 2295 | special-form-stack () 2296 | special-form-depth 0}}] 2297 | "Perform (depth-first, pre-order) logic programming search over 2298 | goals, instantiating `answer-template` upon each success, and return 2299 | a vector of such answers. Discard (and/or do not record) subsumed 2300 | answers, per `discard-subsumed`. Terminate search upon having 2301 | recorded `limit` answers." 2302 | (when (and *transcribe-query-info* (= special-form-depth 0)) 2303 | (println) 2304 | (pprint `(~'do (~'initialize-prolog) 2305 | ~@(map (fn [assn] `(~'assert<- '~assn)) 2306 | (get-matching-head-assertions '?_)))) 2307 | (println) 2308 | (pprint `(~'query '~answer-template '~goals 2309 | :limit ~limit 2310 | :discard-subsumed ~discard-subsumed)) 2311 | (println)) 2312 | ;; An answer template is an expr usually including 2313 | ;; ?vars---e.g., [?x], [?x ?y], unless we don't care about 2314 | ;; bindings (e.g., for negation as failure---NAF). An answer 2315 | ;; template may also include arbitrary stuff, like 2316 | ;; symbols---e.g., [?person bigger_than ?issue]. 2317 | ;; 2318 | ;; A goal is a statement. 2319 | ;; 2320 | ;; Any template ?vars that remain unbound (even those that do not 2321 | ;; occur among the goals) are left as is. 2322 | (if (empty? goals) 2323 | [answer-template] ; Cheesey, not covered by *transcribe-query-info*. 2324 | (let [; stack-index 0 2325 | goal-index stack-index 2326 | ;; Automatic: assn-index (inc goal-index) 2327 | input-goals goals 2328 | goals (distinguish-anons goals) 2329 | goals (indexify goals stack-index) 2330 | query-i?vars (set (i?vars-of goals)) 2331 | goal (first goals) 2332 | goals (rest goals) 2333 | head nil ; Gathered into body-remainder. 2334 | body-index goal-index ; Gathered into body-remainder. 2335 | body-remainders () ; For `gathering-body-remainder`. 2336 | bindings {} 2337 | assertion-matches (goal-assertion-matches (inc goal-index) goal bindings)] 2338 | (binding [*answer-template* (indexify answer-template stack-index) 2339 | *query-i?vars* query-i?vars 2340 | *answers* (atom []) 2341 | *discard-subsumed-answers* discard-subsumed 2342 | *answers-countdown* (if (and discard-subsumed 2343 | (not (seq query-i?vars))) 2344 | ;; One answer is enough, for a 2345 | ;; constant template. (This 2346 | ;; defeats leashing of this 2347 | ;; class of duplicate 2348 | ;; solutions.) 2349 | (atom 1) 2350 | (when limit (atom limit))) 2351 | *unbound-?var-counter* (atom 0)] ; Ok for NAF. 2352 | (let [capo 'query 2353 | capos () 2354 | leash-report (with-out-str 2355 | (when (= special-form-depth 0) 2356 | (leash-query special-form-depth stack-index "Processing" input-goals))) 2357 | ;; Just the stack-frame fields we need (not really a StackFrame). 2358 | continuation {:leash-report (if (= special-form-depth 0) 2359 | (with-out-str 2360 | (leash-query special-form-depth stack-index "Exhausted" input-goals)) 2361 | "") 2362 | :goal-index 0 2363 | :final true}] 2364 | (gathering-body-remainder 2365 | (let [result (trampoline process-stack-frame (gather-stack-frame))] 2366 | (when (and *transcribe-query-info* (= special-form-depth 0)) 2367 | (pprint result)) 2368 | result))))))) 2369 | 2370 | (defmacro ? [answer-template & goals] ; Does not support keyword args. 2371 | "The macro version of function `query`." 2372 | `(query (quote ~answer-template) (quote ~goals))) 2373 | 2374 | -------------------------------------------------------------------------------- /test/clolog/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns clolog.core-test 2 | (:require [clojure.test :refer :all] 3 | [clolog.core :refer :all] 4 | [clojure.pprint :refer [cl-format]])) 5 | 6 | (def ^:dynamic *goal-from-clj*) ; See using test. 7 | 8 | (deftest test-assert<- 9 | (testing "assert<-" 10 | (do (initialize-prolog) 11 | (assert<- '((has-subtype ?type ?subsubtype) ; <-- 12 | (has-subtype ?type ?subtype) 13 | (has-subtype ?subtype ?subsubtype)))) 14 | (is (= '[((has-subtype ?type ?subsubtype) 15 | (has-subtype ?type ?subtype) 16 | (has-subtype ?subtype ?subsubtype))] 17 | (get-matching-head-assertions '?))) 18 | (do (initialize-prolog) 19 | (assert<- '((has-subtype ?type ?subsubtype) ; <-- 20 | (has-subtype ?type ?subtype) 21 | (has-subtype ?subtype ?subsubtype))) 22 | (assert<- '((has-subtype vertebrate mammal))) 23 | (assert<- '((has-subtype mammal primate))) 24 | (assert<- '((has-subtype primate human))) 25 | (assert<- '((has-subtype NONSENSE))) 26 | (assert<- '((NONSENSE primate human))) 27 | (assert<- '((NONSENSE)))) 28 | (is (= '[((has-subtype ?type ?subsubtype) 29 | (has-subtype ?type ?subtype) 30 | (has-subtype ?subtype ?subsubtype)) 31 | ((has-subtype vertebrate mammal)) 32 | ((has-subtype mammal primate)) 33 | ((has-subtype primate human)) 34 | ((has-subtype NONSENSE)) 35 | ((NONSENSE primate human)) 36 | ((NONSENSE))] 37 | (get-matching-head-assertions '?))) 38 | (is (= '[((has-subtype vertebrate mammal))] 39 | (get-subsumed-head-assertions '(has-subtype ?type mammal)))) 40 | (is (= '[((has-subtype ?type ?subsubtype) 41 | (has-subtype ?type ?subtype) 42 | (has-subtype ?subtype ?subsubtype)) 43 | ((has-subtype vertebrate mammal))] 44 | (get-matching-head-assertions '(has-subtype ?type mammal)))) 45 | ;; Access? 46 | (is (= '[((has-subtype ?type ?subsubtype) 47 | (has-subtype ?type ?subtype) 48 | (has-subtype ?subtype ?subsubtype)) 49 | ((has-subtype vertebrate mammal)) 50 | ((has-subtype mammal primate)) 51 | ((has-subtype primate human))] 52 | (get-matching-head-assertions '(has-subtype ? ?)))) 53 | (is (= '(((has-subtype ?type ?subsubtype) 54 | (has-subtype ?type ?subtype) 55 | (has-subtype ?subtype ?subsubtype)) 56 | ((has-subtype vertebrate mammal)) 57 | ((has-subtype mammal primate)) 58 | ((has-subtype primate human)) 59 | ((NONSENSE primate human))) 60 | (get-matching-head-assertions '(? ? ?)))) 61 | ;; Variants: 62 | (is (= '[((bar))] 63 | (do (assert<--- '((bar))) 64 | (get-matching-head-assertions '?)))) 65 | (is (= '[((bar))] 66 | (do (assert<-- '((bar))) 67 | (get-matching-head-assertions '?)))) 68 | (is (= '[((bar)) ((bar))] 69 | (do (assert<-0 '((bar))) 70 | (get-matching-head-assertions '?)))) 71 | ;; Retraction: 72 | (do (initialize-prolog) 73 | (assert<--- '((bar)))) 74 | (is (= [] 75 | (do (retract-subsumed-head-assertions '(bar)) 76 | (get-matching-head-assertions '?)))) 77 | (assert<--- '((bar))) 78 | (is (= [] (do (retract-subsumed-head-assertions '?) 79 | (get-matching-head-assertions '?)))) 80 | (assert<--- '((bar))) 81 | (is (= [] (do (retract-subsumed-assertions '(?)) 82 | (get-matching-head-assertions '?)))) 83 | (assert<--- '((bar))) 84 | (assert<- '((bar none))) 85 | (is (= [] 86 | (do (retract-subsumed-head-assertions '(bar &)) 87 | (get-matching-head-assertions '?)))) 88 | (assert<- '((bar none))) 89 | (is (= [] 90 | (do (--- (bar &)) 91 | (get-matching-head-assertions '?)))) 92 | (do (initialize-prolog) 93 | (<- (variadic-term [])) 94 | (<- (variadic-term [1])) 95 | (<- (variadic-term [1 2]))) 96 | (is (= [] 97 | (do (--- (variadic-term [& ?rest])) 98 | (get-matching-head-assertions '?)))) 99 | (do (initialize-prolog) 100 | (<- (variadic-term [])) 101 | (<- (variadic-term [1])) 102 | (<- (variadic-term [1 2]))) 103 | (is (= '[((variadic-term []))] 104 | (do (--- (variadic-term [1 & ?rest])) 105 | (get-matching-head-assertions '?)))) 106 | (do (initialize-prolog) 107 | (<- (variadic-term [& ?rest])) 108 | (<- (variadic-term [])) 109 | (<- (variadic-term [1])) 110 | (<- (variadic-term [1 2]))) 111 | (is (= '[((variadic-term [])) 112 | ((variadic-term [1])) 113 | ((variadic-term [1 2]))] 114 | (do (-- (variadic-term [& ?rest])) 115 | (get-matching-head-assertions '?)))) 116 | (do (initialize-prolog) 117 | (<- (variadic)) 118 | (<- (variadic 1)) 119 | (<- (variadic 1 2))) 120 | (is (= [] 121 | (do (--- (variadic & ?rest)) 122 | (get-matching-head-assertions '?)))) 123 | ;; Non-ground complex predicate: 124 | (<--- ([complex 1] 1)) 125 | (is (= [] 126 | (do (--- ([complex ?x] ?x)) 127 | (get-matching-head-assertions '?)))) 128 | (<--- ([complex ?x] ?x)) 129 | (is (= [] 130 | (do (--- ([complex ?x] ?x)) 131 | (get-matching-head-assertions '?)))) 132 | (<--- ([complex & ?rest] ?rest)) 133 | (is (= '[(([complex & ?rest] ?rest))] 134 | (do (--- ([complex 1] (1))) 135 | (get-matching-head-assertions '?)))) 136 | (<--- ([complex 1] (1))) 137 | (is (= [] 138 | (do (--- ([complex ?x] ?x)) 139 | (get-matching-head-assertions '?)))) 140 | (do (<--- ([complex 1] (1))) 141 | (<- ([complex ?x] ?x))) 142 | (is (= '[(([complex 1] (1)))] 143 | (do (-- ([complex ?x] ?x)) 144 | (get-matching-head-assertions '?)))) 145 | ;; Retrieval: 146 | (<--- ([complex ?x] ?x)) 147 | (is (= (get-subsuming-head-assertions '([complex 1] 1)) 148 | '[(([complex ?x] ?x))])) 149 | (<--- ([complex 1] 1)) 150 | (is (= '[(([complex 1] 1))] 151 | (get-subsumed-head-assertions '([complex ?x] ?x)))) 152 | ;; Minimalism: 153 | (do (initialize-prolog) 154 | (<-_ (has-subtype vertebrate mammal)) 155 | (<-_ (has-subtype vertebrate ?mammal))) 156 | (is (= '[((has-subtype vertebrate ?mammal))] 157 | (get-matching-head-assertions '?))) 158 | (do (initialize-prolog) 159 | (<-_ (has-subtype vertebrate ?mammal)) 160 | (<-_ (has-subtype vertebrate mammal))) 161 | (is (= '[((has-subtype vertebrate ?mammal))] 162 | (get-matching-head-assertions '?))) 163 | ;; For token-matcher: 164 | (do (initialize-prolog) 165 | (doseq [assn '[((has-subkind* ?kind ?subkind) (has-subkind ?kind ?subkind)) 166 | ((has-subkind* ?kind ?subsubkind) 167 | (has-subkind ?kind ?subkind) 168 | (has-subkind* ?subkind ?subsubkind)) 169 | ((has-kind "really big show" kind)) 170 | ((has-kind "John" kind)) 171 | ((has-kind "John Smith" kind)) 172 | ((has-kind "really" kind)) 173 | ((has-kind "something" kinder)) 174 | ((has-kind "kinder" kinder)) 175 | ((has-kind "something really big" kinder)) 176 | ((has-kind "kinder gentler" kinder)) 177 | ((has-kind "Book 1" kindle)) 178 | ((has-kind "Book 2" kindle))]] 179 | (assert<-_ assn))) 180 | (is (= (get-matching-head-assertions '?) 181 | '[((has-subkind* ?kind ?subkind) (has-subkind ?kind ?subkind)) 182 | ((has-subkind* ?kind ?subsubkind) 183 | (has-subkind ?kind ?subkind) 184 | (has-subkind* ?subkind ?subsubkind)) 185 | ((has-kind "really big show" kind)) 186 | ((has-kind "John" kind)) 187 | ((has-kind "John Smith" kind)) 188 | ((has-kind "really" kind)) 189 | ((has-kind "something" kinder)) 190 | ((has-kind "kinder" kinder)) 191 | ((has-kind "something really big" kinder)) 192 | ((has-kind "kinder gentler" kinder)) 193 | ((has-kind "Book 1" kindle)) 194 | ((has-kind "Book 2" kindle))])) 195 | )) 196 | 197 | (deftest query-test 198 | (testing "query" 199 | ;; Empty goals: 200 | (initialize-prolog) 201 | (is (= [] 202 | ;; Not defined: `pseudo-fail`. 203 | (query true '((pseudo-fail))))) 204 | (is (= [true] 205 | ;; Implicit `and` here. 206 | (query true '()))) 207 | ;; Ground, unit assertions: 208 | (do (initialize-prolog) 209 | (assert<- '((has-subtype vertebrate mammal))) 210 | (assert<- '((has-subtype mammal primate))) 211 | (assert<- '((has-subtype primate human)))) 212 | (is (= [true] 213 | (query true 214 | '((has-subtype vertebrate mammal))))) 215 | (is (= '[mammal] 216 | (query '?x 217 | '((has-subtype vertebrate ?x))))) 218 | (is (= '[(has-subtype vertebrate mammal) 219 | (has-subtype mammal primate) 220 | (has-subtype primate human)] 221 | (query '(has-subtype ?type ?subtype) 222 | '((has-subtype ?type ?subtype))))) 223 | (is (= '[(has-subtype vertebrate mammal) 224 | (has-subtype mammal primate) 225 | (has-subtype primate human)] 226 | (query '(?pred ?type ?subtype) 227 | '((?pred ?type ?subtype))))) 228 | (is (= '[(primate)] 229 | (query '(?subtype) 230 | '((has-subtype mammal ?subtype) 231 | (has-subtype ?subtype human))))) 232 | ;; Add non-ground, non-unit assertions. 233 | (do (initialize-prolog) 234 | ;; `has-subtype` is non-transitive (to avoid infinite recursion) . 235 | (assert<- '((has-subtype vertebrate mammal))) 236 | (assert<- '((has-subtype mammal primate))) 237 | (assert<- '((has-subtype primate human))) 238 | (assert<- '((has-subtype* ?type ?subtype) 239 | (has-subtype ?type ?subtype))) 240 | ;; This assertion of `has-subtype*` is transitive. 241 | (assert<- '((has-subtype* ?type ?subsubtype) 242 | (has-subtype ?type ?subtype) 243 | (has-subtype* ?subtype ?subsubtype)))) 244 | (is (= [true] 245 | (query true '((has-subtype* vertebrate primate))))) 246 | (is (= [true] 247 | (binding [*discard-subsumed-answers* false] 248 | (query true '((has-subtype* vertebrate primate)))))) 249 | (is (= '[mammal primate human] 250 | (? ?x (has-subtype* vertebrate ?x)))) 251 | (is (= '[[vertebrate mammal] 252 | [mammal primate] 253 | [primate human] 254 | [vertebrate primate] 255 | [vertebrate human] 256 | [mammal human]] 257 | (? [?x ?y] (has-subtype* ?x ?y)))) 258 | ;; Alternative formulation: 259 | (do (initialize-prolog) 260 | (<- (is-type vertebrate)) 261 | (<- (is-type mammal)) 262 | (<- (is-type primate)) 263 | (<- (is-type human)) 264 | ;; `has-subtype` is non-transitive (to avoid infinite recursion) . 265 | (assert<- '((has-subtype vertebrate mammal))) 266 | (assert<- '((has-subtype mammal primate))) 267 | (assert<- '((has-subtype primate human))) 268 | (assert<- '((has-subtype* ?type ?subtype) 269 | (has-subtype ?type ?subtype))) 270 | ;; This assertion of `has-subtype*` is transitive. 271 | (assert<- '((has-subtype* ?type ?subsubtype) 272 | (is-type ?type) 273 | (is-type ?subsubtype) 274 | (truthy? (not= (quote ?type) (quote ?subsubtype))) 275 | (has-subtype ?type ?subtype) 276 | (is-type ?subtype) 277 | (truthy? (not= (quote ?type) (quote ?subtype))) 278 | (has-subtype* ?subtype ?subsubtype)))) 279 | (is (= [true] 280 | (query true '((has-subtype* vertebrate primate))))) 281 | (is (= [true] 282 | (binding [*discard-subsumed-answers* false] 283 | (query true '((has-subtype* vertebrate primate)))))) 284 | (is (= '[mammal primate human] 285 | (? ?x (has-subtype* vertebrate ?x)))) 286 | (is (= '[[vertebrate mammal] 287 | [mammal primate] 288 | [primate human] 289 | [vertebrate primate] 290 | [vertebrate human] 291 | [mammal human]] 292 | (? [?x ?y] (has-subtype* ?x ?y)))) 293 | ;; Complex terms: 294 | (do (initialize-prolog) 295 | (assert<- '((successor 0 (s 0))))) 296 | (is (= '[(s 0)] 297 | (query '?x 298 | '((successor 0 ?x))))) 299 | (is (= '[0] 300 | (query '?x 301 | '((successor ?x (s 0)))))) 302 | (is (= '[0] 303 | (query '?x 304 | '((successor ?x (s ?x)))))) 305 | (do (initialize-prolog) 306 | (assert<- '((successor 0 (s 0)))) 307 | (assert<- '((successor (s ?x) (s (s ?x)))))) 308 | (is (= '[(s 0)] 309 | (query '?x 310 | '((successor ?x (s (s 0))))))) 311 | ;; Non-ground assertions: 312 | (do (initialize-prolog) 313 | (assert<- '((has-subtype thing ?thing)))) 314 | (is (= [true] 315 | (query true 316 | '((has-subtype thing mammal))))) 317 | ;; Template ?var answers: 318 | (is (= '[?bar] 319 | (query '?bar 320 | '((has-subtype thing ?bar))))) 321 | (do (initialize-prolog) 322 | (assert<- '((successor ?x (s ?x))))) 323 | (is (= '[[?q (s ?q)]] 324 | (query '[?q ?r] '((successor ?q ?r))))) 325 | (is (= '[(s ?q)] 326 | (query '?r '((successor ?q ?r))))) 327 | (do (initialize-prolog) 328 | (assert<- '((pseudo-same ?x ?x)))) 329 | (is (= '[[?r ?r]] 330 | (query '[?q ?r] '((pseudo-same ?q ?r))))) 331 | (is (= '[?x] 332 | (query '?x '((pseudo-same ?x ?x))))) 333 | (is (= '[?x] 334 | (query '?x '((same ?x ?x))))) 335 | ;; Multi-goal assertions: 336 | (do (initialize-prolog) 337 | ;; "Nibling": niece or nephew. 338 | (assert<- '((uncle ?nibling ?uncle) ; <-- 339 | (parent ?nibling ?parent) 340 | (sibling ?uncle ?parent) 341 | (male ?uncle))) 342 | (assert<- '((sibling ?x ?y) ; <-- 343 | (brother ?x ?y))) 344 | (assert<- '((sibling ?x ?y) ; <-- 345 | (sister ?x ?y))) 346 | (assert<- '((sister laban rebecca))) 347 | (assert<- '((male laban))) 348 | (assert<- '((male jacob))) 349 | (assert<- '((parent jacob rebecca))) 350 | (assert<- '((both-male ?one ?two) ; <-- 351 | (male ?one) 352 | (male ?two)))) 353 | (is (= '[(laban laban) (laban jacob) (jacob laban) (jacob jacob)] 354 | (query '(?x ?y) '((both-male ?x ?y))))) 355 | (is (= '[laban] 356 | (query '?uncle '((uncle jacob ?uncle))))) 357 | (is (= '[[laban rebecca]] 358 | (query '[?x ?y] '((sibling ?x ?y))))) 359 | ;; Answer limit: 360 | (is (= '[(laban laban) (laban jacob)] 361 | (binding [*answer-count-limit* 2] 362 | (query '(?x ?y) '((both-male ?x ?y)))))) 363 | (is (= '[laban] 364 | (query '?uncle '((sister ?uncle rebecca) 365 | (male ?uncle))))) 366 | ;; Answer subsumption: 367 | (do (initialize-prolog) 368 | (<- (sister laban rebecca)) 369 | (<- (sister ?x ?y))) 370 | (is (= '[[?x ?y]] 371 | (query '[?x ?y] '((sister ?x ?y))))) 372 | ;; Smaller. 373 | (do (initialize-prolog) 374 | (assert<- '((sister laban rebecca))) 375 | (assert<- '((male laban))) 376 | (assert<- '((male jacob)))) 377 | ;; Unbound (non-template) ?var answers: 378 | (do (initialize-prolog) 379 | (assert<- '((treasure (buried ?x))))) 380 | (is (= '[(buried ?unbound-0)] 381 | (query '?r '((treasure ?r))))) 382 | (do (initialize-prolog) 383 | (<- (treasure (buried ?x))) 384 | (<- (marks-the-spot X))) 385 | (is (= '[[(buried ?unbound-0) X]] 386 | (? [?r ?x] (treasure ?r) (marks-the-spot ?x)))) 387 | ;; String predicate: 388 | (do (initialize-prolog) 389 | (assert<- '(("treasure" (buried ?x))))) 390 | (is (= '[(buried ?unbound-0)] 391 | (query '?r '(("treasure" ?r))))) 392 | ;; Complex predicate: 393 | (do (initialize-prolog) 394 | (assert<- '(([treasure] (buried ?x))))) 395 | (is (= '[(buried ?unbound-0)] 396 | (query '?r '(([treasure] ?r))))) 397 | (do (initialize-prolog) 398 | (assert<- '(([treasure chest] (buried ?x))))) 399 | (is (= '[(buried ?unbound-0)] 400 | (query '?r '(([treasure ?thing] ?r))))) 401 | (is (= '[[(buried ?unbound-0) chest]] 402 | (query '[?r ?thing] '(([treasure ?thing] ?r))))) 403 | ;; ?var as predicate: 404 | (do (initialize-prolog) 405 | (assert<- '((male jacob)))) 406 | (is (= '[male] 407 | (query '?pred '((?pred jacob))))) 408 | ;; ?var as goal. 409 | (do (initialize-prolog) 410 | (assert<- '((male jacob))) 411 | (assert<- '((goal (male ?male))))) 412 | (is (= '[(male jacob)] 413 | (query '?goal '((goal ?goal) ?goal)))) 414 | (do (initialize-prolog) 415 | (assert<- '((male jacob)))) 416 | (is (= '[(male jacob)] 417 | (query '?goal '(?goal)))) 418 | (comment ; These work fine at the REPL, but they don't compile from here. 419 | (is (= '[jacob] 420 | (binding [*goal-from-clj* '(male ?x)] 421 | (? ?x (evals-from? ?goal *goal-from-clj*) 422 | ?goal)))) 423 | (is (= '[jacob] 424 | (binding [*goal-from-clj* '(male ?x)] 425 | (query '?x '((evals-from? ?goal *goal-from-clj*) 426 | ?goal))))) 427 | ) 428 | ;; `and` goal: 429 | (initialize-prolog) 430 | (is (= [true] 431 | (query true '((and))))) 432 | (is (= [] 433 | (query true '((and (pseudo-fail)))))) 434 | (is (= [true] 435 | (query true '((and) (and))))) 436 | (is (= [true] 437 | (query true '((and (and)))))) 438 | (is (= [true] 439 | (query true '((and (and (and))))))) 440 | (do (initialize-prolog) 441 | (assert<- '((male laban)))) 442 | (is (= [true] 443 | (query true '((and (male ?x)))))) 444 | (is (= [true] 445 | (query true '((and) (male ?x))))) 446 | (is (= [true] 447 | (query true '((and (male ?x) (male ?x)))))) 448 | (is (= [] 449 | (query true '((and (male ?x) (female ?x)))))) 450 | (is (= [true] 451 | (query true '((and (male ?x) (and (male ?x))))))) 452 | (do (initialize-prolog) 453 | (assert<- '((male laban))) 454 | (assert<- '((male jacob)))) 455 | (is (= [true] 456 | (query true '((and (male ?x) (male ?y)))))) 457 | ;; `or` goal: 458 | (do (initialize-prolog) 459 | (assert<- '((pseudo-succeed)))) 460 | (is (= [] 461 | (query true '((or))))) 462 | (is (= [] 463 | (query true '((or (pseudo-fail)))))) 464 | (is (= [true] 465 | (query true '((or (pseudo-succeed)))))) 466 | (is (= [true] 467 | (query true '((or (pseudo-fail) (pseudo-succeed)))))) 468 | ;; clolog's built-in predicates are simple symbols (not 469 | ;; namespace-qualified)---two tests. 470 | (is (= [] 471 | (query true '((clolog.core/or (pseudo-fail) (pseudo-succeed)))))) 472 | (is (= [] 473 | (query true '((clojure.core/or (pseudo-fail) (pseudo-succeed)))))) 474 | (is (= [] 475 | (query true '((or) (or))))) 476 | (is (= [true] 477 | (query true '((or (or (pseudo-succeed))))))) 478 | (is (= [true] 479 | (query true '((or (or (or (pseudo-succeed)))))))) 480 | (do (initialize-prolog) 481 | (assert<- '((male laban)))) 482 | (is (= [true] 483 | (query true '((or (male ?x)))))) 484 | (is (= [true] 485 | (query true '((or (male ?x) (male ?x)))))) 486 | (is (= [true] 487 | (query true '((or (male ?x) (or (male ?x))))))) 488 | (do (initialize-prolog) 489 | (assert<- '((male laban))) 490 | (assert<- '((male jacob)))) 491 | (is (= '[laban jacob] 492 | (query '?x '((or (male ?x) (male ?x)))))) 493 | (is (= '[?y] 494 | (query '?y '((or (male ?x) (male ?x)))))) 495 | (is (= [true] 496 | (query true '((or (male ?x) (male ?y)))))) 497 | (is (= '[[laban ?y] [jacob ?y] [?x laban] [?x jacob]] 498 | (query '[?x ?y] '((or (male ?x) (male ?y)))))) 499 | (is (= '[[?x ?y]] 500 | (binding [*discard-subsumed-answers* true] 501 | (query '[?x ?y] '((or (male ?x) (male ?y) (male ?z))))))) 502 | ;; `succeed` goal: 503 | (initialize-prolog) 504 | (is (= [true] 505 | (query true '((true))))) 506 | (do (initialize-prolog) 507 | (assert<- '((male laban))) 508 | (assert<- '((male jacob)))) 509 | (is (= '[[laban jacob]] 510 | (query '[laban jacob] '((male ?x) (true) (male ?x))))) 511 | ;; `fail` goal: 512 | (initialize-prolog) 513 | (is (= [] 514 | (query true '((false))))) 515 | ;; `truthy?` goal: 516 | (is (= [true] 517 | (query true '((truthy? true))))) 518 | (is (= [true] 519 | (query true '((truthy? (+ 1 2)))))) 520 | (is (= [true] 521 | (query true '((truthy? true) 522 | (true))))) 523 | (do (initialize-prolog) 524 | (assert<- '((male laban)))) 525 | (is (= '[laban] 526 | (query '?x '((male ?x) 527 | (truthy? (list (quote ?x))))))) 528 | (is (= '[(laban)] 529 | (query '?y '((male ?x) 530 | (evals-from? ?y (list (quote ?x))))))) 531 | (is (= '[laban] 532 | (query '?x '((and (male ?x) 533 | (truthy? (list (quote ?x)))))))) 534 | (is (= '[laban] 535 | (query '?x '((male ?x) 536 | (truthy? (= (quote ?x) 'laban)))))) 537 | (is (= [] 538 | (query '?x '((male ?x) 539 | (truthy? nil))))) 540 | (is (= [] 541 | (query '?x '((truthy? ?x))))) 542 | (is (= '[laban] 543 | (query '?x '((or (male leah) 544 | (male ?x) 545 | (truthy? (list (quote ?x)))))))) 546 | ;; `do` goal: 547 | (is (= '["Hello, laban"] 548 | (? ?message (male ?x) 549 | (evals-from? ?message 550 | (str "Hello, " (quote ?x)))))) 551 | (is (= [true] 552 | (query true '((male ?x) 553 | (do ; println 554 | (clojure.pprint/cl-format nil "Hello, ~a." (quote ?x))))))) 555 | ;; `evals-from?` goal: 556 | (is (= '["Hello, laban."] 557 | (query '?message '((male ?x) 558 | (evals-from? ?message 559 | (clojure.pprint/cl-format nil "Hello, ~a." (quote ?x))))))) 560 | (is (= '["Hello, laban."] 561 | (query '?message '((male ?x) 562 | (evals-from? [?message] 563 | [(clojure.pprint/cl-format nil "Hello, ~a." (quote ?x))]))))) 564 | ;;; `same` goal: 565 | (initialize-prolog) 566 | (is (= '[[1 2]] 567 | (query '[?a ?b] '((same [?a 2] [1 ?b]))))) 568 | (is (= '[(1 2)] 569 | (query '(?a ?b) '((same [?a 2] [1 ?b]))))) 570 | (is (= '[] 571 | (query '(?a ?b) '((different [?a 2] [1 ?b]))))) 572 | ;;; `not` goal: 573 | (is (= [true] 574 | (query true '((not (truthy? false)))))) 575 | (is (= [true] 576 | (query true '((not (brother laban rebecca)))))) 577 | (do (initialize-prolog) 578 | (assert<- '((sister laban rebecca)))) 579 | (is (= '[[laban rebecca]] 580 | (query '[?x ?y] '((sister ?x ?y) 581 | (not (sister ?y ?x)))))) 582 | (initialize-prolog) 583 | (is (= [true] 584 | (query '?x '((and (evals-from? ?x true) (truthy? (quote ?x))))))) 585 | (is (= [true] 586 | (query '?x '((and (evals-from? ?x true) (truthy? ?x)))))) 587 | ;;; `if` goal: 588 | (is (= [true] 589 | (query true '((if (true) (true) (true)))))) 590 | (is (= [true] 591 | (query true '((if (truthy? true) (true) (false)))))) 592 | (is (= [true] 593 | (query '?x '((if (true) 594 | (evals-from? ?x true) 595 | (evals-from? ?x false)))))) 596 | (is (= [false] 597 | (query '?x '((if (false) 598 | (evals-from? ?x true) 599 | (evals-from? ?x false)))))) 600 | (is (= [false] 601 | (query '?x '((if (false) 602 | (evals-from? ?x true) 603 | (if (false) 604 | (evals-from? ?x true) 605 | (evals-from? ?x false))))))) 606 | (is (= [:inner-else] 607 | (query '?x '((if (true) 608 | (if (false) 609 | (evals-from? ?x :inner-then) 610 | (evals-from? ?x :inner-else)) 611 | (evals-from? ?x :outer-else)))))) 612 | (do (initialize-prolog) 613 | (assert<- '((sister laban rebecca)))) 614 | (is (= [true] 615 | (query '?x '((if (sister laban rebecca) 616 | (evals-from? ?x true) 617 | (evals-from? ?x false)))))) 618 | (do (initialize-prolog) 619 | (assert<- '((sister laban rebecca))) 620 | (assert<- '((sister rachel leah)))) 621 | (is (= '[[laban rebecca true] [rachel leah true]] 622 | (query '[?sibling ?sister ?x] '((if (sister ?sibling ?sister) 623 | (evals-from? ?x true) 624 | (evals-from? ?x false)))))) 625 | (initialize-prolog) 626 | (is (= '[[?sibling ?sister false]] 627 | (query '[?sibling ?sister ?x] '((if (sister ?sibling ?sister) 628 | (evals-from? ?x true) 629 | (evals-from? ?x false)))))) 630 | ;;; `first` goal: 631 | (do (initialize-prolog) 632 | (assert<- '((sister laban rebecca))) 633 | (assert<- '((sister rachel leah)))) 634 | (is (= '[[laban rebecca]] 635 | (query '[?sibling ?sister] '((first (sister ?sibling ?sister)))))) 636 | (is (= '[[laban rebecca true]] 637 | (query '[?sibling ?sister ?x] '((if (first (sister ?sibling ?sister)) 638 | (evals-from? ?x true) 639 | (evals-from? ?x false)))))) 640 | (is (= '[[laban rebecca]] 641 | (query '[?sibling ?sister] '((first (and (sister ?sibling ?sister) 642 | (sister ?sibling ?sister))))))) 643 | ;; `var` goal: 644 | (initialize-prolog) 645 | (is (= [true] 646 | (? true (var ?x)))) 647 | (is (= [true] 648 | (query true '((var ?x))))) 649 | (is (= '[?x] 650 | (query '?x '((var ?x))))) 651 | (is (= '[?y] 652 | (query '?y '((var ?x))))) 653 | (is (= [] 654 | (query true '((var 1))))) 655 | ;; Anonymous ?vars: 656 | (do (initialize-prolog) 657 | (assert<- '((sister laban rebecca))) 658 | (assert<- '((sister rachel leah)))) 659 | (is (= '[true] 660 | (query true '((sister ?_person ?_person))))) 661 | (is (= '[true] 662 | (query true '((sister ?_ ?_))))) 663 | (is (= '[true] 664 | (query true '((sister ? ?))))) 665 | ;; Compound special forms: 666 | (initialize-prolog) 667 | (is (= '[] 668 | (query '?x '((and (if (true) 669 | (same ?x :succeed) 670 | (same ?x :fail)) 671 | (evals-from? ?x :succeed) 672 | (false)))))) 673 | (is (= '[:fail] 674 | (query '?x '((and (if (false) 675 | (same ?x :succeed) 676 | (same ?x :fail)) 677 | (evals-from? ?x :fail) 678 | (true)))))) 679 | (is (= '[:fail] 680 | (query '?x '((and (if (false) 681 | (same ?x :succeed) 682 | (same ?x :fail)) 683 | (evals-from? ?x :fail) 684 | (or (true) (false))))))) 685 | (is (= '[:fail] 686 | (query '?x '((and) 687 | (evals-from? ?x :fail) 688 | (true))))) 689 | (is (= '[:fail] 690 | (query '?x '((and (and) 691 | (evals-from? ?x :fail) 692 | (true)))))) 693 | ;; Logic macros: 694 | (initialize-prolog) 695 | (is (= [] 696 | (query true '((cond*))))) 697 | (do (initialize-prolog) 698 | (assert<- '((sister laban rebecca))) 699 | (assert<- '((sister rachel leah)))) 700 | (is (= '[[laban rebecca true]] 701 | (query '[?sibling ?sister ?x] '((if% (sister ?sibling ?sister) 702 | (evals-from? ?x true) 703 | (evals-from? ?x false)))))) 704 | (is (= '[[?sibling false]] 705 | (query '[?sibling ?x] '((cond% (sister ?sibling adam) 706 | (evals-from? ?x 'adam) 707 | 708 | (sister ?sibling eve) 709 | (evals-from? ?x 'eve) 710 | 711 | :else 712 | (evals-from? ?x false)))))) 713 | (is (= '[[?sibling ?sister]] 714 | (binding [*discard-subsumed-answers* true] 715 | (query '[?sibling ?sister] 716 | ;; Wrong definition of `optional`: 717 | '((or (sister ?sibling ?sister) (true))))))) 718 | (is (= '[[laban rebecca]] 719 | (query '[?sibling ?sister] 720 | ;; Also wrong definition of `optional`: 721 | '((first (or (sister ?sibling ?sister) (true))))))) 722 | (is (= '[[laban rebecca] [rachel leah]] 723 | (query '[?sibling ?sister] 724 | '((optional (sister ?sibling ?sister)))))) 725 | (do (initialize-prolog) 726 | (assert<- '((sister laban rebecca))) 727 | (assert<- '((sister rachel leah))) 728 | (create-predicate-transforms :debugging)) 729 | (is (= '[[?sibling false]] 730 | ;; Avoid backtracking into intended-transform predicates. 731 | (binding [*answer-count-limit* 1] 732 | (query '[?sibling ?x] '((cond% (sister ?sibling adam) 733 | (evals-from? ?x 'adam) 734 | 735 | (sister ?sibling eve) 736 | (evals-from? ?x 'eve) 737 | 738 | :else 739 | (evals-from? ?x false))))))) 740 | (initialize-prolog) 741 | (is (= [true] 742 | (? true (ground [a b])))) 743 | (is (= [true] 744 | (query true '((ground [a b]))))) 745 | (is (= [] 746 | (? true (ground ?x)))) 747 | (is (= [1] 748 | (? ?x (same ?x 1) (ground ?x)))) 749 | (is (= '[[?sibling ?sister]] 750 | (query '[?sibling ?sister] 751 | '((optional (sister ?sibling ?sister)))))) 752 | (is (= [true] 753 | (query true '((different 1 2))))) 754 | (is (= [] 755 | (query true '((different 2 2))))) 756 | ;; `->?` forms in goals: 757 | (is (= [true] 758 | (query true '((same (->? (+ 0 1)) 1))))) 759 | ;; `&` in answer template: 760 | (is (= [[1 2 3 4]] 761 | (query '[1 2 & ?rest] '((same ?rest [3 4]))))) 762 | ;; `&` in assertion head statement: 763 | (do (initialize-prolog) 764 | (<- (variadic 1)) 765 | (<- (variadic 1 2))) 766 | (is (= '[(1) (1 2)] 767 | (? ?rest (variadic & ?rest)))) 768 | ;; `&` in goal term: 769 | (is (= '[(variadic 1) (variadic 1 2)] 770 | (? (variadic & ?rest) (variadic & ?rest)))) 771 | ;; `&` in assertion head statement term: 772 | (do (initialize-prolog) 773 | (<- (variadic-term [1])) 774 | (<- (variadic-term [1 2]))) 775 | (is (= '[[1] [1 2]] 776 | (? ?rest (variadic-term [& ?rest])))) 777 | (is (= '[[] [2]] 778 | (? ?rest (variadic-term [1 & ?rest])))) 779 | (is (= '[[1] [1 2]] 780 | (? ?rest (variadic-term (& ?rest))))) 781 | (do (initialize-prolog) 782 | (<- (variadic)) 783 | (<- (variadic 1)) 784 | (<- (variadic 1 2))) 785 | (is (= '[() (1) (1 2)] 786 | (? ?rest (variadic & ?rest)))) 787 | (is (= '[(variadic) (variadic 1) (variadic 1 2)] 788 | (? ?rest (& ?rest)))) 789 | (do (initialize-prolog) 790 | (<- (variadic & ?rest))) 791 | (is (= [true] 792 | (? true (variadic 1)))) 793 | (comment ; Deferred. (Marginal value.) 794 | ;; Map answer template: 795 | (do (initialize-prolog) 796 | (<- (foo 1))) 797 | (is (= [{:answer 1}] 798 | (? {:answer ?x} (foo ?x))))) 799 | ;; Complex predicate: 800 | (do (initialize-prolog) 801 | (<- ([complex] 1))) 802 | (is (= [1] 803 | (? ?x ([complex] ?x)))) 804 | ;; Non-ground complex predicate: 805 | (do (initialize-prolog) 806 | (<- ([complex 1] 1))) 807 | (is (= [1] 808 | (? ?x ([complex ?x] ?x)))) 809 | (do (initialize-prolog) 810 | (<- ([complex ?x] ?x))) 811 | (is (= [true] 812 | (? true ([complex 1] 1)))) 813 | (do (initialize-prolog) 814 | (<- ([complex & ?rest] ?rest))) 815 | (is (= [true] 816 | (? true ([complex 1] (1))))) 817 | ;; Zebra puzzle, adapted from https://franz.com/support/documentation/10.1/doc/prolog.html: 818 | (do (initialize-prolog) 819 | (<-- (member ?item (?item & ?rest))) 820 | (<- (member ?item (?x ?item))) 821 | (<- (member ?item (?x & ?rest)) 822 | (different ?rest ()) 823 | (member ?item ?rest)) 824 | (<-- (nextto ?x ?y ?list) (iright ?x ?y ?list)) 825 | (<- (nextto ?x ?y ?list) (iright ?y ?x ?list)) 826 | (<-- (iright ?left ?right (?left ?right & ?rest))) 827 | (<- (iright ?left ?right (? & ?rest)) 828 | (different ?rest (?)) 829 | (iright ?left ?right ?rest)) 830 | (<-- (zebra ?houses ?w ?z) 831 | (same ?houses ((house norwegian ? ? ? ?) ; 1,10 832 | ? 833 | (house ? ? ? milk ?) ; 9 834 | ? 835 | ?)) 836 | (member (house englishman ? ? ? red) ?houses) ; 2 837 | (member (house spaniard dog ? ? ?) ?houses) ; 3 838 | (member (house ? ? ? coffee green) ?houses) ; 4 839 | (member (house ukrainian ? ? tea ?) ?houses) ; 5 840 | (iright (house ? ? ? ? ivory) ; 6 841 | (house ? ? ? ? green) ?houses) 842 | (member (house ? snails winston ? ?) ?houses) ; 7 843 | (member (house ? ? kools ? yellow) ?houses) ; 8 844 | (nextto (house ? ? chesterfield ? ?) ; 11 845 | (house ? fox ? ? ?) ?houses) 846 | (nextto (house ? ? kools ? ?) ; 12 847 | (house ? horse ? ? ?) ?houses) 848 | (member (house ? ? luckystrike oj ?) ?houses) ; 13 849 | (member (house japanese ? parliaments ? ?) ?houses) ; 14 850 | (nextto (house norwegian ? ? ? ?) ; 15 851 | (house ? ? ? ? blue) ?houses) 852 | (member (house ?w ? ? water ?) ?houses) ; Q1 853 | (member (house ?z zebra ? ? ?) ?houses)) ; Q2 854 | ) 855 | (is (= [true] 856 | (? true (member 1 (1 2 3))))) 857 | (is (= [1 2 3] 858 | (? ?x (member ?x (1 2 3))))) 859 | (is (= [true] 860 | (? true (member 2 ?)))) 861 | (is (= '[(1)] 862 | (? ?numbers (same ?numbers (?first)) 863 | (member 1 ?numbers)))) 864 | (is (= '[(1)] 865 | (? ?numbers (same ?numbers (?)) 866 | (member 1 ?numbers)))) 867 | (is (= '[(1 2 3)] 868 | (? ?numbers (same ?numbers (1 2 ?)) 869 | (member 3 ?numbers)))) 870 | (is (= [true] 871 | (? true (iright 1 2 (1 2 3))))) 872 | (is (= '[[1 2] [2 3]] 873 | (? [?l ?r] (iright ?l ?r (1 2 3))))) 874 | (is (= [[1 2] [2 3] [2 1] [3 2]] 875 | (? [?a ?b] (nextto ?a ?b (1 2 3))))) 876 | (is (= '[((house norwegian ?anon-0 ?anon-1 ?anon-2 ?anon-3) 877 | (house englishman ?anon-11 ?anon-12 ?anon-13 red) 878 | (house spaniard dog ?anon-7 milk ivory) 879 | (house ?anon-17 ?anon-18 ?anon-19 coffee green) 880 | (house ukrainian ?anon-20 ?anon-21 tea ?anon-22))] 881 | (binding [*pprint-leash-statements* true] ; Show this off, briefly. 882 | (? ((house norwegian ?anon-0 ?anon-1 ?anon-2 ?anon-3) 883 | (house englishman ?anon-11 ?anon-12 ?anon-13 red) 884 | (house spaniard dog ?anon-7 milk ?anon-8) 885 | (house ?anon-17 ?anon-18 ?anon-19 coffee green) 886 | (house ukrainian ?anon-20 ?anon-21 tea ?anon-22)) 887 | (iright 888 | (house ?anon-23 ?anon-24 ?anon-25 ?anon-26 ivory) 889 | (house ?anon-27 ?anon-28 ?anon-29 ?anon-30 green) 890 | ((house norwegian ?anon-0 ?anon-1 ?anon-2 ?anon-3) 891 | (house englishman ?anon-11 ?anon-12 ?anon-13 red) 892 | (house spaniard dog ?anon-7 milk ?anon-8) 893 | (house ?anon-17 ?anon-18 ?anon-19 coffee green) 894 | (house ukrainian ?anon-20 ?anon-21 tea ?anon-22))))))) 895 | (is (= '[(? red ivory green)] 896 | (? (? red ivory green) (iright ivory green (? red ? green))))) 897 | (comment ; Long run time (especially when leashed). See separate test. 898 | (is (= '[[((house norwegian fox kools water yellow) 899 | (house ukrainian horse chesterfield tea blue) 900 | (house englishman snails winston milk red) 901 | (house spaniard dog luckystrike oj ivory) 902 | (house japanese zebra parliaments coffee green)) 903 | norwegian 904 | japanese]] 905 | (query '[?h ?w ?z] '((zebra ?h ?w ?z)) :limit 1)))) 906 | )) 907 | 908 | (comment ; Long run time. 909 | (deftest test-zebra-puzzle-only 910 | (testing "zebra" 911 | ;; Zebra puzzle, adapted from https://github.com/p-swift/projure README: 912 | (do (initialize-prolog) 913 | (<-- (member ?item (?item & ?rest))) 914 | (<- (member ?item (?x ?item))) 915 | (<- (member ?item (?x & ?rest)) 916 | (different ?rest ()) 917 | (member ?item ?rest)) 918 | (<-- (nextto ?x ?y ?list) (iright ?x ?y ?list)) 919 | (<- (nextto ?x ?y ?list) (iright ?y ?x ?list)) 920 | (<-- (iright ?left ?right (?left ?right & ?rest))) 921 | (<- (iright ?left ?right (? & ?rest)) 922 | (different ?rest (?)) 923 | (iright ?left ?right ?rest)) 924 | (<-- (zebra ?houses ?w ?z) 925 | (same ?houses ((house norwegian ? ? ? ?) ; 1,10 926 | ? 927 | (house ? ? ? milk ?) ; 9 928 | ? 929 | ?)) 930 | (member (house englishman ? ? ? red) ?houses) ; 2 931 | (member (house spaniard dog ? ? ?) ?houses) ; 3 932 | (member (house ? ? ? coffee green) ?houses) ; 4 933 | (member (house ukrainian ? ? tea ?) ?houses) ; 5 934 | (iright (house ? ? ? ? ivory) ; 6 935 | (house ? ? ? ? green) ?houses) 936 | (member (house ? snails winston ? ?) ?houses) ; 7 937 | (member (house ? ? kools ? yellow) ?houses) ; 8 938 | (nextto (house ? ? chesterfield ? ?) ; 11 939 | (house ? fox ? ? ?) ?houses) 940 | (nextto (house ? ? kools ? ?) ; 12 941 | (house ? horse ? ? ?) ?houses) 942 | (member (house ? ? luckystrike oj ?) ?houses) ; 13 943 | (member (house japanese ? parliaments ? ?) ?houses) ; 14 944 | (nextto (house norwegian ? ? ? ?) ; 15 945 | (house ? ? ? ? blue) ?houses) 946 | (member (house ?w ? ? water ?) ?houses) ; Q1 947 | (member (house ?z zebra ? ? ?) ?houses)) ; Q2 948 | ) 949 | (is (= '[[((house norwegian fox kools water yellow) 950 | (house ukrainian horse chesterfield tea blue) 951 | (house englishman snails winston milk red) 952 | (house spaniard dog luckystrike oj ivory) 953 | (house japanese zebra parliaments coffee green)) 954 | norwegian 955 | japanese]] 956 | (query '[?h ?w ?z] '((zebra ?h ?w ?z)) :limit 1)))))) 957 | 958 | (deftest test-zebra-puzzle-only 959 | (testing "zebra" 960 | ;; Zebra puzzle, adapted from https://github.com/p-swift/projure README: 961 | (do (initialize-prolog) 962 | (<-- (member ?item (?item & ?rest))) 963 | (<- (member ?item (?x ?item))) 964 | (<- (member ?item (?x & ?rest)) 965 | (different ?rest ()) 966 | (member ?item ?rest)) 967 | (<-- (nextto ?x ?y ?list) (iright ?x ?y ?list)) 968 | (<- (nextto ?x ?y ?list) (iright ?y ?x ?list)) 969 | (<-- (iright ?left ?right (?left ?right & ?rest))) 970 | (<- (iright ?left ?right (? & ?rest)) 971 | (different ?rest (?)) 972 | (iright ?left ?right ?rest)) 973 | (<-- (zebra ?houses ?w ?z) 974 | (same ?houses ((house norwegian ? ? ? ?) ; 1,10 975 | ? 976 | (house ? ? ? milk ?) ; 9 977 | ? 978 | ?)) 979 | (member (house englishman ? ? ? red) ?houses) ; 2 980 | (member (house spaniard dog ? ? ?) ?houses) ; 3 981 | (member (house ? ? ? coffee green) ?houses) ; 4 982 | (member (house ukrainian ? ? tea ?) ?houses) ; 5 983 | (iright (house ? ? ? ? ivory) ; 6 984 | (house ? ? ? ? green) ?houses) 985 | (member (house ? snails winston ? ?) ?houses) ; 7 986 | (member (house ? ? kools ? yellow) ?houses) ; 8 987 | (nextto (house ? ? chesterfield ? ?) ; 11 988 | (house ? fox ? ? ?) ?houses) 989 | (nextto (house ? ? kools ? ?) ; 12 990 | (house ? horse ? ? ?) ?houses) 991 | (member (house ? ? luckystrike oj ?) ?houses) ; 13 992 | (member (house japanese ? parliaments ? ?) ?houses) ; 14 993 | (nextto (house norwegian ? ? ? ?) ; 15 994 | (house ? ? ? ? blue) ?houses) 995 | (member (house ?w ? ? water ?) ?houses) ; Q1 996 | (member (house ?z zebra ? ? ?) ?houses)) ; Q2 997 | ) 998 | (is (= '[[((house norwegian fox kools water yellow) 999 | (house ukrainian horse chesterfield tea blue) 1000 | (house englishman snails winston milk red) 1001 | (house spaniard dog luckystrike oj ivory) 1002 | (house japanese zebra parliaments coffee green)) 1003 | norwegian 1004 | japanese]] 1005 | (query '[?h ?w ?z] '((zebra ?h ?w ?z)) :limit 1))))) 1006 | 1007 | ;;; Run this (at a clolog.core REPL), to generate leash tests. 1008 | ;;; Copy any authoritative output to leash-tests.txt. 1009 | (comment (binding [*transcribe-query-info* true 1010 | *leash* true 1011 | *answer-count-limit* nil 1012 | ;; Try also `false` (and expect to fail a few tests). 1013 | *discard-subsumed-answers* true] 1014 | (clolog.core-test/query-test))) 1015 | 1016 | (comment 1017 | ;; Not maintained. See leash-tests.txt (which we diff against output 1018 | ;; from the above). 1019 | (deftest test-leashing 1020 | (testing "Leashing" 1021 | (do (initialize-prolog) 1022 | (assert<- '((male laban)))) 1023 | (is (= (with-out-str 1024 | (print "0. Processing query: ((male ?x)) 1025 | 0. Working on goal (male ?x:0) 1026 | 0. Remaining goals: () 1027 | 1. Entering male/1: (male laban) 1028 | 1. Matched head (male laban): (male laban) 1029 | 1. Succeeded male/1: (male laban) 1030 | Recorded answer: laban 1031 | 1. Backtracking into male/1: (male laban) 1032 | 1. Failed male/1: (male laban) 1033 | 0. Finished query: ((male ?x)) 1034 | ")) 1035 | ;; Harder (w.r.t. initial continuation `:done`): 1036 | ;; 1. Backtracking into male/1: (male ?x:0) 1037 | ;; 1. Failed male/1: (male ?x:0) 1038 | ;; Skipping that tail, for now. 1039 | (with-out-str 1040 | (binding [*leash* true] 1041 | (query '?x '((male ?x))))))) 1042 | (do (initialize-prolog) 1043 | (assert<- '((male laban))) 1044 | (assert<- '((male jacob)))) 1045 | (is (= (with-out-str 1046 | (print "0. Processing query: ((male ?x)) 1047 | 0. Working on goal (male ?x:0) 1048 | 0. Remaining goals: () 1049 | 1. Entering male/1: (male laban) 1050 | 1. Matched head (male laban): (male laban) 1051 | 1. Succeeded male/1: (male laban) 1052 | Recorded answer: laban 1053 | 1. Backtracking into male/1: (male laban) 1054 | 1. Succeeded male/1: (male jacob) 1055 | Recorded answer: jacob 1056 | 1. Backtracking into male/1: (male jacob) 1057 | 1. Failed male/1: (male jacob) 1058 | 0. Finished query: ((male ?x)) 1059 | ")) 1060 | (with-out-str 1061 | (binding [*leash* true] 1062 | (query '?x '((male ?x))))))) 1063 | 1064 | ;; Missing predicate: 1065 | (initialize-prolog) 1066 | (is (= (with-out-str 1067 | (print "0. Processing query: ((foo)) 1068 | 0. Working on goal (foo) 1069 | 0. Remaining goals: () 1070 | 1. Entering foo/0: (foo) 1071 | 1. Failed foo/0: (foo) 1072 | 0. Finished query: ((foo)) 1073 | ")) 1074 | (with-out-str 1075 | (binding [*leash* true] 1076 | (query true '((foo))))))) 1077 | 1078 | (do (initialize-prolog) 1079 | (assert<- '((male laban)))) 1080 | (is (= (with-out-str 1081 | (print "0. Processing query: ((male ?x) (foo)) 1082 | 0. Working on goal (male ?x:0) 1083 | 0. Remaining goals: ((foo)) 1084 | 1. Entering male/1: (male laban) 1085 | 1. Matched head (male laban): (male laban) 1086 | 1. Succeeded male/1: (male laban) 1087 | 0. Working on goal (foo) 1088 | 0. Remaining goals: () 1089 | 1. Entering foo/0: (foo) 1090 | 1. Failed foo/0: (foo) 1091 | 1. Backtracking into male/1: (male laban) 1092 | 1. Failed male/1: (male laban) 1093 | 0. Finished query: ((male ?x) (foo)) 1094 | ")) 1095 | (with-out-str 1096 | (binding [*leash* true] 1097 | (query '?x '((male ?x) (foo))))))) 1098 | 1099 | (do (initialize-prolog) 1100 | (assert<- '((uncle ?nibling ?uncle) ; <-- 1101 | (parent ?nibling ?parent) 1102 | (sibling ?uncle ?parent) 1103 | (male ?uncle))) 1104 | (assert<- '((sibling ?x ?y) ; <-- 1105 | (brother ?x ?y))) 1106 | (assert<- '((sibling ?x ?y) ; <-- 1107 | (sister ?x ?y))) 1108 | (assert<- '((sister laban rebecca))) 1109 | (assert<- '((male laban))) 1110 | (assert<- '((male jacob))) 1111 | (assert<- '((parent jacob rebecca))) 1112 | (assert<- '((both-male ?one ?two) ; <-- 1113 | (male ?one) 1114 | (male ?two)))) 1115 | (is (= (with-out-str 1116 | (print "0. Processing query: ((uncle jacob ?uncle)) 1117 | 0. Working on goal (uncle jacob ?uncle:0) 1118 | 0. Remaining goals: () 1119 | 1. Entering uncle/2: (uncle jacob ?uncle:1) 1120 | 1. Matched head (uncle ?nibling:1 ?uncle:1): (uncle jacob ?uncle:1) 1121 | 1. Working on goal (parent ?nibling:1 ?parent:1): (parent jacob ?parent:1) 1122 | 1. Remaining goals: ((sibling ?uncle:1 ?parent:1) (male ?uncle:1) (male jacob)) 1123 | 2. Entering parent/2: (parent jacob rebecca) 1124 | 2. Matched head (parent jacob rebecca): (parent jacob rebecca) 1125 | 2. Succeeded parent/2: (parent jacob rebecca) 1126 | 1. Working on goal (sibling ?uncle:1 ?parent:1): (sibling ?uncle:1 rebecca) 1127 | 1. Remaining goals: ((male ?uncle:1) (male jacob)) 1128 | 2. Entering sibling/2: (sibling ?x:3 rebecca) 1129 | 2. Matched head (sibling ?x:3 ?y:3): (sibling ?x:3 rebecca) 1130 | 2. Working on goal (brother ?x:3 ?y:3): (brother ?x:3 rebecca) 1131 | 2. Remaining goals: () 1132 | 3. Entering brother/2: (brother ?x:3 rebecca) 1133 | 3. Failed brother/2: (brother ?x:3 rebecca) 1134 | 2. Backtracking into sibling/2: (sibling ?x:3 rebecca) 1135 | 2. Working on goal (sister ?x:3 ?y:3): (sister ?x:3 rebecca) 1136 | 2. Remaining goals: () 1137 | 3. Entering sister/2: (sister laban rebecca) 1138 | 3. Matched head (sister laban rebecca): (sister laban rebecca) 1139 | 3. Succeeded sister/2: (sister laban rebecca) 1140 | 1. Working on goal (male ?uncle:1): (male laban) 1141 | 1. Remaining goals: ((male jacob)) 1142 | 2. Entering male/1: (male laban) 1143 | 2. Matched head (male laban): (male laban) 1144 | 2. Succeeded male/1: (male laban) 1145 | 1. Working on goal (male ?nibling:1): (male jacob) 1146 | 1. Remaining goals: () 1147 | 2. Entering male/1: (male jacob) 1148 | 2. Matched head (male jacob): (male jacob) 1149 | 2. Succeeded male/1: (male jacob) 1150 | Recorded answer: laban 1151 | 2. Backtracking into male/1: (male jacob) 1152 | 2. Failed male/1: (male jacob) 1153 | 2. Backtracking into male/1: (male laban) 1154 | 2. Failed male/1: (male laban) 1155 | 3. Backtracking into sister/2: (sister laban rebecca) 1156 | 3. Failed sister/2: (sister laban rebecca) 1157 | 2. Backtracking into sibling/2: (sibling ?x:3 rebecca) 1158 | 2. Failed sibling/2: (sibling ?x:3 rebecca) 1159 | 2. Backtracking into parent/2: (parent jacob rebecca) 1160 | 2. Failed parent/2: (parent jacob rebecca) 1161 | 1. Backtracking into uncle/2: (uncle jacob ?uncle:1) 1162 | 1. Failed uncle/2: (uncle jacob ?uncle:1) 1163 | 0. Finished query: ((uncle jacob ?uncle)) 1164 | ")) 1165 | (with-out-str 1166 | (binding [*leash* true] 1167 | (query '?uncle '((uncle jacob ?uncle))))))) 1168 | ))) 1169 | 1170 | ;;; OBE: Try this on a failing leash test. 1171 | (comment 1172 | (defn elucidate-leash-test-result [result] 1173 | (clojure.string/split-lines result)) 1174 | ) 1175 | 1176 | (comment 1177 | ;; Change `defn-` to `defn` in now-private `adjudication-status` and 1178 | ;; `unify`, then uncomment to run these tests. 1179 | 1180 | 1181 | (deftest adjudication-status-test 1182 | (testing "adjudication-status" 1183 | (is (= :subsumed 1184 | (adjudication-status '?x true))) 1185 | (is (= :subsumes 1186 | (adjudication-status true '?x))) 1187 | (is (= :equivalent 1188 | (adjudication-status true true))) 1189 | (is (= :equivalent 1190 | (adjudication-status '?y '?x))) 1191 | (is (= :different 1192 | (adjudication-status true false))) 1193 | )) 1194 | 1195 | (deftest unify-test 1196 | (testing "unify" 1197 | (is (= '[{?all [1 2 3]} {}] 1198 | (unify '[& ?all] [1 2 3]))) 1199 | (is (= '[{} {?all [1 2 3]}] 1200 | (unify [1 2 3] '[& ?all]))) 1201 | (is (= '[{?all [2 3]} {}] 1202 | (unify '[1 & ?all] [1 2 3]))) 1203 | (is (= '[{?some [2 3]} {}] 1204 | (unify '[1 & ?some] [1 2 3]))) 1205 | (is (= '[{?rest ?more} {?more ?rest}] 1206 | (unify '[1 2 & ?rest] '[1 2 & ?more]))) 1207 | (comment (is (= '[{?rest [3 4]} {}] 1208 | ;; We don't expect/generally support this usage. 1209 | (unify '[1 2 & ?rest] '[1 2 & [3 4]])))) 1210 | (is (= '[{?rest [3 4]} {}] 1211 | (unify '[1 2 & ?rest] '[1 2 3 4]))) 1212 | (is (= '[{?rest (3 4)} {}] 1213 | (unify '(1 2 & ?rest) '(1 2 3 4)))) 1214 | )) 1215 | 1216 | ) 1217 | --------------------------------------------------------------------------------