Eclipse Public License - v 1.0
31 | 32 |THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.
36 | 37 |1. DEFINITIONS
38 | 39 |"Contribution" means:
40 | 41 |a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and
43 |b) in the case of each subsequent Contributor:
44 |i) changes to the Program, and
45 |ii) additions to the Program;
46 |where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.
54 | 55 |"Contributor" means any person or entity that distributes 56 | the Program.
57 | 58 |"Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.
61 | 62 |"Program" means the Contributions distributed in accordance 63 | with this Agreement.
64 | 65 |"Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.
67 | 68 |2. GRANT OF RIGHTS
69 | 70 |a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.
76 | 77 |b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.
88 | 89 |c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.
101 | 102 |d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.
105 | 106 |3. REQUIREMENTS
107 | 108 |A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:
110 | 111 |a) it complies with the terms and conditions of this 112 | Agreement; and
113 | 114 |b) its license agreement:
115 | 116 |i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;
120 | 121 |ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;
124 | 125 |iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and
128 | 129 |iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.
133 | 134 |When the Program is made available in source code form:
135 | 136 |a) it must be made available under this Agreement; and
137 | 138 |b) a copy of this Agreement must be included with each 139 | copy of the Program.
140 | 141 |Contributors may not remove or alter any copyright notices contained 142 | within the Program.
143 | 144 |Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.
147 | 148 |4. COMMERCIAL DISTRIBUTION
149 | 150 |Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.
172 | 173 |For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.
183 | 184 |5. NO WARRANTY
185 | 186 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.
197 | 198 |6. DISCLAIMER OF LIABILITY
199 | 200 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
208 | 209 |7. GENERAL
210 | 211 |If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.
216 | 217 |If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.
223 | 224 |All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.
232 | 233 |Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.
252 | 253 |This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.
258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /examples/employees/example.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; example.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog - Example 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 2 March 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns bacwn.datalog.example 18 | (:require [fogus.datalog.bacwn.impl.literals :as literals]) 19 | (:use [fogus.datalog.bacwn :only (build-work-plan run-work-plan)] 20 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)] 21 | [fogus.datalog.bacwn.impl.rules :only (rules-set)] 22 | [fogus.datalog.bacwn.impl.database :only (add-tuples)])) 23 | 24 | (def db-base 25 | (make-database 26 | (relation :employee [:id :name :position]) 27 | (index :employee :name) 28 | 29 | (relation :boss [:employee-id :boss-id]) 30 | (index :boss :employee-id) 31 | 32 | (relation :can-do-job [:position :job]) 33 | (index :can-do-job :position) 34 | 35 | (relation :job-replacement [:job :can-be-done-by]) 36 | ;;(index :job-replacement :can-be-done-by) 37 | 38 | (relation :job-exceptions [:id :job]))) 39 | 40 | (def db 41 | (add-tuples db-base 42 | [:employee :id 1 :name "Bob" :position :boss] 43 | [:employee :id 2 :name "Mary" :position :chief-accountant] 44 | [:employee :id 3 :name "John" :position :accountant] 45 | [:employee :id 4 :name "Sameer" :position :chief-programmer] 46 | [:employee :id 5 :name "Lilian" :position :programmer] 47 | [:employee :id 6 :name "Li" :position :technician] 48 | [:employee :id 7 :name "Fred" :position :sales] 49 | [:employee :id 8 :name "Brenda" :position :sales] 50 | [:employee :id 9 :name "Miki" :position :project-management] 51 | [:employee :id 10 :name "Albert" :position :technician] 52 | 53 | [:boss :employee-id 2 :boss-id 1] 54 | [:boss :employee-id 3 :boss-id 2] 55 | [:boss :employee-id 4 :boss-id 1] 56 | [:boss :employee-id 5 :boss-id 4] 57 | [:boss :employee-id 6 :boss-id 4] 58 | [:boss :employee-id 7 :boss-id 1] 59 | [:boss :employee-id 8 :boss-id 7] 60 | [:boss :employee-id 9 :boss-id 1] 61 | [:boss :employee-id 10 :boss-id 6] 62 | 63 | [:can-do-job :position :boss :job :management] 64 | [:can-do-job :position :accountant :job :accounting] 65 | [:can-do-job :position :chief-accountant :job :accounting] 66 | [:can-do-job :position :programmer :job :programming] 67 | [:can-do-job :position :chief-programmer :job :programming] 68 | [:can-do-job :position :technician :job :server-support] 69 | [:can-do-job :position :sales :job :sales] 70 | [:can-do-job :position :project-management :job :project-management] 71 | 72 | [:job-replacement :job :pc-support :can-be-done-by :server-support] 73 | [:job-replacement :job :pc-support :can-be-done-by :programming] 74 | [:job-replacement :job :payroll :can-be-done-by :accounting] 75 | 76 | [:job-exceptions :id 4 :job :pc-support])) 77 | 78 | (def rules 79 | (rules-set 80 | (<- (:works-for :employee ?x :boss ?y) 81 | (:boss :employee-id ?e-id :boss-id ?b-id) 82 | (:employee :id ?e-id :name ?x) 83 | (:employee :id ?b-id :name ?y)) 84 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 85 | (:works-for :employee ?z :boss ?y)) 86 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 87 | (:can-do-job :position ?pos :job ?y)) 88 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 89 | (:employee-job* :employee ?x :job ?z)) 90 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 91 | (:employee :name ?x :position ?z) 92 | (if = ?z :boss)) 93 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 94 | (:employee :id ?id :name ?x) 95 | (not! :job-exceptions :id ?id :job ?y)) 96 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 97 | (not! :employee-job :employee ?y :job :pc-support)))) 98 | 99 | (def wp-1 (build-work-plan rules (?- :works-for :employee '??name :boss ?x))) 100 | (def wp-2 (build-work-plan rules (?- :employee-job :employee '??name :job ?x))) 101 | (def wp-3 (build-work-plan rules (?- :bj :name '??name :boss ?x))) 102 | (def wp-4 (build-work-plan rules (?- :works-for :employee ?x :boss ?y))) 103 | 104 | 105 | (run-work-plan wp-1 db {'??name "Mary"}) 106 | ;;({:boss "Li", :employee "Albert"} {:boss "Sameer", :employee "Albert"} {:boss "Bob", :employee "Albert"}) 107 | 108 | (run-work-plan wp-2 db {'??name "Li"}) 109 | ;; ({:job :server-support, :employee "Li"} {:job :pc-support, :employee "Li"}) 110 | 111 | (run-work-plan wp-3 db {'??name "Albert"}) 112 | ;; ({:boss "Sameer", :name "Albert"}) 113 | 114 | (run-work-plan wp-4 db {}) 115 | ;; ({:boss "Bob", :employee "Miki"} {:boss "Li", :employee "Albert"} {:boss "Sameer", :employee "Lilian"} {:boss "Bob", :employee "Li"} {:boss "Bob", :employee "Lilian"} {:boss "Fred", :employee "Brenda"} {:boss "Bob", :employee "Fred"} {:boss "Bob", :employee "John"} {:boss "Mary", :employee "John"} {:boss "Sameer", :employee "Albert"} {:boss "Bob", :employee "Sameer"} {:boss "Bob", :employee "Albert"} {:boss "Bob", :employee "Brenda"} {:boss "Bob", :employee "Mary"} {:boss "Sameer", :employee "Li"}) 116 | 117 | -------------------------------------------------------------------------------- /examples/mst3k/enghraifft.clj: -------------------------------------------------------------------------------- 1 | (ns bacwn.example.mst3k 2 | (:use [fogus.datalog.bacwn :as bacwn] 3 | [fogus.datalog.bacwn.macros :only (facts <- ?- make-database)] 4 | [fogus.datalog.bacwn.impl.rules :only (rules-set)] 5 | [fogus.datalog.bacwn.impl.database :only (add-tuples)])) 6 | 7 | (def mst3k-schema 8 | (make-database 9 | (relation :character [:db.id :name :human?]) 10 | (index :character :name) 11 | 12 | (relation :location [:db.id :character :name]) 13 | (index :location :name))) 14 | 15 | (def mst3k-db 16 | (-> mst3k-schema 17 | (facts {:character/db.id 0 :character/name "Joel" :character/human? true} 18 | {:character/db.id 1 :character/name "Crow" :character/human? false} 19 | {:character/db.id 2 :character/name "TV's Frank" :character/human? true} 20 | {:location/db.id 0 :location/character 0 :location/name "SoL"} 21 | {:location/db.id 0 :location/character 1 :location/name "SoL"} 22 | {:location/db.id 1 :location/character 2 :location/name "Gizmonics"}))) 23 | 24 | (def locate-rule 25 | (rules-set 26 | (<- (:stationed-at :location/name ?loc-name :character/name ?char-name) 27 | (:location :name ?loc-name :character ?char) 28 | (:character :db.id ?char :name ?char-name)))) 29 | 30 | (bacwn/run-work-plan 31 | (bacwn/build-work-plan locate-rule 32 | (?- :stationed-at :location/name '??loc :character/name ?char-name)) 33 | mst3k-db 34 | {'??loc "SoL"}) 35 | ;; ({:location/name "SoL", :character/name "Crow"} {:location/name "SoL", :character/name "Joel"}) 36 | 37 | (q (?- :stationed-at :location/name '??loc :character/name ?char-name) 38 | mst3k-db 39 | locate-rule 40 | {'??loc "SoL"}) 41 | 42 | (def non-human-locate-rule 43 | (rules-set 44 | (<- (:stationed-at :location/name ?loc-name :character/name ?char-name) 45 | (:location :name ?loc-name :character ?char) 46 | (:character :db.id ?char :name ?char-name) 47 | (not! :character :db.id ?char :human? true)))) 48 | 49 | (bacwn/run-work-plan 50 | (bacwn/build-work-plan non-human-locate-rule 51 | (?- :stationed-at :location/name '??loc :character/name ?char-name)) 52 | mst3k-db 53 | {'??loc "SoL"}) 54 | 55 | ;;=> ({:location/name "SoL", :character/name "Crow"}) 56 | 57 | (q (?- :stationed-at :location/name '??loc :character/name ?char-name) 58 | mst3k-db 59 | non-human-locate-rule 60 | {'??loc "SoL"}) 61 | 62 | ;;=> ({:location/name "SoL", :character/name "Crow"}) 63 | 64 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject fogus/bacwn "0.5.0-SNAPSHOT" 2 | :description "A Datalog for Clojure" 3 | :url "http://www.fogus.me/" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.10.1"] 7 | [org.clojure/clojurescript "1.10.758"] 8 | [com.cemerick/clojurescript.test "0.3.3"]] 9 | :repositories {"sonatype-oss-public" "https://oss.sonatype.org/content/groups/public/"} 10 | :plugins [[lein-cljsbuild "1.0.3"] 11 | [lein-marginalia "0.7.1"]] 12 | :extra-classpath-dirs ["checkouts/clojurescript/src/clj" 13 | "checkouts/clojurescript/src/cljs"] 14 | :source-paths ["src/clojure" "src/clojurescript"] 15 | :test-paths ["test/clojure"] 16 | :cljsbuild {:test-commands {"unit-tests" ["phantomjs" "runner.js" "target/unit-test.js"]} 17 | :builds 18 | {:test {:source-paths ["src/clojure" "src/clojurescript" "test-cljs"], 19 | :incremental false, 20 | :compiler {:pretty-print true, 21 | :output-to "target/unit-test.js", 22 | :optimizations :whitespace}}}}) 23 | 24 | -------------------------------------------------------------------------------- /runner.js: -------------------------------------------------------------------------------- 1 | var p = require('webpage').create(); 2 | var sys = require('system'); 3 | p.injectJs(sys.args[1]); 4 | 5 | p.onConsoleMessage = function (x) { 6 | var line = x; 7 | if (line !== "[NEWLINE]") { 8 | console.log(line.replace(/\[NEWLINE\]/g, "\n")); 9 | } 10 | }; 11 | 12 | p.evaluate(function () { 13 | cemerick.cljs.test.set_print_fn_BANG_(function(x) { 14 | console.log(x.replace(/\n/g, "[NEWLINE]")); // since console.log *itself* adds a newline 15 | }); 16 | }); 17 | 18 | var success = p.evaluate(function () { 19 | var results = cemerick.cljs.test.run_all_tests(); 20 | console.log(results); 21 | return cemerick.cljs.test.successful_QMARK_(results); 22 | }); 23 | 24 | phantom.exit(success ? 0 : 1); -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn.clj: -------------------------------------------------------------------------------- 1 | (ns fogus.datalog.bacwn 2 | (:require [fogus.datalog.bacwn.macros :refer [facts]] 3 | [fogus.datalog.bacwn.impl.database :as db] 4 | [fogus.datalog.bacwn.impl.rules :as rules] 5 | [fogus.datalog.bacwn.impl.softstrat :as soft] 6 | [fogus.datalog.bacwn.impl.syntax :as syntax] 7 | clojure.set)) 8 | 9 | (defrecord WorkPlan 10 | [work-plan ; The underlying structure 11 | rules ; The original rules 12 | query ; The original query 13 | work-plan-type]) ; The type of plan 14 | 15 | (defn- validate-work-plan 16 | "Ensure any top level semantics are not violated" 17 | [work-plan database] 18 | (let [common-relations (-> work-plan :rules (clojure.set/intersection (-> database keys set)))] 19 | (when (-> common-relations 20 | empty? 21 | not) 22 | (throw (Exception. (str "The rules and database define the same relation(s):" common-relations)))))) 23 | 24 | (defn build-work-plan 25 | "Given a list of rules and a query, build a work plan that can be 26 | used to execute the query." 27 | [rules query] 28 | (->WorkPlan (soft/build-soft-strat-work-plan rules query) rules query ::soft-stratified)) 29 | 30 | (defn run-work-plan 31 | "Given a work plan, a database, and some query bindings, run the 32 | work plan and return the results." 33 | [work-plan database query-bindings] 34 | (validate-work-plan work-plan database) 35 | (soft/evaluate-soft-work-set (:work-plan work-plan) database query-bindings)) 36 | 37 | ;; querying 38 | 39 | (defn q 40 | [query db rules bindings] 41 | (run-work-plan 42 | (build-work-plan rules query) 43 | db 44 | bindings)) 45 | 46 | ;; printing 47 | 48 | (defmethod print-method :bacwn.datalog.impl.database/datalog-database 49 | [db ^java.io.Writer writer] 50 | (binding [*out* writer] 51 | (do 52 | (println "(datalog-database") 53 | (println "{") 54 | (doseq [key (keys db)] 55 | (println) 56 | (println key) 57 | (print-method (db key) writer)) 58 | (println "})")))) 59 | 60 | (defmethod print-method :bacwn.datalog.impl.database/datalog-relation 61 | [rel ^java.io.Writer writer] 62 | (binding [*out* writer] 63 | (do 64 | (println "(datalog-relation") 65 | (println " ;; Schema") 66 | (println " " (:schema rel)) 67 | (println) 68 | (println " ;; Data") 69 | (println " #{") 70 | (doseq [tuple (:data rel)] 71 | (println " " tuple)) 72 | (println " }") 73 | (println) 74 | (println " ;; Indexes") 75 | (println " {") 76 | (doseq [key (-> rel :indexes keys)] 77 | (println " " key) 78 | (println " {") 79 | (doseq [val (keys ((:indexes rel) key))] 80 | (println " " val) 81 | (println " " (get-in rel [:indexes key val]))) 82 | (println " }")) 83 | (println " })")))) 84 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/database.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; database.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Support for in-memory database 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 21 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.database 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | clojure.set)) 22 | 23 | (defrecord Relation 24 | [schema ; A set of key names 25 | data ; A set of tuples 26 | indexes]) ; A map key names to indexes (in turn a map of value to tuples) 27 | 28 | ;;; DDL 29 | 30 | (defn datalog-database 31 | [rels] 32 | (with-meta rels {:type ::datalog-database})) 33 | 34 | (def empty-database (datalog-database {})) 35 | 36 | (defn datalog-relation 37 | "Creates a relation" 38 | [schema data indexes] 39 | (with-meta (->Relation schema data indexes) {:type ::datalog-relation})) 40 | 41 | (defn add-relation 42 | "Adds a relation to the database" 43 | [db name keys] 44 | (assoc db name (datalog-relation (set keys) #{} {}))) 45 | 46 | (defn add-index 47 | "Adds an index to an empty relation named name" 48 | [db name key] 49 | (assert (empty? (:data (db name)))) 50 | (let [rel (db name) 51 | inx (assoc (:indexes rel) key {})] 52 | (assoc db name (datalog-relation (:schema rel) 53 | (:data rel) 54 | inx)))) 55 | 56 | (defn ensure-relation 57 | "If the database lacks the named relation, add it" 58 | [db name keys indexes] 59 | (if-let [rel (db name)] 60 | (do 61 | (assert (= (:schema rel) (set keys))) 62 | db) 63 | (let [db1 (add-relation db name keys)] 64 | (reduce (fn [db key] (add-index db name key)) 65 | db1 66 | indexes)))) 67 | 68 | (defn get-relation 69 | "Get a relation object by name" 70 | [db rel-name] 71 | (db rel-name)) 72 | 73 | (defn replace-relation 74 | "Add or replace a fully constructed relation object to the database." 75 | [db rel-name rel] 76 | (assoc db rel-name rel)) 77 | 78 | ;;; DML 79 | 80 | (defn database-counts 81 | "Returns a map with the count of elements in each relation." 82 | [db] 83 | (util/map-values #(-> % :data count) db)) 84 | 85 | (defn- modify-indexes 86 | "Perform f on the indexed tuple-set. f should take a set and tuple, 87 | and return the new set." 88 | [idxs tuple f] 89 | (into {} (for [ik (keys idxs)] 90 | (let [im (idxs ik) 91 | iv (tuple ik) 92 | os (get im iv #{}) 93 | ns (f os tuple)] 94 | [ik (if (empty? ns) 95 | (dissoc im iv) 96 | (assoc im iv (f os tuple)))])))) 97 | 98 | (defn- add-to-indexes 99 | "Adds the tuple to the appropriate keys in the index map" 100 | [idxs tuple] 101 | (modify-indexes idxs tuple conj)) 102 | 103 | (defn- remove-from-indexes 104 | "Removes the tuple from the appropriate keys in the index map" 105 | [idxs tuple] 106 | (modify-indexes idxs tuple disj)) 107 | 108 | (defn add-tuple 109 | "Two forms: 110 | 111 | [db relation-name tuple] adds tuple to the named relation. Returns 112 | the new database. 113 | 114 | [rel tuple] adds to the relation object. Returns the new relation." 115 | ([db rel-name tuple] 116 | (assert (= (-> tuple keys set) (-> rel-name db :schema))) 117 | (assoc db rel-name (add-tuple (db rel-name) tuple))) 118 | ([rel tuple] 119 | (let [data (:data rel) 120 | new-data (conj data tuple)] 121 | (if (identical? data new-data) ; optimization hack! 122 | rel 123 | (let [idxs (add-to-indexes (:indexes rel) tuple)] 124 | (assoc rel :data new-data :indexes idxs)))))) 125 | 126 | (defn remove-tuple 127 | "Two forms: 128 | 129 | [db relation-name tuple] removes the tuple from the named relation, 130 | returns a new database. 131 | 132 | [rel tuple] removes the tuple from the relation. Returns the new 133 | relation." 134 | ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) 135 | ([rel tuple] 136 | (let [data (:data rel) 137 | new-data (disj data tuple)] 138 | (if (identical? data new-data) 139 | rel 140 | (let [idxs (remove-from-indexes (:indexes rel) tuple)] 141 | (assoc rel :data new-data :indexes idxs)))))) 142 | 143 | (defn add-tuples 144 | "Adds a collection of tuples to the db, as 145 | (add-tuples db 146 | [:rel-name :key-1 1 :key-2 2] 147 | [:rel-name :key-1 2 :key-2 3])" 148 | [db & tupls] 149 | (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) 150 | 151 | (defn- find-indexes 152 | "Given a map of indexes and a partial tuple, return the sets of full tuples" 153 | [idxs pt] 154 | (if (empty? idxs) 155 | nil 156 | (filter identity (for [key (keys pt)] 157 | (if-let [idx-map (idxs key)] 158 | (get idx-map (pt key) #{}) 159 | nil))))) 160 | 161 | (defn- match? 162 | "Is m2 contained in m1?" 163 | [m1 m2] 164 | (let [compare (fn [key] 165 | (and (contains? m1 key) 166 | (= (m1 key) (m2 key))))] 167 | (every? compare (keys m2)))) 168 | 169 | (defn- scan-space 170 | "Computes a stream of tuples from relation rn matching partial tuple (pt) 171 | and applies fun to each" 172 | [fun db rn pt] 173 | (let [rel (db rn) 174 | idxs (find-indexes (:indexes rel) pt) 175 | space (if (empty? idxs) 176 | (:data rel) ; table scan :( 177 | (reduce clojure.set/intersection idxs))] 178 | (fun #(match? % pt) space))) 179 | 180 | (defn select 181 | "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" 182 | [db rn pt] 183 | (scan-space filter db rn pt)) 184 | 185 | (defn any-match? 186 | "Finds if there are any matching records for the partial tuple" 187 | [db rn pt] 188 | (if (= (-> pt keys set) (:schema (db rn))) 189 | (contains? (:data (db rn)) pt) 190 | (scan-space some db rn pt))) 191 | 192 | 193 | ;;; Merge 194 | 195 | (defn merge-indexes 196 | [idx1 idx2] 197 | (merge-with (fn [h1 h2] (merge-with clojure.set/union h1 h2)) idx1 idx2)) 198 | 199 | (defn merge-relations 200 | "Merges two relations" 201 | [r1 r2] 202 | (assert (= (:schema r1) (:schema r2))) 203 | (let [merged-indexes (merge-indexes (:indexes r1) 204 | (:indexes r2)) 205 | merged-data (clojure.set/union (:data r1) 206 | (:data r2))] 207 | (assoc r1 :data merged-data :indexes merged-indexes))) 208 | 209 | (defn database-merge 210 | "Merges databases together" 211 | [dbs] 212 | (apply merge-with merge-relations dbs)) 213 | 214 | (defn database-merge-parallel 215 | "Merges databases together in parallel" 216 | [dbs] 217 | (util/preduce merge-relations dbs)) 218 | 219 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/graph.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; graph 10 | ;; 11 | ;; Basic Graph Theory Algorithms 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 23 June 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.graph 20 | (:require clojure.set)) 21 | 22 | (defrecord DirectedGraph 23 | [nodes ; The nodes of the graph, a collection 24 | neighbors]) ; A function that, given a node returns a collection neighbor nodes. 25 | 26 | (defn get-neighbors 27 | "Get the neighbors of a node." 28 | [g n] 29 | ((:neighbors g) n)) 30 | 31 | ;; ============================= 32 | ;; Graph Modification 33 | 34 | (defn reverse-graph 35 | "Given a directed graph, return another directed graph with the 36 | order of the edges reversed." 37 | [g] 38 | (let [op (fn [rna idx] 39 | (let [ns (get-neighbors g idx) 40 | am (fn [m val] 41 | (assoc m val (conj (get m val #{}) idx)))] 42 | (reduce am rna ns))) 43 | rn (reduce op {} (:nodes g))] 44 | (->DirectedGraph (:nodes g) rn))) 45 | 46 | (defn add-loops 47 | "For each node n, add the edge n->n if not already present." 48 | [g] 49 | (->DirectedGraph 50 | (:nodes g) 51 | (into {} (map (fn [n] 52 | [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) 53 | 54 | (defn remove-loops 55 | "For each node n, remove any edges n->n." 56 | [g] 57 | (->DirectedGraph 58 | (:nodes g) 59 | (into {} (map (fn [n] 60 | [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) 61 | 62 | ;; ============================= 63 | ;; Graph Walk 64 | 65 | (defn lazy-walk 66 | "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, 67 | provide a set of visited notes (v) and a collection of nodes to 68 | visit (ns)." 69 | ([g n] 70 | (lazy-walk g [n] #{})) 71 | ([g ns v] 72 | (lazy-seq (let [s (seq (drop-while v ns)) 73 | n (first s) 74 | ns (rest s)] 75 | (when s 76 | (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) 77 | 78 | (defn transitive-closure 79 | "Returns the transitive closure of a graph. The neighbors are lazily computed. 80 | 81 | Note: some version of this algorithm return all edges a->a 82 | regardless of whether such loops exist in the original graph. This 83 | version does not. Loops will be included only if produced by 84 | cycles in the graph. If you have code that depends on such 85 | behavior, call (-> g transitive-closure add-loops)" 86 | [g] 87 | (let [nns (fn [n] 88 | [n (delay (lazy-walk g (get-neighbors g n) #{}))]) 89 | nbs (into {} (map nns (:nodes g)))] 90 | (->DirectedGraph 91 | (:nodes g) 92 | (fn [n] (force (nbs n)))))) 93 | 94 | ;; ============================= 95 | ;; Strongly Connected Components 96 | 97 | (defn- post-ordered-visit 98 | "Starting at node n, perform a post-ordered walk." 99 | [g n [visited acc :as state]] 100 | (if (visited n) 101 | state 102 | (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) 103 | [(conj visited n) acc] 104 | (get-neighbors g n))] 105 | [v2 (conj acc2 n)]))) 106 | 107 | (defn post-ordered-nodes 108 | "Return a sequence of indexes of a post-ordered walk of the graph." 109 | [g] 110 | (fnext (reduce #(post-ordered-visit g %2 %1) 111 | [#{} []] 112 | (:nodes g)))) 113 | 114 | (defn scc 115 | "Returns, as a sequence of sets, the strongly connected components 116 | of g." 117 | [g] 118 | (let [po (reverse (post-ordered-nodes g)) 119 | rev (reverse-graph g) 120 | step (fn [stack visited acc] 121 | (if (empty? stack) 122 | acc 123 | (let [[nv comp] (post-ordered-visit rev 124 | (first stack) 125 | [visited #{}]) 126 | ns (remove nv stack)] 127 | (recur ns nv (conj acc comp)))))] 128 | (step po #{} []))) 129 | 130 | (defn component-graph 131 | "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. 132 | Each node in the new graph will be a set of nodes from the old. 133 | These sets are the strongly connected components. Each edge will 134 | be the union of the corresponding edges of the prior graph." 135 | ([g] 136 | (component-graph g (scc g))) 137 | ([g sccs] 138 | (let [find-node-set (fn [n] 139 | (some #(if (% n) % nil) sccs)) 140 | find-neighbors (fn [ns] 141 | (let [nbs1 (map (partial get-neighbors g) ns) 142 | nbs2 (map set nbs1) 143 | nbs3 (apply clojure.set/union nbs2)] 144 | (set (map find-node-set nbs3)))) 145 | nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] 146 | (->DirectedGraph (set sccs) nm)))) 147 | 148 | (defn recursive-component? 149 | "Is the component (recieved from scc) self recursive?" 150 | [g ns] 151 | (or (> (count ns) 1) 152 | (let [n (first ns)] 153 | (some #(= % n) (get-neighbors g n))))) 154 | 155 | (defn self-recursive-sets 156 | "Returns, as a sequence of sets, the components of a graph that are 157 | self-recursive." 158 | [g] 159 | (filter (partial recursive-component? g) (scc g))) 160 | 161 | ;; ============================= 162 | ;; Dependency Lists 163 | 164 | (defn fixed-point 165 | "Repeatedly apply fun to data until (equal old-data new-data) 166 | returns true. If max iterations occur, it will throw an 167 | exception. Set max to nil for unlimited iterations." 168 | [data fun max equal] 169 | (let [step (fn step [data idx] 170 | (when (and idx (= 0 idx)) 171 | (throw (Exception. "Fixed point overflow"))) 172 | (let [new-data (fun data)] 173 | (if (equal data new-data) 174 | new-data 175 | (recur new-data (and idx (dec idx))))))] 176 | (step data max))) 177 | 178 | (defn- fold-into-sets 179 | [priorities] 180 | (let [max (inc (apply max 0 (vals priorities))) 181 | step (fn [acc [n dep]] 182 | (assoc acc dep (conj (acc dep) n)))] 183 | (reduce step 184 | (vec (replicate max #{})) 185 | priorities))) 186 | 187 | (defn dependency-list 188 | "Similar to a topological sort, this returns a vector of sets. The 189 | set of nodes at index 0 are independent. The set at index 1 depend 190 | on index 0; those at 2 depend on 0 and 1, and so on. Those withing 191 | a set have no mutual dependencies. Assume the input graph (which 192 | much be acyclic) has an edge a->b when a depends on b." 193 | [g] 194 | (let [step (fn [d] 195 | (let [update (fn [n] 196 | (inc (apply max -1 (map d (get-neighbors g n)))))] 197 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 198 | counts (fixed-point (zipmap (:nodes g) (repeat 0)) 199 | step 200 | (inc (count (:nodes g))) 201 | =)] 202 | (fold-into-sets counts))) 203 | 204 | (defn stratification-list 205 | "Similar to dependency-list (see doc), except two graphs are 206 | provided. The first is as dependency-list. The second (which may 207 | have cycles) provides a partial-dependency relation. If node a 208 | depends on node b (meaning an edge a->b exists) in the second 209 | graph, node a must be equal or later in the sequence." 210 | [g1 g2] 211 | (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) 212 | (let [step (fn [d] 213 | (let [update (fn [n] 214 | (max (inc (apply max -1 215 | (map d (get-neighbors g1 n)))) 216 | (apply max -1 (map d (get-neighbors g2 n)))))] 217 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 218 | counts (fixed-point (zipmap (:nodes g1) (repeat 0)) 219 | step 220 | (inc (count (:nodes g1))) 221 | =)] 222 | (fold-into-sets counts))) 223 | 224 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/literals.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; literals.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Literals 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 25 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.literals 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | [fogus.datalog.bacwn.impl.database :as db] 22 | clojure.set)) 23 | 24 | ;; ============================= 25 | ;; Type Definitions 26 | 27 | (defrecord AtomicLiteral 28 | [predicate ; The predicate name 29 | term-bindings ; A map of column names to bindings 30 | literal-type]) ; ::literal or ::negated 31 | 32 | (derive ::negated ::literal) 33 | 34 | (defrecord ConditionalLiteral 35 | [fun ; The fun to call 36 | symbol ; The fun symbol (for display) 37 | terms ; The formal arguments 38 | literal-type]) ; ::conditional 39 | 40 | ;; ============================= 41 | ;; Basics 42 | 43 | (defmulti literal-predicate 44 | "Return the predicate/relation this conditional operates over" 45 | :literal-type) 46 | 47 | (defmulti literal-columns 48 | "Return the column names this applies to" 49 | :literal-type) 50 | 51 | (defmulti literal-vars 52 | "Returns the logic vars used by this literal" 53 | :literal-type) 54 | 55 | (defmulti positive-vars 56 | "Returns the logic vars used in a positive position" 57 | :literal-type) 58 | 59 | (defmulti negative-vars 60 | "Returns the logic vars used in a negative position" 61 | :literal-type) 62 | 63 | (defmethod literal-predicate ::literal 64 | [l] 65 | (:predicate l)) 66 | 67 | (defmethod literal-predicate ::conditional 68 | [l] 69 | nil) 70 | 71 | (defmethod literal-columns ::literal 72 | [l] 73 | (-> l :term-bindings keys set)) 74 | 75 | (defmethod literal-columns ::conditional 76 | [l] 77 | nil) 78 | 79 | (defmethod literal-vars ::literal 80 | [l] 81 | (set (filter util/is-var? (-> l :term-bindings vals)))) 82 | 83 | (defmethod literal-vars ::conditional 84 | [l] 85 | (set (filter util/is-var? (:terms l)))) 86 | 87 | (defmethod positive-vars ::literal 88 | [l] 89 | (literal-vars l)) 90 | 91 | (defmethod positive-vars ::negated 92 | [l] 93 | nil) 94 | 95 | (defmethod positive-vars ::conditional 96 | [l] 97 | nil) 98 | 99 | (defmethod negative-vars ::literal 100 | [l] 101 | nil) 102 | 103 | (defmethod negative-vars ::negated 104 | [l] 105 | (literal-vars l)) 106 | 107 | (defmethod negative-vars ::conditional 108 | [l] 109 | (literal-vars l)) 110 | 111 | (defn negated? 112 | "Is this literal a negated literal?" 113 | [l] 114 | (= (:literal-type l) ::negated)) 115 | 116 | (defn positive? 117 | "Is this a positive literal?" 118 | [l] 119 | (= (:literal-type l) ::literal)) 120 | 121 | ;; ============================= 122 | ;; Building Literals 123 | 124 | (def negation-symbol 'not!) 125 | (def conditional-symbol 'if) 126 | 127 | (defmulti build-literal 128 | "(Returns an unevaluated expression (to be used in macros) of a 129 | literal." 130 | first) 131 | 132 | (defn build-atom 133 | "Returns an unevaluated expression (to be used in a macro) of an 134 | atom." 135 | [f type] 136 | (let [p (first f) 137 | ts (map #(if (util/is-var? %) `(quote ~%) %) (next f)) 138 | b (if (seq ts) (apply assoc {} ts) nil)] 139 | `(->AtomicLiteral ~p ~b ~type))) 140 | 141 | (defmethod build-literal :default 142 | [f] 143 | (build-atom f ::literal)) 144 | 145 | (defmethod build-literal negation-symbol 146 | [f] 147 | (build-atom (rest f) ::negated)) 148 | 149 | (defmethod build-literal conditional-symbol 150 | [f] 151 | (let [symbol (fnext f) 152 | terms (nnext f) 153 | fun `(fn [binds#] (apply ~symbol binds#))] 154 | `(->ConditionalLiteral 155 | ~fun 156 | '~symbol 157 | '~terms 158 | ::conditional))) 159 | 160 | ;; ============================= 161 | ;; Display 162 | 163 | (defmulti display-literal 164 | "Converts a struct representing a literal to a normal list" 165 | :literal-type) 166 | 167 | (defn- display 168 | [l] 169 | (conj (-> l :term-bindings list* flatten) (literal-predicate l))) 170 | 171 | (defmethod display-literal ::literal 172 | [l] 173 | (display l)) 174 | 175 | (defmethod display-literal ::negated 176 | [l] 177 | (conj (display l) negation-symbol)) 178 | 179 | (defmethod display-literal ::conditional 180 | [l] 181 | (list* conditional-symbol (:symbol l) (:terms l))) 182 | 183 | ;; ============================= 184 | ;; Sip computation 185 | 186 | (defmulti get-vs-from-cs 187 | "From a set of columns, return the vars" 188 | :literal-type) 189 | 190 | (defmethod get-vs-from-cs ::literal 191 | [l bound] 192 | (set (filter util/is-var? 193 | (vals (select-keys (:term-bindings l) 194 | bound))))) 195 | 196 | (defmethod get-vs-from-cs ::conditional 197 | [l bound] 198 | nil) 199 | 200 | (defmulti get-cs-from-vs 201 | "From a set of vars, get the columns" 202 | :literal-type) 203 | 204 | (defmethod get-cs-from-vs ::literal 205 | [l bound] 206 | (reduce conj 207 | #{} 208 | (remove nil? 209 | (map (fn [[k v]] (if (bound v) k nil)) 210 | (:term-bindings l))))) 211 | 212 | (defmethod get-cs-from-vs ::conditional 213 | [l bound] 214 | nil) 215 | 216 | (defmulti get-self-bound-cs 217 | "Get the columns that are bound withing the literal." 218 | :literal-type) 219 | 220 | (defmethod get-self-bound-cs ::literal 221 | [l] 222 | (reduce conj 223 | #{} 224 | (remove nil? 225 | (map (fn [[k v]] (if (not (util/is-var? v)) k nil)) 226 | (:term-bindings l))))) 227 | 228 | (defmethod get-self-bound-cs ::conditional 229 | [l] 230 | nil) 231 | 232 | (defmulti literal-appropriate? 233 | "When passed a set of bound vars, determines if this literal can be 234 | used during this point of a SIP computation." 235 | (fn [b l] (:literal-type l))) 236 | 237 | (defmethod literal-appropriate? ::literal 238 | [bound l] 239 | (not (empty? (clojure.set/intersection (literal-vars l) bound)))) 240 | 241 | (defmethod literal-appropriate? ::negated 242 | [bound l] 243 | (clojure.set/subset? (literal-vars l) bound)) 244 | 245 | (defmethod literal-appropriate? ::conditional 246 | [bound l] 247 | (clojure.set/subset? (literal-vars l) bound)) 248 | 249 | (defmulti adorned-literal 250 | "When passed a set of bound columns, returns the adorned literal" 251 | (fn [l b] (:literal-type l))) 252 | 253 | (defmethod adorned-literal ::literal 254 | [l bound] 255 | (let [pred (literal-predicate l) 256 | bnds (clojure.set/intersection (literal-columns l) bound)] 257 | (if (empty? bound) 258 | l 259 | (assoc l :predicate {:pred pred :bound bnds})))) 260 | 261 | (defmethod adorned-literal ::conditional 262 | [l bound] 263 | l) 264 | 265 | (defn get-adorned-bindings 266 | "Get the bindings from this adorned literal." 267 | [pred] 268 | (:bound pred)) 269 | 270 | (defn get-base-predicate 271 | "Get the base predicate from this predicate." 272 | [pred] 273 | (if (map? pred) 274 | (:pred pred) 275 | pred)) 276 | 277 | ;; ============================= 278 | ;; Magic Stuff 279 | 280 | (defn magic-literal 281 | "Create a magic version of this adorned predicate." 282 | [l] 283 | (assert (-> l :literal-type (isa? ::literal))) 284 | (let [pred (literal-predicate l) 285 | pred-map (if (map? pred) pred {:pred pred}) 286 | bound (get-adorned-bindings pred) 287 | ntb (select-keys (:term-bindings l) bound)] 288 | (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) 289 | 290 | (defn literal-magic? 291 | "Is this literal magic?" 292 | [lit] 293 | (let [pred (literal-predicate lit)] 294 | (when (map? pred) 295 | (:magic pred)))) 296 | 297 | (defn build-seed-bindings 298 | "Given a seed literal, already adorned and in magic form, convert 299 | its bound constants to new variables." 300 | [s] 301 | (assert (-> s :literal-type (isa? ::literal))) 302 | (let [ntbs (util/map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] 303 | (assoc s :term-bindings ntbs))) 304 | 305 | ;; ============================= 306 | ;; Semi-naive support 307 | 308 | (defn negated-literal 309 | "Given a literal l, return a negated version" 310 | [l] 311 | (assert (-> l :literal-type (= ::literal))) 312 | (assoc l :literal-type ::negated)) 313 | 314 | (defn delta-literal 315 | "Given a literal l, return a delta version" 316 | [l] 317 | (let [pred* (:predicate l) 318 | pred (if (map? pred*) pred* {:pred pred*})] 319 | (assoc l :predicate (assoc pred :delta true)))) 320 | 321 | ;; ============================= 322 | ;; Database operations 323 | 324 | (defn- build-partial-tuple 325 | [lit binds] 326 | (let [tbs (:term-bindings lit) 327 | each (fn [[key val :as pair]] 328 | (if (util/is-var? val) 329 | (if-let [n (binds val)] 330 | [key n] 331 | nil) 332 | pair))] 333 | (into {} (remove nil? (map each tbs))))) 334 | 335 | (defn- project-onto-literal 336 | "Given a literal, and a materialized tuple, return a set of variable 337 | bindings." 338 | [lit tuple] 339 | (let [step (fn [binds [key val]] 340 | (if (and (util/is-var? val) 341 | (contains? tuple key)) 342 | (assoc binds val (tuple key)) 343 | binds))] 344 | (reduce step {} (:term-bindings lit)))) 345 | 346 | (defn- join-literal* 347 | [db lit bs fun] 348 | (let [each (fn [binds] 349 | (let [pt (build-partial-tuple lit binds)] 350 | (fun binds pt)))] 351 | (when (contains? db (literal-predicate lit)) 352 | (apply concat (map each bs))))) 353 | 354 | (defmulti join-literal 355 | "Given a database (db), a literal (lit) and a seq of bindings (bs), 356 | return a new seq of bindings by joining this literal." 357 | (fn [db lit bs] (:literal-type lit))) 358 | 359 | (defmethod join-literal ::literal 360 | [db lit bs] 361 | (join-literal* db lit bs (fn [binds pt] 362 | (map #(merge binds %) 363 | (map (partial project-onto-literal lit) 364 | (db/select db (literal-predicate lit) pt)))))) 365 | 366 | (defmethod join-literal ::negated 367 | [db lit bs] 368 | (join-literal* db lit bs (fn [binds pt] 369 | (if (db/any-match? db (literal-predicate lit) pt) 370 | nil 371 | [binds])))) 372 | 373 | (defmethod join-literal ::conditional 374 | [db lit bs] 375 | (let [each (fn [binds] 376 | (let [resolve (fn [term] 377 | (if (util/is-var? term) 378 | (binds term) 379 | term)) 380 | args (map resolve (:terms lit))] 381 | (if ((:fun lit) args) 382 | binds 383 | nil)))] 384 | (remove nil? (map each bs)))) 385 | 386 | (defn project-literal 387 | "Project a stream of bindings onto a literal/relation. Returns a new 388 | db." 389 | ([db lit bs] (project-literal db lit bs util/is-var?)) 390 | ([db lit bs var?] 391 | (assert (= (:literal-type lit) ::literal)) 392 | (let [rel-name (literal-predicate lit) 393 | columns (-> lit :term-bindings keys) 394 | idxs (vec (get-adorned-bindings (literal-predicate lit))) 395 | db1 (db/ensure-relation db rel-name columns idxs) 396 | rel (db/get-relation db1 rel-name) 397 | step (fn [rel bindings] 398 | (let [step (fn [t [k v]] 399 | (if (var? v) 400 | (assoc t k (bindings v)) 401 | (assoc t k v))) 402 | tuple (reduce step {} (:term-bindings lit))] 403 | (db/add-tuple rel tuple)))] 404 | (db/replace-relation db rel-name (reduce step rel bs))))) 405 | 406 | (defmethod print-method AtomicLiteral 407 | [query ^java.io.Writer writer] 408 | (.write writer (pr-str (list* '?- (display-literal query))))) 409 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/magic.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; magic.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Magic Sets 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 18 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns fogus.datalog.bacwn.impl.magic 18 | (:require [fogus.datalog.bacwn.impl.util :as util] 19 | [fogus.datalog.bacwn.impl.literals :as literal] 20 | [fogus.datalog.bacwn.impl.rules :as rule] 21 | clojure.set)) 22 | 23 | ;; ============================= 24 | ;; Adornment 25 | 26 | (defn adorn-query 27 | "Adorn a query" 28 | [q] 29 | (literal/adorned-literal q (literal/get-self-bound-cs q))) 30 | 31 | (defn adorn-rules-set 32 | "Adorns the given rules-set for the given query. (rs) is a 33 | rules-set, (q) is an adorned query." 34 | [rs q] 35 | (let [i-preds (rule/all-predicates rs) 36 | p-map (rule/predicate-map rs)] 37 | (loop [nrs rule/empty-rules-set ; The rules set being built 38 | needed #{(literal/literal-predicate q)}] 39 | (if (empty? needed) 40 | nrs 41 | (let [pred (first needed) 42 | remaining (disj needed pred) 43 | base-pred (literal/get-base-predicate pred) 44 | bindings (literal/get-adorned-bindings pred) 45 | new-rules (p-map base-pred) 46 | new-adorned-rules (map (partial rule/compute-sip bindings i-preds) 47 | new-rules) 48 | new-nrs (reduce conj nrs new-adorned-rules) 49 | current-preds (rule/all-predicates new-nrs) 50 | not-needed? (fn [pred] 51 | (or (current-preds pred) 52 | (-> pred literal/get-base-predicate i-preds not))) 53 | add-pred (fn [np pred] 54 | (if (not-needed? pred) np (conj np pred))) 55 | add-preds (fn [np rule] 56 | (reduce add-pred np (map literal/literal-predicate (:body rule)))) 57 | new-needed (reduce add-preds remaining new-adorned-rules)] 58 | (recur new-nrs new-needed)))))) 59 | 60 | 61 | ;; ============================= 62 | ;; Magic ! 63 | 64 | (defn seed-relation 65 | "Given a magic form of a query, give back the literal form of its seed 66 | relation" 67 | [q] 68 | (let [pred (-> q literal/literal-predicate literal/get-base-predicate) 69 | bnds (-> q literal/literal-predicate literal/get-adorned-bindings)] 70 | (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) 71 | 72 | (defn seed-rule 73 | "Given an adorned query, give back its seed rule" 74 | [q] 75 | (let [mq (literal/build-seed-bindings (literal/magic-literal q)) 76 | sr (seed-relation mq)] 77 | (rule/build-rule mq [sr]))) 78 | 79 | (defn build-partial-tuple 80 | "Given a query and a set of bindings, build a partial tuple needed 81 | to extract the relation from the database." 82 | [q bindings] 83 | (into {} (remove nil? (map (fn [[k v :as pair]] 84 | (if (util/is-var? v) 85 | nil 86 | (if (util/is-query-var? v) 87 | [k (bindings v)] 88 | pair))) 89 | (:term-bindings q))))) 90 | 91 | (defn seed-predicate-for-insertion 92 | "Given a query, return the predicate to use for database insertion." 93 | [q] 94 | (let [seed (-> q seed-rule :body first) 95 | columns (-> seed :term-bindings keys) 96 | new-term-bindings (-> q :term-bindings (select-keys columns))] 97 | (assoc seed :term-bindings new-term-bindings))) 98 | 99 | (defn magic-transform 100 | "Return a magic transformation of an adorned rules-set (rs). The 101 | (i-preds) are the predicates of the intension database. These 102 | default to the predicates within the rules-set." 103 | ([rs] 104 | (magic-transform rs (rule/all-predicates rs))) 105 | ([rs i-preds] 106 | (let [not-duplicate? (fn [l mh bd] 107 | (or (not (empty? bd)) 108 | (not (= (literal/magic-literal l) 109 | mh)))) 110 | xr (fn [rs rule] 111 | (let [head (:head rule) 112 | body (:body rule) 113 | mh (literal/magic-literal head) 114 | answer-rule (rule/build-rule head 115 | (concat [mh] body)) 116 | step (fn [[rs bd] l] 117 | (if (and (i-preds (literal/literal-predicate l)) 118 | (not-duplicate? l mh bd)) 119 | (let [nr (rule/build-rule (literal/magic-literal l) 120 | (concat [mh] bd))] 121 | [(conj rs nr) (conj bd l)]) 122 | [rs (conj bd l)])) 123 | [nrs _] (reduce step [rs []] body)] 124 | (conj nrs answer-rule)))] 125 | (reduce xr rule/empty-rules-set rs)))) 126 | 127 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/rules.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; rules.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Rules Engine 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 2 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns fogus.datalog.bacwn.impl.rules 18 | (:require [fogus.datalog.bacwn.impl.util :as util] 19 | [fogus.datalog.bacwn.impl.literals :as literal] 20 | [fogus.datalog.bacwn.impl.database :as db] 21 | clojure.set)) 22 | 23 | (defrecord DatalogRule [head body]) 24 | 25 | (defn display-rule 26 | "Return the rule in a readable format." 27 | [rule] 28 | (list* '<- 29 | (-> rule :head literal/display-literal) 30 | (map literal/display-literal (:body rule)))) 31 | 32 | (defn display-query 33 | "Return a query in a readable format." 34 | [query] 35 | (list* '?- (literal/display-literal query))) 36 | 37 | ;; ============================= 38 | ;; Check rule safety 39 | 40 | (defn is-safe? 41 | "Is the rule safe according to the datalog protocol?" 42 | [rule] 43 | (let [hv (literal/literal-vars (:head rule)) 44 | bpv (apply clojure.set/union (map literal/positive-vars (:body rule))) 45 | bnv (apply clojure.set/union (map literal/negative-vars (:body rule))) 46 | ehv (clojure.set/difference hv bpv) 47 | env (clojure.set/difference bnv bpv)] 48 | (when-not (empty? ehv) 49 | (throw (Exception. (str "Head vars" ehv "not bound in body of rule" rule)))) 50 | (when-not (empty? env) 51 | (throw (Exception. (str "Body vars" env "not bound in negative positions of rule" rule)))) 52 | rule)) 53 | 54 | ;; ============================= 55 | ;; Rule creation and printing 56 | 57 | (defn build-rule 58 | [hd bd] 59 | (with-meta (->DatalogRule hd bd) {:type ::datalog-rule})) 60 | 61 | (defmethod print-method ::datalog-rule 62 | [rule ^java.io.Writer writer] 63 | (print-method (display-rule rule) writer)) 64 | 65 | (defn return-rule-data 66 | "Returns an untypted rule that will be fully printed" 67 | [rule] 68 | (with-meta rule {})) 69 | 70 | (defmethod print-method ::datalog-query 71 | [query ^java.io.Writer writer] 72 | (print-method (display-query query) writer)) 73 | 74 | ;; ============================= 75 | ;; SIP 76 | 77 | (defn compute-sip 78 | "Given a set of bound column names, return an adorned sip for this 79 | rule. A set of intensional predicates should be provided to 80 | determine what should be adorned." 81 | [bindings i-preds rule] 82 | (let [next-lit (fn [bv body] 83 | (or (first (drop-while 84 | #(not (literal/literal-appropriate? bv %)) 85 | body)) 86 | (first (drop-while (complement literal/positive?) body)))) 87 | adorn (fn [lit bvs] 88 | (if (i-preds (literal/literal-predicate lit)) 89 | (let [bnds (clojure.set/union (literal/get-cs-from-vs lit bvs) 90 | (literal/get-self-bound-cs lit))] 91 | (literal/adorned-literal lit bnds)) 92 | lit)) 93 | new-h (literal/adorned-literal (:head rule) bindings)] 94 | (loop [bound-vars (literal/get-vs-from-cs (:head rule) bindings) 95 | body (:body rule) 96 | sip []] 97 | (if-let [next (next-lit bound-vars body)] 98 | (recur (clojure.set/union bound-vars (literal/literal-vars next)) 99 | (remove #(= % next) body) 100 | (conj sip (adorn next bound-vars))) 101 | (build-rule new-h (concat sip body)))))) 102 | 103 | ;; ============================= 104 | ;; Rule sets 105 | 106 | (defn make-rules-set 107 | "Given an existing set of rules, make it a 'rules-set' for 108 | printing." 109 | [rs] 110 | (with-meta rs {:type ::datalog-rules-set})) 111 | 112 | (def empty-rules-set (make-rules-set #{})) 113 | 114 | (defn rules-set 115 | "Given a collection of rules return a rules set" 116 | [& rules] 117 | (reduce conj empty-rules-set rules)) 118 | 119 | (defmethod print-method ::datalog-rules-set 120 | [rules ^java.io.Writer writer] 121 | (binding [*out* writer] 122 | (do 123 | (print "(rules-set") 124 | (doseq [rule rules] 125 | (println) 126 | (print " ") 127 | (print rule)) 128 | (println ")")))) 129 | 130 | (defn predicate-map 131 | "Given a rules-set, return a map of rules keyed by their predicates. 132 | Each value will be a set of rules." 133 | [rs] 134 | (let [add-rule (fn [m r] 135 | (let [pred (-> r :head literal/literal-predicate) 136 | os (get m pred #{})] 137 | (assoc m pred (conj os r))))] 138 | (reduce add-rule {} rs))) 139 | 140 | (defn all-predicates 141 | "Given a rules-set, return all defined predicates" 142 | [rs] 143 | (set (map literal/literal-predicate (map :head rs)))) 144 | 145 | (defn non-base-rules 146 | "Return a collection of rules that depend, somehow, on other rules" 147 | [rs] 148 | (let [pred (all-predicates rs) 149 | non-base (fn [r] 150 | (if (some #(pred %) 151 | (map literal/literal-predicate (:body r))) 152 | r 153 | nil))] 154 | (remove nil? (map non-base rs)))) 155 | 156 | ;; ============================= 157 | ;; Database operations 158 | 159 | (def empty-bindings [{}]) 160 | 161 | (defn apply-rule 162 | "Apply the rule against db-1, adding the results to the appropriate 163 | relation in db-2. The relation will be created if needed." 164 | ([db rule] (apply-rule db db rule)) 165 | ([db-1 db-2 rule] 166 | (let [head (:head rule) 167 | body (:body rule) 168 | step (fn [bs lit] 169 | (literal/join-literal db-1 lit bs)) 170 | bs (reduce step empty-bindings body)] 171 | (literal/project-literal db-2 head bs)))) 172 | 173 | (defn apply-rules-set 174 | [db rs] 175 | (reduce (fn [rdb rule] 176 | (apply-rule db rdb rule)) db rs)) -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/softstrat.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; softstrat.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Soft Stratification 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 28 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Ported to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.softstrat 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | [fogus.datalog.bacwn.impl.database :as db] 22 | [fogus.datalog.bacwn.impl.literals :as literal] 23 | [fogus.datalog.bacwn.impl.rules :as rule] 24 | [fogus.datalog.bacwn.impl.magic :as magic] 25 | [fogus.datalog.bacwn.impl.graph :as graph] 26 | clojure.set)) 27 | 28 | ;; ============================= 29 | ;; Dependency graph 30 | 31 | (defn- build-rules-graph 32 | "Given a rules-set (rs), build a graph where each predicate symbol in rs, 33 | there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges 34 | from the (literal-predicate h) -> (literal-predicate b-*), one for each 35 | b-*." 36 | [rs] 37 | (let [preds (rule/all-predicates rs) 38 | pred-map (rule/predicate-map rs) 39 | step (fn [nbs pred] 40 | (let [rules (pred-map pred) 41 | preds (reduce (fn [pds lits] 42 | (reduce (fn [pds lit] 43 | (if-let [pred (literal/literal-predicate lit)] 44 | (conj pds pred) 45 | pds)) 46 | pds 47 | lits)) 48 | #{} 49 | (map :body rules))] 50 | (assoc nbs pred preds))) 51 | neighbors (reduce step {} preds)] 52 | (graph/->DirectedGraph preds neighbors))) 53 | 54 | (defn- build-def 55 | "Given a rules-set, build its def function" 56 | [rs] 57 | (let [pred-map (rule/predicate-map rs) 58 | graph (-> rs 59 | build-rules-graph 60 | graph/transitive-closure 61 | graph/add-loops)] 62 | (fn [pred] 63 | (apply clojure.set/union (map set (map pred-map (graph/get-neighbors graph pred))))))) 64 | 65 | ;; ============================= 66 | ;; Soft Stratificattion REQ Graph 67 | 68 | (defn- req 69 | "Returns a rules-set that is a superset of req(lit) for the lit at 70 | index lit-index" 71 | [rs soft-def rule lit-index] 72 | (let [head (:head rule) 73 | body (:body rule) 74 | lit (nth body lit-index) 75 | pre (subvec (vec body) 0 lit-index)] 76 | (conj (-> lit 77 | literal/literal-predicate 78 | soft-def 79 | (magic/magic-transform (rule/all-predicates rs))) 80 | (rule/build-rule (literal/magic-literal lit) pre)))) 81 | 82 | (defn- rule-dep 83 | "Given a rule, return the set of rules it depends on." 84 | [rs mrs soft-def rule] 85 | (let [step (fn [nrs [idx lit]] 86 | (if (literal/negated? lit) 87 | (clojure.set/union nrs (req rs soft-def rule idx)) 88 | nrs))] 89 | (clojure.set/intersection mrs 90 | (reduce step rule/empty-rules-set 91 | (->> rule :body (map-indexed vector)))))) 92 | 93 | (defn- soft-strat-graph 94 | "The dependency graph for soft stratification." 95 | [rs mrs] 96 | (let [soft-def (build-def rs) 97 | step (fn [nbrs rule] 98 | (assoc nbrs rule (rule-dep rs mrs soft-def rule))) 99 | nbrs (reduce step {} mrs)] 100 | (graph/->DirectedGraph mrs nbrs))) 101 | 102 | (defn- build-soft-strat 103 | "Given a rules-set (unadorned) and an adorned query, return the soft 104 | stratified list. The rules will be magic transformed, and the 105 | magic seed will be appended." 106 | [rs q] 107 | (let [ars (magic/adorn-rules-set rs q) 108 | mrs (conj (magic/magic-transform ars) 109 | (magic/seed-rule q)) 110 | gr (soft-strat-graph ars mrs)] 111 | (map rule/make-rules-set (graph/dependency-list gr)))) 112 | 113 | ;; ============================= 114 | ;; Work plan 115 | 116 | (defrecord SoftStratWorkPlan [query stratification]) 117 | 118 | (defn build-soft-strat-work-plan 119 | "Return a work plan for the given rules-set and query" 120 | [rs q] 121 | (let [aq (magic/adorn-query q)] 122 | (->SoftStratWorkPlan aq (build-soft-strat rs aq)))) 123 | 124 | (defn get-all-relations 125 | "Return a set of all relation names defined in this workplan" 126 | [ws] 127 | (apply clojure.set/union (map rule/all-predicates (:stratification ws)))) 128 | 129 | ;; ============================= 130 | ;; Evaluate 131 | 132 | (defn- weak-consq-operator 133 | [db strat] 134 | (let [counts (db/database-counts db)] 135 | (loop [strat strat] 136 | (let [rs (first strat)] 137 | (if rs 138 | (let [new-db (rule/apply-rules-set db rs)] 139 | (if (= counts (db/database-counts new-db)) 140 | (recur (next strat)) 141 | new-db)) 142 | db))))) 143 | 144 | (defn evaluate-soft-work-set 145 | ([ws db] (evaluate-soft-work-set ws db {})) 146 | ([ws db bindings] 147 | (let [query (:query ws) 148 | strat (:stratification ws) 149 | seed (magic/seed-predicate-for-insertion query) 150 | seeded-db (literal/project-literal db seed [bindings] util/is-query-var?) 151 | fun (fn [data] 152 | (weak-consq-operator data strat)) 153 | equal (fn [db1 db2] 154 | (= (db/database-counts db1) (db/database-counts db2))) 155 | new-db (graph/fixed-point seeded-db fun nil equal) 156 | pt (magic/build-partial-tuple query bindings)] 157 | (db/select new-db (literal/literal-predicate query) pt)))) 158 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/syntax.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Michael Fogus. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; syntax.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Support for in-memory database 12 | ;; 13 | 14 | (ns fogus.datalog.bacwn.impl.syntax) 15 | 16 | (def ID_KEY :db.id) 17 | (def ^:private nums (atom 0)) 18 | 19 | (defn explode 20 | "Convert a map into a clj-Datalog tuple vector. Brittle, but 21 | works along the happy path." 22 | [entity] 23 | (let [relation-type (-> entity seq ffirst namespace keyword) 24 | id-key (keyword (name relation-type) "db.id") 25 | id (get entity id-key) 26 | id (if id id (swap! nums inc)) 27 | kvs (seq (dissoc entity id-key))] 28 | (vec 29 | (apply concat [relation-type :db.id id] 30 | (reduce (fn [acc [k v]] 31 | (cons [(keyword (name k)) v] acc)) 32 | [] 33 | kvs))))) 34 | 35 | (defn agg [tuples] 36 | (group-by (comp keyword namespace second) tuples)) 37 | 38 | (defn propagate [agg] 39 | (apply concat 40 | (for [[k v] agg] 41 | (map #(vec (cons k %)) v)))) 42 | 43 | (defn shuffle-tuples [tups] 44 | (let [ids (atom {})] 45 | (map (fn [[nspace id prop val]] 46 | [nspace 47 | ID_KEY (get (swap! ids 48 | (fn [m] 49 | (if-let [i (get m id)] 50 | m 51 | (let [i (swap! nums inc)] 52 | (assoc m id i))))) 53 | id) 54 | (keyword (name prop)) val]) 55 | tups))) 56 | 57 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/impl/util.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; util.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Utilities 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 3 Feburary 2009 15 | ;; Ported to ClojureScript by Fogus 2012. 16 | ;; 17 | 18 | 19 | (ns fogus.datalog.bacwn.impl.util) 20 | 21 | ;; From clojure.contrib.seqs 22 | (defn separate 23 | "Returns a vector: 24 | [ (filter f s), (filter (complement f) s) ]" 25 | [f s] 26 | [(filter f s) (filter (complement f) s)]) 27 | 28 | ;;; Bindings and logic vars. A binding in a hash of logic vars to 29 | ;;; bound values. Logic vars are any symbol prefixed with a \?. 30 | 31 | (defn is-var? 32 | "Is this a logic variable: e.g. a symbol prefixed with a ?" 33 | [sym] 34 | (when (symbol? sym) 35 | (let [name (name sym)] 36 | (and (= \? (first name)) 37 | (not= \? (fnext name)))))) 38 | 39 | (defn is-query-var? 40 | "Is this a query variable: e.g. a symbol prefixed with ??" 41 | [sym] 42 | (when (symbol? sym) 43 | (let [name (name sym)] 44 | (and (= \? (first name)) 45 | (= \? (fnext name)))))) 46 | 47 | (defn map-values 48 | "Like map, but works over the values of a hash map" 49 | [f hash] 50 | (let [key-vals (map (fn [[key val]] [key (f val)]) hash)] 51 | (if (seq key-vals) 52 | (apply conj (empty hash) key-vals) 53 | hash))) 54 | 55 | (defn keys-to-vals 56 | "Given a map and a collection of keys, return the collection of vals" 57 | [m ks] 58 | (vals (select-keys m ks))) 59 | 60 | (defn reverse-map 61 | "Reverse the keys/values of a map" 62 | [m] 63 | (into {} (map (fn [[k v]] [v k]) m))) 64 | 65 | 66 | ;;; Preduce -- A parallel reduce over hashes 67 | 68 | (defn preduce 69 | "Similar to merge-with, but the contents of each key are merged in 70 | parallel using f. 71 | 72 | f - a function of 2 arguments. 73 | data - a collection of hashes." 74 | [f data] 75 | (let [data-1 (map (fn [h] (map-values #(list %) h)) data) 76 | merged (doall (apply merge-with concat data-1)) 77 | ; Groups w/ multiple elements are identified for parallel processing 78 | [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged) 79 | fold-group (fn [[key vals]] {key (reduce f vals)}) 80 | fix-single (fn [[key [val]]] [key val])] 81 | (apply merge (concat (pmap fold-group merged) (map fix-single simple))))) 82 | 83 | -------------------------------------------------------------------------------- /src/clojure/fogus/datalog/bacwn/macros.clj: -------------------------------------------------------------------------------- 1 | (ns fogus.datalog.bacwn.macros 2 | (:require [fogus.datalog.bacwn.impl.syntax :as syntax] 3 | [fogus.datalog.bacwn.impl.database :as db] 4 | fogus.datalog.bacwn.impl.literals 5 | fogus.datalog.bacwn.impl.rules 6 | fogus.datalog.bacwn.impl.magic)) 7 | 8 | (defmacro facts [db & tuples] 9 | `(db/add-tuples ~db 10 | ~@(map syntax/explode tuples))) 11 | 12 | (defmacro make-database 13 | "Makes a database, like this 14 | (make-database 15 | (relation :fred [:mary :sue]) 16 | (index :fred :mary) 17 | (relation :sally [:jen :becky]) 18 | (index :sally :jen) 19 | (index :sally :becky))" 20 | [& commands] 21 | (let [wrapper (fn [cur new] 22 | (let [cmd (first new) 23 | body (next new)] 24 | (assert (= 2 (count body))) 25 | (cond 26 | (= cmd 'relation) 27 | `(fogus.datalog.bacwn.impl.database/add-relation ~cur ~(first body) ~(fnext body)) 28 | (= cmd 'index) 29 | `(fogus.datalog.bacwn.impl.database/add-index ~cur ~(first body) ~(fnext body)) 30 | :otherwise (throw (Exception. (str new "not recognized"))))))] 31 | (reduce wrapper `fogus.datalog.bacwn.impl.database/empty-database commands))) 32 | 33 | (defmacro <- 34 | "Build a datalog rule. Like this: 35 | 36 | (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" 37 | [hd & body] 38 | (let [head (fogus.datalog.bacwn.impl.literals/build-atom hd :fogus.datalog.bacwn.impl.literals/literal) 39 | body (map fogus.datalog.bacwn.impl.literals/build-literal body)] 40 | `(fogus.datalog.bacwn.impl.rules/is-safe? (fogus.datalog.bacwn.impl.rules/build-rule ~head [~@body])))) 41 | 42 | (defmacro ?- 43 | "Define a datalog query" 44 | [& q] 45 | (let [qq (fogus.datalog.bacwn.impl.literals/build-atom q :fogus.datalog.bacwn.impl.literals/literal)] 46 | `(with-meta ~qq {:type :fogus.datalog.bacwn.impl.rules/datalog-query}))) 47 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn.cljs: -------------------------------------------------------------------------------- 1 | (ns fogus.datalog.bacwn 2 | (:require [fogus.datalog.bacwn.impl.database :as db] 3 | [fogus.datalog.bacwn.impl.rules :as rules] 4 | [fogus.datalog.bacwn.impl.softstrat :as soft] 5 | [fogus.datalog.bacwn.impl.syntax :as syntax] 6 | [clojure.set :as sets])) 7 | 8 | (defrecord WorkPlan 9 | [work-plan ; The underlying structure 10 | rules ; The original rules 11 | query ; The original query 12 | work-plan-type]) ; The type of plan 13 | 14 | (defn- validate-work-plan 15 | "Ensure any top level semantics are not violated" 16 | [work-plan database] 17 | (let [common-relations (-> work-plan :rules (clojure.set/intersection (-> database keys set)))] 18 | (when (-> common-relations 19 | empty? 20 | not) 21 | (throw (js/Error. (str "The rules and database define the same relation(s):" common-relations)))))) 22 | 23 | (defn build-work-plan 24 | "Given a list of rules and a query, build a work plan that can be 25 | used to execute the query." 26 | [rules query] 27 | (->WorkPlan (soft/build-soft-strat-work-plan rules query) rules query ::soft-stratified)) 28 | 29 | (defn run-work-plan 30 | "Given a work plan, a database, and some query bindings, run the 31 | work plan and return the results." 32 | [work-plan database query-bindings] 33 | (validate-work-plan work-plan database) 34 | (soft/evaluate-soft-work-set (:work-plan work-plan) database query-bindings)) 35 | 36 | ;; querying 37 | 38 | (defn q 39 | [query db rules bindings] 40 | (run-work-plan 41 | (build-work-plan rules query) 42 | db 43 | bindings)) 44 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/database.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; database.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Support for in-memory database 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 21 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.database 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | clojure.set)) 22 | 23 | (defrecord Relation 24 | [schema ; A set of key names 25 | data ; A set of tuples 26 | indexes]) ; A map key names to indexes (in turn a map of value to tuples) 27 | 28 | ;;; DDL 29 | 30 | (defn datalog-database 31 | [rels] 32 | (with-meta rels {:type ::datalog-database})) 33 | 34 | (def empty-database (datalog-database {})) 35 | 36 | (defn datalog-relation 37 | "Creates a relation" 38 | [schema data indexes] 39 | (with-meta (->Relation schema data indexes) {:type ::datalog-relation})) 40 | 41 | (defn add-relation 42 | "Adds a relation to the database" 43 | [db name keys] 44 | (assoc db name (datalog-relation (set keys) #{} {}))) 45 | 46 | (defn add-index 47 | "Adds an index to an empty relation named name" 48 | [db name key] 49 | (assert (empty? (:data (db name)))) 50 | (let [rel (db name) 51 | inx (assoc (:indexes rel) key {})] 52 | (assoc db name (datalog-relation (:schema rel) 53 | (:data rel) 54 | inx)))) 55 | 56 | (defn ensure-relation 57 | "If the database lacks the named relation, add it" 58 | [db name keys indexes] 59 | (if-let [rel (db name)] 60 | (do 61 | (assert (= (:schema rel) (set keys))) 62 | db) 63 | (let [db1 (add-relation db name keys)] 64 | (reduce (fn [db key] (add-index db name key)) 65 | db1 66 | indexes)))) 67 | 68 | (defn get-relation 69 | "Get a relation object by name" 70 | [db rel-name] 71 | (db rel-name)) 72 | 73 | (defn replace-relation 74 | "Add or replace a fully constructed relation object to the database." 75 | [db rel-name rel] 76 | (assoc db rel-name rel)) 77 | 78 | ;;; DML 79 | 80 | (defn database-counts 81 | "Returns a map with the count of elements in each relation." 82 | [db] 83 | (util/map-values #(-> % :data count) db)) 84 | 85 | (defn- modify-indexes 86 | "Perform f on the indexed tuple-set. f should take a set and tuple, 87 | and return the new set." 88 | [idxs tuple f] 89 | (into {} (for [ik (keys idxs)] 90 | (let [im (idxs ik) 91 | iv (tuple ik) 92 | os (get im iv #{}) 93 | ns (f os tuple)] 94 | [ik (if (empty? ns) 95 | (dissoc im iv) 96 | (assoc im iv (f os tuple)))])))) 97 | 98 | (defn- add-to-indexes 99 | "Adds the tuple to the appropriate keys in the index map" 100 | [idxs tuple] 101 | (modify-indexes idxs tuple conj)) 102 | 103 | (defn- remove-from-indexes 104 | "Removes the tuple from the appropriate keys in the index map" 105 | [idxs tuple] 106 | (modify-indexes idxs tuple disj)) 107 | 108 | (defn add-tuple 109 | "Two forms: 110 | 111 | [db relation-name tuple] adds tuple to the named relation. Returns 112 | the new database. 113 | 114 | [rel tuple] adds to the relation object. Returns the new relation." 115 | ([db rel-name tuple] 116 | (assert (= (-> tuple keys set) (-> rel-name db :schema))) 117 | (assoc db rel-name (add-tuple (db rel-name) tuple))) 118 | ([rel tuple] 119 | (let [data (:data rel) 120 | new-data (conj data tuple)] 121 | (if (identical? data new-data) ; optimization hack! 122 | rel 123 | (let [idxs (add-to-indexes (:indexes rel) tuple)] 124 | (assoc rel :data new-data :indexes idxs)))))) 125 | 126 | (defn remove-tuple 127 | "Two forms: 128 | 129 | [db relation-name tuple] removes the tuple from the named relation, 130 | returns a new database. 131 | 132 | [rel tuple] removes the tuple from the relation. Returns the new 133 | relation." 134 | ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) 135 | ([rel tuple] 136 | (let [data (:data rel) 137 | new-data (disj data tuple)] 138 | (if (identical? data new-data) 139 | rel 140 | (let [idxs (remove-from-indexes (:indexes rel) tuple)] 141 | (assoc rel :data new-data :indexes idxs)))))) 142 | 143 | (defn add-tuples 144 | "Adds a collection of tuples to the db, as 145 | (add-tuples db 146 | [:rel-name :key-1 1 :key-2 2] 147 | [:rel-name :key-1 2 :key-2 3])" 148 | [db & tupls] 149 | (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) 150 | 151 | (defn- find-indexes 152 | "Given a map of indexes and a partial tuple, return the sets of full tuples" 153 | [idxs pt] 154 | (if (empty? idxs) 155 | nil 156 | (filter identity (for [key (keys pt)] 157 | (if-let [idx-map (idxs key)] 158 | (get idx-map (pt key) #{}) 159 | nil))))) 160 | 161 | (defn- match? 162 | "Is m2 contained in m1?" 163 | [m1 m2] 164 | (let [compare (fn [key] 165 | (and (contains? m1 key) 166 | (= (m1 key) (m2 key))))] 167 | (every? compare (keys m2)))) 168 | 169 | (defn- scan-space 170 | "Computes a stream of tuples from relation rn matching partial tuple (pt) 171 | and applies fun to each" 172 | [fun db rn pt] 173 | (let [rel (db rn) 174 | idxs (find-indexes (:indexes rel) pt) 175 | space (if (empty? idxs) 176 | (:data rel) ; table scan :( 177 | (reduce clojure.set/intersection idxs))] 178 | (fun #(match? % pt) space))) 179 | 180 | (defn select 181 | "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" 182 | [db rn pt] 183 | (scan-space filter db rn pt)) 184 | 185 | (defn any-match? 186 | "Finds if there are any matching records for the partial tuple" 187 | [db rn pt] 188 | (if (= (-> pt keys set) (:schema (db rn))) 189 | (contains? (:data (db rn)) pt) 190 | (scan-space some db rn pt))) 191 | 192 | 193 | ;;; Merge 194 | 195 | (defn merge-indexes 196 | [idx1 idx2] 197 | (merge-with (fn [h1 h2] (merge-with clojure.set/union h1 h2)) idx1 idx2)) 198 | 199 | (defn merge-relations 200 | "Merges two relations" 201 | [r1 r2] 202 | (assert (= (:schema r1) (:schema r2))) 203 | (let [merged-indexes (merge-indexes (:indexes r1) 204 | (:indexes r2)) 205 | merged-data (clojure.set/union (:data r1) 206 | (:data r2))] 207 | (assoc r1 :data merged-data :indexes merged-indexes))) 208 | 209 | (defn database-merge 210 | "Merges databases together" 211 | [dbs] 212 | (apply merge-with merge-relations dbs)) 213 | 214 | (defn database-merge-parallel 215 | "Merges databases together in parallel" 216 | [dbs] 217 | (util/preduce merge-relations dbs)) 218 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/graph.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; graph 10 | ;; 11 | ;; Basic Graph Theory Algorithms 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 23 June 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.graph 20 | (:require clojure.set)) 21 | 22 | (defrecord DirectedGraph 23 | [nodes ; The nodes of the graph, a collection 24 | neighbors]) ; A function that, given a node returns a collection neighbor nodes. 25 | 26 | (defn get-neighbors 27 | "Get the neighbors of a node." 28 | [g n] 29 | ((:neighbors g) n)) 30 | 31 | ;; ============================= 32 | ;; Graph Modification 33 | 34 | (defn reverse-graph 35 | "Given a directed graph, return another directed graph with the 36 | order of the edges reversed." 37 | [g] 38 | (let [op (fn [rna idx] 39 | (let [ns (get-neighbors g idx) 40 | am (fn [m val] 41 | (assoc m val (conj (get m val #{}) idx)))] 42 | (reduce am rna ns))) 43 | rn (reduce op {} (:nodes g))] 44 | (->DirectedGraph (:nodes g) rn))) 45 | 46 | (defn add-loops 47 | "For each node n, add the edge n->n if not already present." 48 | [g] 49 | (->DirectedGraph 50 | (:nodes g) 51 | (into {} (map (fn [n] 52 | [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) 53 | 54 | (defn remove-loops 55 | "For each node n, remove any edges n->n." 56 | [g] 57 | (->DirectedGraph 58 | (:nodes g) 59 | (into {} (map (fn [n] 60 | [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) 61 | 62 | ;; ============================= 63 | ;; Graph Walk 64 | 65 | (defn lazy-walk 66 | "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, 67 | provide a set of visited notes (v) and a collection of nodes to 68 | visit (ns)." 69 | ([g n] 70 | (lazy-walk g [n] #{})) 71 | ([g ns v] 72 | (lazy-seq (let [s (seq (drop-while v ns)) 73 | n (first s) 74 | ns (rest s)] 75 | (when s 76 | (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) 77 | 78 | (defn transitive-closure 79 | "Returns the transitive closure of a graph. The neighbors are lazily computed. 80 | 81 | Note: some version of this algorithm return all edges a->a 82 | regardless of whether such loops exist in the original graph. This 83 | version does not. Loops will be included only if produced by 84 | cycles in the graph. If you have code that depends on such 85 | behavior, call (-> g transitive-closure add-loops)" 86 | [g] 87 | (let [nns (fn [n] 88 | [n (delay (lazy-walk g (get-neighbors g n) #{}))]) 89 | nbs (into {} (map nns (:nodes g)))] 90 | (->DirectedGraph 91 | (:nodes g) 92 | (fn [n] (force (nbs n)))))) 93 | 94 | ;; ============================= 95 | ;; Strongly Connected Components 96 | 97 | (defn- post-ordered-visit 98 | "Starting at node n, perform a post-ordered walk." 99 | [g n [visited acc :as state]] 100 | (if (visited n) 101 | state 102 | (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) 103 | [(conj visited n) acc] 104 | (get-neighbors g n))] 105 | [v2 (conj acc2 n)]))) 106 | 107 | (defn post-ordered-nodes 108 | "Return a sequence of indexes of a post-ordered walk of the graph." 109 | [g] 110 | (fnext (reduce #(post-ordered-visit g %2 %1) 111 | [#{} []] 112 | (:nodes g)))) 113 | 114 | (defn scc 115 | "Returns, as a sequence of sets, the strongly connected components 116 | of g." 117 | [g] 118 | (let [po (reverse (post-ordered-nodes g)) 119 | rev (reverse-graph g) 120 | step (fn [stack visited acc] 121 | (if (empty? stack) 122 | acc 123 | (let [[nv comp] (post-ordered-visit rev 124 | (first stack) 125 | [visited #{}]) 126 | ns (remove nv stack)] 127 | (recur ns nv (conj acc comp)))))] 128 | (step po #{} []))) 129 | 130 | (defn component-graph 131 | "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. 132 | Each node in the new graph will be a set of nodes from the old. 133 | These sets are the strongly connected components. Each edge will 134 | be the union of the corresponding edges of the prior graph." 135 | ([g] 136 | (component-graph g (scc g))) 137 | ([g sccs] 138 | (let [find-node-set (fn [n] 139 | (some #(if (% n) % nil) sccs)) 140 | find-neighbors (fn [ns] 141 | (let [nbs1 (map (partial get-neighbors g) ns) 142 | nbs2 (map set nbs1) 143 | nbs3 (apply clojure.set/union nbs2)] 144 | (set (map find-node-set nbs3)))) 145 | nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] 146 | (->DirectedGraph (set sccs) nm)))) 147 | 148 | (defn recursive-component? 149 | "Is the component (recieved from scc) self recursive?" 150 | [g ns] 151 | (or (> (count ns) 1) 152 | (let [n (first ns)] 153 | (some #(= % n) (get-neighbors g n))))) 154 | 155 | (defn self-recursive-sets 156 | "Returns, as a sequence of sets, the components of a graph that are 157 | self-recursive." 158 | [g] 159 | (filter (partial recursive-component? g) (scc g))) 160 | 161 | ;; ============================= 162 | ;; Dependency Lists 163 | 164 | (defn fixed-point 165 | "Repeatedly apply fun to data until (equal old-data new-data) 166 | returns true. If max iterations occur, it will throw an 167 | exception. Set max to nil for unlimited iterations." 168 | [data fun max equal] 169 | (let [step (fn step [data idx] 170 | (when (and idx (= 0 idx)) 171 | (throw (js/Error. "Fixed point overflow"))) 172 | (let [new-data (fun data)] 173 | (if (equal data new-data) 174 | new-data 175 | (recur new-data (and idx (dec idx))))))] 176 | (step data max))) 177 | 178 | (defn- fold-into-sets 179 | [priorities] 180 | (let [max (inc (apply max 0 (vals priorities))) 181 | step (fn [acc [n dep]] 182 | (assoc acc dep (conj (acc dep) n)))] 183 | (reduce step 184 | (vec (replicate max #{})) 185 | priorities))) 186 | 187 | (defn dependency-list 188 | "Similar to a topological sort, this returns a vector of sets. The 189 | set of nodes at index 0 are independent. The set at index 1 depend 190 | on index 0; those at 2 depend on 0 and 1, and so on. Those withing 191 | a set have no mutual dependencies. Assume the input graph (which 192 | much be acyclic) has an edge a->b when a depends on b." 193 | [g] 194 | (let [step (fn [d] 195 | (let [update (fn [n] 196 | (inc (apply max -1 (map d (get-neighbors g n)))))] 197 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 198 | counts (fixed-point (zipmap (:nodes g) (repeat 0)) 199 | step 200 | (inc (count (:nodes g))) 201 | =)] 202 | (fold-into-sets counts))) 203 | 204 | (defn stratification-list 205 | "Similar to dependency-list (see doc), except two graphs are 206 | provided. The first is as dependency-list. The second (which may 207 | have cycles) provides a partial-dependency relation. If node a 208 | depends on node b (meaning an edge a->b exists) in the second 209 | graph, node a must be equal or later in the sequence." 210 | [g1 g2] 211 | (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) 212 | (let [step (fn [d] 213 | (let [update (fn [n] 214 | (max (inc (apply max -1 215 | (map d (get-neighbors g1 n)))) 216 | (apply max -1 (map d (get-neighbors g2 n)))))] 217 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 218 | counts (fixed-point (zipmap (:nodes g1) (repeat 0)) 219 | step 220 | (inc (count (:nodes g1))) 221 | =)] 222 | (fold-into-sets counts))) 223 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/literals.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; literals.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Literals 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 25 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Converted to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.literals 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | [fogus.datalog.bacwn.impl.database :as db] 22 | clojure.set)) 23 | 24 | ;; ============================= 25 | ;; Type Definitions 26 | 27 | (defrecord AtomicLiteral 28 | [predicate ; The predicate name 29 | term-bindings ; A map of column names to bindings 30 | literal-type]) ; ::literal or ::negated 31 | 32 | (derive ::negated ::literal) 33 | 34 | (defrecord ConditionalLiteral 35 | [fun ; The fun to call 36 | symbol ; The fun symbol (for display) 37 | terms ; The formal arguments 38 | literal-type]) ; ::conditional 39 | 40 | ;; ============================= 41 | ;; Basics 42 | 43 | (defmulti literal-predicate 44 | "Return the predicate/relation this conditional operates over" 45 | :literal-type) 46 | 47 | (defmulti literal-columns 48 | "Return the column names this applies to" 49 | :literal-type) 50 | 51 | (defmulti literal-vars 52 | "Returns the logic vars used by this literal" 53 | :literal-type) 54 | 55 | (defmulti positive-vars 56 | "Returns the logic vars used in a positive position" 57 | :literal-type) 58 | 59 | (defmulti negative-vars 60 | "Returns the logic vars used in a negative position" 61 | :literal-type) 62 | 63 | (defmethod literal-predicate ::literal 64 | [l] 65 | (:predicate l)) 66 | 67 | (defmethod literal-predicate ::conditional 68 | [l] 69 | nil) 70 | 71 | (defmethod literal-columns ::literal 72 | [l] 73 | (-> l :term-bindings keys set)) 74 | 75 | (defmethod literal-columns ::conditional 76 | [l] 77 | nil) 78 | 79 | (defmethod literal-vars ::literal 80 | [l] 81 | (set (filter util/is-var? (-> l :term-bindings vals)))) 82 | 83 | (defmethod literal-vars ::conditional 84 | [l] 85 | (set (filter util/is-var? (:terms l)))) 86 | 87 | (defmethod positive-vars ::literal 88 | [l] 89 | (literal-vars l)) 90 | 91 | (defmethod positive-vars ::negated 92 | [l] 93 | nil) 94 | 95 | (defmethod positive-vars ::conditional 96 | [l] 97 | nil) 98 | 99 | (defmethod negative-vars ::literal 100 | [l] 101 | nil) 102 | 103 | (defmethod negative-vars ::negated 104 | [l] 105 | (literal-vars l)) 106 | 107 | (defmethod negative-vars ::conditional 108 | [l] 109 | (literal-vars l)) 110 | 111 | (defn negated? 112 | "Is this literal a negated literal?" 113 | [l] 114 | (= (:literal-type l) ::negated)) 115 | 116 | (defn positive? 117 | "Is this a positive literal?" 118 | [l] 119 | (= (:literal-type l) ::literal)) 120 | 121 | ;; ============================= 122 | ;; Building Literals 123 | 124 | (def negation-symbol 'not!) 125 | (def conditional-symbol 'if) 126 | 127 | (defmulti build-literal 128 | "(Returns an unevaluated expression (to be used in macros) of a 129 | literal." 130 | first) 131 | 132 | (defn build-atom 133 | "Returns an unevaluated expression (to be used in a macro) of an 134 | atom." 135 | [f type] 136 | (let [p (first f) 137 | ts (map #(if (util/is-var? %) `(quote ~%) %) (next f)) 138 | b (if (seq ts) (apply assoc {} ts) nil)] 139 | `(->AtomicLiteral ~p ~b ~type))) 140 | 141 | (defmethod build-literal :default 142 | [f] 143 | (build-atom f ::literal)) 144 | 145 | (defmethod build-literal negation-symbol 146 | [f] 147 | (build-atom (rest f) ::negated)) 148 | 149 | (defmethod build-literal conditional-symbol 150 | [f] 151 | (let [symbol (fnext f) 152 | terms (nnext f) 153 | fun `(fn [binds#] (apply ~symbol binds#))] 154 | `(->ConditionalLiteral 155 | ~fun 156 | '~symbol 157 | '~terms 158 | ::conditional))) 159 | 160 | ;; ============================= 161 | ;; Display 162 | 163 | (defmulti display-literal 164 | "Converts a struct representing a literal to a normal list" 165 | :literal-type) 166 | 167 | (defn- display 168 | [l] 169 | (conj (-> l :term-bindings list* flatten) (literal-predicate l))) 170 | 171 | (defmethod display-literal ::literal 172 | [l] 173 | (display l)) 174 | 175 | (defmethod display-literal ::negated 176 | [l] 177 | (conj (display l) negation-symbol)) 178 | 179 | (defmethod display-literal ::conditional 180 | [l] 181 | (list* conditional-symbol (:symbol l) (:terms l))) 182 | 183 | ;; ============================= 184 | ;; Sip computation 185 | 186 | (defmulti get-vs-from-cs 187 | "From a set of columns, return the vars" 188 | :literal-type) 189 | 190 | (defmethod get-vs-from-cs ::literal 191 | [l bound] 192 | (set (filter util/is-var? 193 | (vals (select-keys (:term-bindings l) 194 | bound))))) 195 | 196 | (defmethod get-vs-from-cs ::conditional 197 | [l bound] 198 | nil) 199 | 200 | (defmulti get-cs-from-vs 201 | "From a set of vars, get the columns" 202 | :literal-type) 203 | 204 | (defmethod get-cs-from-vs ::literal 205 | [l bound] 206 | (reduce conj 207 | #{} 208 | (remove nil? 209 | (map (fn [[k v]] (if (bound v) k nil)) 210 | (:term-bindings l))))) 211 | 212 | (defmethod get-cs-from-vs ::conditional 213 | [l bound] 214 | nil) 215 | 216 | (defmulti get-self-bound-cs 217 | "Get the columns that are bound withing the literal." 218 | :literal-type) 219 | 220 | (defmethod get-self-bound-cs ::literal 221 | [l] 222 | (reduce conj 223 | #{} 224 | (remove nil? 225 | (map (fn [[k v]] (if (not (util/is-var? v)) k nil)) 226 | (:term-bindings l))))) 227 | 228 | (defmethod get-self-bound-cs ::conditional 229 | [l] 230 | nil) 231 | 232 | (defmulti literal-appropriate? 233 | "When passed a set of bound vars, determines if this literal can be 234 | used during this point of a SIP computation." 235 | (fn [b l] (:literal-type l))) 236 | 237 | (defmethod literal-appropriate? ::literal 238 | [bound l] 239 | (not (empty? (clojure.set/intersection (literal-vars l) bound)))) 240 | 241 | (defmethod literal-appropriate? ::negated 242 | [bound l] 243 | (clojure.set/subset? (literal-vars l) bound)) 244 | 245 | (defmethod literal-appropriate? ::conditional 246 | [bound l] 247 | (clojure.set/subset? (literal-vars l) bound)) 248 | 249 | (defmulti adorned-literal 250 | "When passed a set of bound columns, returns the adorned literal" 251 | (fn [l b] (:literal-type l))) 252 | 253 | (defmethod adorned-literal ::literal 254 | [l bound] 255 | (let [pred (literal-predicate l) 256 | bnds (clojure.set/intersection (literal-columns l) bound)] 257 | (if (empty? bound) 258 | l 259 | (assoc l :predicate {:pred pred :bound bnds})))) 260 | 261 | (defmethod adorned-literal ::conditional 262 | [l bound] 263 | l) 264 | 265 | (defn get-adorned-bindings 266 | "Get the bindings from this adorned literal." 267 | [pred] 268 | (try 269 | (:bound pred) 270 | (catch js/Error e nil))) 271 | 272 | (defn get-base-predicate 273 | "Get the base predicate from this predicate." 274 | [pred] 275 | (if (map? pred) 276 | (:pred pred) 277 | pred)) 278 | 279 | ;; ============================= 280 | ;; Magic Stuff 281 | 282 | (defn magic-literal 283 | "Create a magic version of this adorned predicate." 284 | [l] 285 | (assert (-> l :literal-type (isa? ::literal))) 286 | (let [pred (literal-predicate l) 287 | pred-map (if (map? pred) pred {:pred pred}) 288 | bound (get-adorned-bindings pred) 289 | ntb (select-keys (:term-bindings l) bound)] 290 | (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) 291 | 292 | (defn literal-magic? 293 | "Is this literal magic?" 294 | [lit] 295 | (let [pred (literal-predicate lit)] 296 | (when (map? pred) 297 | (:magic pred)))) 298 | 299 | (defn build-seed-bindings 300 | "Given a seed literal, already adorned and in magic form, convert 301 | its bound constants to new variables." 302 | [s] 303 | (assert (-> s :literal-type (isa? ::literal))) 304 | (let [ntbs (util/map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] 305 | (assoc s :term-bindings ntbs))) 306 | 307 | ;; ============================= 308 | ;; Semi-naive support 309 | 310 | (defn negated-literal 311 | "Given a literal l, return a negated version" 312 | [l] 313 | (assert (-> l :literal-type (= ::literal))) 314 | (assoc l :literal-type ::negated)) 315 | 316 | (defn delta-literal 317 | "Given a literal l, return a delta version" 318 | [l] 319 | (let [pred* (:predicate l) 320 | pred (if (map? pred*) pred* {:pred pred*})] 321 | (assoc l :predicate (assoc pred :delta true)))) 322 | 323 | ;; ============================= 324 | ;; Database operations 325 | 326 | (defn- build-partial-tuple 327 | [lit binds] 328 | (let [tbs (:term-bindings lit) 329 | each (fn [[key val :as pair]] 330 | (if (util/is-var? val) 331 | (if-let [n (binds val)] 332 | [key n] 333 | nil) 334 | pair))] 335 | (into {} (remove nil? (map each tbs))))) 336 | 337 | (defn- project-onto-literal 338 | "Given a literal, and a materialized tuple, return a set of variable 339 | bindings." 340 | [lit tuple] 341 | (let [step (fn [binds [key val]] 342 | (if (and (util/is-var? val) 343 | (contains? tuple key)) 344 | (assoc binds val (tuple key)) 345 | binds))] 346 | (reduce step {} (:term-bindings lit)))) 347 | 348 | (defn- join-literal* 349 | [db lit bs fun] 350 | (let [each (fn [binds] 351 | (let [pt (build-partial-tuple lit binds)] 352 | (fun binds pt)))] 353 | (when (contains? db (literal-predicate lit)) 354 | (apply concat (map each bs))))) 355 | 356 | (defmulti join-literal 357 | "Given a database (db), a literal (lit) and a seq of bindings (bs), 358 | return a new seq of bindings by joining this literal." 359 | (fn [db lit bs] (:literal-type lit))) 360 | 361 | (defmethod join-literal ::literal 362 | [db lit bs] 363 | (join-literal* db lit bs (fn [binds pt] 364 | (map #(merge binds %) 365 | (map (partial project-onto-literal lit) 366 | (db/select db (literal-predicate lit) pt)))))) 367 | 368 | (defmethod join-literal ::negated 369 | [db lit bs] 370 | (join-literal* db lit bs (fn [binds pt] 371 | (if (db/any-match? db (literal-predicate lit) pt) 372 | nil 373 | [binds])))) 374 | 375 | (defmethod join-literal ::conditional 376 | [db lit bs] 377 | (let [each (fn [binds] 378 | (let [resolve (fn [term] 379 | (if (util/is-var? term) 380 | (binds term) 381 | term)) 382 | args (map resolve (:terms lit))] 383 | (if ((:fun lit) args) 384 | binds 385 | nil)))] 386 | (remove nil? (map each bs)))) 387 | 388 | (defn project-literal 389 | "Project a stream of bindings onto a literal/relation. Returns a new 390 | db." 391 | ([db lit bs] (project-literal db lit bs util/is-var?)) 392 | ([db lit bs var?] 393 | (assert (= (:literal-type lit) ::literal)) 394 | (let [rel-name (literal-predicate lit) 395 | columns (-> lit :term-bindings keys) 396 | idxs (vec (get-adorned-bindings (literal-predicate lit))) 397 | db1 (db/ensure-relation db rel-name columns idxs) 398 | rel (db/get-relation db1 rel-name) 399 | step (fn [rel bindings] 400 | (let [step (fn [t [k v]] 401 | (if (var? v) 402 | (assoc t k (bindings v)) 403 | (assoc t k v))) 404 | tuple (reduce step {} (:term-bindings lit))] 405 | (db/add-tuple rel tuple)))] 406 | (db/replace-relation db rel-name (reduce step rel bs))))) 407 | 408 | (cljs.reader/register-tag-parser! "fogus.datalog.bacwn.impl.literals.AtomicLiteral" 409 | map->AtomicLiteral) 410 | 411 | (extend-protocol IPrintWithWriter 412 | fogus.datalog.bacwn.impl.literals/AtomicLiteral 413 | (-pr-writer [query writer opts] 414 | (write-all writer (pr-str (list* '?- (display-literal query)))))) 415 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/magic.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; magic.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Magic Sets 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 18 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns fogus.datalog.bacwn.impl.magic 18 | (:require [fogus.datalog.bacwn.impl.util :as util] 19 | [fogus.datalog.bacwn.impl.literals :as literal] 20 | [fogus.datalog.bacwn.impl.rules :as rule] 21 | clojure.set)) 22 | 23 | ;; ============================= 24 | ;; Adornment 25 | 26 | (defn adorn-query 27 | "Adorn a query" 28 | [q] 29 | (literal/adorned-literal q (literal/get-self-bound-cs q))) 30 | 31 | (defn adorn-rules-set 32 | "Adorns the given rules-set for the given query. (rs) is a 33 | rules-set, (q) is an adorned query." 34 | [rs q] 35 | (let [i-preds (rule/all-predicates rs) 36 | p-map (rule/predicate-map rs)] 37 | (loop [nrs rule/empty-rules-set ; The rules set being built 38 | needed #{(literal/literal-predicate q)}] 39 | (if (empty? needed) 40 | nrs 41 | (let [pred (first needed) 42 | remaining (disj needed pred) 43 | base-pred (literal/get-base-predicate pred) 44 | bindings (literal/get-adorned-bindings pred) 45 | new-rules (p-map base-pred) 46 | new-adorned-rules (map (partial rule/compute-sip bindings i-preds) 47 | new-rules) 48 | new-nrs (reduce conj nrs new-adorned-rules) 49 | current-preds (rule/all-predicates new-nrs) 50 | not-needed? (fn [pred] 51 | (or (current-preds pred) 52 | (-> pred literal/get-base-predicate i-preds not))) 53 | add-pred (fn [np pred] 54 | (if (not-needed? pred) np (conj np pred))) 55 | add-preds (fn [np rule] 56 | (reduce add-pred np (map literal/literal-predicate (:body rule)))) 57 | new-needed (reduce add-preds remaining new-adorned-rules)] 58 | (recur new-nrs new-needed)))))) 59 | 60 | 61 | ;; ============================= 62 | ;; Magic ! 63 | 64 | (defn seed-relation 65 | "Given a magic form of a query, give back the literal form of its seed 66 | relation" 67 | [q] 68 | (let [pred (-> q literal/literal-predicate literal/get-base-predicate) 69 | bnds (-> q literal/literal-predicate literal/get-adorned-bindings)] 70 | (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) 71 | 72 | (defn seed-rule 73 | "Given an adorned query, give back its seed rule" 74 | [q] 75 | (let [mq (literal/build-seed-bindings (literal/magic-literal q)) 76 | sr (seed-relation mq)] 77 | (rule/build-rule mq [sr]))) 78 | 79 | (defn build-partial-tuple 80 | "Given a query and a set of bindings, build a partial tuple needed 81 | to extract the relation from the database." 82 | [q bindings] 83 | (into {} (remove nil? (map (fn [[k v :as pair]] 84 | (if (util/is-var? v) 85 | nil 86 | (if (util/is-query-var? v) 87 | [k (bindings v)] 88 | pair))) 89 | (:term-bindings q))))) 90 | 91 | (defn seed-predicate-for-insertion 92 | "Given a query, return the predicate to use for database insertion." 93 | [q] 94 | (let [seed (-> q seed-rule :body first) 95 | columns (-> seed :term-bindings keys) 96 | new-term-bindings (-> q :term-bindings (select-keys columns))] 97 | (assoc seed :term-bindings new-term-bindings))) 98 | 99 | (defn magic-transform 100 | "Return a magic transformation of an adorned rules-set (rs). The 101 | (i-preds) are the predicates of the intension database. These 102 | default to the predicates within the rules-set." 103 | ([rs] 104 | (magic-transform rs (rule/all-predicates rs))) 105 | ([rs i-preds] 106 | (let [not-duplicate? (fn [l mh bd] 107 | (or (not (empty? bd)) 108 | (not (= (literal/magic-literal l) 109 | mh)))) 110 | xr (fn [rs rule] 111 | (let [head (:head rule) 112 | body (:body rule) 113 | mh (literal/magic-literal head) 114 | answer-rule (rule/build-rule head 115 | (concat [mh] body)) 116 | step (fn [[rs bd] l] 117 | (if (and (i-preds (literal/literal-predicate l)) 118 | (not-duplicate? l mh bd)) 119 | (let [nr (rule/build-rule (literal/magic-literal l) 120 | (concat [mh] bd))] 121 | [(conj rs nr) (conj bd l)]) 122 | [rs (conj bd l)])) 123 | [nrs _] (reduce step [rs []] body)] 124 | (conj nrs answer-rule)))] 125 | (reduce xr rule/empty-rules-set rs)))) 126 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/rules.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; rules.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Rules Engine 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 2 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns fogus.datalog.bacwn.impl.rules 18 | (:require [fogus.datalog.bacwn.impl.util :as util] 19 | [fogus.datalog.bacwn.impl.literals :as literal] 20 | [fogus.datalog.bacwn.impl.database :as db] 21 | clojure.set 22 | cljs.reader)) 23 | 24 | (defrecord DatalogRule [head body]) 25 | 26 | (defn display-rule 27 | "Return the rule in a readable format." 28 | [rule] 29 | (list* '<- 30 | (-> rule :head literal/display-literal) 31 | (map literal/display-literal (:body rule)))) 32 | 33 | (defn display-query 34 | "Return a query in a readable format." 35 | [query] 36 | (list* '?- (literal/display-literal query))) 37 | 38 | ;; ============================= 39 | ;; Check rule safety 40 | 41 | (defn is-safe? 42 | "Is the rule safe according to the datalog protocol?" 43 | [rule] 44 | (let [hv (literal/literal-vars (:head rule)) 45 | bpv (apply clojure.set/union (map literal/positive-vars (:body rule))) 46 | bnv (apply clojure.set/union (map literal/negative-vars (:body rule))) 47 | ehv (clojure.set/difference hv bpv) 48 | env (clojure.set/difference bnv bpv)] 49 | (when-not (empty? ehv) 50 | (throw (js/Error. (str "Head vars" ehv "not bound in body of rule" rule)))) 51 | (when-not (empty? env) 52 | (throw (js/Error. (str "Body vars" env "not bound in negative positions of rule" rule)))) 53 | rule)) 54 | 55 | ;; ============================= 56 | ;; Rule creation and printing 57 | 58 | (defn build-rule 59 | [hd bd] 60 | (with-meta (->DatalogRule hd bd) {:type ::datalog-rule})) 61 | 62 | (cljs.reader/register-tag-parser! "fogus.datalog.bacwn.impl.rules.DatalogRule" 63 | map->DatalogRule) 64 | 65 | (extend-protocol IPrintWithWriter 66 | fogus.datalog.bacwn.impl.rules/DatalogRule 67 | (-pr-writer [rule writer opts] 68 | (write-all writer (pr-str (display-rule rule))))) 69 | 70 | (defn return-rule-data 71 | "Returns an untypted rule that will be fully printed" 72 | [rule] 73 | (with-meta rule {})) 74 | 75 | ;(defmethod print-method ::datalog-query 76 | ; [query ^java.io.Writer writer] 77 | ; (print-method (display-query query) writer)) 78 | 79 | ;; ============================= 80 | ;; SIP 81 | 82 | (defn compute-sip 83 | "Given a set of bound column names, return an adorned sip for this 84 | rule. A set of intensional predicates should be provided to 85 | determine what should be adorned." 86 | [bindings i-preds rule] 87 | (let [next-lit (fn [bv body] 88 | (or (first (drop-while 89 | #(not (literal/literal-appropriate? bv %)) 90 | body)) 91 | (first (drop-while (complement literal/positive?) body)))) 92 | adorn (fn [lit bvs] 93 | (if (i-preds (literal/literal-predicate lit)) 94 | (let [bnds (clojure.set/union (literal/get-cs-from-vs lit bvs) 95 | (literal/get-self-bound-cs lit))] 96 | (literal/adorned-literal lit bnds)) 97 | lit)) 98 | new-h (literal/adorned-literal (:head rule) bindings)] 99 | (loop [bound-vars (literal/get-vs-from-cs (:head rule) bindings) 100 | body (:body rule) 101 | sip []] 102 | (if-let [next (next-lit bound-vars body)] 103 | (recur (clojure.set/union bound-vars (literal/literal-vars next)) 104 | (remove #(= % next) body) 105 | (conj sip (adorn next bound-vars))) 106 | (build-rule new-h (concat sip body)))))) 107 | 108 | ;; ============================= 109 | ;; Rule sets 110 | 111 | (defn make-rules-set 112 | "Given an existing set of rules, make it a 'rules-set' for 113 | printing." 114 | [rs] 115 | (with-meta rs {:type ::datalog-rules-set})) 116 | 117 | (def empty-rules-set (make-rules-set #{})) 118 | 119 | (defn rules-set 120 | "Given a collection of rules return a rules set" 121 | [& rules] 122 | (reduce conj empty-rules-set rules)) 123 | 124 | ;(defmethod print-method ::datalog-rules-set 125 | ; [rules ^java.io.Writer writer] 126 | ; (binding [*out* writer] 127 | ; (do 128 | ; (print "(rules-set") 129 | ; (doseq [rule rules] 130 | ; (println) 131 | ; (print " ") 132 | ; (print rule)) 133 | ; (println ")")))) 134 | 135 | (defn predicate-map 136 | "Given a rules-set, return a map of rules keyed by their predicates. 137 | Each value will be a set of rules." 138 | [rs] 139 | (let [add-rule (fn [m r] 140 | (let [pred (-> r :head literal/literal-predicate) 141 | os (get m pred #{})] 142 | (assoc m pred (conj os r))))] 143 | (reduce add-rule {} rs))) 144 | 145 | (defn all-predicates 146 | "Given a rules-set, return all defined predicates" 147 | [rs] 148 | (set (map literal/literal-predicate (map :head rs)))) 149 | 150 | (defn non-base-rules 151 | "Return a collection of rules that depend, somehow, on other rules" 152 | [rs] 153 | (let [pred (all-predicates rs) 154 | non-base (fn [r] 155 | (if (some #(pred %) 156 | (map literal/literal-predicate (:body r))) 157 | r 158 | nil))] 159 | (remove nil? (map non-base rs)))) 160 | 161 | ;; ============================= 162 | ;; Database operations 163 | 164 | (def empty-bindings [{}]) 165 | 166 | (defn apply-rule 167 | "Apply the rule against db-1, adding the results to the appropriate 168 | relation in db-2. The relation will be created if needed." 169 | ([db rule] (apply-rule db db rule)) 170 | ([db-1 db-2 rule] 171 | (let [head (:head rule) 172 | body (:body rule) 173 | step (fn [bs lit] 174 | (literal/join-literal db-1 lit bs)) 175 | bs (reduce step empty-bindings body)] 176 | (literal/project-literal db-2 head bs)))) 177 | 178 | (defn apply-rules-set 179 | [db rs] 180 | (reduce (fn [rdb rule] 181 | (apply-rule db rdb rule)) db rs)) -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/softstrat.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; softstrat.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Soft Stratification 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 28 Feburary 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | ;; Ported to ClojureScript by Fogus 2012. 17 | ;; 18 | 19 | (ns fogus.datalog.bacwn.impl.softstrat 20 | (:require [fogus.datalog.bacwn.impl.util :as util] 21 | [fogus.datalog.bacwn.impl.database :as db] 22 | [fogus.datalog.bacwn.impl.literals :as literal] 23 | [fogus.datalog.bacwn.impl.rules :as rule] 24 | [fogus.datalog.bacwn.impl.magic :as magic] 25 | [fogus.datalog.bacwn.impl.graph :as graph] 26 | clojure.set)) 27 | 28 | ;; ============================= 29 | ;; Dependency graph 30 | 31 | (defn- build-rules-graph 32 | "Given a rules-set (rs), build a graph where each predicate symbol in rs, 33 | there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges 34 | from the (literal-predicate h) -> (literal-predicate b-*), one for each 35 | b-*." 36 | [rs] 37 | (let [preds (rule/all-predicates rs) 38 | pred-map (rule/predicate-map rs) 39 | step (fn [nbs pred] 40 | (let [rules (pred-map pred) 41 | preds (reduce (fn [pds lits] 42 | (reduce (fn [pds lit] 43 | (if-let [pred (literal/literal-predicate lit)] 44 | (conj pds pred) 45 | pds)) 46 | pds 47 | lits)) 48 | #{} 49 | (map :body rules))] 50 | (assoc nbs pred preds))) 51 | neighbors (reduce step {} preds)] 52 | (graph/->DirectedGraph preds neighbors))) 53 | 54 | (defn- build-def 55 | "Given a rules-set, build its def function" 56 | [rs] 57 | (let [pred-map (rule/predicate-map rs) 58 | graph (-> rs 59 | build-rules-graph 60 | graph/transitive-closure 61 | graph/add-loops)] 62 | (fn [pred] 63 | (apply clojure.set/union (map set (map pred-map (graph/get-neighbors graph pred))))))) 64 | 65 | ;; ============================= 66 | ;; Soft Stratificattion REQ Graph 67 | 68 | (defn- req 69 | "Returns a rules-set that is a superset of req(lit) for the lit at 70 | index lit-index" 71 | [rs soft-def rule lit-index] 72 | (let [head (:head rule) 73 | body (:body rule) 74 | lit (nth body lit-index) 75 | pre (subvec (vec body) 0 lit-index)] 76 | (conj (-> lit 77 | literal/literal-predicate 78 | soft-def 79 | (magic/magic-transform (rule/all-predicates rs))) 80 | (rule/build-rule (literal/magic-literal lit) pre)))) 81 | 82 | (defn- rule-dep 83 | "Given a rule, return the set of rules it depends on." 84 | [rs mrs soft-def rule] 85 | (let [step (fn [nrs [idx lit]] 86 | (if (literal/negated? lit) 87 | (clojure.set/union nrs (req rs soft-def rule idx)) 88 | nrs))] 89 | (clojure.set/intersection mrs 90 | (reduce step rule/empty-rules-set 91 | (->> rule :body (map-indexed vector)))))) 92 | 93 | (defn- soft-strat-graph 94 | "The dependency graph for soft stratification." 95 | [rs mrs] 96 | (let [soft-def (build-def rs) 97 | step (fn [nbrs rule] 98 | (assoc nbrs rule (rule-dep rs mrs soft-def rule))) 99 | nbrs (reduce step {} mrs)] 100 | (graph/->DirectedGraph mrs nbrs))) 101 | 102 | (defn- build-soft-strat 103 | "Given a rules-set (unadorned) and an adorned query, return the soft 104 | stratified list. The rules will be magic transformed, and the 105 | magic seed will be appended." 106 | [rs q] 107 | (let [ars (magic/adorn-rules-set rs q) 108 | mrs (conj (magic/magic-transform ars) 109 | (magic/seed-rule q)) 110 | gr (soft-strat-graph ars mrs)] 111 | (map rule/make-rules-set (graph/dependency-list gr)))) 112 | 113 | ;; ============================= 114 | ;; Work plan 115 | 116 | (defrecord SoftStratWorkPlan [query stratification]) 117 | 118 | (defn build-soft-strat-work-plan 119 | "Return a work plan for the given rules-set and query" 120 | [rs q] 121 | (let [aq (magic/adorn-query q)] 122 | (->SoftStratWorkPlan aq (build-soft-strat rs aq)))) 123 | 124 | (defn get-all-relations 125 | "Return a set of all relation names defined in this workplan" 126 | [ws] 127 | (apply clojure.set/union (map rule/all-predicates (:stratification ws)))) 128 | 129 | ;; ============================= 130 | ;; Evaluate 131 | 132 | (defn- weak-consq-operator 133 | [db strat] 134 | (let [counts (db/database-counts db)] 135 | (loop [strat strat] 136 | (let [rs (first strat)] 137 | (if rs 138 | (let [new-db (rule/apply-rules-set db rs)] 139 | (if (= counts (db/database-counts new-db)) 140 | (recur (next strat)) 141 | new-db)) 142 | db))))) 143 | 144 | (defn evaluate-soft-work-set 145 | ([ws db] (evaluate-soft-work-set ws db {})) 146 | ([ws db bindings] 147 | (let [query (:query ws) 148 | strat (:stratification ws) 149 | seed (magic/seed-predicate-for-insertion query) 150 | seeded-db (literal/project-literal db seed [bindings] util/is-query-var?) 151 | fun (fn [data] 152 | (weak-consq-operator data strat)) 153 | equal (fn [db1 db2] 154 | (= (db/database-counts db1) (db/database-counts db2))) 155 | new-db (graph/fixed-point seeded-db fun nil equal) 156 | pt (magic/build-partial-tuple query bindings)] 157 | (db/select new-db (literal/literal-predicate query) pt)))) 158 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/syntax.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Michael Fogus. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; syntax.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Support for in-memory database 12 | ;; 13 | 14 | (ns fogus.datalog.bacwn.impl.syntax) 15 | 16 | (def ID_KEY :db.id) 17 | (def ^:private nums (atom 0)) 18 | 19 | (defn explode 20 | "Convert a map into a clj-Datalog tuple vector. Brittle, but 21 | works along the happy path." 22 | [entity] 23 | (let [relation-type (-> entity seq ffirst namespace keyword) 24 | id-key (keyword (name relation-type) "db.id") 25 | id (get entity id-key) 26 | id (if id id (swap! nums inc)) 27 | kvs (seq (dissoc entity id-key))] 28 | (vec 29 | (apply concat [relation-type :db.id id] 30 | (reduce (fn [acc [k v]] 31 | (cons [(keyword (name k)) v] acc)) 32 | [] 33 | kvs))))) 34 | 35 | (defn agg [tuples] 36 | (group-by (comp keyword namespace second) tuples)) 37 | 38 | (defn propagate [agg] 39 | (apply concat 40 | (for [[k v] agg] 41 | (map #(vec (cons k %)) v)))) 42 | 43 | (defn shuffle-tuples [tups] 44 | (let [ids (atom {})] 45 | (map (fn [[nspace id prop val]] 46 | [nspace 47 | ID_KEY (get (swap! ids 48 | (fn [m] 49 | (if-let [i (get m id)] 50 | m 51 | (let [i (swap! nums inc)] 52 | (assoc m id i))))) 53 | id) 54 | (keyword (name prop)) val]) 55 | tups))) 56 | -------------------------------------------------------------------------------- /src/clojurescript/fogus/datalog/bacwn/impl/util.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; util.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Utilities 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 3 Feburary 2009 15 | ;; Ported to ClojureScript by Fogus 2012. 16 | ;; 17 | 18 | 19 | (ns fogus.datalog.bacwn.impl.util) 20 | 21 | ;; From clojure.contrib.seqs 22 | (defn separate 23 | "Returns a vector: 24 | [ (filter f s), (filter (complement f) s) ]" 25 | [f s] 26 | [(filter f s) (filter (complement f) s)]) 27 | 28 | ;;; Bindings and logic vars. A binding in a hash of logic vars to 29 | ;;; bound values. Logic vars are any symbol prefixed with a \?. 30 | 31 | (defn is-var? 32 | "Is this a logic variable: e.g. a symbol prefixed with a ?" 33 | [sym] 34 | (when (symbol? sym) 35 | (let [name (name sym)] 36 | (and (= \? (first name)) 37 | (not= \? (fnext name)))))) 38 | 39 | (defn is-query-var? 40 | "Is this a query variable: e.g. a symbol prefixed with ??" 41 | [sym] 42 | (when (symbol? sym) 43 | (let [name (name sym)] 44 | (and (= \? (first name)) 45 | (= \? (fnext name)))))) 46 | 47 | (defn map-values 48 | "Like map, but works over the values of a hash map" 49 | [f hash] 50 | (let [key-vals (map (fn [[key val]] [key (f val)]) hash)] 51 | (if (seq key-vals) 52 | (apply conj (empty hash) key-vals) 53 | hash))) 54 | 55 | (defn keys-to-vals 56 | "Given a map and a collection of keys, return the collection of vals" 57 | [m ks] 58 | (vals (select-keys m ks))) 59 | 60 | (defn reverse-map 61 | "Reverse the keys/values of a map" 62 | [m] 63 | (into {} (map (fn [[k v]] [v k]) m))) 64 | 65 | 66 | ;;; Preduce -- A parallel reduce over hashes 67 | 68 | (defn preduce 69 | "Similar to merge-with, but the contents of each key are merged in 70 | parallel using f. 71 | 72 | f - a function of 2 arguments. 73 | data - a collection of hashes." 74 | [f data] 75 | (let [data-1 (map (fn [h] (map-values #(list %) h)) data) 76 | merged (doall (apply merge-with concat data-1)) 77 | ; Groups w/ multiple elements are identified for parallel processing 78 | [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged) 79 | fold-group (fn [[key vals]] {key (reduce f vals)}) 80 | fix-single (fn [[key [val]]] [key val])] 81 | (apply merge (concat (map fold-group merged) (map fix-single simple))))) 82 | -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_database.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-database.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Database 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 12 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test_database 18 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)] 19 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 20 | (:require [cemerick.cljs.test :as t]) 21 | (:use [fogus.datalog.bacwn.impl.database :only [add-tuples add-tuple remove-tuple any-match? select datalog-database datalog-relation ensure-relation]])) 22 | 23 | (def test-db 24 | (make-database 25 | (relation :fred [:mary :sue]) 26 | (index :fred :mary) 27 | (relation :sally [:jen :becky :joan]) 28 | (index :sally :jen) 29 | (index :sally :becky))) 30 | 31 | (deftest test-make-database 32 | (is (= test-db 33 | (datalog-database 34 | {:sally (datalog-relation 35 | #{:jen :joan :becky} 36 | #{} 37 | {:becky {} 38 | :jen {}}) 39 | :fred (datalog-relation 40 | #{:sue :mary} 41 | #{} 42 | {:mary {}})})))) 43 | 44 | 45 | (deftest test-ensure-relation 46 | (is (contains? (ensure-relation test-db :bob [:sam :george] [:sam]) :bob)) 47 | (is (contains? (ensure-relation test-db :fred [:mary :sue] [:mary]) :fred)) 48 | (is (thrown? js/Error (ensure-relation test-db :fred [:bob :joe] [])))) 49 | 50 | (deftest test-add-tuple 51 | (let [new-db (add-tuple test-db :fred {:mary 1 :sue 2})] 52 | (is (= (select new-db :fred {:mary 1}) [{:mary 1 :sue 2}]))) 53 | (is (thrown? js/Error (add-tuple test-db :fred {:mary 1})))) 54 | 55 | (def test-db-1 56 | (add-tuples test-db 57 | [:fred :mary 1 :sue 2] 58 | [:fred :mary 2 :sue 3] 59 | [:sally :jen 1 :becky 2 :joan 0] 60 | [:sally :jen 1 :becky 4 :joan 3] 61 | [:sally :jen 1 :becky 3 :joan 0] 62 | [:sally :jen 1 :becky 2 :joan 3] 63 | [:fred :mary 1 :sue 1] 64 | [:fred :mary 3 :sue 1])) 65 | 66 | (deftest test-add-tuples 67 | (is (= test-db-1 68 | (datalog-database 69 | {:sally (datalog-relation 70 | #{:jen :joan :becky} 71 | #{{:jen 1, :joan 0, :becky 3} 72 | {:jen 1, :joan 0, :becky 2} 73 | {:jen 1, :joan 3, :becky 2} 74 | {:jen 1, :joan 3, :becky 4}} 75 | {:becky {3 76 | #{{:jen 1, :joan 0, :becky 3}} 77 | 4 78 | #{{:jen 1, :joan 3, :becky 4}} 79 | 2 80 | #{{:jen 1, :joan 0, :becky 2} 81 | {:jen 1, :joan 3, :becky 2}}} 82 | :jen {1 83 | #{{:jen 1, :joan 0, :becky 3} 84 | {:jen 1, :joan 0, :becky 2} 85 | {:jen 1, :joan 3, :becky 2} 86 | {:jen 1, :joan 3, :becky 4}}}}) 87 | :fred (datalog-relation 88 | #{:sue :mary} 89 | #{{:sue 2, :mary 1} 90 | {:sue 1, :mary 1} 91 | {:sue 3, :mary 2} 92 | {:sue 1, :mary 3}} 93 | {:mary {3 94 | #{{:sue 1, :mary 3}} 95 | 2 96 | #{{:sue 3, :mary 2}} 97 | 1 98 | #{{:sue 2, :mary 1} 99 | {:sue 1, :mary 1}}}})})))) 100 | 101 | (deftest test-remove-tuples 102 | (let [db (reduce #(apply remove-tuple %1 (first %2) (next %2)) 103 | test-db-1 104 | [[:fred {:mary 1 :sue 1}] 105 | [:fred {:mary 3 :sue 1}] 106 | [:sally {:jen 1 :becky 2 :joan 0}] 107 | [:sally {:jen 1 :becky 4 :joan 3}]])] 108 | (is (= db 109 | (datalog-database 110 | {:sally (datalog-relation 111 | #{:jen :joan :becky} 112 | #{{:jen 1, :joan 0, :becky 3} 113 | {:jen 1, :joan 3, :becky 2}} 114 | {:becky 115 | {3 116 | #{{:jen 1, :joan 0, :becky 3}} 117 | 2 118 | #{{:jen 1, :joan 3, :becky 2}}} 119 | :jen 120 | {1 121 | #{{:jen 1, :joan 0, :becky 3} 122 | {:jen 1, :joan 3, :becky 2}}}}) 123 | :fred (datalog-relation 124 | #{:sue :mary} 125 | #{{:sue 2, :mary 1} 126 | {:sue 3, :mary 2}} 127 | {:mary 128 | {2 129 | #{{:sue 3, :mary 2}} 130 | 1 131 | #{{:sue 2, :mary 1}}}})}))))) 132 | 133 | 134 | 135 | (deftest test-select 136 | (is (= (set (select test-db-1 :sally {:jen 1 :becky 2})) 137 | #{{:jen 1 :joan 0 :becky 2} {:jen 1 :joan 3 :becky 2}})) 138 | (is (= (set (select test-db-1 :fred {:sue 1}))) 139 | #{{:mary 3 :sue 1} {:mary 1 :sue 1}}) 140 | (is (empty? (select test-db-1 :sally {:joan 5 :jen 1})))) 141 | 142 | (deftest test-any-match? 143 | (is (any-match? test-db-1 :fred {:mary 3})) 144 | (is (any-match? test-db-1 :sally {:jen 1 :becky 2 :joan 3})) 145 | (is (not (any-match? test-db-1 :sally {:jen 5}))) 146 | (is (not (any-match? test-db-1 :fred {:mary 1 :sue 5})))) 147 | 148 | 149 | (comment 150 | (run-tests) 151 | ) 152 | 153 | ;; End of file 154 | -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_literals.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-literals.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Literals tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 25 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test-literals 18 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)] 19 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 20 | (:use [fogus.datalog.bacwn.impl.literals :only [build-literal literal-predicate literal-columns literal-vars positive-vars negative-vars 21 | negated? get-vs-from-cs literal-appropriate? adorned-literal get-adorned-bindings get-cs-from-vs 22 | get-base-predicate magic-literal join-literal project-literal]] 23 | [fogus.datalog.bacwn.impl.database :only [add-tuples datalog-relation]])) 24 | 25 | (def pl (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :fred {:z 3, :y (quote ?y), :x (quote ?x)} :fogus.datalog.bacwn.impl.literals/literal)) 26 | (def nl (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :fred {:z 3, :y (quote ?y), :x (quote ?x)} :fogus.datalog.bacwn.impl.literals/negated)) 27 | (def cl (fogus.datalog.bacwn.impl.literals/->ConditionalLiteral (clojure.core/fn [binds__5075__auto__] (clojure.core/apply > binds__5075__auto__)) (quote >) (quote (?x 3)) :fogus.datalog.bacwn.impl.literals/conditional)) 28 | 29 | (def bl (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :fred nil :fogus.datalog.bacwn.impl.literals/literal)) 30 | 31 | (def bns {:x '?x :y '?y :z 3}) 32 | 33 | (deftest test-build-literal 34 | (is (= (:predicate pl) :fred)) 35 | (is (= (:term-bindings pl) bns)) 36 | (is (= (:predicate nl) :fred)) 37 | (is (= (:term-bindings nl) bns)) 38 | (is (= (:symbol cl) '>)) 39 | (is (= (:terms cl) '(?x 3))) 40 | (is ((:fun cl) [4 3])) 41 | (is (not ((:fun cl) [2 4]))) 42 | (is (= (:predicate bl) :fred))) 43 | 44 | (deftest test-literal-predicate 45 | (is (= (literal-predicate pl) :fred)) 46 | (is (= (literal-predicate nl) :fred)) 47 | (is (nil? (literal-predicate cl))) 48 | (is (= (literal-predicate bl) :fred))) 49 | 50 | (deftest test-literal-columns 51 | (is (= (literal-columns pl) #{:x :y :z})) 52 | (is (= (literal-columns nl) #{:x :y :z})) 53 | (is (nil? (literal-columns cl))) 54 | (is (empty? (literal-columns bl)))) 55 | 56 | (deftest test-literal-vars 57 | (is (= (literal-vars pl) #{'?x '?y})) 58 | (is (= (literal-vars nl) #{'?x '?y})) 59 | (is (= (literal-vars cl) #{'?x})) 60 | (is (empty? (literal-vars bl)))) 61 | 62 | (deftest test-positive-vars 63 | (is (= (positive-vars pl) (literal-vars pl))) 64 | (is (nil? (positive-vars nl))) 65 | (is (nil? (positive-vars cl))) 66 | (is (empty? (positive-vars bl)))) 67 | 68 | (deftest test-negative-vars 69 | (is (nil? (negative-vars pl))) 70 | (is (= (negative-vars nl) (literal-vars nl))) 71 | (is (= (negative-vars cl) (literal-vars cl))) 72 | (is (empty? (negative-vars bl)))) 73 | 74 | (deftest test-negated? 75 | (is (not (negated? pl))) 76 | (is (negated? nl)) 77 | (is (not (negated? cl)))) 78 | 79 | (deftest test-vs-from-cs 80 | (is (= (get-vs-from-cs pl #{:x}) #{'?x})) 81 | (is (empty? (get-vs-from-cs pl #{:z}))) 82 | (is (= (get-vs-from-cs pl #{:x :r}) #{'?x})) 83 | (is (empty? (get-vs-from-cs pl #{})))) 84 | 85 | (deftest test-cs-from-vs 86 | (is (= (get-cs-from-vs pl #{'?x}) #{:x})) 87 | (is (= (get-cs-from-vs pl #{'?x '?r}) #{:x})) 88 | (is (empty? (get-cs-from-vs pl #{})))) 89 | 90 | (deftest test-literal-appropriate? 91 | (is (not (literal-appropriate? #{} pl))) 92 | (is (literal-appropriate? #{'?x} pl)) 93 | (is (not (literal-appropriate? #{'?x} nl))) 94 | (is (literal-appropriate? #{'?x '?y} nl)) 95 | (is (not (literal-appropriate? #{'?z} cl))) 96 | (is (literal-appropriate? #{'?x} cl))) 97 | 98 | (deftest test-adorned-literal 99 | (is (= (literal-predicate (adorned-literal pl #{:x})) 100 | {:pred :fred :bound #{:x}})) 101 | (is (= (literal-predicate (adorned-literal nl #{:x :y :q})) 102 | {:pred :fred :bound #{:x :y}})) 103 | (is (= (:term-bindings (adorned-literal nl #{:x})) 104 | {:x '?x :y '?y :z 3})) 105 | (is (= (adorned-literal cl #{}) 106 | cl))) 107 | 108 | (deftest test-get-adorned-bindings 109 | (is (= (get-adorned-bindings (literal-predicate (adorned-literal pl #{:x}))) 110 | #{:x})) 111 | (is (= (get-adorned-bindings (literal-predicate pl)) 112 | nil))) 113 | 114 | (deftest test-get-base-predicate 115 | (is (= (get-base-predicate (literal-predicate (adorned-literal pl #{:x}))) 116 | :fred)) 117 | (is (= (get-base-predicate (literal-predicate pl)) 118 | :fred))) 119 | 120 | ;(deftest test-magic-literal 121 | ; (is (.equals (magic-literal pl) 122 | ; {:predicate {:pred :fred :magic true}, :term-bindings {}, :literal-type :fogus.datalog.bacwn.impl.literals/literal})) 123 | ; (is (.equals (magic-literal (adorned-literal pl #{:x})) 124 | ; {:predicate {:pred :fred :magic true :bound #{:x}}, 125 | ; :term-bindings {:x '?x}, 126 | ; :literal-type :fogus.datalog.bacwn.impl.literals/literal}))) 127 | 128 | 129 | (def db1 (make-database 130 | (relation :fred [:x :y]) 131 | (index :fred :x) 132 | (relation :sally [:x]))) 133 | 134 | (def db2 (add-tuples db1 135 | [:fred :x 1 :y :mary] 136 | [:fred :x 1 :y :becky] 137 | [:fred :x 3 :y :sally] 138 | [:fred :x 4 :y :joe] 139 | [:sally :x 1] 140 | [:sally :x 2])) 141 | 142 | (def lit1 (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :fred {:y (quote ?y), :x (quote ?x)} :fogus.datalog.bacwn.impl.literals/literal)) 143 | (def lit2 (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :fred {:x (quote ?x)} :fogus.datalog.bacwn.impl.literals/negated)) 144 | (def lit3 (fogus.datalog.bacwn.impl.literals/->ConditionalLiteral (clojure.core/fn [binds__5075__auto__] (clojure.core/apply > binds__5075__auto__)) (quote >) (quote (?x ?y)) :fogus.datalog.bacwn.impl.literals/conditional)) 145 | (def lit4 (adorned-literal (fogus.datalog.bacwn.impl.literals/->AtomicLiteral :joan {:y (quote ?y), :x (quote ?x)} :fogus.datalog.bacwn.impl.literals/literal) #{:x})) 146 | 147 | (deftest test-join-literal 148 | (is (= (set (join-literal db2 lit1 [{'?x 1} {'?x 2} {'?x 3}])) 149 | #{{'?x 1, '?y :mary} {'?x 1, '?y :becky} {'?x 3, '?y :sally}})) 150 | (is (= (join-literal db2 lit2 [{'?x 1} {'?x 2} {'?x 3}]) 151 | [{'?x 2}])) 152 | (is (= (join-literal db2 lit3 [{'?x 1 '?y 2} {'?x 3 '?y 1}]) 153 | [{'?x 3 '?y 1}]))) 154 | 155 | (deftest test-project-literal 156 | (is (= ((project-literal db2 lit4 [{'?x 1 '?y 3}{'?x 4 '?y 2}]) {:pred :joan :bound #{:x}}) 157 | (datalog-relation 158 | ;; Schema 159 | #{:y :x} 160 | 161 | ;; Data 162 | #{ 163 | {:x 1, :y 3} 164 | {:x 4, :y 2} 165 | } 166 | 167 | ;; Indexes 168 | { 169 | :x 170 | { 171 | 4 172 | #{{:x 4, :y 2}} 173 | 1 174 | #{{:x 1, :y 3}} 175 | } 176 | })))) 177 | -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_magic.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-magic.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Magic Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 18 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-magic 17 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)] 18 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 19 | (:require [cemerick.cljs.test :as t]) 20 | (:use [fogus.datalog.bacwn.impl.magic :only [adorn-query adorn-rules-set magic-transform]] 21 | [fogus.datalog.bacwn.impl.rules :only [rules-set]])) 22 | 23 | (def rs (rules-set 24 | (<- (:p :x ?x :y ?y) (:e :x ?x :y ?y)) 25 | (<- (:p :x ?x :y ?y) (:e :x ?x :y ?z) (:p :x ?z :y ?y)) 26 | (<- (:e :x ?x :y ?y) (:b :x ?x :y ?y)) 27 | (<- (:e :x ?y :y ?y) (:c :x ?x :y ?y)))) 28 | 29 | (def q (adorn-query (?- :p :x 1 :y ?y))) 30 | 31 | (def ars (adorn-rules-set rs q)) 32 | 33 | (deftest test-adorn-rules-set 34 | (is (= ars 35 | (rules-set 36 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?y :x ?x)) 37 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x) 38 | ({:pred :p :bound #{:x}} :y ?y :x ?z)) 39 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) (:c :y ?y :x ?x)) 40 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) (:b :y ?y :x ?x)))))) 41 | 42 | 43 | (def m (magic-transform ars)) 44 | 45 | (deftest test-magic-transform 46 | (is (= m 47 | (rules-set 48 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) ({:pred :e :magic true :bound #{:x}} :x ?y) (:c :y ?y :x ?x)) 49 | 50 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) ({:pred :e :magic true :bound #{:x}} :x ?x) (:b :y ?y :x ?x)) 51 | 52 | (<- ({:pred :p :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) 53 | ({:pred :e :bound #{:x}} :y ?z :x ?x)) 54 | 55 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 56 | ({:pred :e :bound #{:x}} :y ?z :x ?x) 57 | ({:pred :p :bound #{:x}} :y ?y :x ?z)) 58 | 59 | (<- ({:pred :e :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x)) 60 | 61 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 62 | ({:pred :e :bound #{:x}} :y ?y :x ?x)))))) 63 | -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_rules.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-rules.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Rule Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 12 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test-rules 18 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)] 19 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 20 | (:require [cemerick.cljs.test :as t]) 21 | (:use [fogus.datalog.bacwn.impl.rules :only [predicate-map compute-sip display-rule rules-set apply-rule]] 22 | [fogus.datalog.bacwn.impl.database :only [datalog-relation datalog-database add-tuples empty-database]])) 23 | 24 | (def tr-1 (<- (:fred :x ?x :y ?y) (:mary :x ?x :z ?z) (:sally :z ?z :y ?y))) 25 | (def tr-2 (<- (:fred) (not! :mary :x 3))) 26 | (def tr-3 (<- (:fred :x ?x :y ?y) (if > ?x ?y) (:mary :x ?x) (:sally :y ?y))) 27 | 28 | 29 | 30 | (deftest test-rule-safety 31 | (is (thrown-with-msg? js/Error #".*Head vars.*not bound.*" 32 | (<- (:fred :x ?x) (:sally :y ?y)))) 33 | (is (thrown-with-msg? js/Error #".*Body vars.*not bound.*negative position.*" 34 | (<- (:fred :x ?x) (:becky :x ?x) (not! :sally :y ?y)))) 35 | (is (thrown-with-msg? js/Error #".*Body vars.*not bound.*negative position.*" 36 | (<- (:fred :x ?x) (:becky :x ?x) (if > ?x ?y))))) 37 | 38 | 39 | (deftest test-sip 40 | (is (= (compute-sip #{:x} #{:mary :sally} tr-1) 41 | (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 42 | ({:pred :mary :bound #{:x}} :z ?z :x ?x) 43 | ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 44 | 45 | (is (= (compute-sip #{} #{:mary :sally} tr-1) 46 | (<- (:fred :y ?y :x ?x) (:mary :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 47 | 48 | (is (= (compute-sip #{} #{:mary} tr-2) 49 | (<- (:fred) (not! {:pred :mary :bound #{:x}} :x 3)))) 50 | 51 | (is (= (compute-sip #{} #{} tr-2) 52 | tr-2)) 53 | 54 | (is (= (display-rule (compute-sip #{:x} #{:mary :sally} tr-3)) 55 | (display-rule (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 56 | ({:pred :mary :bound #{:x}} :x ?x) 57 | (:sally :y ?y) 58 | (if > ?x ?y)))))) 59 | ; Display rule is used because = does not work on 60 | ; (if > ?x ?y) because it contains a closure 61 | 62 | 63 | (def rs 64 | (rules-set 65 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 66 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y)) 67 | (<- (:edge :a ?x :b ?y) (:route :a ?x :b ?y) (if not= ?x ?y)))) 68 | 69 | (deftest test-rules-set 70 | (is (= (count rs) 3)) 71 | (is (contains? rs (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))))) 72 | 73 | (deftest test-predicate-map 74 | (let [pm (predicate-map rs)] 75 | (is (= (pm :path) 76 | #{(<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 77 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))})) 78 | (is (= (-> :edge pm count) 1)))) 79 | 80 | 81 | (def db1 (make-database 82 | (relation :fred [:x :y]) 83 | (index :fred :x) 84 | (relation :sally [:x]) 85 | (relation :ben [:y]))) 86 | 87 | (def db2 (add-tuples db1 88 | [:fred :x 1 :y :mary] 89 | [:fred :x 1 :y :becky] 90 | [:fred :x 3 :y :sally] 91 | [:fred :x 4 :y :joe] 92 | [:fred :x 4 :y :bob] 93 | [:sally :x 1] 94 | [:sally :x 2] 95 | [:sally :x 3] 96 | [:sally :x 4] 97 | [:ben :y :bob])) 98 | 99 | 100 | (deftest test-apply-rule 101 | (is (= (apply-rule db2 empty-database (<- (:becky :y ?y) (:sally :x ?x) 102 | (:fred :x ?x :y ?y) 103 | (not! :ben :y ?y) 104 | (if not= ?x 3))) 105 | (datalog-database 106 | { 107 | :becky 108 | (datalog-relation 109 | ;; Schema 110 | #{:y} 111 | ;; Data 112 | #{ 113 | {:y :joe} 114 | {:y :mary} 115 | {:y :becky} 116 | } 117 | ;; Indexes 118 | { 119 | }) 120 | })))) -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_softstat.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-softstrat.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Soft Stratification Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 28 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-softstrat 17 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)] 18 | [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 19 | (:require [cemerick.cljs.test :as t] 20 | [clojure.set :as sets]) 21 | (:use [fogus.datalog.bacwn.impl.softstrat :only [valuate-soft-work-set build-soft-strat-work-plan evaluate-soft-work-set]] 22 | [fogus.datalog.bacwn.impl.rules :only [rules-set]] 23 | [fogus.datalog.bacwn.impl.database :only [add-tuples]])) 24 | 25 | (def rs1 (rules-set 26 | (<- (:p :x ?x) (:b :x ?x :y ?y :z ?z) (not! :q :x ?x) (not! :q :x ?y) (not! :q :x ?z)) 27 | (<- (:q :x ?x) (:d :x ?x)))) 28 | 29 | (def q1 (?- :p :x 1)) 30 | 31 | (def ws (build-soft-strat-work-plan rs1 q1)) 32 | 33 | (deftest test-soft-stratification 34 | (let [soft (:stratification ws) 35 | q (:query ws)] 36 | (is (= q (?- {:pred :p :bound #{:x}} :x 1))) 37 | (is (= (count soft) 4)) 38 | (is (clojure.set/subset? (rules-set 39 | (<- ({:pred :q :bound #{:x}} :x ?x) ({:pred :q :magic true :bound #{:x}} :x ?x) 40 | (:d :x ?x)) 41 | 42 | (<- ({:pred :q :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 43 | (:b :z ?z :y ?y :x ?x))) 44 | (nth soft 0))) 45 | (is (= (nth soft 1) 46 | (rules-set 47 | (<- ({:pred :q :magic true :bound #{:x}} :x ?y) ({:pred :p :magic true :bound #{:x}} :x ?x) 48 | (:b :z ?z :y ?y :x ?x) 49 | (not! {:pred :q :bound #{:x}} :x ?x))))) 50 | (is (= (nth soft 2) 51 | (rules-set 52 | (<- ({:pred :q :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) 53 | (:b :z ?z :y ?y :x ?x) 54 | (not! {:pred :q :bound #{:x}} :x ?x) 55 | (not! {:pred :q :bound #{:x}} :x ?y))))) 56 | (is (= (nth soft 3) 57 | (rules-set 58 | (<- ({:pred :p :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 59 | (:b :z ?z :y ?y :x ?x) 60 | (not! {:pred :q :bound #{:x}} :x ?x) 61 | (not! {:pred :q :bound #{:x}} :x ?y) 62 | (not! {:pred :q :bound #{:x}} :x ?z))))))) 63 | 64 | 65 | (def tdb-1 66 | (make-database 67 | (relation :b [:x :y :z]) 68 | (relation :d [:x]))) 69 | 70 | (def tdb-2 71 | (add-tuples tdb-1 72 | [:b :x 1 :y 2 :z 3])) 73 | 74 | (deftest test-tdb-2 75 | (is (= (evaluate-soft-work-set ws tdb-2 {}) 76 | [{:x 1}]))) 77 | 78 | 79 | 80 | (def tdb-3 81 | (add-tuples tdb-2 82 | [:d :x 2] 83 | [:d :x 3])) 84 | 85 | (deftest test-tdb-3 86 | (is (empty? (evaluate-soft-work-set ws tdb-3 {})))) 87 | 88 | 89 | 90 | ;;;;;;;;;;; 91 | 92 | 93 | 94 | (def db-base 95 | (make-database 96 | (relation :employee [:id :name :position]) 97 | (index :employee :name) 98 | 99 | (relation :boss [:employee-id :boss-id]) 100 | (index :boss :employee-id) 101 | 102 | (relation :can-do-job [:position :job]) 103 | (index :can-do-job :position) 104 | 105 | (relation :job-replacement [:job :can-be-done-by]) 106 | 107 | (relation :job-exceptions [:id :job]))) 108 | 109 | (def db 110 | (add-tuples db-base 111 | [:employee :id 1 :name "Bob" :position :boss] 112 | [:employee :id 2 :name "Mary" :position :chief-accountant] 113 | [:employee :id 3 :name "John" :position :accountant] 114 | [:employee :id 4 :name "Sameer" :position :chief-programmer] 115 | [:employee :id 5 :name "Lilian" :position :programmer] 116 | [:employee :id 6 :name "Li" :position :technician] 117 | [:employee :id 7 :name "Fred" :position :sales] 118 | [:employee :id 8 :name "Brenda" :position :sales] 119 | [:employee :id 9 :name "Miki" :position :project-management] 120 | [:employee :id 10 :name "Albert" :position :technician] 121 | 122 | [:boss :employee-id 2 :boss-id 1] 123 | [:boss :employee-id 3 :boss-id 2] 124 | [:boss :employee-id 4 :boss-id 1] 125 | [:boss :employee-id 5 :boss-id 4] 126 | [:boss :employee-id 6 :boss-id 4] 127 | [:boss :employee-id 7 :boss-id 1] 128 | [:boss :employee-id 8 :boss-id 7] 129 | [:boss :employee-id 9 :boss-id 1] 130 | [:boss :employee-id 10 :boss-id 6] 131 | 132 | [:can-do-job :position :boss :job :management] 133 | [:can-do-job :position :accountant :job :accounting] 134 | [:can-do-job :position :chief-accountant :job :accounting] 135 | [:can-do-job :position :programmer :job :programming] 136 | [:can-do-job :position :chief-programmer :job :programming] 137 | [:can-do-job :position :technician :job :server-support] 138 | [:can-do-job :position :sales :job :sales] 139 | [:can-do-job :position :project-management :job :project-management] 140 | 141 | [:job-replacement :job :pc-support :can-be-done-by :server-support] 142 | [:job-replacement :job :pc-support :can-be-done-by :programming] 143 | [:job-replacement :job :payroll :can-be-done-by :accounting] 144 | 145 | [:job-exceptions :id 4 :job :pc-support])) 146 | 147 | (def rules 148 | (rules-set 149 | (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) 150 | (:employee :id ?e-id :name ?x) 151 | (:employee :id ?b-id :name ?y)) 152 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 153 | (:works-for :employee ?z :boss ?y)) 154 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 155 | (:can-do-job :position ?pos :job ?y)) 156 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 157 | (:employee-job* :employee ?x :job ?z)) 158 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 159 | (:employee :name ?x :position ?z) 160 | (if = ?z :boss)) 161 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 162 | (:employee :id ?id :name ?x) 163 | (not! :job-exceptions :id ?id :job ?y)) 164 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 165 | (not! :employee-job :employee ?y :job :pc-support)))) 166 | 167 | 168 | (def ws-1 (build-soft-strat-work-plan rules (?- :works-for :employee '??name :boss ?x))) 169 | (defn evaluate-1 [name] (set (evaluate-soft-work-set ws-1 db {'??name name}))) 170 | 171 | (deftest test-ws-1 172 | (is (= (evaluate-1 "Albert") 173 | #{{:employee "Albert", :boss "Li"} 174 | {:employee "Albert", :boss "Sameer"} 175 | {:employee "Albert", :boss "Bob"}})) 176 | (is (empty? (evaluate-1 "Bob"))) 177 | (is (= (evaluate-1 "John") 178 | #{{:employee "John", :boss "Bob"} 179 | {:employee "John", :boss "Mary"}}))) 180 | 181 | 182 | (def ws-2 (build-soft-strat-work-plan rules (?- :employee-job :employee '??name :job ?x))) 183 | (defn evaluate-2 [name] (set (evaluate-soft-work-set ws-2 db {'??name name}))) 184 | 185 | (deftest test-ws-2 186 | (is (= (evaluate-2 "Albert") 187 | #{{:employee "Albert", :job :pc-support} 188 | {:employee "Albert", :job :server-support}})) 189 | (is (= (evaluate-2 "Sameer") 190 | #{{:employee "Sameer", :job :programming}})) 191 | (is (= (evaluate-2 "Bob") 192 | #{{:employee "Bob", :job :accounting} 193 | {:employee "Bob", :job :management} 194 | {:employee "Bob", :job :payroll} 195 | {:employee "Bob", :job :pc-support} 196 | {:employee "Bob", :job :project-management} 197 | {:employee "Bob", :job :programming} 198 | {:employee "Bob", :job :server-support} 199 | {:employee "Bob", :job :sales}}))) 200 | 201 | (def ws-3 (build-soft-strat-work-plan rules (?- :bj :name '??name :boss ?x))) 202 | (defn evaluate-3 [name] (set (evaluate-soft-work-set ws-3 db {'??name name}))) 203 | 204 | (deftest test-ws-3 205 | (is (= (evaluate-3 "Albert") 206 | #{{:name "Albert", :boss "Sameer"}}))) 207 | 208 | (def ws-4 (build-soft-strat-work-plan rules (?- :works-for :name ?x :boss ?x))) 209 | 210 | (deftest test-ws-4 211 | (is (= (set (evaluate-soft-work-set ws-4 db {})) 212 | #{{:employee "Miki", :boss "Bob"} 213 | {:employee "Albert", :boss "Li"} 214 | {:employee "Lilian", :boss "Sameer"} 215 | {:employee "Li", :boss "Bob"} 216 | {:employee "Lilian", :boss "Bob"} 217 | {:employee "Brenda", :boss "Fred"} 218 | {:employee "Fred", :boss "Bob"} 219 | {:employee "John", :boss "Bob"} 220 | {:employee "John", :boss "Mary"} 221 | {:employee "Albert", :boss "Sameer"} 222 | {:employee "Sameer", :boss "Bob"} 223 | {:employee "Albert", :boss "Bob"} 224 | {:employee "Brenda", :boss "Bob"} 225 | {:employee "Mary", :boss "Bob"} 226 | {:employee "Li", :boss "Sameer"}}))) 227 | -------------------------------------------------------------------------------- /test-cljs/bacwm/test/impl/test_util.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-util.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Utilities Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 11 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-util 17 | (:use-macros [cemerick.cljs.test :only (is deftest with-test run-tests testing)]) 18 | (:use [fogus.datalog.bacwn.impl.util :only [is-var? map-values keys-to-vals reverse-map preduce]])) 19 | 20 | (deftest test-is-var? 21 | (is (is-var? '?x)) 22 | (is (is-var? '?)) 23 | (is (not (is-var? '??x))) 24 | (is (not (is-var? '??))) 25 | (is (not (is-var? 'x))) 26 | (is (not (is-var? "fred"))) 27 | (is (not (is-var? :q)))) 28 | 29 | (deftest test-map-values 30 | (let [map {:fred 1 :sally 2}] 31 | (is (= (map-values #(* 2 %) map) {:fred 2 :sally 4})) 32 | (is (= (map-values identity {}) {})))) 33 | 34 | (deftest test-keys-to-vals 35 | (let [map {:fred 1 :sally 2 :joey 3}] 36 | (is (= (set (keys-to-vals map [:fred :sally])) #{1 2})) 37 | (is (= (set (keys-to-vals map [:fred :sally :becky])) #{1 2})) 38 | (is (empty? (keys-to-vals map []))) 39 | (is (empty? (keys-to-vals {} [:fred]))))) 40 | 41 | (deftest test-reverse-map 42 | (let [map {:fred 1 :sally 2 :joey 3} 43 | map-1 (assoc map :mary 3)] 44 | (is (= (reverse-map map) {1 :fred 2 :sally 3 :joey})) 45 | (is (or (= (reverse-map map-1) {1 :fred 2 :sally 3 :joey}) 46 | (= (reverse-map map-1) {1 :fred 2 :sally 3 :mary}))))) 47 | 48 | (def some-maps 49 | [ 50 | { :a 1 :b 2 } 51 | { :c 3 :b 3 } 52 | { :d 4 :a 1 } 53 | { :g 4 :b 4 } 54 | { :a 2 :b 1 } 55 | { :e 1 :f 1 } 56 | ]) 57 | 58 | (def preduced (preduce + some-maps)) 59 | (def merged (apply merge-with + some-maps)) 60 | 61 | (deftest test-preduce 62 | (is (= preduced merged))) -------------------------------------------------------------------------------- /test-cljs/example.cljs: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; example.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog - Example 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 2 March 2009 15 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 16 | 17 | (ns example 18 | (:use-macros [fogus.datalog.bacwn.macros :only (<- ?- make-database)]) 19 | (:require [fogus.datalog.bacwn :as bacwn] 20 | [fogus.datalog.bacwn.impl.rules :as r] 21 | [fogus.datalog.bacwn.impl.database :as database])) 22 | 23 | 24 | (def db-base 25 | (make-database 26 | (relation :employee [:id :name :position]) 27 | (index :employee :name) 28 | 29 | (relation :boss [:employee-id :boss-id]) 30 | (index :boss :employee-id) 31 | 32 | (relation :can-do-job [:position :job]) 33 | (index :can-do-job :position) 34 | 35 | (relation :job-replacement [:job :can-be-done-by]) 36 | ;;(index :job-replacement :can-be-done-by) 37 | 38 | (relation :job-exceptions [:id :job]))) 39 | 40 | (def db 41 | (database/add-tuples db-base 42 | [:employee :id 1 :name "Bob" :position :boss] 43 | [:employee :id 2 :name "Mary" :position :chief-accountant] 44 | [:employee :id 3 :name "John" :position :accountant] 45 | [:employee :id 4 :name "Sameer" :position :chief-programmer] 46 | [:employee :id 5 :name "Lilian" :position :programmer] 47 | [:employee :id 6 :name "Li" :position :technician] 48 | [:employee :id 7 :name "Fred" :position :sales] 49 | [:employee :id 8 :name "Brenda" :position :sales] 50 | [:employee :id 9 :name "Miki" :position :project-management] 51 | [:employee :id 10 :name "Albert" :position :technician] 52 | 53 | [:boss :employee-id 2 :boss-id 1] 54 | [:boss :employee-id 3 :boss-id 2] 55 | [:boss :employee-id 4 :boss-id 1] 56 | [:boss :employee-id 5 :boss-id 4] 57 | [:boss :employee-id 6 :boss-id 4] 58 | [:boss :employee-id 7 :boss-id 1] 59 | [:boss :employee-id 8 :boss-id 7] 60 | [:boss :employee-id 9 :boss-id 1] 61 | [:boss :employee-id 10 :boss-id 6] 62 | 63 | [:can-do-job :position :boss :job :management] 64 | [:can-do-job :position :accountant :job :accounting] 65 | [:can-do-job :position :chief-accountant :job :accounting] 66 | [:can-do-job :position :programmer :job :programming] 67 | [:can-do-job :position :chief-programmer :job :programming] 68 | [:can-do-job :position :technician :job :server-support] 69 | [:can-do-job :position :sales :job :sales] 70 | [:can-do-job :position :project-management :job :project-management] 71 | 72 | [:job-replacement :job :pc-support :can-be-done-by :server-support] 73 | [:job-replacement :job :pc-support :can-be-done-by :programming] 74 | [:job-replacement :job :payroll :can-be-done-by :accounting] 75 | 76 | [:job-exceptions :id 4 :job :pc-support])) 77 | 78 | (def rules 79 | (r/rules-set 80 | (<- (:works-for :employee ?x :boss ?y) 81 | (:boss :employee-id ?e-id :boss-id ?b-id) 82 | (:employee :id ?e-id :name ?x) 83 | (:employee :id ?b-id :name ?y)) 84 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 85 | (:works-for :employee ?z :boss ?y)) 86 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 87 | (:can-do-job :position ?pos :job ?y)) 88 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 89 | (:employee-job* :employee ?x :job ?z)) 90 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 91 | (:employee :name ?x :position ?z) 92 | (if = ?z :boss)) 93 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 94 | (:employee :id ?id :name ?x) 95 | (not! :job-exceptions :id ?id :job ?y)) 96 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 97 | (not! :employee-job :employee ?y :job :pc-support)))) 98 | 99 | (def wp-1 (bacwn/build-work-plan rules (?- :works-for :employee '??name :boss ?x))) 100 | (def wp-2 (bacwn/build-work-plan rules (?- :employee-job :employee '??name :job ?x))) 101 | (def wp-3 (bacwn/build-work-plan rules (?- :bj :name '??name :boss ?x))) 102 | (def wp-4 (bacwn/build-work-plan rules (?- :works-for :employee ?x :boss ?y))) 103 | 104 | 105 | (bacwn/run-work-plan wp-1 db {'??name "Albert"}) 106 | ;;({:boss "Li", :employee "Albert"} {:boss "Sameer", :employee "Albert"} {:boss "Bob", :employee "Albert"}) 107 | 108 | (bacwn/run-work-plan wp-2 db {'??name "Li"}) 109 | ;; ({:job :server-support, :employee "Li"} {:job :pc-support, :employee "Li"}) 110 | 111 | (bacwn/run-work-plan wp-3 db {'??name "Albert"}) 112 | ;; ({:boss "Sameer", :name "Albert"}) 113 | 114 | (bacwn/run-work-plan wp-4 db {}) 115 | ;; ({:boss "Bob", :employee "Miki"} {:boss "Li", :employee "Albert"} {:boss "Sameer", :employee "Lilian"} {:boss "Bob", :employee "Li"} {:boss "Bob", :employee "Lilian"} {:boss "Fred", :employee "Brenda"} {:boss "Bob", :employee "Fred"} {:boss "Bob", :employee "John"} {:boss "Mary", :employee "John"} {:boss "Sameer", :employee "Albert"} {:boss "Bob", :employee "Sameer"} {:boss "Bob", :employee "Albert"} {:boss "Bob", :employee "Brenda"} {:boss "Bob", :employee "Mary"} {:boss "Sameer", :employee "Li"}) 116 | -------------------------------------------------------------------------------- /test-cljs/mst3k.cljs: -------------------------------------------------------------------------------- 1 | (ns mst3k 2 | (:use-macros [fogus.datalog.bacwn.macros :only (facts <- ?- make-database)]) 3 | (:require [fogus.datalog.bacwn :as bacwn]) 4 | (:use [fogus.datalog.bacwn.impl.rules :only [rules-set] 5 | [fogus.datalog.bacwn.impl.database :only [add-tuples]]])) 6 | 7 | (def mst3k-schema 8 | (make-database 9 | (relation :character [:db.id :name :human?]) 10 | (index :character :name) 11 | 12 | (relation :location [:db.id :character :name]) 13 | (index :location :name))) 14 | 15 | (def mst3k-db 16 | (-> mst3k-schema 17 | (facts {:character/db.id 0 :character/name "Joel" :character/human? true} 18 | {:character/db.id 1 :character/name "Crow" :character/human? false} 19 | {:character/db.id 2 :character/name "TV's Frank" :character/human? true} 20 | {:location/db.id 0 :location/character 0 :location/name "SoL"} 21 | {:location/db.id 0 :location/character 1 :location/name "SoL"} 22 | {:location/db.id 1 :location/character 2 :location/name "Gizmonics"}))) 23 | 24 | (def locate-rule 25 | (rules-set 26 | (<- (:stationed-at :location/name ?loc-name :character/name ?char-name) 27 | (:location :name ?loc-name :character ?char) 28 | (:character :db.id ?char :name ?char-name)))) 29 | 30 | (bacwn/run-work-plan 31 | (bacwn/build-work-plan locate-rule 32 | (?- :stationed-at :location/name '??loc :character/name ?char-name)) 33 | mst3k-db 34 | {'??loc "SoL"}) 35 | ;; ({:location/name "SoL", :character/name "Crow"} {:location/name "SoL", :character/name "Joel"}) 36 | 37 | 38 | (def non-human-locate-rule 39 | (rules-set 40 | (<- (:stationed-at :location/name ?loc-name :character/name ?char-name) 41 | (:location :name ?loc-name :character ?char) 42 | (:character :character/db.id ?char :name ?char-name) 43 | (not! :character :character/db.id ?char :human? true)))) 44 | 45 | (bacwn/run-work-plan 46 | (bacwn/build-work-plan non-human-locate-rule 47 | (?- :stationed-at :location/name '??loc :character/name ?char-name)) 48 | mst3k-db 49 | {'??loc "SoL"}) 50 | 51 | ;;=> ({:location/name "SoL", :character/name "Crow"}) 52 | 53 | (bacwn/q (?- :stationed-at :location/name '??loc :character/name ?char-name) 54 | mst3k-db 55 | non-human-locate-rule 56 | {'??loc "SoL"}) 57 | 58 | ;;=> ({:location/name "SoL", :character/name "Crow"}) 59 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_database.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-database.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Database 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 12 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test-database 18 | (:use clojure.test 19 | fogus.datalog.bacwn.impl.database 20 | fogus.datalog.bacwn.macros)) 21 | 22 | 23 | (def test-db 24 | (make-database 25 | (relation :fred [:mary :sue]) 26 | (index :fred :mary) 27 | (relation :sally [:jen :becky :joan]) 28 | (index :sally :jen) 29 | (index :sally :becky))) 30 | 31 | (deftest test-make-database 32 | (is (= test-db 33 | (datalog-database 34 | {:sally (datalog-relation 35 | #{:jen :joan :becky} 36 | #{} 37 | {:becky {} 38 | :jen {}}) 39 | :fred (datalog-relation 40 | #{:sue :mary} 41 | #{} 42 | {:mary {}})})))) 43 | 44 | 45 | (deftest test-ensure-relation 46 | (is (contains? (ensure-relation test-db :bob [:sam :george] [:sam]) :bob)) 47 | (is (contains? (ensure-relation test-db :fred [:mary :sue] [:mary]) :fred)) 48 | (is (thrown? AssertionError (ensure-relation test-db :fred [:bob :joe] [])))) 49 | 50 | (deftest test-add-tuple 51 | (let [new-db (add-tuple test-db :fred {:mary 1 :sue 2})] 52 | (is (= (select new-db :fred {:mary 1}) [{:mary 1 :sue 2}]))) 53 | (is (thrown? AssertionError (add-tuple test-db :fred {:mary 1})))) 54 | 55 | (def test-db-1 56 | (add-tuples test-db 57 | [:fred :mary 1 :sue 2] 58 | [:fred :mary 2 :sue 3] 59 | [:sally :jen 1 :becky 2 :joan 0] 60 | [:sally :jen 1 :becky 4 :joan 3] 61 | [:sally :jen 1 :becky 3 :joan 0] 62 | [:sally :jen 1 :becky 2 :joan 3] 63 | [:fred :mary 1 :sue 1] 64 | [:fred :mary 3 :sue 1])) 65 | 66 | (deftest test-add-tuples 67 | (is (= test-db-1 68 | (datalog-database 69 | {:sally (datalog-relation 70 | #{:jen :joan :becky} 71 | #{{:jen 1, :joan 0, :becky 3} 72 | {:jen 1, :joan 0, :becky 2} 73 | {:jen 1, :joan 3, :becky 2} 74 | {:jen 1, :joan 3, :becky 4}} 75 | {:becky {3 76 | #{{:jen 1, :joan 0, :becky 3}} 77 | 4 78 | #{{:jen 1, :joan 3, :becky 4}} 79 | 2 80 | #{{:jen 1, :joan 0, :becky 2} 81 | {:jen 1, :joan 3, :becky 2}}} 82 | :jen {1 83 | #{{:jen 1, :joan 0, :becky 3} 84 | {:jen 1, :joan 0, :becky 2} 85 | {:jen 1, :joan 3, :becky 2} 86 | {:jen 1, :joan 3, :becky 4}}}}) 87 | :fred (datalog-relation 88 | #{:sue :mary} 89 | #{{:sue 2, :mary 1} 90 | {:sue 1, :mary 1} 91 | {:sue 3, :mary 2} 92 | {:sue 1, :mary 3}} 93 | {:mary {3 94 | #{{:sue 1, :mary 3}} 95 | 2 96 | #{{:sue 3, :mary 2}} 97 | 1 98 | #{{:sue 2, :mary 1} 99 | {:sue 1, :mary 1}}}})})))) 100 | 101 | (deftest test-remove-tuples 102 | (let [db (reduce #(apply remove-tuple %1 (first %2) (next %2)) 103 | test-db-1 104 | [[:fred {:mary 1 :sue 1}] 105 | [:fred {:mary 3 :sue 1}] 106 | [:sally {:jen 1 :becky 2 :joan 0}] 107 | [:sally {:jen 1 :becky 4 :joan 3}]])] 108 | (is (= db 109 | (datalog-database 110 | {:sally (datalog-relation 111 | #{:jen :joan :becky} 112 | #{{:jen 1, :joan 0, :becky 3} 113 | {:jen 1, :joan 3, :becky 2}} 114 | {:becky 115 | {3 116 | #{{:jen 1, :joan 0, :becky 3}} 117 | 2 118 | #{{:jen 1, :joan 3, :becky 2}}} 119 | :jen 120 | {1 121 | #{{:jen 1, :joan 0, :becky 3} 122 | {:jen 1, :joan 3, :becky 2}}}}) 123 | :fred (datalog-relation 124 | #{:sue :mary} 125 | #{{:sue 2, :mary 1} 126 | {:sue 3, :mary 2}} 127 | {:mary 128 | {2 129 | #{{:sue 3, :mary 2}} 130 | 1 131 | #{{:sue 2, :mary 1}}}})}))))) 132 | 133 | 134 | 135 | (deftest test-select 136 | (is (= (set (select test-db-1 :sally {:jen 1 :becky 2})) 137 | #{{:jen 1 :joan 0 :becky 2} {:jen 1 :joan 3 :becky 2}})) 138 | (is (= (set (select test-db-1 :fred {:sue 1}))) 139 | #{{:mary 3 :sue 1} {:mary 1 :sue 1}}) 140 | (is (empty? (select test-db-1 :sally {:joan 5 :jen 1})))) 141 | 142 | (deftest test-any-match? 143 | (is (any-match? test-db-1 :fred {:mary 3})) 144 | (is (any-match? test-db-1 :sally {:jen 1 :becky 2 :joan 3})) 145 | (is (not (any-match? test-db-1 :sally {:jen 5}))) 146 | (is (not (any-match? test-db-1 :fred {:mary 1 :sue 5})))) 147 | 148 | 149 | (comment 150 | (run-tests) 151 | ) 152 | 153 | ;; End of file 154 | 155 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_literals.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-literals.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Literals tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 25 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test-literals 18 | (:use clojure.test) 19 | (:use fogus.datalog.bacwn.impl.literals 20 | fogus.datalog.bacwn.impl.database 21 | fogus.datalog.bacwn.macros)) 22 | 23 | 24 | (def pl (eval (build-literal '(:fred :x ?x :y ?y :z 3)))) 25 | (def nl (eval (build-literal '(not! :fred :x ?x :y ?y :z 3)))) 26 | (def cl (eval (build-literal '(if > ?x 3)))) 27 | 28 | (def bl (eval (build-literal '(:fred)))) 29 | 30 | (def bns {:x '?x :y '?y :z 3}) 31 | 32 | (deftest test-build-literal 33 | (is (= (:predicate pl) :fred)) 34 | (is (= (:term-bindings pl) bns)) 35 | (is (= (:predicate nl) :fred)) 36 | (is (= (:term-bindings nl) bns)) 37 | (is (= (:symbol cl) '>)) 38 | (is (= (:terms cl) '(?x 3))) 39 | (is ((:fun cl) [4 3])) 40 | (is (not ((:fun cl) [2 4]))) 41 | (is (= (:predicate bl) :fred))) 42 | 43 | (deftest test-literal-predicate 44 | (is (= (literal-predicate pl) :fred)) 45 | (is (= (literal-predicate nl) :fred)) 46 | (is (nil? (literal-predicate cl))) 47 | (is (= (literal-predicate bl) :fred))) 48 | 49 | (deftest test-literal-columns 50 | (is (= (literal-columns pl) #{:x :y :z})) 51 | (is (= (literal-columns nl) #{:x :y :z})) 52 | (is (nil? (literal-columns cl))) 53 | (is (empty? (literal-columns bl)))) 54 | 55 | (deftest test-literal-vars 56 | (is (= (literal-vars pl) #{'?x '?y})) 57 | (is (= (literal-vars nl) #{'?x '?y})) 58 | (is (= (literal-vars cl) #{'?x})) 59 | (is (empty? (literal-vars bl)))) 60 | 61 | (deftest test-positive-vars 62 | (is (= (positive-vars pl) (literal-vars pl))) 63 | (is (nil? (positive-vars nl))) 64 | (is (nil? (positive-vars cl))) 65 | (is (empty? (positive-vars bl)))) 66 | 67 | (deftest test-negative-vars 68 | (is (nil? (negative-vars pl))) 69 | (is (= (negative-vars nl) (literal-vars nl))) 70 | (is (= (negative-vars cl) (literal-vars cl))) 71 | (is (empty? (negative-vars bl)))) 72 | 73 | (deftest test-negated? 74 | (is (not (negated? pl))) 75 | (is (negated? nl)) 76 | (is (not (negated? cl)))) 77 | 78 | (deftest test-vs-from-cs 79 | (is (= (get-vs-from-cs pl #{:x}) #{'?x})) 80 | (is (empty? (get-vs-from-cs pl #{:z}))) 81 | (is (= (get-vs-from-cs pl #{:x :r}) #{'?x})) 82 | (is (empty? (get-vs-from-cs pl #{})))) 83 | 84 | (deftest test-cs-from-vs 85 | (is (= (get-cs-from-vs pl #{'?x}) #{:x})) 86 | (is (= (get-cs-from-vs pl #{'?x '?r}) #{:x})) 87 | (is (empty? (get-cs-from-vs pl #{})))) 88 | 89 | (deftest test-literal-appropriate? 90 | (is (not (literal-appropriate? #{} pl))) 91 | (is (literal-appropriate? #{'?x} pl)) 92 | (is (not (literal-appropriate? #{'?x} nl))) 93 | (is (literal-appropriate? #{'?x '?y} nl)) 94 | (is (not (literal-appropriate? #{'?z} cl))) 95 | (is (literal-appropriate? #{'?x} cl))) 96 | 97 | (deftest test-adorned-literal 98 | (is (= (literal-predicate (adorned-literal pl #{:x})) 99 | {:pred :fred :bound #{:x}})) 100 | (is (= (literal-predicate (adorned-literal nl #{:x :y :q})) 101 | {:pred :fred :bound #{:x :y}})) 102 | (is (= (:term-bindings (adorned-literal nl #{:x})) 103 | {:x '?x :y '?y :z 3})) 104 | (is (= (adorned-literal cl #{}) 105 | cl))) 106 | 107 | (deftest test-get-adorned-bindings 108 | (is (= (get-adorned-bindings (literal-predicate (adorned-literal pl #{:x}))) 109 | #{:x})) 110 | (is (= (get-adorned-bindings (literal-predicate pl)) 111 | nil))) 112 | 113 | (deftest test-get-base-predicate 114 | (is (= (get-base-predicate (literal-predicate (adorned-literal pl #{:x}))) 115 | :fred)) 116 | (is (= (get-base-predicate (literal-predicate pl)) 117 | :fred))) 118 | 119 | (deftest test-magic-literal 120 | (is (.equals (magic-literal pl) 121 | {:predicate {:pred :fred :magic true}, :term-bindings {}, :literal-type :fogus.datalog.bacwn.impl.literals/literal})) 122 | (is (.equals (magic-literal (adorned-literal pl #{:x})) 123 | {:predicate {:pred :fred :magic true :bound #{:x}}, 124 | :term-bindings {:x '?x}, 125 | :literal-type :fogus.datalog.bacwn.impl.literals/literal}))) 126 | 127 | 128 | (def db1 (make-database 129 | (relation :fred [:x :y]) 130 | (index :fred :x) 131 | (relation :sally [:x]))) 132 | 133 | (def db2 (add-tuples db1 134 | [:fred :x 1 :y :mary] 135 | [:fred :x 1 :y :becky] 136 | [:fred :x 3 :y :sally] 137 | [:fred :x 4 :y :joe] 138 | [:sally :x 1] 139 | [:sally :x 2])) 140 | 141 | (def lit1 (eval (build-literal '(:fred :x ?x :y ?y)))) 142 | (def lit2 (eval (build-literal '(not! :fred :x ?x)))) 143 | (def lit3 (eval (build-literal '(if > ?x ?y)))) 144 | (def lit4 (adorned-literal (eval (build-literal '(:joan :x ?x :y ?y))) #{:x})) 145 | 146 | (deftest test-join-literal 147 | (is (= (set (join-literal db2 lit1 [{'?x 1} {'?x 2} {'?x 3}])) 148 | #{{'?x 1, '?y :mary} {'?x 1, '?y :becky} {'?x 3, '?y :sally}})) 149 | (is (= (join-literal db2 lit2 [{'?x 1} {'?x 2} {'?x 3}]) 150 | [{'?x 2}])) 151 | (is (= (join-literal db2 lit3 [{'?x 1 '?y 2} {'?x 3 '?y 1}]) 152 | [{'?x 3 '?y 1}]))) 153 | 154 | (deftest test-project-literal 155 | (is (= ((project-literal db2 lit4 [{'?x 1 '?y 3}{'?x 4 '?y 2}]) {:pred :joan :bound #{:x}}) 156 | (datalog-relation 157 | ;; Schema 158 | #{:y :x} 159 | 160 | ;; Data 161 | #{ 162 | {:x 1, :y 3} 163 | {:x 4, :y 2} 164 | } 165 | 166 | ;; Indexes 167 | { 168 | :x 169 | { 170 | 4 171 | #{{:x 4, :y 2}} 172 | 1 173 | #{{:x 1, :y 3}} 174 | } 175 | })))) 176 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_magic.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-magic.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Magic Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 18 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-magic 17 | (:use clojure.test) 18 | (:use fogus.datalog.bacwn.impl.magic 19 | fogus.datalog.bacwn.impl.rules 20 | fogus.datalog.bacwn.macros)) 21 | 22 | 23 | 24 | (def rs (rules-set 25 | (<- (:p :x ?x :y ?y) (:e :x ?x :y ?y)) 26 | (<- (:p :x ?x :y ?y) (:e :x ?x :y ?z) (:p :x ?z :y ?y)) 27 | (<- (:e :x ?x :y ?y) (:b :x ?x :y ?y)) 28 | (<- (:e :x ?y :y ?y) (:c :x ?x :y ?y)))) 29 | 30 | (def q (adorn-query (?- :p :x 1 :y ?y))) 31 | 32 | (def ars (adorn-rules-set rs q)) 33 | 34 | (deftest test-adorn-rules-set 35 | (is (= ars 36 | (rules-set 37 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?y :x ?x)) 38 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :e :bound #{:x}} :y ?z :x ?x) 39 | ({:pred :p :bound #{:x}} :y ?y :x ?z)) 40 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) (:c :y ?y :x ?x)) 41 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) (:b :y ?y :x ?x)))))) 42 | 43 | 44 | (def m (magic-transform ars)) 45 | 46 | (deftest test-magic-transform 47 | (is (= m 48 | (rules-set 49 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?y) ({:pred :e :magic true :bound #{:x}} :x ?y) (:c :y ?y :x ?x)) 50 | 51 | (<- ({:pred :e :bound #{:x}} :y ?y :x ?x) ({:pred :e :magic true :bound #{:x}} :x ?x) (:b :y ?y :x ?x)) 52 | 53 | (<- ({:pred :p :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) 54 | ({:pred :e :bound #{:x}} :y ?z :x ?x)) 55 | 56 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 57 | ({:pred :e :bound #{:x}} :y ?z :x ?x) 58 | ({:pred :p :bound #{:x}} :y ?y :x ?z)) 59 | 60 | (<- ({:pred :e :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x)) 61 | 62 | (<- ({:pred :p :bound #{:x}} :y ?y :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 63 | ({:pred :e :bound #{:x}} :y ?y :x ?x)))))) 64 | 65 | 66 | 67 | 68 | (comment 69 | (run-tests) 70 | ) 71 | 72 | ;; End of file 73 | 74 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_rules.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-rules.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Rule Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 12 Feburary 2009 15 | 16 | 17 | (ns bacwn.test.impl.test-rules 18 | (:use clojure.test 19 | fogus.datalog.bacwn.impl.rules 20 | fogus.datalog.bacwn.impl.literals 21 | fogus.datalog.bacwn.impl.database 22 | fogus.datalog.bacwn.macros)) 23 | 24 | 25 | (def tr-1 (<- (:fred :x ?x :y ?y) (:mary :x ?x :z ?z) (:sally :z ?z :y ?y))) 26 | (def tr-2 (<- (:fred) (not! :mary :x 3))) 27 | (def tr-3 (<- (:fred :x ?x :y ?y) (if > ?x ?y) (:mary :x ?x) (:sally :y ?y))) 28 | 29 | 30 | 31 | (deftest test-rule-safety 32 | (is (thrown-with-msg? Exception #".*Head vars.*not bound.*" 33 | (<- (:fred :x ?x) (:sally :y ?y)))) 34 | (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" 35 | (<- (:fred :x ?x) (:becky :x ?x) (not! :sally :y ?y)))) 36 | (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" 37 | (<- (:fred :x ?x) (:becky :x ?x) (if > ?x ?y))))) 38 | 39 | 40 | (deftest test-sip 41 | (is (= (compute-sip #{:x} #{:mary :sally} tr-1) 42 | (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 43 | ({:pred :mary :bound #{:x}} :z ?z :x ?x) 44 | ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 45 | 46 | (is (= (compute-sip #{} #{:mary :sally} tr-1) 47 | (<- (:fred :y ?y :x ?x) (:mary :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 48 | 49 | (is (= (compute-sip #{} #{:mary} tr-2) 50 | (<- (:fred) (not! {:pred :mary :bound #{:x}} :x 3)))) 51 | 52 | (is (= (compute-sip #{} #{} tr-2) 53 | tr-2)) 54 | 55 | (is (= (display-rule (compute-sip #{:x} #{:mary :sally} tr-3)) 56 | (display-rule (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 57 | ({:pred :mary :bound #{:x}} :x ?x) 58 | (:sally :y ?y) 59 | (if > ?x ?y)))))) 60 | ; Display rule is used because = does not work on 61 | ; (if > ?x ?y) because it contains a closure 62 | 63 | 64 | (def rs 65 | (rules-set 66 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 67 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y)) 68 | (<- (:edge :a ?x :b ?y) (:route :a ?x :b ?y) (if not= ?x ?y)))) 69 | 70 | (deftest test-rules-set 71 | (is (= (count rs) 3)) 72 | (is (contains? rs (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))))) 73 | 74 | (deftest test-predicate-map 75 | (let [pm (predicate-map rs)] 76 | (is (= (pm :path) 77 | #{(<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 78 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))})) 79 | (is (= (-> :edge pm count) 1)))) 80 | 81 | 82 | (def db1 (make-database 83 | (relation :fred [:x :y]) 84 | (index :fred :x) 85 | (relation :sally [:x]) 86 | (relation :ben [:y]))) 87 | 88 | (def db2 (add-tuples db1 89 | [:fred :x 1 :y :mary] 90 | [:fred :x 1 :y :becky] 91 | [:fred :x 3 :y :sally] 92 | [:fred :x 4 :y :joe] 93 | [:fred :x 4 :y :bob] 94 | [:sally :x 1] 95 | [:sally :x 2] 96 | [:sally :x 3] 97 | [:sally :x 4] 98 | [:ben :y :bob])) 99 | 100 | 101 | (deftest test-apply-rule 102 | (is (= (apply-rule db2 empty-database (<- (:becky :y ?y) (:sally :x ?x) 103 | (:fred :x ?x :y ?y) 104 | (not! :ben :y ?y) 105 | (if not= ?x 3))) 106 | (datalog-database 107 | { 108 | :becky 109 | (datalog-relation 110 | ;; Schema 111 | #{:y} 112 | ;; Data 113 | #{ 114 | {:y :joe} 115 | {:y :mary} 116 | {:y :becky} 117 | } 118 | ;; Indexes 119 | { 120 | }) 121 | })))) 122 | 123 | 124 | 125 | 126 | (comment 127 | (run-tests) 128 | ) 129 | 130 | ;; End of file 131 | 132 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_softstrat.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-softstrat.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Soft Stratification Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 28 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-softstrat 17 | (:use clojure.test) 18 | (:use fogus.datalog.bacwn.impl.softstrat 19 | fogus.datalog.bacwn.impl.magic 20 | fogus.datalog.bacwn.impl.rules 21 | fogus.datalog.bacwn.impl.database 22 | fogus.datalog.bacwn.impl.util 23 | fogus.datalog.bacwn.macros) 24 | (:require clojure.set)) 25 | 26 | 27 | 28 | (def rs1 (rules-set 29 | (<- (:p :x ?x) (:b :x ?x :y ?y :z ?z) (not! :q :x ?x) (not! :q :x ?y) (not! :q :x ?z)) 30 | (<- (:q :x ?x) (:d :x ?x)))) 31 | 32 | (def q1 (?- :p :x 1)) 33 | 34 | (def ws (build-soft-strat-work-plan rs1 q1)) 35 | 36 | (deftest test-soft-stratification 37 | (let [soft (:stratification ws) 38 | q (:query ws)] 39 | (is (= q (?- {:pred :p :bound #{:x}} :x 1))) 40 | (is (= (count soft) 4)) 41 | (is (clojure.set/subset? (rules-set 42 | (<- ({:pred :q :bound #{:x}} :x ?x) ({:pred :q :magic true :bound #{:x}} :x ?x) 43 | (:d :x ?x)) 44 | 45 | (<- ({:pred :q :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 46 | (:b :z ?z :y ?y :x ?x))) 47 | (nth soft 0))) 48 | (is (= (nth soft 1) 49 | (rules-set 50 | (<- ({:pred :q :magic true :bound #{:x}} :x ?y) ({:pred :p :magic true :bound #{:x}} :x ?x) 51 | (:b :z ?z :y ?y :x ?x) 52 | (not! {:pred :q :bound #{:x}} :x ?x))))) 53 | (is (= (nth soft 2) 54 | (rules-set 55 | (<- ({:pred :q :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) 56 | (:b :z ?z :y ?y :x ?x) 57 | (not! {:pred :q :bound #{:x}} :x ?x) 58 | (not! {:pred :q :bound #{:x}} :x ?y))))) 59 | (is (= (nth soft 3) 60 | (rules-set 61 | (<- ({:pred :p :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 62 | (:b :z ?z :y ?y :x ?x) 63 | (not! {:pred :q :bound #{:x}} :x ?x) 64 | (not! {:pred :q :bound #{:x}} :x ?y) 65 | (not! {:pred :q :bound #{:x}} :x ?z))))))) 66 | 67 | 68 | (def tdb-1 69 | (make-database 70 | (relation :b [:x :y :z]) 71 | (relation :d [:x]))) 72 | 73 | (def tdb-2 74 | (add-tuples tdb-1 75 | [:b :x 1 :y 2 :z 3])) 76 | 77 | (deftest test-tdb-2 78 | (is (= (evaluate-soft-work-set ws tdb-2 {}) 79 | [{:x 1}]))) 80 | 81 | 82 | 83 | (def tdb-3 84 | (add-tuples tdb-2 85 | [:d :x 2] 86 | [:d :x 3])) 87 | 88 | (deftest test-tdb-3 89 | (is (empty? (evaluate-soft-work-set ws tdb-3 {})))) 90 | 91 | 92 | 93 | ;;;;;;;;;;; 94 | 95 | 96 | 97 | (def db-base 98 | (make-database 99 | (relation :employee [:id :name :position]) 100 | (index :employee :name) 101 | 102 | (relation :boss [:employee-id :boss-id]) 103 | (index :boss :employee-id) 104 | 105 | (relation :can-do-job [:position :job]) 106 | (index :can-do-job :position) 107 | 108 | (relation :job-replacement [:job :can-be-done-by]) 109 | 110 | (relation :job-exceptions [:id :job]))) 111 | 112 | (def db 113 | (add-tuples db-base 114 | [:employee :id 1 :name "Bob" :position :boss] 115 | [:employee :id 2 :name "Mary" :position :chief-accountant] 116 | [:employee :id 3 :name "John" :position :accountant] 117 | [:employee :id 4 :name "Sameer" :position :chief-programmer] 118 | [:employee :id 5 :name "Lilian" :position :programmer] 119 | [:employee :id 6 :name "Li" :position :technician] 120 | [:employee :id 7 :name "Fred" :position :sales] 121 | [:employee :id 8 :name "Brenda" :position :sales] 122 | [:employee :id 9 :name "Miki" :position :project-management] 123 | [:employee :id 10 :name "Albert" :position :technician] 124 | 125 | [:boss :employee-id 2 :boss-id 1] 126 | [:boss :employee-id 3 :boss-id 2] 127 | [:boss :employee-id 4 :boss-id 1] 128 | [:boss :employee-id 5 :boss-id 4] 129 | [:boss :employee-id 6 :boss-id 4] 130 | [:boss :employee-id 7 :boss-id 1] 131 | [:boss :employee-id 8 :boss-id 7] 132 | [:boss :employee-id 9 :boss-id 1] 133 | [:boss :employee-id 10 :boss-id 6] 134 | 135 | [:can-do-job :position :boss :job :management] 136 | [:can-do-job :position :accountant :job :accounting] 137 | [:can-do-job :position :chief-accountant :job :accounting] 138 | [:can-do-job :position :programmer :job :programming] 139 | [:can-do-job :position :chief-programmer :job :programming] 140 | [:can-do-job :position :technician :job :server-support] 141 | [:can-do-job :position :sales :job :sales] 142 | [:can-do-job :position :project-management :job :project-management] 143 | 144 | [:job-replacement :job :pc-support :can-be-done-by :server-support] 145 | [:job-replacement :job :pc-support :can-be-done-by :programming] 146 | [:job-replacement :job :payroll :can-be-done-by :accounting] 147 | 148 | [:job-exceptions :id 4 :job :pc-support])) 149 | 150 | (def rules 151 | (rules-set 152 | (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) 153 | (:employee :id ?e-id :name ?x) 154 | (:employee :id ?b-id :name ?y)) 155 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 156 | (:works-for :employee ?z :boss ?y)) 157 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 158 | (:can-do-job :position ?pos :job ?y)) 159 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 160 | (:employee-job* :employee ?x :job ?z)) 161 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 162 | (:employee :name ?x :position ?z) 163 | (if = ?z :boss)) 164 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 165 | (:employee :id ?id :name ?x) 166 | (not! :job-exceptions :id ?id :job ?y)) 167 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 168 | (not! :employee-job :employee ?y :job :pc-support)))) 169 | 170 | 171 | (def ws-1 (build-soft-strat-work-plan rules (?- :works-for :employee '??name :boss ?x))) 172 | (defn evaluate-1 [name] (set (evaluate-soft-work-set ws-1 db {'??name name}))) 173 | 174 | (deftest test-ws-1 175 | (is (= (evaluate-1 "Albert") 176 | #{{:employee "Albert", :boss "Li"} 177 | {:employee "Albert", :boss "Sameer"} 178 | {:employee "Albert", :boss "Bob"}})) 179 | (is (empty? (evaluate-1 "Bob"))) 180 | (is (= (evaluate-1 "John") 181 | #{{:employee "John", :boss "Bob"} 182 | {:employee "John", :boss "Mary"}}))) 183 | 184 | 185 | (def ws-2 (build-soft-strat-work-plan rules (?- :employee-job :employee '??name :job ?x))) 186 | (defn evaluate-2 [name] (set (evaluate-soft-work-set ws-2 db {'??name name}))) 187 | 188 | (deftest test-ws-2 189 | (is (= (evaluate-2 "Albert") 190 | #{{:employee "Albert", :job :pc-support} 191 | {:employee "Albert", :job :server-support}})) 192 | (is (= (evaluate-2 "Sameer") 193 | #{{:employee "Sameer", :job :programming}})) 194 | (is (= (evaluate-2 "Bob") 195 | #{{:employee "Bob", :job :accounting} 196 | {:employee "Bob", :job :management} 197 | {:employee "Bob", :job :payroll} 198 | {:employee "Bob", :job :pc-support} 199 | {:employee "Bob", :job :project-management} 200 | {:employee "Bob", :job :programming} 201 | {:employee "Bob", :job :server-support} 202 | {:employee "Bob", :job :sales}}))) 203 | 204 | (def ws-3 (build-soft-strat-work-plan rules (?- :bj :name '??name :boss ?x))) 205 | (defn evaluate-3 [name] (set (evaluate-soft-work-set ws-3 db {'??name name}))) 206 | 207 | (deftest test-ws-3 208 | (is (= (evaluate-3 "Albert") 209 | #{{:name "Albert", :boss "Sameer"}}))) 210 | 211 | (def ws-4 (build-soft-strat-work-plan rules (?- :works-for :name ?x :boss ?x))) 212 | 213 | (deftest test-ws-4 214 | (is (= (set (evaluate-soft-work-set ws-4 db {})) 215 | #{{:employee "Miki", :boss "Bob"} 216 | {:employee "Albert", :boss "Li"} 217 | {:employee "Lilian", :boss "Sameer"} 218 | {:employee "Li", :boss "Bob"} 219 | {:employee "Lilian", :boss "Bob"} 220 | {:employee "Brenda", :boss "Fred"} 221 | {:employee "Fred", :boss "Bob"} 222 | {:employee "John", :boss "Bob"} 223 | {:employee "John", :boss "Mary"} 224 | {:employee "Albert", :boss "Sameer"} 225 | {:employee "Sameer", :boss "Bob"} 226 | {:employee "Albert", :boss "Bob"} 227 | {:employee "Brenda", :boss "Bob"} 228 | {:employee "Mary", :boss "Bob"} 229 | {:employee "Li", :boss "Sameer"}}))) 230 | 231 | (comment 232 | (run-tests) 233 | ) 234 | 235 | ;; End of file 236 | -------------------------------------------------------------------------------- /test/clojure/bacwn/test/impl/test_util.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and 2 | ;; distribution terms for this software are covered by the Eclipse Public 3 | ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can 4 | ;; be found in the file epl-v10.html at the root of this distribution. By 5 | ;; using this software in any fashion, you are agreeing to be bound by the 6 | ;; terms of this license. You must not remove this notice, or any other, 7 | ;; from this software. 8 | ;; 9 | ;; test-util.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog -- Utilities Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 11 Feburary 2009 15 | 16 | (ns bacwn.test.impl.test-util 17 | (:use clojure.test 18 | fogus.datalog.bacwn.impl.util)) 19 | 20 | (deftest test-is-var? 21 | (is (is-var? '?x)) 22 | (is (is-var? '?)) 23 | (is (not (is-var? '??x))) 24 | (is (not (is-var? '??))) 25 | (is (not (is-var? 'x))) 26 | (is (not (is-var? "fred"))) 27 | (is (not (is-var? :q)))) 28 | 29 | (deftest test-map-values 30 | (let [map {:fred 1 :sally 2}] 31 | (is (= (map-values #(* 2 %) map) {:fred 2 :sally 4})) 32 | (is (= (map-values identity {}) {})))) 33 | 34 | (deftest test-keys-to-vals 35 | (let [map {:fred 1 :sally 2 :joey 3}] 36 | (is (= (set (keys-to-vals map [:fred :sally])) #{1 2})) 37 | (is (= (set (keys-to-vals map [:fred :sally :becky])) #{1 2})) 38 | (is (empty? (keys-to-vals map []))) 39 | (is (empty? (keys-to-vals {} [:fred]))))) 40 | 41 | (deftest test-reverse-map 42 | (let [map {:fred 1 :sally 2 :joey 3} 43 | map-1 (assoc map :mary 3)] 44 | (is (= (reverse-map map) {1 :fred 2 :sally 3 :joey})) 45 | (is (or (= (reverse-map map-1) {1 :fred 2 :sally 3 :joey}) 46 | (= (reverse-map map-1) {1 :fred 2 :sally 3 :mary}))))) 47 | 48 | (def some-maps 49 | [ 50 | { :a 1 :b 2 } 51 | { :c 3 :b 3 } 52 | { :d 4 :a 1 } 53 | { :g 4 :b 4 } 54 | { :a 2 :b 1 } 55 | { :e 1 :f 1 } 56 | ]) 57 | 58 | (def preduced (preduce + some-maps)) 59 | (def merged (apply merge-with + some-maps)) 60 | 61 | (deftest test-preduce 62 | (is (= preduced merged))) 63 | 64 | (comment 65 | (run-tests) 66 | ) 67 | 68 | ; End of file 69 | -------------------------------------------------------------------------------- /thoughts.org: -------------------------------------------------------------------------------- 1 | * Bacwn 2 | 3 | /Bacwn is a simple Datalog engine for Clojure./ 4 | 5 | ** Goals 6 | 7 | - Instructive codebase (learn and teach) 8 | - CLJS 9 | 10 | ** References / Influences 11 | 12 | - L44k stratification paper 13 | 14 | ** Tasks 15 | 16 | *** TODO Get CLJS dev env working 17 | *** TODO Make work with CLJS 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | --------------------------------------------------------------------------------