├── .gitignore
├── CHANGELOG.md
├── LICENSE
├── README.md
├── build.clj
├── deps.edn
├── doc
├── API.md
├── ARCHITECTURE.md
├── ideas.txt
└── rv.bib
├── pom.xml
├── src
└── fogus
│ └── rv
│ ├── amb.clj
│ ├── constraints.clj
│ ├── core.clj
│ ├── datalog.clj
│ ├── fuzzy
│ └── soundex.clj
│ ├── impl
│ └── unification.clj
│ ├── learn.clj
│ ├── learn
│ └── vs.clj
│ ├── productions.clj
│ ├── search.clj
│ ├── search
│ └── graph.clj
│ └── util.clj
└── test
└── rv
├── amb_test.clj
├── constraint_test.clj
├── datalog_test.clj
├── fuzzy
└── soundex_test.clj
├── learn
└── vs_test.clj
├── productions_test.clj
└── search
└── astar_test.clj
/.gitignore:
--------------------------------------------------------------------------------
1 | /target
2 | /classes
3 | /checkouts
4 | pom.xml.asc
5 | *.jar
6 | *.class
7 | /.lein-*
8 | /.nrepl-port
9 | .hgignore
10 | .hg/
11 | .cpcache
12 | _
13 |
--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # v0.0.10
2 | - Added vector encoding for datalog tuples
3 |
4 | # v0.0.9
5 | - Added functions to enable human-in-the-loop learning to `fogus.rv.learn.vs` namespace
6 | - `(explain [vs example])` returns a structure explaining how the classifier reaches a conclusion
7 | - `(best-fit [vs example])` returns the best-fit hypothesis for an example
8 | - See [API.md](https://github.com/fogus/rv/blob/main/doc/API.md#fogusrvlearnvs) for details
9 | - Cleaned up the docstrings in the `fogus.rv.learn.vs`
10 |
11 | # v0.0.8
12 | - Added (fogus.rv.util/pairwise-every? [pred xs ys]) combinator to build Clojure
13 | style `*-every?` functions of two arguments.
14 | - Added (fogus.rv.util/positions-of [pred & xs]) function that returns the indices
15 | of values that match a predicate in any number of collections.
16 | - Added fogus.rv.learn.vs containing an implementation of version space learning
17 | using an inductive candidate-elimination algorithm.
18 | - Added docs/API.md documentation.
19 |
20 | # v0.0.7
21 | - Added (fogus.rv.util/f-by [f key coll]) combinator to build Clojure-style `*-by`
22 | functions.
23 | - Added fogus.rv.search ns containing search-related protocols GraphSearch and
24 | HeuristicSearch.
25 | - Refined fogus.rv.search.astar/astar to work in terms of the GraphSearch and
26 | HeuristicSearch protocols. Takes a graph object implementing those protocols
27 | plus a start node and goal node to find the lowest cost path between them.
28 |
29 | # v0.0.6
30 | - Added fogus.rv.constraints ns exposing two functions: satisfy1 and satisfy* that take
31 | a constraint description containing :variables and :formula mappings and return
32 | context(s) defining bindings for the variables constrained by formula.
33 | - Added a bibtex file with the references for rv
34 |
35 | # v0.0.5
36 | - Added the ability to define entity enumerations by mapping a key to a set. These are
37 | expanded into [id k v] for each element in the set.
38 | - Changed the name from reinen-vernunft to rv... please stop contacting me about the old name. ;)
39 |
40 | # v0.0.4
41 | - Added extra arity to both map->relation and table->kb to take id function, which can
42 | be used to override the default :kb/id gen or existing key.
43 | - Added a fogus.reinen-vernunft.fuzzy.soundex/encode function that implements the
44 | American soundex algorithm. https://en.wikipedia.org/wiki/Soundex
45 |
46 | # v0.0.3
47 | - Added fogus.reinen-vernunft.datalog ns based on cgrand's 39loc datalog
48 | - Added map->relation and table->kb conversion functions in fogus.reinen-vernunft.core
49 |
50 | # v0.0.2
51 | - me.fogus release
52 |
53 |
54 |
--------------------------------------------------------------------------------
/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: GNU General Public
267 | License as published by the Free Software Foundation, either version 2
268 | of the License, or (at your option) any later version, with the GNU
269 | Classpath Exception which is available at
270 | https://www.gnu.org/software/classpath/license.html."
271 |
272 | Simply including a copy of this Agreement, including this Exhibit A
273 | is not sufficient to license the Source Code under Secondary Licenses.
274 |
275 | If it is not possible or desirable to put the notice in a particular
276 | file, then You may include the notice in a location (such as a LICENSE
277 | file in a relevant directory) where a recipient would be likely to
278 | look for such a notice.
279 |
280 | You may add additional accurate notices of copyright ownership.
281 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # rv
2 |
3 | Explorations in pure reasoning algorithms with Clojure.
4 |
5 | ## Including
6 |
7 | ### deps.edn
8 |
9 | me.fogus/rv {:mvn/version "0.0.10"}
10 |
11 | OR
12 |
13 | io.github.fogus/rv {:git/tag "v0.0.10" :git/sha "..."}
14 |
15 | ### Leiningen
16 |
17 | Modify your [Leiningen](http://github.com/technomancy/leiningen) dependencies to include:
18 |
19 | :dependencies [[me.fogus/rv "0.0.10"] ...]
20 |
21 | ### Maven
22 |
23 | Add the following to your `pom.xml` file:
24 |
25 |
26 | me.fogus
27 | rv
28 | 0.0.10
29 |
30 |
31 | ## Dev
32 |
33 | Namespaces under the wip sub-ns are works in progress and should only be used for experimentation. It is expected that these implementations will change frequently and may disappear altogether.
34 |
35 | clj -X:dev:test
36 |
37 | To generate the current API docs run the following:
38 |
39 | clj -Tquickdoc quickdoc '{:outfile "doc/API.md", :github/repo "https://github.com/fogus/rv", :toc false}'
40 |
41 | The above requires that you install quickdocs as a CLI tool first.
42 |
43 | ## License
44 |
45 | Copyright © 2017-2025 Fogus
46 |
47 | Distributed under the Eclipse Public License version 2.0
48 |
--------------------------------------------------------------------------------
/build.clj:
--------------------------------------------------------------------------------
1 | (ns build
2 | (:require [clojure.tools.build.api :as b]))
3 |
4 | (def lib 'me.fogus/rv)
5 | (def description "Code conversations in Clojure regarding the application of pure search, reasoning, and query algorithms.")
6 | ;;(def version (format "0.0.%s" (b/git-count-revs nil)))
7 | (def version "0.0.10")
8 | (def class-dir "target/classes")
9 | (def jar-file (format "target/%s.jar" (name lib)))
10 |
11 | ;; delay to defer side effects (artifact downloads)
12 | (def basis (delay (b/create-basis{:project "deps.edn"})))
13 |
14 | (defn clean [_]
15 | (b/delete {:path "target"}))
16 |
17 | (defn jar [_]
18 | (b/write-pom {:class-dir class-dir
19 | :lib lib
20 | :version version
21 | :basis (update-in @basis [:libs] dissoc 'org.clojure/clojure)
22 | :src-dirs ["src"]})
23 | (b/copy-dir {:src-dirs ["src" "resources"]
24 | :target-dir class-dir})
25 | (b/jar {:class-dir class-dir
26 | :jar-file jar-file}))
27 |
--------------------------------------------------------------------------------
/deps.edn:
--------------------------------------------------------------------------------
1 | {
2 | :paths ["src"]
3 | :deps {org.clojure/core.unify {:mvn/version "0.7.0"}
4 | me.fogus/evalive {:mvn/version "1.1.1"}}
5 |
6 | :aliases {:test {:extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}
7 | :main-opts ["-m" "cognitect.test-runner"]
8 | :exec-fn cognitect.test-runner.api/test
9 | :extra-paths ["test"]}
10 |
11 | :build
12 | {:deps {io.github.clojure/tools.build {:git/tag "v0.10.6" :git/sha "52cf7d6"}}
13 | :ns-default build}
14 |
15 | :deploy
16 | {:extra-deps {slipset/deps-deploy {:mvn/version "RELEASE"}}
17 | :exec-fn deps-deploy.deps-deploy/deploy
18 | :exec-args {:installer :remote
19 | :sign-releases? true
20 | :sign-key-id "CBBDC7BE00954E2E3A46C80CA3994949855D2816"
21 | :artifact "target/rv.jar"}}
22 |
23 | :dev {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0"}}}
24 | }
25 | }
26 |
27 |
--------------------------------------------------------------------------------
/doc/API.md:
--------------------------------------------------------------------------------
1 |
2 | -----
3 | # fogus.rv.amb
4 |
5 |
6 | Provides an implementation of McCarthy's [`amb`](#fogus.rv.amb/amb) operator with
7 | binding forms and acceptance test operator.
8 |
9 |
10 |
11 |
12 | ## `accept`
13 | ``` clojure
14 |
15 | (accept condition ret)
16 | ```
17 | Function.
18 | Source
19 |
20 | ## `amb`
21 | ``` clojure
22 |
23 | (amb & [binds & body])
24 | ```
25 | Function.
26 |
27 | A macro that provides a non-deterministic way to traverse a space
28 | and find a single solution amongst potentially many. If the search
29 | space is exhausted then [[[`amb`](#fogus.rv.amb/amb)](#fogus.rv.amb/amb)](#fogus.rv.amb/amb) will return `nil`. The general form
30 | of [[[`amb`](#fogus.rv.amb/amb)](#fogus.rv.amb/amb)](#fogus.rv.amb/amb) is as follows:
31 |
32 | (amb )
33 |
34 | Where `` is a typical Clojure bindings form:
35 |
36 | [ ... ]
37 |
38 | And `` is one or more Clojure expressions.
39 |
40 | Within the execution body the `(accept )`
41 | form is used to test some combination of the bindings for adherence
42 | to a `` and return an `` that serves as the
43 | return value of the call to [[[`amb`](#fogus.rv.amb/amb)](#fogus.rv.amb/amb)](#fogus.rv.amb/amb).
44 |
45 | A call to `(amb)` (i.e. without bindings and body) will exhaust
46 | immediately and thus result in `nil` as its value.
47 | Source
48 |
49 | -----
50 | # fogus.rv.constraints
51 |
52 |
53 | Constraints solving functions that operate on a Constraint Description
54 | which is a map describing a constraint description containing the mappings:
55 | - :variables -> seq of LVars
56 | - :formula -> list describing a predicate expression composed of a mix of
57 | the LVars in :variables and Clojure functions.
58 |
59 |
60 |
61 |
62 | ## `satisfy*`
63 | ``` clojure
64 |
65 | (satisfy* {:keys [variables formula :as c]})
66 | ```
67 |
68 | Accepts a map describing a constraint description containing the mappings:
69 | - :variables -> seq of LVars
70 | - :formula -> list describing a predicate expression composed of a mix of
71 | the LVars in :variables and Clojure functions
72 |
73 | This function will use the constraint description to calculate the all of
74 | the values for the LVars that satisfy the formula. The result is a seq of
75 | maps with mappings from LVar -> value. If there is no way to satisfy the
76 | formula then an empty seq is the result.
77 |
78 | The ordering of the results of this function is not guaranteed to be stable.
79 | Source
80 |
81 | ## `satisfy1`
82 | ``` clojure
83 |
84 | (satisfy1 {:keys [variables formula :as c]})
85 | ```
86 |
87 | Accepts a map describing a constraint description containing the mappings:
88 | - :variables -> seq of LVars
89 | - :formula -> list describing a predicate expression composed of a mix of
90 | the LVars in :variables and Clojure functions
91 |
92 | This function will use the constraint description to calculate the first
93 | set of values for the LVars that satisfy the formula. The result is a map
94 | with mappings from LVar -> value. If there is no way to satisfy the formula
95 | then an empty map is the result.
96 |
97 | The first found result of this function is not guaranteed to be stable.
98 | Source
99 |
100 | -----
101 | # fogus.rv.core
102 |
103 |
104 | Most functions in rv work off of one or more of the following core
105 | concepts:
106 |
107 | - Entity: a hashmap with a :kb/id key mapped to a unique value and namespaced keys
108 | - Table: a set of hashmaps or Entities
109 | - Fact: a vector triple in the form [entity-id attribute value]
110 | - Relation: a set of Facts pertaining to a particular Entity
111 | - LVar: a logic variable that can bind to any value in its :range
112 | - Ground: a concrete value
113 | - Query: a set of Facts containing a mix of LVars and Grounds
114 | - Rules: a set of Facts describing synthetic relations
115 | - Production: a pair of: antecedent query and consequent Facts
116 | - KB: a set of Relations about many Entities and possibly containing Productions
117 | - Constraint Description: a set of LVars and a Formula describing the domain of their values
118 | - Formula: a list describing a predicate expression of mixed LVars and clojure functions
119 |
120 |
121 |
122 |
123 | ## `->AnyT`
124 | ``` clojure
125 |
126 | (->AnyT)
127 | ```
128 | Source
129 |
130 | ## `->AskT`
131 | ``` clojure
132 |
133 | (->AskT)
134 | ```
135 | Source
136 |
137 | ## `->IgnoreT`
138 | ``` clojure
139 |
140 | (->IgnoreT)
141 | ```
142 | Source
143 |
144 | ## `AnyT`
145 |
146 |
147 |
148 | Source
149 |
150 | ## `AskT`
151 |
152 |
153 |
154 | Source
155 |
156 | ## `ID_KEY`
157 |
158 |
159 |
160 | Source
161 |
162 | ## `IgnoreT`
163 |
164 |
165 |
166 | Source
167 |
168 | ## `lv?`
169 | ``` clojure
170 |
171 | (lv? %1)
172 | ```
173 | Source
174 |
175 | ## `map->relation`
176 | ``` clojure
177 |
178 | (map->relation entity)
179 | (map->relation idfn entity)
180 | ```
181 |
182 | Converts a map to a set of tuples for that map, applying a unique
183 | :kb/id if the map doesn't already have a value mapped for that key.
184 |
185 | Relation values that are sets are expanded into individual tuples
186 | per item in the set with the same :kb/id as the entity and the
187 | attribute that the whole set was mapped to.
188 |
189 | An idfn is a function of map -> id and if provided is used to
190 | override the default entity id generation and any existing :kb/id
191 | values.
192 | Source
193 |
194 | ## `table->kb`
195 | ``` clojure
196 |
197 | (table->kb table)
198 | (table->kb idfn table)
199 | ```
200 |
201 | Converts a Table into a KB, applying unique :kb/id to maps without a
202 | mapped identity value.
203 |
204 | See map->relation for more information about how the entities in the
205 | table are converted to relations.
206 |
207 | An idfn is a function of map -> id and if provided is used to
208 | override the default entity id generation and any existing :kb/id
209 | values.
210 | Source
211 |
212 | -----
213 | # fogus.rv.datalog
214 |
215 |
216 | A minimal implementation of Datalog.
217 |
218 |
219 |
220 |
221 | ## `linked-list-rules`
222 |
223 |
224 |
225 | Source
226 |
227 | ## `q`
228 | ``` clojure
229 |
230 | (q query kb)
231 | (q query kb rules)
232 | ```
233 |
234 | Queries a knowledge base or a set of relations given a vector
235 | form of a query and an optional set of rules.
236 |
237 | A query takes the form:
238 |
239 | [:find find-spec :where clauses]
240 |
241 | A find-spec can be any number of lvars like:
242 |
243 | [:find ?e ?v :where ...]
244 |
245 | or a tuple containing a mix of lvars and grounds which is used to
246 | build output tuples from the query results:
247 |
248 | [:find [?e :an/attribute ?v] :where ...]
249 |
250 | The :where clauses are any number of tuples containing a mix of
251 | lvars and grounds:
252 |
253 | [:find ...
254 | :where
255 | [?e :an/attribute ?v]
256 | [?e :another/attr 42]]
257 |
258 | :where clauses may also contain filters defined as calls to predicates
259 | used to constrain the values that may bind to lvars:
260 |
261 | [:find ...
262 | :where
263 | [?e :an/attribute ?v]
264 | (= ?v 42)]
265 |
266 | The possible filter predicates are: =, not=, <, >, <=, >=
267 |
268 | rules are a vector of lists where each list defines a rule with a
269 | single head tuple followed by any number of rule clauses:
270 |
271 | ([?p :relationship/parent ?c] [?p :relationship/father ?c])
272 |
273 | The rule above defines a syntheic relation called
274 | `:relationship/parent` defined in terms of another relation
275 | `relationship/father`. Rules describe synthetic relations derived
276 | from real relations in the data or other synthetic relations
277 | derived from previous rule applications.
278 | Source
279 |
280 | ## `query->map`
281 | ``` clojure
282 |
283 | (query->map query)
284 | ```
285 |
286 | Accepts the vector form of a Datalog query and outputs a map
287 | of the component sections as keyword->seq mappings.
288 | Source
289 |
290 | -----
291 | # fogus.rv.fuzzy.soundex
292 |
293 |
294 | I came across the Soundex algorithm when researching the retro KAMAS outlining application.
295 | Soundex is a phonetic algorithm for indexing words by sound.
296 |
297 |
298 |
299 |
300 | ## `encode`
301 | ``` clojure
302 |
303 | (encode word & {:keys [numeric?], :as opts})
304 | ```
305 |
306 | Soundex is an algorithm for creating indices for words based on their
307 | English pronunciation. Homophones are encoded such that words can be matched
308 | despite minor differences in spelling. Example, the words "Ashcraft" and
309 | "Ashcroft" are both encoded as the same soundex code "A261".
310 |
311 | This function accepts the following keyword arguments:
312 |
313 | :numeric? -> true numerically encodes the entire word rather than using
314 | the default soundex letter prefix.
315 | Source
316 |
317 | -----
318 | # fogus.rv.impl.unification
319 |
320 |
321 | Provides internal unification functions.
322 | DO NOT USE THIS NS.
323 | There is no guarantee that it will remain stable or at all.
324 |
325 |
326 |
327 |
328 | ## `subst`
329 |
330 |
331 |
332 | Source
333 |
334 | -----
335 | # fogus.rv.learn
336 |
337 |
338 | Common learning-related functions and protocols.
339 |
340 |
341 |
342 |
343 | ## `-generalize`
344 | ``` clojure
345 |
346 | (-generalize lhs rhs)
347 | ```
348 | Source
349 |
350 | ## `-init`
351 | ``` clojure
352 |
353 | (-init basis)
354 | (-init basis arity)
355 | ```
356 | Source
357 |
358 | ## `-specialize`
359 | ``` clojure
360 |
361 | (-specialize lhs neg rhs)
362 | ```
363 | Source
364 |
365 | ## `S&G`
366 |
367 |
368 |
369 | Source
370 |
371 | -----
372 | # fogus.rv.learn.vs
373 |
374 |
375 | Version spaces are a binary classification, empirical learning algorithm.
376 | The approach, as described in 'Version spaces: a candidate elimination approach
377 | to rule learning' by Tom Mitchel (1977) takes training examples (currently
378 | Tuples of a like-arity) and manages a 'version space'. A version space is a
379 | map containing two 'boundaries' `:S` and `:G`. The `:G` boundary contains 'hypotheses'
380 | corresponding to the most general versions of the training data that are consistent
381 | and `:S` is the most specific versions. When a version space is presented with a new
382 | example it runs a 'candidate elimination' algorithm to modify the boundaries `:S`
383 | and `:G` accordingly. Examples can be marked as 'positive' examples, meaning
384 | that they are preferred instances. Anything not marked as 'positive' are taken as
385 | negative examples. Once trained, a version space can classify new examples as
386 | `::positive` or `::negative`. If new examples are not covered by the existing hypotheses
387 | in either boundary then they are classified as `::ambiguous` instead.
388 |
389 |
390 |
391 |
392 | ## `??`
393 |
394 |
395 |
396 | Source
397 |
398 | ## `?G`
399 |
400 |
401 |
402 | Source
403 |
404 | ## `?S`
405 |
406 |
407 |
408 | Source
409 |
410 | ## `applicable?`
411 | ``` clojure
412 |
413 | (applicable? vs example)
414 | (applicable? vs example positive?)
415 | ```
416 |
417 | Returns true if at least one hypothesis in the version space `vs` is consistent
418 | with the `example` and false otherwise.
419 | Source
420 |
421 | ## `arity-vec`
422 | ``` clojure
423 |
424 | (arity-vec n)
425 | ```
426 |
427 | Returns a vector template for arity n.
428 | Source
429 |
430 | ## `best-fit`
431 | ``` clojure
432 |
433 | (best-fit vs example)
434 | ```
435 |
436 | Returns the best-fit hypothesis coverage analysis (see [`explain`](#fogus.rv.learn.vs/explain)) for a given
437 | version space `vs` and compatible `example`. The metadata of the best fit return will
438 | have a mapping of `::fit-from` -> `:S` or `:G` pertaining to which boundary set the
439 | fit came from.
440 | Source
441 |
442 | ## `classify`
443 | ``` clojure
444 |
445 | (classify vs example)
446 | ```
447 |
448 | Attempts to classify an `example` using the given version space `vs`.
449 | Returns `::positive`, `::negative`, or `::ambiguous` if the boundaries
450 | G and S are incongruent.
451 | Source
452 |
453 | ## `collapsed?`
454 | ``` clojure
455 |
456 | (collapsed? vs)
457 | (collapsed? g s)
458 | ```
459 |
460 | Returns if a version space `vs` or boundaries `g` and `s` have collapsed.
461 | That is, training data have caused the hypotheses to become inconsistent,
462 | making further classification impossible.
463 | Source
464 |
465 | ## `consistent?`
466 | ``` clojure
467 |
468 | (consistent? vs example)
469 | (consistent? vs example positive?)
470 | ```
471 |
472 | Returns `true` if all hypotheses in the version space `vs`'s general and specific
473 | boundaries are consistent with the `example` features and classification.
474 | Source
475 |
476 | ## `converged?`
477 | ``` clojure
478 |
479 | (converged? vs)
480 | (converged? g s)
481 | ```
482 |
483 | Returns if a version space `vs` or boundaries `g` and `s` have
484 | converged. That is, training has caused the boundaries to converge to a single
485 | case.
486 | Source
487 |
488 | ## `covers?`
489 | ``` clojure
490 |
491 | (covers? hypothesis example)
492 | ```
493 |
494 | Takes a `hypothesis` from a version space and returns if the `example` is
495 | consistent with it.
496 | Source
497 |
498 | ## `explain`
499 | ``` clojure
500 |
501 | (explain vs example)
502 | ```
503 |
504 | Returns a structure explaining how the classifier reaches a conclusion,
505 | given a version space `vs` and a compatible `example`.
506 |
507 | The map returned contains the mappings:
508 |
509 | - `:explain/classification` -> the result of the call to [`classify`](#fogus.rv.learn.vs/classify)
510 | - `:explain/example` -> the example given
511 | - `explain/G` -> a sequence of hypotheses coverage analysis structures in the G boundary
512 | - `explain/S` -> a sequence of hypotheses coverage analysis structures in the S boundary
513 |
514 | The hypotheses coverage analyses contain the mappings:
515 |
516 | - `:hypothesis` -> The hypothesis inspected
517 | - `:covers?` -> true or false if the hypothesis covers the example
518 | - `:similarity` -> A ratio of hypothesis coverages over its arity
519 | - `:mismatched-features` -> a sequence of the features of the hypothesis that do not match the example
520 |
521 | A mismatched feature of a hypothesis has the mappings:
522 |
523 | - `:position` -> the position of the feature in the hypothesis
524 | - `:constraint` -> the value or wildcard at that position
525 |
526 | The information provided is sufficient for informing human-in-the-loop learning
527 | interactions.
528 | Source
529 |
530 | ## `refine`
531 | ``` clojure
532 |
533 | (refine vs example)
534 | (refine vs example positive?)
535 | ```
536 |
537 | Given a version space `vs` and an `example`, returns a new version space
538 | with boundaries adjusted according to the given example's features and
539 | classification. An example is marked as positive by attaching a metadata mapping
540 | `:positive?` -> boolean or by passing a boolean as the last argument. The
541 | explicit classification argument will always dominate the metadata
542 | classification.
543 | Source
544 |
545 | -----
546 | # fogus.rv.productions
547 |
548 |
549 | The simplest possible production rules system that uses a set
550 | of EAV tuples as its knowledge base.
551 |
552 |
553 |
554 |
555 | ## `apply-production`
556 | ``` clojure
557 |
558 | (apply-production production facts context)
559 | ```
560 | Source
561 |
562 | ## `cycle`
563 | ``` clojure
564 |
565 | (cycle qf kb)
566 | ```
567 |
568 | Feeds the results of states into a function qf that is responsible for
569 | detecting when production firings have stopped and returns an augmented
570 | fact set.
571 | Source
572 |
573 | ## `naive-qf`
574 | ``` clojure
575 |
576 | (naive-qf states)
577 | ```
578 |
579 | Takes the last environment in a long sequence of states in the hope that
580 | the sequence was long enough that all of the productions fired in creating it.
581 | Source
582 |
583 | ## `select-production`
584 | ``` clojure
585 |
586 | (select-production selection-strategy {:keys [productions facts]})
587 | ```
588 |
589 | Builds a sequence of bindings paired with each production and then uses a selection
590 | function to execute one of the productions that matched.
591 | Source
592 |
593 | ## `states`
594 | ``` clojure
595 |
596 | (states kb)
597 | ```
598 |
599 | Will apply the result of one production firing to the fact base and feed
600 | the result forward into the next firing.
601 | Source
602 |
603 | ## `step`
604 | ``` clojure
605 |
606 | (step kb)
607 | (step choice-fn kb)
608 | ```
609 |
610 | Takes a set of productions and facts and returns a new fact base based on the application of single production.
611 | Source
612 |
613 | ## `unifications`
614 | ``` clojure
615 |
616 | (unifications [clause & more :as clauses] facts context)
617 | ```
618 |
619 | Walks through all of the clauses in an implied antecedent and matches
620 | each against every fact provided. Returns a seq of contexts representing
621 | all of the bindings established by the antecedent unifications across all
622 | facts provided.
623 | Source
624 |
625 | -----
626 | # fogus.rv.search
627 |
628 |
629 | Common search-related functions and protocols.
630 |
631 |
632 |
633 |
634 | ## `GraphSearch`
635 |
636 |
637 |
638 |
639 | Functions related to graph-search algorithms.
640 | Source
641 |
642 | ## `HeuristicSearch`
643 |
644 |
645 |
646 |
647 | Function(s) related to heuristic-guided search.
648 | Source
649 |
650 | ## `add-route`
651 | ``` clojure
652 |
653 | (add-route _ node new-route)
654 | ```
655 |
656 | Adds a route to a `node` as a seq of nodes. Implementors of this function
657 | should return an instance of the object implementing this protocol.
658 | Source
659 |
660 | ## `cost-of`
661 | ``` clojure
662 |
663 | (cost-of _ node)
664 | ```
665 |
666 | Returns the cost to visit `node`.
667 | Source
668 |
669 | ## `estimate-cost`
670 | ``` clojure
671 |
672 | (estimate-cost _ node goal)
673 | ```
674 |
675 | Returns an estimated cost of the route from `node` to `goal`.
676 | Source
677 |
678 | ## `neighbors-of`
679 | ``` clojure
680 |
681 | (neighbors-of _ node)
682 | ```
683 |
684 | Returns a seq of neighbors of the given `node`.
685 | Source
686 |
687 | ## `route-of`
688 | ``` clojure
689 |
690 | (route-of _ node)
691 | ```
692 |
693 | Given a `node`, returns the route associated with it.
694 | Source
695 |
696 | -----
697 | # fogus.rv.search.graph
698 |
699 |
700 | A* search implementation.
701 |
702 |
703 |
704 |
705 | ## `astar`
706 | ``` clojure
707 |
708 | (astar graph start-node goal-node)
709 | ```
710 |
711 | Implements a lazy A* best-first graph traversal algorithm. Takes a
712 | `graph` object implementing both of the `fogus.rv.search.GraphSearch`
713 | and `fogus.rv.search.HeuristicSearch` protocols and a `start-node`
714 | and `goal-node` describing the bounds of the search. Returns of map
715 | with keys `:path` mapped to a sequence of nodes from `start-node` to
716 | `goal-node` and `:cost` describing the cost of the path. This search
717 | guarantees to return the lowest cost path as long as one exists.
718 | In the event that there is no path to the `goal-node` the current result
719 | is undefined.
720 | Source
721 |
722 | -----
723 | # fogus.rv.util
724 |
725 |
726 |
727 |
728 |
729 |
730 | ## `cart`
731 | ``` clojure
732 |
733 | (cart colls)
734 | ```
735 | Source
736 |
737 | ## `f-by`
738 | ``` clojure
739 |
740 | (f-by f key coll)
741 | ```
742 | Source
743 |
744 | ## `pairwise-every?`
745 | ``` clojure
746 |
747 | (pairwise-every? pred xs ys)
748 | ```
749 | Source
750 |
751 | ## `positions-of`
752 | ``` clojure
753 |
754 | (positions-of pred & xs)
755 | ```
756 | Source
757 |
758 | ## `process-bindings`
759 | ``` clojure
760 |
761 | (process-bindings bindings)
762 | ```
763 | Source
764 |
--------------------------------------------------------------------------------
/doc/ARCHITECTURE.md:
--------------------------------------------------------------------------------
1 | # reinen-vernunft architecture concerns
2 |
3 | ## EAV tuple sets
4 |
5 | If at all possible the reasoning functions provided herein will operate on EAV tuple sets. EAV stands for Entity, Attribute, Value. An EAV tuple is simply a Clojure vector of three elements, such as:
6 |
7 | [100 :person/name "Gilbert"]
8 |
9 | In the EAV tuple above the elements refer to the following:
10 |
11 | * *Entity* - a unique id that refers to an entity in the tuple set
12 | * *Attribute* - a keyword that names a common attribute
13 | * *Value* - the value of the attribute for the given entity
14 |
15 | The id contained in the first slot of the tuple should be a unique value pertaining to a set of attributes associated with a single entity. Any tuples in the EAV set with the same id will logically refer to the same entity:
16 |
17 | [100 :person/name "Gilbert"]
18 | [100 :person/age 42]
19 |
20 | The id 100 thus pertains to a single person named Gilbert who's aged 42. The id can be any type that allows mutual comparability.
21 |
22 | The entire collection of EAV tuples refering to one or more entities should be contained in a Clojure set.
23 |
24 | #{[100 :person/name "Gilbert"], [100 :person/age 42]}
25 |
26 | An EAV tuple set can be thought of as representing a relational database:
27 |
28 | #{[100 :person/name "Gilbert"]
29 | [100 :person/age 42]
30 | [200 :person/name "Zippy"]
31 | [300 :person/name "Queequeg"]
32 | [100 :person/friend 200]}
33 |
34 | In the EAV tuple set above, the `:person/friend` attribute establishes a link between two entities via their ids.
35 |
36 | ### Why EAV tuple sets?
37 |
38 | Aside from the simplicity of the data, the relational nature of the EAV tuple set is robust enough to model fairly complex domains. In addition, there are existing libraries that can directly query EAV tuple sets:
39 |
40 | * [DataScript](https://github.com/tonsky/datascript)
41 | * [Datomic](http://www.datomic.com)
42 |
43 | To name only a couple.
44 |
45 | ## Logic variables
46 |
47 | TODO
48 |
49 |
--------------------------------------------------------------------------------
/doc/ideas.txt:
--------------------------------------------------------------------------------
1 | Some possible implementations to explore:
2 |
3 | - Frames
4 | - BEINGS
5 | - Goal reduction
6 | - Hillcliming search
7 | - Microkanren
8 | - pmatch
9 | - Version Spaces
10 | - https://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/areas/reasonng/0.html
11 | - "Building Problem Solvers"
12 | - Add a smarter quiessence function to productions rules
13 | - Relational algebra (built on clojure.set)
14 | - https://www.youtube.com/watch?v=HB5TrK7A4pI
15 |
--------------------------------------------------------------------------------
/doc/rv.bib:
--------------------------------------------------------------------------------
1 | @incollection{Hughes:90,
2 | AUTHOR = "J. Hughes",
3 | TITLE = "Why Functional Programming Matters",
4 | YEAR = 1990,
5 | EDITOR = "D.A. Turner",
6 | BOOKTITLE = "Research Topics in Functional Programming",
7 | PUBLISHER = "Addison Wesley",
8 | PAGES = 17}
9 |
10 | @inproceedings {Wadler:92,
11 | AUTHOR = "Wadler, P.",
12 | TITLE = "The Essence of Functional Programming",
13 | BOOKTITLE = "19th Annual Symposium on Principles of Programming Languages, Albuquerque",
14 | YEAR = 1992}
15 |
16 | @book {Ableson1985,
17 | title = "Structure and Interpretation of Computer Programs",
18 | author = {Abelson, Harold and Sussman, Gerald Jay and {with~Julie~Sussman}},
19 | edition = {1st~Editon},
20 | publisher = {MIT Press/McGraw-Hill},
21 | year = 1985}
22 |
23 | @book{marriott98programming,
24 | Title = "Programming with Constraints: An Introduction",
25 | Author = {Marriott, Kim and Stuckey, Peter J.},
26 | Publisher = {The MIT Press},
27 | Year = 1998}
--------------------------------------------------------------------------------
/pom.xml:
--------------------------------------------------------------------------------
1 |
2 |
3 | 4.0.0
4 | jar
5 | me.fogus
6 | rv
7 | 0.0.10
8 | rv
9 |
10 |
11 | org.clojure
12 | core.unify
13 | 0.7.0
14 |
15 |
16 | me.fogus
17 | evalive
18 | 1.1.1
19 |
20 |
21 |
22 | src
23 |
24 |
25 |
26 | clojars
27 | https://repo.clojars.org/
28 |
29 |
30 |
31 |
32 | Eclipse Public License 1.0
33 | https://opensource.org/license/epl-2-0
34 | repo
35 |
36 |
37 |
38 |
--------------------------------------------------------------------------------
/src/fogus/rv/amb.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.amb
10 | "Provides an implementation of McCarthy's `amb` operator with
11 | binding forms and acceptance test operator."
12 | (:require [fogus.rv.util :as util]))
13 |
14 | (defmacro accept [condition ret]
15 | `(do (when (not ~condition)
16 | (throw (ex-info "Failing" {::failure '~condition
17 | ::backtrack true})))
18 | ~ret))
19 |
20 | (defmacro amb
21 | "A macro that provides a non-deterministic way to traverse a space
22 | and find a single solution amongst potentially many. If the search
23 | space is exhausted then `amb` will return `nil`. The general form
24 | of `amb` is as follows:
25 |
26 | (amb )
27 |
28 | Where `` is a typical Clojure bindings form:
29 |
30 | [ ... ]
31 |
32 | And `` is one or more Clojure expressions.
33 |
34 | Within the execution body the `(accept )`
35 | form is used to test some combination of the bindings for adherence
36 | to a `` and return an `` that serves as the
37 | return value of the call to `amb`.
38 |
39 | A call to `(amb)` (i.e. without bindings and body) will exhaust
40 | immediately and thus result in `nil` as its value."
41 | [& [binds & body]]
42 | (when (and binds body)
43 | (let [{:keys [names values]} (util/process-bindings binds)]
44 | `(let [proc# (fn [[~@names]]
45 | (try (do ~@body)
46 | (catch clojure.lang.ExceptionInfo e#
47 | (ex-data e#))))
48 | vals# (util/cart ~values)]
49 | (loop [[v# & vs#] vals#]
50 | (let [result# (proc# v#)]
51 | (if (::backtrack result#)
52 | (when (seq vs#)
53 | (recur vs#))
54 | result#)))))))
55 |
56 |
57 |
--------------------------------------------------------------------------------
/src/fogus/rv/constraints.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.constraints
10 | "Constraints solving functions that operate on a Constraint Description
11 | which is a map describing a constraint description containing the mappings:
12 | - :variables -> seq of LVars
13 | - :formula -> list describing a predicate expression composed of a mix of
14 | the LVars in :variables and Clojure functions."
15 | (:require [fogus.rv.core :as core]
16 | [fogus.rv.util :as util]
17 | [fogus.rv.impl.unification :as u]))
18 |
19 | (defn- cartesian-groups [vars]
20 | (let [tuples (util/cart (map :range vars))]
21 | (map #(map vector vars %) tuples)))
22 |
23 | (defn- test-in-context [formula group]
24 | (let [formula' (u/subst formula (into {} group))]
25 | (eval formula')))
26 |
27 | (defn- find1 [formula [group & more :as groupings]]
28 | (cond (nil? groupings) []
29 | (test-in-context formula group) group
30 | :else (recur formula more)))
31 |
32 | (defn satisfy1
33 | "Accepts a map describing a constraint description containing the mappings:
34 | - :variables -> seq of LVars
35 | - :formula -> list describing a predicate expression composed of a mix of
36 | the LVars in :variables and Clojure functions
37 |
38 | This function will use the constraint description to calculate the first
39 | set of values for the LVars that satisfy the formula. The result is a map
40 | with mappings from LVar -> value. If there is no way to satisfy the formula
41 | then an empty map is the result.
42 |
43 | The first found result of this function is not guaranteed to be stable."
44 | [{:keys [variables formula :as c]}]
45 | (into {} (find1 formula (cartesian-groups variables))))
46 |
47 | (defn satisfy*
48 | "Accepts a map describing a constraint description containing the mappings:
49 | - :variables -> seq of LVars
50 | - :formula -> list describing a predicate expression composed of a mix of
51 | the LVars in :variables and Clojure functions
52 |
53 | This function will use the constraint description to calculate the all of
54 | the values for the LVars that satisfy the formula. The result is a seq of
55 | maps with mappings from LVar -> value. If there is no way to satisfy the
56 | formula then an empty seq is the result.
57 |
58 | The ordering of the results of this function is not guaranteed to be stable."
59 | [{:keys [variables formula :as c]}]
60 | (let [groupings (cartesian-groups variables)
61 | groupings* (take-while seq (iterate rest groupings))]
62 | (->> groupings*
63 | (map #(find1 formula %))
64 | (keep seq)
65 | set
66 | (map #(into {} %)))))
67 |
--------------------------------------------------------------------------------
/src/fogus/rv/core.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.core
10 | "Most functions in rv work off of one or more of the following core
11 | concepts:
12 |
13 | Entity: a hashmap with a :kb/id key mapped to a unique value and namespaced keys.
14 |
15 | {:kb/id :person/john-doe
16 | :person/name "John Doe"
17 | :person/age 42}
18 |
19 | Table: a set of hashmaps or Entities. Tables represent unstructured or
20 | semi-structured collections of data.
21 |
22 | #{{:kb/id :city/blt :city/name "Baltimore"}
23 | {:kb/id :city/atl :city/name "Atlanta"}}
24 |
25 | Fact: a vector triple in the form [entity-id attribute value] that describe that
26 | a given entity has an attribute with a specific value. You can tie facts together
27 | by referencing their :kb/ids.
28 |
29 | [:person/john-doe :person/age 42]
30 | [:city/blt :city/name \"Baltimore\"]
31 |
32 | Relation: a set of Facts pertaining to a particular Entity. You can tie facts
33 | together by referencing :kb/ids in value positions.
34 |
35 | #{[:person/john-doe :person/age 42]
36 | [:city/blt :city/name \"Baltimore\"]
37 | [:person/john-doe :address/city :city/blt]}
38 |
39 | LVar: a logic variable that can unify with any value in its :range
40 |
41 | (map->LVar {:domain 'x :range (range 0 5)})
42 |
43 | Ground: a concrete value, like a keyword, number, string, etc.
44 |
45 | 42, \"John Doe\", :city/blt
46 |
47 | Query: a set of Facts containing a mix of LVars and Grounds used to find
48 | bindings for the LVars that satisfy a set of Facts.
49 |
50 | Rules: a set of Facts describing derived or synthetic relations in terms of
51 | existing ones.
52 |
53 | Production: a map containing :antecedent -> query and :consequent -> Facts
54 | to be asserted if the query fires.
55 |
56 | KB: a set of Relations about many Entities and possibly containing Productions. It
57 | represents all the knowledge currently known or derivable.
58 |
59 | Constraint Description: a set of LVars and a Formula describing the domain
60 | of their values.
61 |
62 | Formula: a list describing a predicate expression of mixed LVars and clojure functions."
63 | (:import java.io.Writer))
64 |
65 | ;; Logic variables
66 |
67 | (defrecord LVar [domain range]
68 | Object
69 | (toString [this]
70 | (if range
71 | (str "?" domain "::" range)
72 | (str "?" domain))))
73 |
74 | (def lv? #(instance? LVar %))
75 |
76 | (deftype IgnoreT []
77 | Object
78 | (toString [_] "_")
79 | (equals [_ o] (instance? IgnoreT o)))
80 |
81 | (deftype AnyT []
82 | Object
83 | (toString [_] "*")
84 | (equals [_ o] (instance? AnyT o)))
85 |
86 | (deftype AskT []
87 | Object
88 | (toString [_] "?")
89 | (equals [_ o] true))
90 |
91 | (defmethod print-method LVar [lvar ^Writer writer]
92 | (.write writer (str lvar)))
93 |
94 | (defmethod print-method IgnoreT [i ^Writer writer]
95 | (.write writer (str i)))
96 |
97 | (defmethod print-method AnyT [a ^Writer writer]
98 | (.write writer (str a)))
99 |
100 | (def ID_KEY :kb/id)
101 |
102 | (def ^:private use-or-gen-id
103 | (let [next-id (atom 0)]
104 | (fn [entity]
105 | (if-let [id (get entity ID_KEY)]
106 | id
107 | (swap! next-id inc)))))
108 |
109 | (defn- set->tuples
110 | [id k s]
111 | (for [v s] [id k v]))
112 |
113 | (defn- vector->tuples
114 | [idfn eid k v]
115 | (let [vid (idfn v)
116 | sid (idfn v)
117 | pre [[eid k vid]
118 | [vid :sequence/items sid]
119 | [vid :sequence/indexed? true]]]
120 | (loop [elems v
121 | i 0
122 | cid sid
123 | tuples pre]
124 | (if (seq elems)
125 | (let [head [cid :cell/head (first elems)]
126 | index [cid :cell/i i]
127 | tid (when (next elems)
128 | (idfn (inc i)))]
129 | (recur (rest elems)
130 | (inc i)
131 | tid
132 | (into tuples (if tid
133 | [head index [cid :cell/tail tid]]
134 | [head index]))))
135 | tuples))))
136 |
137 | (comment
138 | (map->relation {:kb/id :primes
139 | :num/primes [1 2 3 5 7]})
140 |
141 | (vector->tuples use-or-gen-id :primes :num/primes [1 2 3 5 7])
142 |
143 | ;; becomes
144 |
145 | [:primes :num/primes 100]
146 | [100 :sequence/items 101]
147 | [100 :sequence/indexed? true]
148 | [101 :cell/head 1] [101 :cell/i 0] [101 :cell/tail 103]
149 | [103 :cell/head 2] [103 :cell/i 1] [103 :cell/tail 105]
150 | [105 :cell/head 3] [105 :cell/i 2] [105 :cell/tail 107]
151 | [107 :cell/head 5] [107 :cell/i 3] [107 :cell/tail 109]
152 | [109 :cell/head 7] [109 :cell/i 4]
153 |
154 | )
155 |
156 | (defn map->relation
157 | "Converts a map to a set of tuples for that map, applying a unique
158 | :kb/id if the map doesn't already have a value mapped for that key.
159 |
160 | Relation values that are sets are expanded into individual tuples
161 | per item in the set with the same :kb/id as the entity and the
162 | attribute that the whole set was mapped to.
163 |
164 | An idfn is a function of map -> id and if provided is used to
165 | override the default entity id generation and any existing :kb/id
166 | values."
167 | ([entity]
168 | (map->relation use-or-gen-id entity))
169 | ([idfn entity]
170 | (let [id (idfn entity)]
171 | (reduce (fn [acc [k v]]
172 | (if (= k ID_KEY)
173 | acc
174 | (cond (set? v) (concat acc (set->tuples id k v))
175 | (vector? v) (concat acc (vector->tuples idfn id k v))
176 | :default (conj acc [id k v]))))
177 | []
178 | (seq entity)))))
179 |
180 | (defn table->kb
181 | "Converts a Table into a KB, applying unique :kb/id to maps without a
182 | mapped identity value.
183 |
184 | See map->relation for more information about how the entities in the
185 | table are converted to relations.
186 |
187 | An idfn is a function of map -> id and if provided is used to
188 | override the default entity id generation and any existing :kb/id
189 | values."
190 | ([table] (table->kb use-or-gen-id table))
191 | ([idfn table]
192 | {:facts (set (mapcat #(map->relation idfn %) table))}))
193 |
194 |
--------------------------------------------------------------------------------
/src/fogus/rv/datalog.clj:
--------------------------------------------------------------------------------
1 | (ns fogus.rv.datalog
2 | "A minimal implementation of Datalog.")
3 |
4 | ;; Implementation is a modified version of Christophe Grand's 39loc Datalog implementation
5 | ;; adding more operators and allowing a Datomic-style query function. To
6 | ;; understand the core implementation I recommend reading Christophe's posts:
7 | ;;
8 | ;; - https://buttondown.com/tensegritics-curiosities/archive/writing-the-worst-datalog-ever-in-26loc
9 | ;; - https://buttondown.com/tensegritics-curiosities/archive/half-dumb-datalog-in-30-loc/
10 | ;; - https://buttondown.com/tensegritics-curiosities/archive/restrained-datalog-in-39loc/
11 | ;;
12 | ;; While this implementation may diverge over time, the articles above are
13 | ;; a master class in simplicity and emergent behavior.
14 |
15 | (defn- lookup-op [op]
16 | (case op
17 | not= not=
18 | = =
19 | < <
20 | > >
21 | <= <=
22 | >= >=))
23 |
24 | (defn- constrain [env [op & args]]
25 | (let [args (map #(let [v (env % %)] (if (set? v) % v)) args)]
26 | (if-some [free-var (->> args (filter symbol?) first)]
27 | (update env free-var (fnil conj #{}) (cons op args))
28 | (when (apply (lookup-op op) args) env))))
29 |
30 | (defn- bind [env p v]
31 | (let [p-or-v (env p p)]
32 | (cond
33 | (= p '_) env
34 | (= p-or-v v) env
35 | (symbol? p-or-v) (assoc env p v)
36 | (set? p-or-v) (reduce constrain (assoc env p v) p-or-v))))
37 |
38 | (defn- match [pattern fact env]
39 | (assert (= (count pattern) (count fact) 3) (str "[e a v] pattern expected, got: " pattern " - " fact))
40 | (reduce (fn [env [p v]] (or (bind env p v) (reduced nil)))
41 | env
42 | (map vector pattern fact)))
43 |
44 | (defn- match-patterns [patterns dfacts facts]
45 | (reduce
46 | (fn [[envs denvs] pattern]
47 | (if (seq? pattern)
48 | [(->> @envs (keep #(constrain % pattern)) set delay)
49 | (->> denvs (keep #(constrain % pattern)) set)]
50 | [(-> #{} (into (for [fact facts env @envs] (match pattern fact env))) (disj nil) delay)
51 | (-> #{}
52 | (into (for [fact facts env denvs] (match pattern fact env)))
53 | (into (for [fact dfacts env denvs] (match pattern fact env)))
54 | (into (for [fact dfacts env @envs] (match pattern fact env)))
55 | (disj nil))]))
56 | [(delay #{{}}) #{}] patterns))
57 |
58 | (defn- match-rule [dfacts facts [head & patterns]]
59 | (for [env (second (match-patterns patterns dfacts facts))]
60 | (into [] (map #(env % %)) head)))
61 |
62 | (defn- saturate [facts rules]
63 | (loop [dfacts facts, facts #{}]
64 | (let [facts' (into facts dfacts)
65 | dfacts' (into #{} (comp (mapcat #(match-rule dfacts facts %)) (remove facts')) rules)]
66 | (cond->> facts' (seq dfacts') (recur dfacts')))))
67 |
68 | (defn- q*
69 | "Underlying query impl.
70 |
71 | - facts: a set of tuples
72 | - query: a seq of ([..binds..] tuple*)
73 | - rules: a seq of ((head-tuple tuple*)*)
74 |
75 | [..binds..] can contain lvars and grounds to form output tuples
76 | "
77 | [facts query rules]
78 | (-> facts (saturate rules) (match-rule #{} query) set))
79 |
80 | (def linked-list-rules '[([?h :cell/linked ?t] [?h :cell/head _] [?t :cell/head _] (= ?h ?t))
81 | ([?h :cell/linked ?t] [?h :cell/linked ?x] [?x :cell/tail ?t])])
82 |
83 | (defn query->map
84 | "Accepts the vector form of a Datalog query and outputs a map
85 | of the component sections as keyword->seq mappings."
86 | [query]
87 | (letfn [(q->pairs [qq]
88 | (let [q (partition-by keyword? qq)]
89 | (map #(conj (vec %1) %2)
90 | (take-nth 2 q)
91 | (take-nth 2 (rest q)))))]
92 | (into {} (q->pairs query))))
93 |
94 | (defn q
95 | "Queries a knowledge base or a set of relations given a vector
96 | form of a query and an optional set of rules.
97 |
98 | A query takes the form:
99 |
100 | [:find find-spec :where clauses]
101 |
102 | A find-spec can be any number of lvars like:
103 |
104 | [:find ?e ?v :where ...]
105 |
106 | or a tuple containing a mix of lvars and grounds which is used to
107 | build output tuples from the query results:
108 |
109 | [:find [?e :an/attribute ?v] :where ...]
110 |
111 | The :where clauses are any number of tuples containing a mix of
112 | lvars and grounds:
113 |
114 | [:find ...
115 | :where
116 | [?e :an/attribute ?v]
117 | [?e :another/attr 42]]
118 |
119 | :where clauses may also contain filters defined as calls to predicates
120 | used to constrain the values that may bind to lvars:
121 |
122 | [:find ...
123 | :where
124 | [?e :an/attribute ?v]
125 | (= ?v 42)]
126 |
127 | The possible filter predicates are: =, not=, <, >, <=, >=
128 |
129 | rules are a vector of lists where each list defines a rule with a
130 | single head tuple followed by any number of rule clauses:
131 |
132 | ([?p :relationship/parent ?c] [?p :relationship/father ?c])
133 |
134 | The rule above defines a syntheic relation called
135 | `:relationship/parent` defined in terms of another relation
136 | `relationship/father`. Rules describe synthetic relations derived
137 | from real relations in the data or other synthetic relations
138 | derived from previous rule applications."
139 | ([query kb] (q query kb '()))
140 | ([query kb rules]
141 | (let [{:keys [find where]} (query->map query)
142 | find (if (vector? (first find)) (first find) find)
143 | facts (cond (map? kb) (:facts kb)
144 | (set? kb) kb
145 | :else (throw (ex-info "Cannot derive facts from KB"
146 | {:kb/type (type kb)})))]
147 | (q* facts
148 | (list* find where)
149 | rules))))
150 |
151 | (comment
152 | (def fkb
153 | {:facts
154 | #{[-1002 :response/to -51]
155 | [-51 :emergency/type :emergency.type/flood]
156 | [-50 :emergency/type :emergency.type/fire]
157 | [-1002 :response/type :response.type/kill-electricity]
158 | [-1000 :response/to -50]
159 | [-1000 :response/type :response.type/activate-sprinklers]}})
160 |
161 | (q* fkb
162 | '([?response] [_ :response/type ?response])
163 | '())
164 |
165 | (q* fkb
166 | '([?problem ?response]
167 | [?id :response/type ?response]
168 | [?id :response/to ?pid]
169 | [?pid :emergency/type ?problem])
170 | '())
171 |
172 | (q '[:find ?problem ?response
173 | :where
174 | [?id :response/type ?response]
175 | [?id :response/to ?pid]
176 | [?pid :emergency/type ?problem]]
177 | fkb)
178 |
179 |
180 |
181 | (query->map '[:find ?problem ?response
182 | :where
183 | [?id :response/type ?response]
184 | [?id :response/to ?pid]
185 | [?pid :emergency/type ?problem]])
186 |
187 | (query->map '[:find [?response :response/to ?problem]
188 | :where
189 | [?id :response/type ?response]
190 | [?id :response/to ?pid]
191 | [?pid :emergency/type ?problem]])
192 |
193 | (def vkb #{[:primes :num/primes 100]
194 | [100 :sequence/items 101]
195 | [100 :sequence/indexed? true]
196 | [101 :cell/head 1] [101 :cell/i 0] [101 :cell/tail 103]
197 | [103 :cell/head 2] [103 :cell/i 1] [103 :cell/tail 105]
198 | [105 :cell/head 3] [105 :cell/i 2] [105 :cell/tail 107]
199 | [107 :cell/head 5] [107 :cell/i 3] [107 :cell/tail 109]
200 | [109 :cell/head 7] [109 :cell/i 4]})
201 |
202 | (q '[:find ?h2
203 | :where
204 | [:primes :num/primes ?primes]
205 | [?primes :sequence/items ?e]
206 | [?e :cell/head _]
207 | [?e :cell/linked ?t]
208 | [?t :cell/head ?h2]]
209 | vkb
210 | linked-list-rules
211 | )
212 |
213 | (q '[:find ?h2
214 | :where
215 | [?e :cell/head 1]
216 | [?e :cell/linked ?t]
217 | [?t :cell/head ?h2]]
218 | vkb
219 | rvrules
220 | )
221 |
222 | (q '[:find ?s ?h
223 | :where
224 | [?s :sequence/items ?h]
225 | [?h :cell/i 0]]
226 | vkb
227 | ;;vrules
228 | )
229 |
230 | (q '[:find ?s ?h
231 | :where
232 | [?s :sequence/items ?h]
233 | [?h :cell/i 0]]
234 | vkb
235 | ;;vrules
236 | )
237 |
238 | )
239 |
--------------------------------------------------------------------------------
/src/fogus/rv/fuzzy/soundex.clj:
--------------------------------------------------------------------------------
1 | (ns fogus.rv.fuzzy.soundex
2 | "I came across the Soundex algorithm when researching the retro KAMAS outlining application.
3 | Soundex is a phonetic algorithm for indexing words by sound."
4 | (:require [clojure.string :as string]))
5 |
6 | (def ^:private ^:const IGNORE Long/MAX_VALUE)
7 | (def ^:private ^:const SKIP Long/MIN_VALUE)
8 |
9 | ;; TODO: is it better to convert to upcase or account for lowercase below?
10 |
11 | (def ^:private en-ch->code
12 | {\B 1, \F 1, \P 1, \V 1
13 | \C 2, \G 2, \J 2, \K 2, \Q 2, \S 2, \X 2, \Z 2
14 | \D 3, \T 3
15 | \L 4
16 | \M 5, \N 5
17 | \R 6
18 | \A IGNORE \E IGNORE \I IGNORE \O IGNORE \U IGNORE \Y IGNORE
19 | \H SKIP \W SKIP})
20 |
21 | (defn- en-alpha-only [x]
22 | (clojure.string/replace x #"[^A-Za-z]" ""))
23 |
24 | (defn- handle-skips
25 | [processed-word]
26 | (filter #(not= SKIP %) processed-word))
27 |
28 | (defn- drop-similar-head
29 | [encoding first-letter]
30 | (drop-while #(= % (en-ch->code first-letter)) encoding))
31 |
32 | (defn- drop-ignore-codes [encoding]
33 | (filter #(not= IGNORE %) encoding))
34 |
35 | (defn- assemble-soundex [first-letter preprocessed-code]
36 | (->> (-> preprocessed-code
37 | handle-skips
38 | (drop-similar-head first-letter)
39 | dedupe
40 | drop-ignore-codes
41 | (concat (repeat 0)))
42 | (take 3)
43 | (apply str)
44 | (str first-letter)))
45 |
46 | (defn encode
47 | "Soundex is an algorithm for creating indices for words based on their
48 | English pronunciation. Homophones are encoded such that words can be matched
49 | despite minor differences in spelling. Example, the words \"Ashcraft\" and
50 | \"Ashcroft\" are both encoded as the same soundex code \"A261\".
51 |
52 | This function accepts the following keyword arguments:
53 |
54 | :numeric? -> true numerically encodes the entire word rather than using
55 | the default soundex letter prefix."
56 | [word & {:keys [numeric?] :as opts}]
57 | (let [word (string/upper-case (en-alpha-only word))
58 | first-letter (first word)
59 | result (assemble-soundex first-letter (map en-ch->code (rest word)))]
60 | (if numeric?
61 | (apply str (en-ch->code first-letter) (rest result))
62 | result)))
63 |
64 |
--------------------------------------------------------------------------------
/src/fogus/rv/impl/unification.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.impl.unification
10 | "Provides internal unification functions.
11 | DO NOT USE THIS NS.
12 | There is no guarantee that it will remain stable or at all."
13 | (:require [fogus.rv.core :as core]
14 | clojure.core.unify))
15 |
16 | (def subst (clojure.core.unify/make-occurs-subst-fn core/lv?))
17 |
--------------------------------------------------------------------------------
/src/fogus/rv/learn.clj:
--------------------------------------------------------------------------------
1 | (ns fogus.rv.learn
2 | "Common learning-related functions and protocols.")
3 |
4 | (defprotocol S&G
5 | (-generalize [lhs rhs])
6 | (-specialize [lhs neg rhs])
7 | (-init [basis] [basis arity]))
8 |
--------------------------------------------------------------------------------
/src/fogus/rv/learn/vs.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.learn.vs
10 | "Version spaces are a binary classification, empirical learning algorithm.
11 | The approach, as described in 'Version spaces: a candidate elimination approach
12 | to rule learning' by Tom Mitchel (1977) takes training examples (currently
13 | Tuples of a like-arity) and manages a 'version space'. A version space is a
14 | map containing two 'boundaries' `:S` and `:G`. The `:G` boundary contains 'hypotheses'
15 | corresponding to the most general versions of the training data that are consistent
16 | and `:S` is the most specific versions. When a version space is presented with a new
17 | example it runs a 'candidate elimination' algorithm to modify the boundaries `:S`
18 | and `:G` accordingly. Examples can be marked as 'positive' examples, meaning
19 | that they are preferred instances. Anything not marked as 'positive' are taken as
20 | negative examples. Once trained, a version space can classify new examples as
21 | `::positive` or `::negative`. If new examples are not covered by the existing hypotheses
22 | in either boundary then they are classified as `::ambiguous` instead."
23 | (:require [fogus.rv.core :as core]
24 | [fogus.rv.learn :as proto]
25 | [fogus.rv.util :as util]))
26 |
27 | (def ^:const ?S (core/->IgnoreT))
28 | (def ^:const ?G (core/->AnyT))
29 | (def ^:const ?? (core/->AskT))
30 |
31 | (defn- specializable? [g neg-example s]
32 | (and (= g ?G) (not= s neg-example)))
33 |
34 | (defn- maybe-generalize [g s]
35 | (cond (= g ?S) s
36 | (= s ?S) g
37 | (= g s) g
38 | :default ?G))
39 |
40 | (defn- specialization-indexes [g neg s]
41 | (util/positions-of specializable? g neg s))
42 |
43 | (defn- generalize-sequential [g s]
44 | (map maybe-generalize g s))
45 |
46 | (defn- specialize-with [f g neg s]
47 | (map f (specialization-indexes g neg s)))
48 |
49 | (extend-protocol proto/S&G
50 | clojure.lang.PersistentVector
51 | (proto/-generalize [g s]
52 | (vec (generalize-sequential g s)))
53 | (proto/-specialize [g neg s]
54 | (vec (specialize-with #(assoc g % (get s %)) g neg s)))
55 | (proto/-init [tmpl]
56 | (let [d (count tmpl)]
57 | {:S [(vec (repeat d ?S))]
58 | :G [(vec (repeat d ?G))]
59 | :arity d})))
60 |
61 | (defn- covers-elem? [h e]
62 | (or (= h e) (= h ?G)))
63 |
64 | (declare covers? collapsed? converged?)
65 |
66 | (defn- positive [{:keys [S G arity]} example]
67 | (let [g' (filter #(covers? %1 example) G)]
68 | {:G g'
69 |
70 | :S (let [s' (map (fn [s]
71 | (if (not (covers? s example))
72 | (proto/-generalize s example)
73 | s))
74 | S)]
75 | (if (converged? g' s')
76 | s'
77 | (filter
78 | (fn [s] (not-any? #(covers? s %1) G))
79 | s')))
80 |
81 | :arity arity}))
82 |
83 | (defn- negative [{:keys [S G arity]} example]
84 | {:G (reduce (fn [acc g]
85 | (if (not (covers? g example))
86 | (conj acc g)
87 | (into acc
88 | (reduce (fn [acc g']
89 | (if (and (not (covers? g' example))
90 | (every? #(covers? g' %) S)
91 | (not-any? #(and (not= g %) (covers? % g')) G))
92 | (conj acc g')
93 | acc))
94 | []
95 | (proto/-specialize g example (first S))))))
96 | []
97 | G)
98 |
99 | :S (filter #(not (covers? %1 example)) S)
100 |
101 | :arity arity})
102 |
103 | (defn arity-vec
104 | "Returns a vector template for arity n."
105 | [n]
106 | (vec (repeat n ??)))
107 |
108 | (defn covers?
109 | "Takes a `hypothesis` from a version space and returns if the `example` is
110 | consistent with it."
111 | [hypothesis example]
112 | (util/pairwise-every? covers-elem? hypothesis example))
113 |
114 | (defn collapsed?
115 | "Returns if a version space `vs` or boundaries `g` and `s` have collapsed.
116 | That is, training data have caused the hypotheses to become inconsistent,
117 | making further classification impossible."
118 | ([vs] (collapsed? (:G vs) (:S vs)))
119 | ([g s] (and (empty? g) (empty? s))))
120 |
121 | (defn converged?
122 | "Returns if a version space `vs` or boundaries `g` and `s` have
123 | converged. That is, training has caused the boundaries to converge to a single
124 | case."
125 | ([vs] (converged? (:G vs) (:S vs)))
126 | ([g s]
127 | (and (= 1 (bounded-count 2 g) (bounded-count 2 s)) (= g s))))
128 |
129 | (defn- positive [{:keys [S G arity]} example]
130 | (let [g' (filter #(covers? %1 example) G)]
131 | {:G g'
132 |
133 | :S (let [s' (map (fn [s]
134 | (if (not (covers? s example))
135 | (proto/-generalize s example)
136 | s))
137 | S)]
138 | (if (converged? g' s')
139 | s'
140 | (filter
141 | (fn [s] (not-any? #(covers? s %1) G))
142 | s')))
143 |
144 | :arity arity}))
145 |
146 | (defn- negative [{:keys [S G arity]} example]
147 | {:G (reduce (fn [acc g]
148 | (if (not (covers? g example))
149 | (conj acc g)
150 | (into acc
151 | (reduce (fn [acc g']
152 | (if (and (not (covers? g' example))
153 | (every? #(covers? g' %) S)
154 | (not-any? #(and (not= g %) (covers? % g')) G))
155 | (conj acc g')
156 | acc))
157 | []
158 | (proto/-specialize g example (first S))))))
159 | []
160 | G)
161 |
162 | :S (filter #(not (covers? %1 example)) S)
163 |
164 | :arity arity})
165 |
166 | (defn- classification-for [example]
167 | (-> example meta ::positive))
168 |
169 | (defn refine
170 | "Given a version space `vs` and an `example`, returns a new version space
171 | with boundaries adjusted according to the given example's features and
172 | classification. An example is marked as positive by attaching a metadata mapping
173 | `:positive?` -> boolean or by passing a boolean as the last argument. The
174 | explicit classification argument will always dominate the metadata
175 | classification."
176 | ([vs example]
177 | (refine vs example (classification-for example)))
178 | ([vs example positive?]
179 | (if positive?
180 | (positive vs example)
181 | (negative vs example))))
182 |
183 | (defn consistent?
184 | "Returns `true` if all hypotheses in the version space `vs`'s general and specific
185 | boundaries are consistent with the `example` features and classification."
186 | ([vs example]
187 | (consistent? vs example (classification-for example)))
188 | ([vs example positive?]
189 | (and
190 | (every? #(and positive? (covers? % example)) (:S vs))
191 | (every? #(and positive? (covers? % example)) (:G vs)))))
192 |
193 | (defn applicable?
194 | "Returns true if at least one hypothesis in the version space `vs` is consistent
195 | with the `example` and false otherwise."
196 | ([vs example]
197 | (applicable? vs example (classification-for example)))
198 | ([vs example positive?]
199 | (boolean
200 | (or
201 | (some #(and positive? (covers? % example)) (:S vs))
202 | (some #(and positive? (covers? % example)) (:G vs))))))
203 |
204 | (defn classify
205 | "Attempts to classify an `example` using the given version space `vs`.
206 | Returns `::positive`, `::negative`, or `::ambiguous` if the boundaries
207 | G and S are incongruent."
208 | [vs example]
209 | (let [at-least-one-s? (boolean (some #(covers? % example) (:S vs)))
210 | all-g? (every? #(covers? % example) (:G vs))]
211 | (cond
212 | (and all-g? at-least-one-s?) ::positive
213 | (and (not at-least-one-s?) (not (some #(covers? % example) (:G vs)))) ::negative
214 | :otherwise ::ambiguous)))
215 |
216 | (defn- similarity
217 | "Computes a similarity score as the ratio of positions in which
218 | the hypothesis covers the example."
219 | [hypothesis example]
220 | (let [arity (count hypothesis)]
221 | (if (zero? arity)
222 | arity
223 | (/ (->> (map covers-elem? hypothesis example)
224 | (filter identity)
225 | count)
226 | arity))))
227 |
228 | (defn- explain-hypothesis
229 | [hypothesis example]
230 | (let [mismatches (keep-indexed
231 | (fn [i [h e]]
232 | (when-not (covers-elem? h e)
233 | {:position i
234 | :constraint h}))
235 | (map vector hypothesis example))]
236 | {:hypothesis hypothesis
237 | :covers? (covers? hypothesis example)
238 | :mismatched-features (vec mismatches)
239 | :similarity (similarity hypothesis example)}))
240 |
241 | (defn explain
242 | "Returns a structure explaining how the classifier reaches a conclusion,
243 | given a version space `vs` and a compatible `example`.
244 |
245 | The map returned contains the mappings:
246 |
247 | - `:explain/classification` -> the result of the call to `classify`
248 | - `:explain/example` -> the example given
249 | - `explain/G` -> a sequence of hypotheses coverage analysis structures in the G boundary
250 | - `explain/S` -> a sequence of hypotheses coverage analysis structures in the S boundary
251 |
252 | The hypotheses coverage analyses contain the mappings:
253 |
254 | - `:hypothesis` -> The hypothesis inspected
255 | - `:covers?` -> true or false if the hypothesis covers the example
256 | - `:similarity` -> A ratio of hypothesis coverages over its arity
257 | - `:mismatched-features` -> a sequence of the features of the hypothesis that do not match the example
258 |
259 | A mismatched feature of a hypothesis has the mappings:
260 |
261 | - `:position` -> the position of the feature in the hypothesis
262 | - `:constraint` -> the value or wildcard at that position
263 |
264 | The information provided is sufficient for informing human-in-the-loop learning
265 | interactions."
266 | [vs example]
267 | {:explain/classification (classify vs example)
268 | :explain/example example
269 | :explain/S (vec (map #(explain-hypothesis % example) (:S vs)))
270 | :explain/G (vec (map #(explain-hypothesis % example) (:G vs)))})
271 |
272 | (defn best-fit
273 | "Returns the best-fit hypothesis coverage analysis (see `explain`) for a given
274 | version space `vs` and compatible `example`. The metadata of the best fit return will
275 | have a mapping of `::fit-from` -> `:S` or `:G` pertaining to which boundary set the
276 | fit came from."
277 | [vs example]
278 | (let [explanation (explain vs example)
279 | best #(vec (sort-by (comp - :similarity) %))
280 | [best-s & _] (best (:explain/S explanation))
281 | [best-g & _] (best (:explain/G explanation))]
282 | (if (> (:similarity best-s) (:similarity best-g))
283 | (with-meta best-s {::fit-from :S})
284 | (with-meta best-g {::fit-from :G}))))
285 |
--------------------------------------------------------------------------------
/src/fogus/rv/productions.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.productions
10 | "The simplest possible production rules system that uses a set
11 | of EAV tuples as its knowledge base."
12 | (:require [clojure.core.unify :as u]
13 | [clojure.set :as s])
14 | (:refer-clojure :exclude [cycle]))
15 |
16 | ;; Productions are represented as maps having two privileged keys:
17 | ;; {:antecedent ...
18 | ;; :consequent ...}
19 |
20 | ;; The :antecedent key in the production map contains a sequence of EAV 3-tuples
21 | ;; with logical variables at key locations for the purpose of pattern matching.
22 | ;; These patterns refer to facts in the knowledge base.
23 | ;;
24 | ;; [[?id :person/name "Fogus"]
25 | ;; [?id :language/speaks ?lang]]
26 | ;;
27 | ;; The antecedent describes the patterns that must be present in the EAV
28 | ;; set in order for the production to activate. The antecedent is also known as
29 | ;; the left-hand-side (LHS) of the production.
30 |
31 | ;; When a production activates, the structure in the :consequent key in the production
32 | ;; map is applied to the knowledge base to potentially create new facts.
33 | ;; The consequent also contains a sequence of EAV 3-tuples with logical
34 | ;; variables at key locations. However, the tuples describe new facts
35 | ;; with values bound to embedded logic variables as defined within the
36 | ;; context of a production activation.
37 |
38 | ;; A production set is just a data structure defines as such:
39 | ;;
40 | ;; 1. A production set is simply a vector of production definitions
41 | ;; 2. A production definition is a map containing :antecedent and :consequent keys
42 | ;; 3. An antecedent is a vector of EAV 3-tuples representing patterns in data
43 | ;; 4. An EAV 3-tuple is a vector of three elements: id, attribute, value
44 | ;; 5. A consequent is a vector of EAV 3-tuples representing new attribute assertions
45 |
46 | ;; A fact base is a set of EAV 3-tuples.
47 |
48 | ;; A knowledge base is a map with two keys in it
49 | ;; {:productions
50 | ;; :facts }
51 |
52 | ;; The production productions sytem implemented herein is a a four stage system:
53 | ;;
54 | ;; 1. Antecedent unifications
55 | ;; 2. Production selection
56 | ;; 3. Consequent substitutions and assertion
57 | ;; 4. System quiessence
58 |
59 | ;; Stage 1: Unifications
60 |
61 | (defn unifications
62 | "Walks through all of the clauses in an implied antecedent and matches
63 | each against every fact provided. Returns a seq of contexts representing
64 | all of the bindings established by the antecedent unifications across all
65 | facts provided."
66 | [[clause & more :as clauses] facts context]
67 | (if clause
68 | (let [bindings (keep #(u/unify clause % context) facts)]
69 | (mapcat #(unifications more facts %) bindings))
70 | [context]))
71 |
72 | ;; Stage 2: Production selection
73 |
74 | (defn select-production
75 | "Builds a sequence of bindings paired with each production and then uses a selection
76 | function to execute one of the productions that matched."
77 | [selection-strategy {:keys [productions facts]}]
78 | (let [possibilities
79 | (for [production productions
80 | bindings (unifications (:antecedent production) facts {})]
81 | [production bindings])]
82 | (selection-strategy possibilities)))
83 |
84 |
85 | ;; Stage 3: Consequent substitutions and assertion
86 |
87 | (defn apply-production [production facts context]
88 | (let [new-facts (set (for [rhs (:consequent production)]
89 | (u/subst rhs context)))]
90 | (s/union new-facts facts)))
91 |
92 | ;; Stage 3a: Single substitution and assertion
93 |
94 | (defn step
95 | "Takes a set of productions and facts and returns a new fact base based on the application of single production."
96 | ([kb] (step rand-nth kb))
97 | ([choice-fn kb]
98 | (when-let [[production binds] (select-production choice-fn kb)]
99 | (apply-production production (:facts kb) binds))))
100 |
101 | ;; Stage 3b: Repeated substitution and assertion
102 |
103 | (defn states
104 | "Will apply the result of one production firing to the fact base and feed
105 | the result forward into the next firing."
106 | [kb]
107 | (iterate #(step (assoc kb :facts %))
108 | (set (:facts kb))))
109 |
110 | (defn cycle
111 | "Feeds the results of states into a function qf that is responsible for
112 | detecting when production firings have stopped and returns an augmented
113 | fact set."
114 | [qf kb]
115 | (qf (states kb)))
116 |
117 | ;; Stage 4: System quiessence
118 |
119 | (defn naive-qf
120 | "Takes the last environment in a long sequence of states in the hope that
121 | the sequence was long enough that all of the productions fired in creating it."
122 | [states]
123 | (last (take 256 states)))
124 |
125 |
--------------------------------------------------------------------------------
/src/fogus/rv/search.clj:
--------------------------------------------------------------------------------
1 | (ns fogus.rv.search
2 | "Common search-related functions and protocols.")
3 |
4 | (defprotocol GraphSearch
5 | "Functions related to graph-search algorithms."
6 | (cost-of [_ node] "Returns the cost to visit `node`.")
7 | (neighbors-of [_ node] "Returns a seq of neighbors of the given `node`.")
8 | (add-route [_ node new-route]
9 | "Adds a route to a `node` as a seq of nodes. Implementors of this function
10 | should return an instance of the object implementing this protocol.")
11 | (route-of [_ node] "Given a `node`, returns the route associated with it."))
12 |
13 | (defprotocol HeuristicSearch
14 | "Function(s) related to heuristic-guided search."
15 | (estimate-cost [_ node goal]
16 | "Returns an estimated cost of the route from `node` to `goal`."))
17 |
--------------------------------------------------------------------------------
/src/fogus/rv/search/graph.clj:
--------------------------------------------------------------------------------
1 | (ns fogus.rv.search.graph
2 | "A* search implementation."
3 | (:require [fogus.rv.search :as search]
4 | [fogus.rv.util :as util]))
5 |
6 | (defn- path-cost
7 | "The g(n) function calculating the cost of the path from the start
8 | to the current node."
9 | [node-cost cheapest-nbr]
10 | (+ node-cost (or cheapest-nbr 0)))
11 |
12 | (defn- total-cost
13 | "The f(n) function built from g(n) + h(n) or
14 | total_cost = current_path_cost + estimated_remaining_cost"
15 | [graph newcost node goal]
16 | (+ newcost (search/estimate-cost graph node goal)))
17 |
18 | (defn astar
19 | "Implements a lazy A* best-first graph traversal algorithm. Takes a
20 | `graph` object implementing both of the `fogus.rv.search.GraphSearch`
21 | and `fogus.rv.search.HeuristicSearch` protocols and a `start-node`
22 | and `goal-node` describing the bounds of the search. Returns of map
23 | with keys `:path` mapped to a sequence of nodes from `start-node` to
24 | `goal-node` and `:cost` describing the cost of the path. This search
25 | guarantees to return the lowest cost path as long as one exists.
26 | In the event that there is no path to the `goal-node` the current result
27 | is undefined."
28 | [graph start-node goal-node]
29 | (loop [steps 0
30 | graph graph
31 | work-queue (sorted-set [0 start-node])]
32 | (if (empty? work-queue)
33 | (with-meta (search/route-of graph goal-node) {:steps steps})
34 | (let [[_ node :as work-item] (first work-queue)
35 | rest-work-queue (disj work-queue work-item)
36 | neighbors (search/neighbors-of graph node)
37 | cheapest-nbr (util/f-by min-key :cost (keep #(search/route-of graph %) neighbors))
38 | newcost (path-cost (search/cost-of graph node) (:cost cheapest-nbr))
39 | oldcost (:cost (search/route-of graph node))]
40 | (if (= node goal-node)
41 | (recur (inc steps)
42 | (search/add-route graph node
43 | {:cost newcost
44 | :path (conj (:path cheapest-nbr []) node)})
45 | rest-work-queue)
46 | (if (and oldcost (>= newcost oldcost))
47 | (recur (inc steps) graph rest-work-queue)
48 | (recur (inc steps)
49 | (search/add-route graph node
50 | {:cost newcost
51 | :path (conj (:path cheapest-nbr []) node)})
52 | (into rest-work-queue
53 | (map #(vector (total-cost graph newcost % goal-node) %) neighbors)))))))))
54 |
55 |
56 |
57 |
--------------------------------------------------------------------------------
/src/fogus/rv/util.clj:
--------------------------------------------------------------------------------
1 | ; Copyright (c) Fogus. All rights reserved.
2 | ; The use and distribution terms for this software are covered by the
3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
4 | ; which can be found in the file epl-v10.html at the root of this distribution.
5 | ; By using this software in any fashion, you are agreeing to be bound by
6 | ; the terms of this license.
7 | ; You must not remove this notice, or any other, from this software.
8 |
9 | (ns fogus.rv.util)
10 |
11 | (defn process-bindings [bindings]
12 | {:names (take-nth 2 bindings)
13 | :values (vec (take-nth 2 (rest bindings)))})
14 |
15 | (defn cart [colls]
16 | (if (empty? colls)
17 | '(())
18 | (for [more (cart (rest colls))
19 | x (first colls)]
20 | (cons x more))))
21 |
22 | (defn f-by [f key coll]
23 | (when (seq coll)
24 | (reduce #(f key %1 %2)
25 | coll)))
26 |
27 | (defn pairwise-every? [pred xs ys]
28 | (every? identity (map pred xs ys)))
29 |
30 | (defn positions-of [pred & xs]
31 | (keep-indexed #(when %2 %1) (apply map pred xs)))
32 |
--------------------------------------------------------------------------------
/test/rv/amb_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.amb-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.amb :as rv]))
4 |
5 | (deftest test-amb-null-body
6 | (is (nil? (rv/amb))))
7 |
8 | (deftest test-amb-simple-binding
9 | (is (= 3 (rv/amb [x (range 10)]
10 | (rv/accept (= x 3)
11 | x))))
12 | (is (nil? (rv/amb [x (range 10)]
13 | (rv/accept false
14 | x))))
15 | (is (nil? (rv/amb [x (range 10)]
16 | (rv/accept (> x 10)
17 | x)))))
18 |
19 | (deftest test-amb-complex-binding
20 | (testing "that a complex binding passes as expected."
21 | (is (= ["that" "thing" "grows" "slowly"]
22 | (rv/amb [A ["the" "that" "a"]
23 | B ["frog" "elephant" "thing"]
24 | C ["walked" "treaded" "grows"]
25 | D ["slowly" "quickly"]]
26 |
27 | (rv/accept (and (= (last A) (first B))
28 | (= (last B) (first C))
29 | (= (last C) (first D)))
30 | [A B C D])))))
31 |
32 | (testing "that a complex binding fails when an imposible condition is present."
33 | (is (nil? (rv/amb [A ["the" "that" "a"]
34 | B ["frog" "elephant" "thing"]
35 | C ["walked" "treaded" "grows"]
36 | D ["slowly" "quickly"]]
37 |
38 | (rv/accept false [A B C D]))))))
39 |
--------------------------------------------------------------------------------
/test/rv/constraint_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.constraint-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.core :as core]
4 | [fogus.rv.constraints :as c]))
5 |
6 | (deftest test-satisfy1-no-answer
7 | (let [?x (core/->LVar 'x [0 1])
8 | ?y (core/->LVar 'y [0 1])
9 | ?z (core/->LVar 'z [0 1])
10 | c1 {:variables [?x ?y ?z]
11 | :formula `(= (+ ~?x ~?y 10000) ~?z)}]
12 | (is (= {}
13 | (c/satisfy1 c1)))))
14 |
15 | (deftest test-satisfy1-single-answer
16 | (let [?x (core/->LVar 'x [0 1])
17 | ?y (core/->LVar 'y [0 1])
18 | ?z (core/->LVar 'z [0 1])
19 | c1 {:variables [?x ?y ?z]
20 | :formula `(= (+ ~?x ~?y) ~?z)}]
21 | (is (= {?x 0 ?y 0 ?z 0}
22 | (c/satisfy1 c1)))))
23 |
24 | (deftest test-satisfy1-2
25 | (let [?x (core/->LVar 'x [0 1])
26 | ?y (core/->LVar 'y [1 2])
27 | ?z (core/->LVar 'z [2 3])
28 | c1 {:variables [?x ?y ?z]
29 | :formula `(= (+ ~?x ~?y) ~?z)}]
30 | (is (= {?x 1 ?y 1 ?z 2}
31 | (c/satisfy1 c1)))))
32 |
33 | (deftest test-satisfy1-3
34 | (let [?x (core/->LVar 'x [1 1])
35 | ?y (core/->LVar 'y [2 2])
36 | ?z (core/->LVar 'z [3 3])
37 | c1 {:variables [?x ?y ?z]
38 | :formula `(= (+ ~?x ~?y) ~?z)}]
39 | (is (= {?x 1 ?y 2 ?z 3}
40 | (c/satisfy1 c1)))))
41 |
42 | (deftest test-satisfy1-range
43 | (let [?x (core/->LVar 'x (range 1 7))
44 | ?y (core/->LVar 'y (range 3 8))
45 | c1 {:variables [?x ?y]
46 | :formula `(= (+ ~?x ~?y) 10)}]
47 | (is (= {?x 6 ?y 4}
48 | (c/satisfy1 c1)))))
49 |
50 | (deftest test-satisfy*-range
51 | (let [?x (core/->LVar 'x (range 1 7))
52 | ?y (core/->LVar 'y (range 3 8))
53 | c1 {:variables [?x ?y]
54 | :formula `(= (+ ~?x ~?y) 10)}]
55 | (is (= #{{?x 5, ?y 5} {?x 3, ?y 7} {?x 6, ?y 4} {?x 4, ?y 6}}
56 | (set (c/satisfy* c1))))))
57 |
58 | (deftest test-satisfy*-range-no-answer
59 | (let [?x (core/->LVar 'x (range 1 7))
60 | ?y (core/->LVar 'y (range 3 8))
61 | c1 {:variables [?x ?y]
62 | :formula `(= (+ ~?x ~?y) 1000000)}]
63 | (is (empty? (c/satisfy* c1)))))
64 |
--------------------------------------------------------------------------------
/test/rv/datalog_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.datalog-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.core :as core]
4 | [fogus.rv.datalog :as d]
5 | [fogus.rv.fuzzy.soundex :as s]))
6 |
7 | (deftest test-datalog-q*-no-rules
8 | (let [fkb #{[-1002 :response/to -51]
9 | [-51 :emergency/type :emergency.type/flood]
10 | [-50 :emergency/type :emergency.type/fire]
11 | [-1002 :response/type :response.type/kill-electricity]
12 | [-1000 :response/to -50]
13 | [-1000 :response/type :response.type/activate-sprinklers]}]
14 | (is (= #{[:response.type/kill-electricity] [:response.type/activate-sprinklers]}
15 | (#'d/q* fkb
16 | '([?response] [_ :response/type ?response])
17 | '())))
18 |
19 | (is (= #{[:emergency.type/fire :response.type/activate-sprinklers] [:emergency.type/flood :response.type/kill-electricity]}
20 | (#'d/q* fkb
21 | '([?problem ?response]
22 | [?id :response/type ?response]
23 | [?id :response/to ?pid]
24 | [?pid :emergency/type ?problem])
25 | '())))
26 |
27 | (is (= #{[:response.type/activate-sprinklers :response/to :emergency.type/fire]
28 | [:response.type/kill-electricity :response/to :emergency.type/flood]}
29 | (#'d/q* fkb
30 | '([?response :response/to ?problem]
31 | [?id :response/type ?response]
32 | [?id :response/to ?pid]
33 | [?pid :emergency/type ?problem])
34 | '())))
35 |
36 | (is (= #{[:response.type/activate-sprinklers :response/to :emergency.type/fire]
37 | [:response.type/kill-electricity :response/to :emergency.type/flood]}
38 | (d/q '[:find [?response :response/to ?problem]
39 | :where
40 | [?id :response/type ?response]
41 | [?id :response/to ?pid]
42 | [?pid :emergency/type ?problem]]
43 | fkb)))))
44 |
45 | (deftest test-datalog-ops
46 | (let [nkb #{[0 :a/num 0]
47 | [1 :a/num 1]
48 | [2 :a/num 2]
49 | [3 :a/num 3]
50 | [4 :a/num 4]
51 | [5 :a/num 5]}]
52 | (is (= #{[0]}
53 | (#'d/q* nkb '([?num] [0 :a/num ?num]) '())))
54 | (is (= #{[0] [1] [2]}
55 | (#'d/q* nkb '([?num] [_ :a/num ?num] (< ?num 3)) '())))
56 | (is (= #{[1] [2]}
57 | (#'d/q* nkb '([?num] [_ :a/num ?num] (< ?num 3) (> ?num 0)) '())))
58 | (is (= #{[0]}
59 | (#'d/q* nkb '([?num] [_ :a/num ?num] (= ?num 0)) '())))
60 | (is (= #{[0] [1] [2] [3] [4]}
61 | (#'d/q* nkb '([?num] [_ :a/num ?num] (not= ?num 5)) '())))
62 | (is (= #{[0] [1] [2] [3] [4]}
63 | (#'d/q* nkb '([?num] [_ :a/num ?num] (<= ?num 4)) '())))
64 | (is (= #{[5] [1] [2] [3] [4]}
65 | (#'d/q* nkb '([?num] [_ :a/num ?num] (>= ?num 1)) '())))))
66 |
67 | (deftest test-datalog-q*-with-rules
68 | (let [ekb {:facts #{[:homer :person/name "Homer"]
69 | [:bart :person/name "Bart"]
70 | [:lisa :person/name "Lisa"]
71 | [:marge :person/name "Marge"]
72 | [:maggie :person/name "Maggie"]
73 | [:abe :person/name "Abe"]
74 | [:mona :person/name "Mona"]
75 | [:homer :relationship/father :bart]
76 | [:marge :relationship/mother :bart]
77 | [:homer :relationship/father :lisa]
78 | [:marge :relationship/mother :lisa]
79 | [:homer :relationship/father :maggie]
80 | [:marge :relationship/mother :maggie]
81 | [:abe :relationship/father :homer]
82 | [:mona :relationship/mother :marge]}}
83 | anc-rules '[([?p :relationship/parent ?c] [?p :relationship/father ?c])
84 | ([?p :relationship/parent ?c] [?p :relationship/mother ?c])
85 | ([?gp :relationship/grand-parent ?c] [?gp :relationship/parent ?p] [?p :relationship/parent ?c])
86 | ([?p :relationship/ancestor ?c] [?p :relationship/parent ?c])
87 | ([?ancp :relationship/ancestor ?c] [?anc :relationship/ancestor ?c] [?ancp :relationship/parent ?anc])]
88 | sib-rules '[([?p :relationship/parent ?c] [?p :relationship/father ?c])
89 | ([?p :relationship/parent ?c] [?p :relationship/mother ?c])
90 | ([?c' :relationship/sibling ?c] [?p :relationship/parent ?c] (not= ?c ?c') [?p :relationship/parent ?c'])]]
91 | (is (= #{["Lisa"] ["Maggie"]}
92 | (d/q '[:find ?n
93 | :where
94 | [?s :relationship/sibling :bart]
95 | [?s :person/name ?n]]
96 | ekb
97 | sib-rules)))
98 | (is (= #{["Abe"] ["Mona"]}
99 | (d/q '[:find ?n
100 | :where
101 | [?s :relationship/grand-parent :lisa]
102 | [?s :person/name ?n]]
103 | ekb
104 | anc-rules)))))
105 |
106 | (deftest test-from-table
107 | (let [e {:person/name "Ethel"
108 | :person/age 31
109 | :address/state "NJ"
110 | :kb/id ::ethel}
111 | table #{{:person/name "Fred"
112 | :person/age 33
113 | :address/state "NY"}
114 | e
115 | {:person/name "Jimbo"
116 | :person/age 55
117 | :address/state "VA"
118 | :kb/id -1000}}]
119 | (is (= ::ethel (-> e core/map->relation ffirst)))
120 | (is (= #{["Fred"] ["Ethel"]}
121 | (d/q '[:find ?name
122 | :where
123 | [?p :person/age ?age]
124 | (> 50 ?age)
125 | [?p :person/name ?name]]
126 | (core/table->kb table))))))
127 |
128 | (deftest test-with-sets
129 | (let [table #{{:person/name "Fred"
130 | :address/state "NY"
131 | :person/tag #{}}
132 | {:person/name "Ethel"
133 | :address/state "NJ"
134 | :kb/id ::ethel
135 | :person/tag #{:foo/bar :baz/quux}}
136 | {:person/name "Jimbo"
137 | :address/state "VA"
138 | :person/tag #{:baz/quux}
139 | :kb/id -1000}}]
140 | (is (= #{["Jimbo"] ["Ethel"]}
141 | (d/q '[:find ?name
142 | :where
143 | [?p :person/tag :baz/quux]
144 | [?p :person/name ?name]]
145 | (core/table->kb table))))
146 |
147 | (is (= #{["Ethel"]}
148 | (d/q '[:find ?name
149 | :where
150 | [?p :person/tag :foo/bar]
151 | [?p :person/name ?name]]
152 | (core/table->kb table))))
153 |
154 | (is (= #{}
155 | (d/q '[:find ?name
156 | :where
157 | [?p :person/tag ::this-is-nowhere]
158 | [?p :person/name ?name]]
159 | (core/table->kb table))))))
160 |
161 | (deftest test-datalog-with-fuzzy-ids
162 | (let [table #{{:person/name "Fogus"
163 | :favorite/color "Purple"}
164 | {:person/name "Phogus"
165 | :spelled/wrong? true}}]
166 | (is (= #{["Fogus" "Purple" true] ["Phogus" "Purple" true]}
167 | (d/q '[:find ?n ?c ?sw
168 | :where
169 | [?p :person/name ?n]
170 | [?p :favorite/color ?c]
171 | [?p :spelled/wrong? ?sw]]
172 | (core/table->kb #(-> % :person/name (s/encode :numeric? true))
173 | table))))))
174 |
175 | (deftest test-datalog-vectors
176 | (testing "vector tuples"
177 | (let [res1 (d/q '[:find ?val
178 | :where
179 | [:primes :num/primes ?primes]
180 | [?primes :sequence/items ?h]
181 | [?h :cell/head _]
182 | [?h :cell/linked ?t]
183 | [?t :cell/head ?val]]
184 | (core/table->kb #{{:kb/id :primes
185 | :num/primes [2 3 5 7]}})
186 | d/linked-list-rules)
187 |
188 | res2 (d/q '[:find ?i ?val
189 | :where
190 | [:primes :num/primes ?primes]
191 | [?primes :sequence/items ?h]
192 | [?h :cell/head _]
193 | [?h :cell/linked ?t]
194 | [?t :cell/head ?val]
195 | [?t :cell/i ?i]]
196 | (core/table->kb #{{:kb/id :primes
197 | :num/primes [2 3 5 7]}})
198 | d/linked-list-rules)]
199 | (is (= #{[2] [3] [5] [7]} res1))
200 | (is (= [[0 2] [1 3] [2 5] [3 7]] (sort-by first res2))))))
201 |
--------------------------------------------------------------------------------
/test/rv/fuzzy/soundex_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.fuzzy.soundex-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.fuzzy.soundex :as fuzzy]))
4 |
5 | (def encodings {
6 | "Ashcraft" "A261"
7 | "Ashcroft" "A261"
8 | "Burroughs" "B620"
9 | "Burrows" "B620"
10 | "Clojure" "C426"
11 | "Ellery" "E460"
12 | "Euler" "E460"
13 | "Gauss" "G200"
14 | "Ghosh" "G200"
15 | "Gutierrez" "G362"
16 | "Heilbronn" "H416"
17 | "Hilbert" "H416"
18 | "Honeyman" "H555"
19 | "Jackson" "J250"
20 | "Johnson" "J525"
21 | "KAMAS" "K520"
22 | "Kant" "K530"
23 | "Knuth" "K530"
24 | "Ladd" "L300"
25 | "Lee" "L000"
26 | "Lissajous" "L222"
27 | "Lloyd" "L300"
28 | "Lukasiewicz" "L222"
29 | "Michael" "M240"
30 | "O'Hara" "O600"
31 | "Pfister" "P236"
32 | "Rubin" "R150"
33 | "Soundex" "S532"
34 | "Sownteks" "S532"
35 | "Tymczak" "T522"
36 | "VanDeusen" "V532"
37 | "Washington" "W252"
38 | "Wheaton" "W350"
39 | })
40 |
41 | (deftest test-single-words
42 | (is (= "A000" (fuzzy/encode "A")))
43 | (is (= "A100" (fuzzy/encode "Ab")))
44 | (is (= "A200" (fuzzy/encode "Ac")))
45 | (is (= "C123" (fuzzy/encode "CAaEeIiOoUuHhYybcd")))
46 | (is (= "C123" (fuzzy/encode "CAaEeIiOoUuHhYybcdkfsdjklsfdjkfsdjfsdkjfsdkfjsdkfsjk;sflajoweiuiowejrwekllksnwhjksdfnmsdfkpwipwj'kwer'dsfjkldfjsp")))
47 |
48 | (doseq [[k v] encodings]
49 | (is (= (fuzzy/encode k) v))))
50 |
51 | (deftest test-similar-sounds
52 | (is (= ["S532" "S532"] (map fuzzy/encode ["Soundex" "Sownteks"])))
53 |
54 | (is (= ["R163" "R163"] (map fuzzy/encode ["Robert" "Rupert"])))
55 |
56 | (is (= ["E251" "E251" "E251" "E251" "E251"]
57 | (map fuzzy/encode ["Example" "Ekzampul" "Ekzampull" "exzampull" "exzampull "])))
58 |
59 | (is (= ["M200" "M200" "M200" "M200" "M200"] (map fuzzy/encode ["Mike" "Maick" "Maiku" "Mike," " ,Mike"]))))
60 |
61 | (deftest test-numeric-results
62 | (is (apply not= (map fuzzy/encode ["Fogus" "Phogus" "Phogas" "Foegas"])))
63 | (is (apply = (map #(fuzzy/encode % :numeric? true) ["Fogus" "Phogus" "Phogas" "Foegas"]))))
64 |
--------------------------------------------------------------------------------
/test/rv/learn/vs_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.learn.vs-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.learn :as proto]
4 | [fogus.rv.learn.vs :as vs])
5 | (:refer-clojure :exclude [*]))
6 |
7 | (def ^:const _ vs/?S)
8 | (def ^:const * vs/?G)
9 |
10 | (deftest generalization-test
11 | (is (empty? (proto/-generalize [] [:a :b])))
12 | (is (= [:a] (proto/-generalize [:a] [:a])))
13 | (is (= [:a] (proto/-generalize [_] [:a])))
14 | (is (= [*] (proto/-generalize [:a] [:b])))
15 | (is (= [:a :b] (proto/-generalize [:a _] [:a :b])))
16 | (is (= [:b] (proto/-generalize [:b] [_])))
17 | (is (= [* :b] (proto/-generalize [:a :b] [:z :b]))))
18 |
19 | (deftest specialization-test
20 | (is (= [[:small :blue]] (proto/-specialize [:small *] [:small :yellow] [:small :blue])))
21 | (is (= [[:small *]] (proto/-specialize [* *] [:mid :blue] [:small :blue])))
22 | (is (= [[:small * *] [* * :laying]] (proto/-specialize [* * *] [:mid :blue :standing] [:small :blue :laying]))))
23 |
24 | (deftest collapsed-test
25 | (is (vs/collapsed? (-> (proto/-init (vs/arity-vec 2))
26 | (vs/refine '(1 2) true)
27 | (vs/refine '(:a :b) true)
28 | (vs/refine '("c" "d") false)
29 | (vs/refine '([] [1]) false)))))
30 |
31 | (deftest s&g-tests
32 | (let [{:keys [S G]} (-> (proto/-init (vs/arity-vec 3))
33 | (vs/refine [:vocal :jazz 50] true)
34 | (vs/refine [:band :pop 70] false)
35 | (vs/refine [:band :pop 80] false)
36 | (vs/refine [:solo :jazz 40] false)
37 | (vs/refine [:vocal :jazz 50] true)
38 | (vs/refine [:orchestra :classical 100] false)
39 | (vs/refine [:vocal :jazz 70] true))]
40 | (is (= [[:vocal * *]] G))
41 | (is (= [[:vocal :jazz *]] S)))
42 |
43 | (let [{:keys [S G]} (-> (proto/-init (vs/arity-vec 11))
44 | (vs/refine '("rookie" "P" "R" "MLB" "Active" "AL" "East" "Orioles" "Active" 19 "Mike") true)
45 | (vs/refine '("veteran" "P" "R" "MLB" "Active" "AL" "East" "Orioles" "Active" 23 "Jeff") true)
46 | (vs/refine '("ace" "LF" "L" "MLB" "Active" "NL" "West" "Giants" "IL" 19 "Jamie") false))]
47 | (is (= G
48 | [[* "P" * * * * * * * * *]
49 | [* * "R" * * * * * * * *]
50 | [* * * * * "AL" * * * * *]
51 | [* * * * * * "East" * * * *]
52 | [* * * * * * * "Orioles" * * *]
53 | [* * * * * * * * "Active" * *]]))
54 | (is (= S
55 | [[* "P" "R" "MLB" "Active" "AL" "East" "Orioles" "Active" * *]])))
56 |
57 | (let [{:keys [S G]} (-> (proto/-init (vs/arity-vec 6))
58 | (vs/refine [:sunny :warm :normal :strong :warm :same] true)
59 | (vs/refine [:sunny :warm :high :strong :warm :same] true)
60 | (vs/refine [:rainy :cold :high :strong :warm :change] false)
61 | (vs/refine [:sunny :warm :high :strong :cool :change] true))]
62 | (is (= G [[:sunny * * * * *] [* :warm * * * *]]))
63 | (is (= S [[:sunny :warm * :strong * *]]))))
64 |
65 | (deftest convergence-test
66 | (let [example [:japan "Honda" :blue 1980 :economy]
67 | {:keys [S G] :as V} (-> (proto/-init (vs/arity-vec 5))
68 | (vs/refine example true))]
69 | (testing "CONVERGENCE TEST STEP 1"
70 | (is (= G [[* * * * *]]))
71 | (is (= S [[:japan "Honda" :blue 1980 :economy]]))
72 | (is (not (vs/converged? V)))
73 | (is (= :fogus.rv.learn.vs/positive (vs/classify V example))))
74 |
75 | (testing "CONVERGENCE TEST STEP 2"
76 | (let [example [:japan "Toyota" :green 1970 :sports]
77 | {:keys [S G] :as V} (-> V (vs/refine example false))]
78 | (is (= G [[* "Honda" * * *]
79 | [* * :blue * *]
80 | [* * * 1980 *]
81 | [* * * * :economy]]))
82 | (is (= S [[:japan "Honda" :blue 1980 :economy]]))
83 | (is (not (vs/converged? V)))
84 | (is (= :fogus.rv.learn.vs/negative (vs/classify V example)))
85 |
86 | (testing "CONVERGENCE TEST STEP 3"
87 | (let [example [:japan "Toyota" :blue 1990 :economy]
88 | {:keys [S G] :as V} (-> V (vs/refine example true))]
89 | (is (= G [[* * :blue * *]
90 | [* * * * :economy]]))
91 | (is (= S [[:japan * :blue * :economy]]))
92 | (is (not (vs/converged? V)))
93 | (is (= :fogus.rv.learn.vs/positive (vs/classify V example)))
94 |
95 | (testing "CONVERGENCE TEST STEP 4"
96 | (let [example [:usa "Chrysler" :red 1980 :economy]
97 | {:keys [S G] :as V} (-> V (vs/refine example false))]
98 | (is (= G [[* * :blue * *]
99 | [:japan * * * :economy]]))
100 | (is (= S [[:japan * :blue * :economy]]))
101 | (is (not (vs/converged? V)))
102 | (is (= :fogus.rv.learn.vs/negative (vs/classify V example)))
103 |
104 | (testing "CONVERGENCE TEST STEP 5 - LAST"
105 | (let [example [:japan "Honda" :white 1980 :economy]]
106 | (is (vs/applicable? V example true))
107 | (let [{:keys [S G] :as V} (-> V (vs/refine example true))]
108 | (is (= :fogus.rv.learn.vs/positive (vs/classify V example)))
109 | (is (vs/converged? V)))))))))))))
110 |
111 | (deftest applicable?-test
112 | (let [vs {:S '[[Small Red Soft]]
113 | :G [[* * *]]}]
114 | (is (vs/applicable? vs ['Small 'Red 'Soft] true))
115 | (is (not (vs/applicable? vs ['Large 'Blue 'Hard] false)))
116 | (is (not (vs/applicable? vs ['Small 'Red 'Soft] false)))))
117 |
118 | (deftest consistent?-test
119 | (let [vs {:S '[[Small Red Soft]]
120 | :G [[* * *]]}]
121 | (is (vs/consistent? vs ['Small 'Red 'Soft] true))
122 | (is (not (vs/consistent? vs ['Large 'Blue 'Hard] false)))
123 | (is (not (vs/consistent? vs ['Small 'Red 'Soft] false)))))
124 |
125 | (deftest classify-test
126 | (let [vs {:S [['Small 'Red 'Soft]]
127 | :G [[* 'Red *]]}]
128 | (is (= :fogus.rv.learn.vs/positive (vs/classify vs '[Small Red Soft])))
129 | (is (= :fogus.rv.learn.vs/negative (vs/classify vs '[Large Blue Hard])))
130 | (is (= :fogus.rv.learn.vs/ambiguous (vs/classify vs '[Large Red Hard])))
131 | (is true? (vs/covers? (:G vs) '[Large Red Hard]))
132 | (is false? (vs/covers? (:S vs) '[Large Red Hard]))))
133 |
134 | (deftest explain-test
135 | (let [vs (-> (proto/-init (vs/arity-vec 6))
136 | (vs/refine [:sunny :warm :normal :strong :warm :same] true)
137 | (vs/refine [:sunny :warm :high :strong :warm :same] true)
138 | (vs/refine [:rainy :cold :high :strong :warm :change] false))
139 | example [:sunny :warm :high :strong :cool :change]]
140 | (testing "explain"
141 | (let [res (vs/explain vs example)]
142 | (is (= :fogus.rv.learn.vs/ambiguous (:explain/classification res)))
143 | (is (= [2/3] (map :similarity (:explain/S res))))
144 | (is (= [1 1 5/6] (map :similarity (:explain/G res))))))
145 | (is (= 1 (:similarity (vs/best-fit vs example))))))
146 |
--------------------------------------------------------------------------------
/test/rv/productions_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.productions-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.productions :as p]
4 | [fogus.rv.datalog :as d]))
5 |
6 | (def productions
7 | '[{:antecedent [[?id :emergency/type :emergency.type/fire]]
8 | :consequent [[-1000 :response/type :response.type/activate-sprinklers]
9 | [-1000 :response/to ?id]]}
10 | {:antecedent [[?id :emergency/type :emergency.type/flood]]
11 | :consequent [[-1002 :response/type :response.type/kill-electricity]
12 | [-1002 :response/to ?id]]}])
13 |
14 | (def all-facts #{[-50 :emergency/type :emergency.type/fire]
15 | [-51 :emergency/type :emergency.type/flood]})
16 |
17 | (def KB {:productions productions
18 | :facts all-facts})
19 |
20 | (deftest test-unifications
21 | ""
22 | (testing "that the context seq is built with a single antecedent pattern."
23 | (is (= '[{?id -50}]
24 | (p/unifications '[[?id :emergency/type :emergency.type/fire]]
25 | (:facts KB)
26 | {})))
27 |
28 | (is (= '[{?id -50} {?id -1000000}]
29 | (p/unifications '[[?id :emergency/type :emergency.type/fire]]
30 | (conj all-facts [-1000000 :emergency/type :emergency.type/fire])
31 | {}))))
32 |
33 | (testing "that the context is built with multiple antecedent patterns"
34 | (is (= '[{?id -50, ?rid -5000000}]
35 | (p/unifications '[[?id :emergency/type :emergency.type/fire]
36 | [?rid :response/to ?id]]
37 | (conj all-facts [-5000000 :response/to -50])
38 | {})))))
39 |
40 | (deftest test-select-production
41 | (testing "that productions are selected as expected"
42 | (let [first-matching-production (comp first identity)]
43 | (is (= (first (:productions KB))
44 | (first (p/select-production first-matching-production KB)))))))
45 |
46 | (deftest test-apply-production
47 | (testing "that a production applied to a KB causes expected assertions"
48 | (let [first-matching-production (comp first identity)
49 | [production binds] (p/select-production first-matching-production KB)]
50 | (is (= #{[-51 :emergency/type :emergency.type/flood]
51 | [-50 :emergency/type :emergency.type/fire]
52 | [-1000 :response/type :response.type/activate-sprinklers]
53 | [-1000 :response/to -50]}
54 | (p/apply-production production (:facts KB) binds))))))
55 |
56 | (deftest test-step
57 | (testing "that a single step occurs as expected"
58 | (let [first-matching-production (comp first identity)
59 | results (p/step first-matching-production KB)]
60 | (is (= #{[-1000 -50]}
61 | (d/q '[:find ?from ?to
62 | :where
63 | [?to :emergency/type :emergency.type/fire]
64 | [?from :response/to ?to]]
65 | results)))
66 |
67 | (is (= #{[:response.type/activate-sprinklers]}
68 | (d/q '[:find ?response
69 | :where
70 | [_ :response/type ?response]]
71 | results))))))
72 |
73 | (deftest test-cycle
74 | (testing "that the whole cycle occurs as expected"
75 | (let [results (p/cycle p/naive-qf
76 | '{:productions [{:antecedent [[?id :person/name ?n]
77 | [?id :isa/human? true]]
78 | :consequent [[?id :isa/mortal? true]]}]
79 | :facts #{[42 :person/name "Socrates"]
80 | [42 :isa/human? true]}})]
81 | (is (= #{[42 :isa/mortal? true] [42 :isa/human? true] [42 :person/name "Socrates"]}
82 | results)))
83 | (let [results (p/cycle p/naive-qf KB)]
84 | (is (= #{[:response.type/kill-electricity] [:response.type/activate-sprinklers]}
85 | (d/q '[:find ?response
86 | :where
87 | [_ :response/type ?response]]
88 | results)))
89 |
90 | (is (= #{[:emergency.type/fire :response.type/activate-sprinklers]
91 | [:emergency.type/flood :response.type/kill-electricity]}
92 | (d/q '[:find ?problem ?response
93 | :where
94 | [?id :response/type ?response]
95 | [?id :response/to ?pid]
96 | [?pid :emergency/type ?problem]]
97 | results))))))
98 |
--------------------------------------------------------------------------------
/test/rv/search/astar_test.clj:
--------------------------------------------------------------------------------
1 | (ns rv.search.astar-test
2 | (:require [clojure.test :refer :all]
3 | [fogus.rv.search :as search]
4 | [fogus.rv.search.graph :as graph]))
5 |
6 | (def ^:private ^:const ORTHO-DIRS [[-1 0] [1 0] [0 -1] [0 1]])
7 |
8 | (defn- neighbors
9 | [deltas size yx]
10 | (filter (fn [new-yx] (every? #(< -1 % size) new-yx))
11 | (map #(vec (map + yx %)) deltas)))
12 |
13 | (defn- init-routes [yxcosts]
14 | (let [size (count yxcosts)]
15 | (vec (repeat size (vec (repeat size nil))))))
16 |
17 | (deftype SimpleAsciiGraph [dirs step-est yxcosts routes]
18 | search/GraphSearch
19 | (neighbors-of [_ yx]
20 | (neighbors dirs (count yxcosts) yx))
21 | (add-route [_ node new-path]
22 | (SimpleAsciiGraph. dirs step-est yxcosts (assoc-in routes node new-path)))
23 | (route-of [_ node]
24 | (get-in routes node))
25 | (cost-of [_ yx]
26 | (get-in yxcosts yx))
27 | search/HeuristicSearch
28 | (estimate-cost [_ yx _]
29 | (let [[y x] yx
30 | sz (count yxcosts)]
31 | (* step-est (- (+ sz sz) y x 2)))))
32 |
33 | (deftest test-astar
34 | (let [z-world [[ 1 1 1 1 1]
35 | [999 999 999 999 1]
36 | [ 1 1 1 1 1]
37 | [ 1 999 999 999 999]
38 | [ 1 1 1 1 1]]
39 | z-graph (SimpleAsciiGraph. ORTHO-DIRS 900 z-world (init-routes z-world))
40 | res (graph/astar z-graph [0 0] [4 4])]
41 | (is (= 17 (:cost res)))
42 | (is (= [[0 0] [0 1] [0 2] [0 3] [0 4] [1 4] [2 4] [2 3] [2 2] [2 1] [2 0] [3 0] [4 0] [4 1] [4 2] [4 3] [4 4]]
43 | (:path res))))
44 |
45 | (let [down-path [[1 1 1 2 1]
46 | [1 1 1 999 1]
47 | [1 1 1 999 1]
48 | [1 1 1 999 1]
49 | [1 1 1 1 1]]
50 | down-graph (SimpleAsciiGraph. ORTHO-DIRS 900 down-path (init-routes down-path))
51 | res (graph/astar down-graph [0 0] [4 4])]
52 | (is (= 9 (:cost res)))
53 | (is (= [[0 0] [0 1] [0 2] [1 2] [2 2] [3 2] [4 2] [4 3] [4 4]]
54 | (:path res))))
55 |
56 | (let [up-path [[1 1 1 2 1]
57 | [1 1 1 999 1]
58 | [1 1 1 999 1]
59 | [1 1 1 999 1]
60 | [1 1 1 3 1]]
61 | up-graph (SimpleAsciiGraph. ORTHO-DIRS 900 up-path (init-routes up-path))
62 | res (graph/astar up-graph [0 0] [4 4])]
63 | (is (= 10 (:cost res)))
64 | (is (= [[0 0] [0 1] [0 2] [0 3] [0 4] [1 4] [2 4] [3 4] [4 4]]
65 | (:path res))))
66 |
67 | (let [l-path [[1 2 1 2 1]
68 | [1 2 1 999 1]
69 | [1 2 1 999 1]
70 | [1 2 2 999 1]
71 | [1 1 1 2 1]]
72 | l-graph (SimpleAsciiGraph. ORTHO-DIRS 900 l-path (init-routes l-path))
73 | res (graph/astar l-graph [0 0] [4 4])]
74 | (is (= 10 (:cost res)))
75 | (is (= [[0 0] [1 0] [2 0] [3 0] [4 0] [4 1] [4 2] [4 3] [4 4]]
76 | (:path res))))
77 |
78 | (let [short-path [[1 2 1 2 1]
79 | [1 0 1 999 1]
80 | [1 1 1 999 1]
81 | [1 1 1 999 1]
82 | [1 1 1 1 1]]
83 | short-graph (SimpleAsciiGraph. ORTHO-DIRS 900 short-path (init-routes short-path))
84 | res (graph/astar short-graph [0 0] [1 1])]
85 | (is (= 2 (:cost res)))
86 | (is (= [[0 0] [1 0] [1 1]]
87 | (:path res)))))
88 |
89 |
--------------------------------------------------------------------------------