├── .gitignore ├── README.md ├── project.clj ├── src └── datalog │ ├── database.clj │ ├── datalog.clj │ ├── example.clj │ ├── graph.clj │ ├── literals.clj │ ├── magic.clj │ ├── rules.clj │ ├── softstrat.clj │ └── util.clj └── test └── datalog ├── test_database.clj ├── test_graph.clj ├── test_literals.clj ├── test_magic.clj ├── test_rules.clj ├── test_softstrat.clj └── test_util.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | .lein-deps-sum 9 | .lein-failures 10 | .lein-plugins 11 | *~ 12 | 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # datalog 2 | 3 | Bringing clojure.contrib.datalog back to life. 4 | 5 | As in running nicely on 1.4, and following "modern" conventions. 6 | 7 | Used as a play pen for disk based (non in-memory) database queries. 8 | 9 | Check out [wiki] (https://github.com/martintrojer/datalog/wiki) for more info 10 | 11 | ## Usage 12 | 13 | * add `[datalog "0.1.1"]` to `:dependencies` in your project.clj 14 | 15 | * [example.clj] (https://github.com/martintrojer/datalog/blob/master/src/datalog/example.clj) 16 | 17 | * lein test 18 | 19 | ## License 20 | 21 | Copyright © 2012 Martin Trojer 22 | 23 | Distributed under the Eclipse Public License, the same as Clojure. 24 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject datalog "0.1.1" 2 | :description "contrib.datalog brought back to life" 3 | :url "https://github.com/martintrojer/datalog" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.6.0"]]) 7 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.database 19 | (:use [datalog.util]) 20 | (:use [clojure.set :only (union intersection difference)])) 21 | 22 | (defrecord Relation 23 | [schema ; A set of key names 24 | data ; A set of tuples 25 | indexes]) ; A map key names to indexes (in turn a map of value to tuples) 26 | 27 | ;;; DDL 28 | 29 | (defmethod print-method ::datalog-database 30 | [db ^java.io.Writer writer] 31 | (binding [*out* writer] 32 | (do 33 | (println "(datalog-database") 34 | (println "{") 35 | (doseq [key (keys db)] 36 | (println) 37 | (println key) 38 | (print-method (db key) writer)) 39 | (println "})")))) 40 | 41 | (defn datalog-database 42 | [rels] 43 | (with-meta rels {:type ::datalog-database})) 44 | 45 | (def empty-database (datalog-database {})) 46 | 47 | (defmethod print-method ::datalog-relation 48 | [rel ^java.io.Writer writer] 49 | (binding [*out* writer] 50 | (do 51 | (println "(datalog-relation") 52 | (println " ;; Schema") 53 | (println " " (:schema rel)) 54 | (println) 55 | (println " ;; Data") 56 | (println " #{") 57 | (doseq [tuple (:data rel)] 58 | (println " " tuple)) 59 | (println " }") 60 | (println) 61 | (println " ;; Indexes") 62 | (println " {") 63 | (doseq [key (-> rel :indexes keys)] 64 | (println " " key) 65 | (println " {") 66 | (doseq [val (keys ((:indexes rel) key))] 67 | (println " " val) 68 | (println " " (get-in rel [:indexes key val]))) 69 | (println " }")) 70 | (println " })")))) 71 | 72 | (defn datalog-relation 73 | "Creates a relation" 74 | [schema data indexes] 75 | (with-meta (->Relation schema data indexes) {:type ::datalog-relation})) 76 | 77 | (defn add-relation 78 | "Adds a relation to the database" 79 | [db name keys] 80 | (assoc db name (datalog-relation (set keys) #{} {}))) 81 | 82 | (defn add-index 83 | "Adds an index to an empty relation named name" 84 | [db name key] 85 | (assert (empty? (:data (db name)))) 86 | (let [rel (db name) 87 | inx (assoc (:indexes rel) key {})] 88 | (assoc db name (datalog-relation (:schema rel) 89 | (:data rel) 90 | inx)))) 91 | 92 | (defn ensure-relation 93 | "If the database lacks the named relation, add it" 94 | [db name keys indexes] 95 | (if-let [rel (db name)] 96 | (do 97 | (assert (= (:schema rel) (set keys))) 98 | db) 99 | (let [db1 (add-relation db name keys)] 100 | (reduce (fn [db key] (add-index db name key)) 101 | db1 102 | indexes)))) 103 | 104 | (defmacro make-database 105 | "Makes a database, like this 106 | (make-database 107 | (relation :fred [:mary :sue]) 108 | (index :fred :mary) 109 | (relation :sally [:jen :becky]) 110 | (index :sally :jen) 111 | (index :sally :becky))" 112 | [& commands] 113 | (let [wrapper (fn [cur new] 114 | (let [cmd (first new) 115 | body (next new)] 116 | (assert (= 2 (count body))) 117 | (cond 118 | (= cmd 'relation) 119 | `(add-relation ~cur ~(first body) ~(fnext body)) 120 | (= cmd 'index) 121 | `(add-index ~cur ~(first body) ~(fnext body)) 122 | :otherwise (throw (Exception. (str new "not recognized"))))))] 123 | (reduce wrapper `empty-database commands))) 124 | 125 | (defn get-relation 126 | "Get a relation object by name" 127 | [db rel-name] 128 | (db rel-name)) 129 | 130 | (defn replace-relation 131 | "Add or replace a fully constructed relation object to the database." 132 | [db rel-name rel] 133 | (assoc db rel-name rel)) 134 | 135 | ;;; DML 136 | 137 | (defn database-counts 138 | "Returns a map with the count of elements in each relation." 139 | [db] 140 | (map-values #(-> % :data count) db)) 141 | 142 | (defn- modify-indexes 143 | "Perform f on the indexed tuple-set. f should take a set and tuple, 144 | and return the new set." 145 | [idxs tuple f] 146 | (into {} (for [ik (keys idxs)] 147 | (let [im (idxs ik) 148 | iv (tuple ik) 149 | os (get im iv #{}) 150 | ns (f os tuple)] 151 | [ik (if (empty? ns) 152 | (dissoc im iv) 153 | (assoc im iv (f os tuple)))])))) 154 | 155 | (defn- add-to-indexes 156 | "Adds the tuple to the appropriate keys in the index map" 157 | [idxs tuple] 158 | (modify-indexes idxs tuple conj)) 159 | 160 | (defn- remove-from-indexes 161 | "Removes the tuple from the appropriate keys in the index map" 162 | [idxs tuple] 163 | (modify-indexes idxs tuple disj)) 164 | 165 | (defn add-tuple 166 | "Two forms: 167 | 168 | [db relation-name tuple] adds tuple to the named relation. Returns 169 | the new database. 170 | 171 | [rel tuple] adds to the relation object. Returns the new relation." 172 | ([db rel-name tuple] 173 | (assert (= (-> tuple keys set) (-> rel-name db :schema))) 174 | (assoc db rel-name (add-tuple (db rel-name) tuple))) 175 | ([rel tuple] 176 | (let [data (:data rel) 177 | new-data (conj data tuple)] 178 | (if (identical? data new-data) ; optimization hack! 179 | rel 180 | (let [idxs (add-to-indexes (:indexes rel) tuple)] 181 | (assoc rel :data new-data :indexes idxs)))))) 182 | 183 | (defn remove-tuple 184 | "Two forms: 185 | 186 | [db relation-name tuple] removes the tuple from the named relation, 187 | returns a new database. 188 | 189 | [rel tuple] removes the tuple from the relation. Returns the new 190 | relation." 191 | ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) 192 | ([rel tuple] 193 | (let [data (:data rel) 194 | new-data (disj data tuple)] 195 | (if (identical? data new-data) 196 | rel 197 | (let [idxs (remove-from-indexes (:indexes rel) tuple)] 198 | (assoc rel :data new-data :indexes idxs)))))) 199 | 200 | (defn add-tuples 201 | "Adds a collection of tuples to the db, as 202 | (add-tuples db 203 | [:rel-name :key-1 1 :key-2 2] 204 | [:rel-name :key-1 2 :key-2 3])" 205 | [db & tupls] 206 | (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) 207 | 208 | (defn- find-indexes 209 | "Given a map of indexes and a partial tuple, return the sets of full tuples" 210 | [idxs pt] 211 | (if (empty? idxs) 212 | nil 213 | (filter identity (for [key (keys pt)] 214 | (if-let [idx-map (idxs key)] 215 | (get idx-map (pt key) #{}) 216 | nil))))) 217 | 218 | (defn- match? 219 | "Is m2 contained in m1?" 220 | [m1 m2] 221 | (let [compare (fn [key] 222 | (and (contains? m1 key) 223 | (= (m1 key) (m2 key))))] 224 | (every? compare (keys m2)))) 225 | 226 | (defn- scan-space 227 | "Computes a stream of tuples from relation rn matching partial tuple (pt) 228 | and applies fun to each" 229 | [fun db rn pt] 230 | (let [rel (db rn) 231 | idxs (find-indexes (:indexes rel) pt) 232 | space (if (empty? idxs) 233 | (:data rel) ; table scan :( 234 | (reduce intersection idxs))] 235 | (trace-datalog (when (empty? idxs) 236 | (println (format "Table scan of %s: %s rows!!!!!" 237 | rn 238 | (count space))))) 239 | (fun #(match? % pt) space))) 240 | 241 | (defn select 242 | "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" 243 | [db rn pt] 244 | (scan-space filter db rn pt)) 245 | 246 | (defn any-match? 247 | "Finds if there are any matching records for the partial tuple" 248 | [db rn pt] 249 | (if (= (-> pt keys set) (:schema (db rn))) 250 | (contains? (:data (db rn)) pt) 251 | (scan-space some db rn pt))) 252 | 253 | 254 | ;;; Merge 255 | 256 | (defn merge-indexes 257 | [idx1 idx2] 258 | (merge-with (fn [h1 h2] (merge-with union h1 h2)) idx1 idx2)) 259 | 260 | (defn merge-relations 261 | "Merges two relations" 262 | [r1 r2] 263 | (assert (= (:schema r1) (:schema r2))) 264 | (let [merged-indexes (merge-indexes (:indexes r1) 265 | (:indexes r2)) 266 | merged-data (union (:data r1) 267 | (:data r2))] 268 | (assoc r1 :data merged-data :indexes merged-indexes))) 269 | 270 | (defn database-merge 271 | "Merges databases together" 272 | [dbs] 273 | (apply merge-with merge-relations dbs)) 274 | 275 | (defn database-merge-parallel 276 | "Merges databases together in parallel" 277 | [dbs] 278 | (preduce merge-relations dbs)) 279 | -------------------------------------------------------------------------------- /src/datalog/datalog.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 | ;; datalog.clj 10 | ;; 11 | ;; A Clojure implementation of Datalog 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 2 March 2009 15 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | ;; ============================= 19 | ;; Please see the example.clj 20 | 21 | (ns ^{:author "Jeffrey Straszheim", 22 | :doc "A Clojure implementation of Datalog"} 23 | datalog.datalog 24 | (:use [datalog.rules] 25 | [datalog.softstrat] 26 | [datalog.database]) 27 | (:use [clojure.set :only (intersection)])) 28 | 29 | (defrecord WorkPlan 30 | [work-plan ; The underlying structure 31 | rules ; The original rules 32 | query ; The original query 33 | work-plan-type]) ; The type of plan 34 | 35 | (defn- validate-work-plan 36 | "Ensure any top level semantics are not violated" 37 | [work-plan database] 38 | (let [common-relations (-> work-plan :rules (intersection (-> database keys set)))] 39 | (when (-> common-relations 40 | empty? 41 | not) 42 | (throw (Exception. (str "The rules and database define the same relation(s):" common-relations)))))) 43 | 44 | (defn build-work-plan 45 | "Given a list of rules and a query, build a work plan that can be 46 | used to execute the query." 47 | [rules query] 48 | (->WorkPlan (build-soft-strat-work-plan rules query) rules query ::soft-stratified)) 49 | 50 | (defn run-work-plan 51 | "Given a work plan, a database, and some query bindings, run the 52 | work plan and return the results." 53 | [work-plan database query-bindings] 54 | (validate-work-plan work-plan database) 55 | (evaluate-soft-work-set (:work-plan work-plan) database query-bindings)) 56 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.example 19 | (:use [datalog.datalog :only (build-work-plan run-work-plan)] 20 | [datalog.rules :only (<- ?- rules-set)] 21 | [datalog.database :only (make-database add-tuples)] 22 | [datalog.util :only (*trace-datalog*)])) 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) (:boss :employee-id ?e-id :boss-id ?b-id) 81 | (:employee :id ?e-id :name ?x) 82 | (:employee :id ?b-id :name ?y)) 83 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 84 | (:works-for :employee ?z :boss ?y)) 85 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 86 | (:can-do-job :position ?pos :job ?y)) 87 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 88 | (:employee-job* :employee ?x :job ?z)) 89 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 90 | (:employee :name ?x :position ?z) 91 | (if = ?z :boss)) 92 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 93 | (:employee :id ?id :name ?x) 94 | (not! :job-exceptions :id ?id :job ?y)) 95 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 96 | (not! :employee-job :employee ?y :job :pc-support)))) 97 | 98 | (def wp-1 (build-work-plan rules (?- :works-for :employee '??name :boss ?x))) 99 | (run-work-plan wp-1 db {'??name "Albert"}) 100 | ;;({:boss "Li", :employee "Albert"} {:boss "Sameer", :employee "Albert"} {:boss "Bob", :employee "Albert"}) 101 | 102 | (def wp-2 (build-work-plan rules (?- :employee-job :employee '??name :job ?x))) 103 | (binding [*trace-datalog* true] 104 | (run-work-plan wp-2 db {'??name "Li"})) 105 | ;; ({:job :server-support, :employee "Li"} {:job :pc-support, :employee "Li"}) 106 | 107 | (def wp-3 (build-work-plan rules (?- :bj :name '??name :boss ?x))) 108 | (run-work-plan wp-3 db {'??name "Albert"}) 109 | ;; ({:boss "Sameer", :name "Albert"}) 110 | 111 | (def wp-4 (build-work-plan rules (?- :works-for :employee ?x :boss ?y))) 112 | (run-work-plan wp-4 db {}) 113 | ;; ({: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"}) 114 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; This was clojure.contrib.graph 17 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 18 | 19 | (ns 20 | ^{:author "Jeffrey Straszheim", 21 | :doc "Basic graph theory algorithms"} 22 | datalog.graph 23 | (:use [clojure.set :only (union)])) 24 | 25 | (defrecord DirectedGraph 26 | [nodes ; The nodes of the graph, a collection 27 | neighbors]) ; A function that, given a node returns a collection neighbor nodes. 28 | 29 | (defn get-neighbors 30 | "Get the neighbors of a node." 31 | [g n] 32 | ((:neighbors g) n)) 33 | 34 | ;; ============================= 35 | ;; Graph Modification 36 | 37 | (defn reverse-graph 38 | "Given a directed graph, return another directed graph with the 39 | order of the edges reversed." 40 | [g] 41 | (let [op (fn [rna idx] 42 | (let [ns (get-neighbors g idx) 43 | am (fn [m val] 44 | (assoc m val (conj (get m val #{}) idx)))] 45 | (reduce am rna ns))) 46 | rn (reduce op {} (:nodes g))] 47 | (->DirectedGraph (:nodes g) rn))) 48 | 49 | (defn add-loops 50 | "For each node n, add the edge n->n if not already present." 51 | [g] 52 | (->DirectedGraph 53 | (:nodes g) 54 | (into {} (map (fn [n] 55 | [n (conj (set (get-neighbors g n)) n)]) (:nodes g))))) 56 | 57 | (defn remove-loops 58 | "For each node n, remove any edges n->n." 59 | [g] 60 | (->DirectedGraph 61 | (:nodes g) 62 | (into {} (map (fn [n] 63 | [n (disj (set (get-neighbors g n)) n)]) (:nodes g))))) 64 | 65 | ;; ============================= 66 | ;; Graph Walk 67 | 68 | (defn lazy-walk 69 | "Return a lazy sequence of the nodes of a graph starting a node n. Optionally, 70 | provide a set of visited notes (v) and a collection of nodes to 71 | visit (ns)." 72 | ([g n] 73 | (lazy-walk g [n] #{})) 74 | ([g ns v] 75 | (lazy-seq (let [s (seq (drop-while v ns)) 76 | n (first s) 77 | ns (rest s)] 78 | (when s 79 | (cons n (lazy-walk g (concat (get-neighbors g n) ns) (conj v n)))))))) 80 | 81 | (defn transitive-closure 82 | "Returns the transitive closure of a graph. The neighbors are lazily computed. 83 | 84 | Note: some version of this algorithm return all edges a->a 85 | regardless of whether such loops exist in the original graph. This 86 | version does not. Loops will be included only if produced by 87 | cycles in the graph. If you have code that depends on such 88 | behavior, call (-> g transitive-closure add-loops)" 89 | [g] 90 | (let [nns (fn [n] 91 | [n (delay (lazy-walk g (get-neighbors g n) #{}))]) 92 | nbs (into {} (map nns (:nodes g)))] 93 | (->DirectedGraph 94 | (:nodes g) 95 | (fn [n] (force (nbs n)))))) 96 | 97 | ;; ============================= 98 | ;; Strongly Connected Components 99 | 100 | (defn- post-ordered-visit 101 | "Starting at node n, perform a post-ordered walk." 102 | [g n [visited acc :as state]] 103 | (if (visited n) 104 | state 105 | (let [[v2 acc2] (reduce (fn [st nd] (post-ordered-visit g nd st)) 106 | [(conj visited n) acc] 107 | (get-neighbors g n))] 108 | [v2 (conj acc2 n)]))) 109 | 110 | (defn post-ordered-nodes 111 | "Return a sequence of indexes of a post-ordered walk of the graph." 112 | [g] 113 | (fnext (reduce #(post-ordered-visit g %2 %1) 114 | [#{} []] 115 | (:nodes g)))) 116 | 117 | (defn scc 118 | "Returns, as a sequence of sets, the strongly connected components 119 | of g." 120 | [g] 121 | (let [po (reverse (post-ordered-nodes g)) 122 | rev (reverse-graph g) 123 | step (fn [stack visited acc] 124 | (if (empty? stack) 125 | acc 126 | (let [[nv comp] (post-ordered-visit rev 127 | (first stack) 128 | [visited #{}]) 129 | ns (remove nv stack)] 130 | (recur ns nv (conj acc comp)))))] 131 | (step po #{} []))) 132 | 133 | (defn component-graph 134 | "Given a graph, perhaps with cycles, return a reduced graph that is acyclic. 135 | Each node in the new graph will be a set of nodes from the old. 136 | These sets are the strongly connected components. Each edge will 137 | be the union of the corresponding edges of the prior graph." 138 | ([g] 139 | (component-graph g (scc g))) 140 | ([g sccs] 141 | (let [find-node-set (fn [n] 142 | (some #(if (% n) % nil) sccs)) 143 | find-neighbors (fn [ns] 144 | (let [nbs1 (map (partial get-neighbors g) ns) 145 | nbs2 (map set nbs1) 146 | nbs3 (apply union nbs2)] 147 | (set (map find-node-set nbs3)))) 148 | nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))] 149 | (->DirectedGraph (set sccs) nm)))) 150 | 151 | (defn recursive-component? 152 | "Is the component (recieved from scc) self recursive?" 153 | [g ns] 154 | (or (> (count ns) 1) 155 | (let [n (first ns)] 156 | (some #(= % n) (get-neighbors g n))))) 157 | 158 | (defn self-recursive-sets 159 | "Returns, as a sequence of sets, the components of a graph that are 160 | self-recursive." 161 | [g] 162 | (filter (partial recursive-component? g) (scc g))) 163 | 164 | ;; ============================= 165 | ;; Dependency Lists 166 | 167 | (defn fixed-point 168 | "Repeatedly apply fun to data until (equal old-data new-data) 169 | returns true. If max iterations occur, it will throw an 170 | exception. Set max to nil for unlimited iterations." 171 | [data fun max equal] 172 | (let [step (fn step [data idx] 173 | (when (and idx (= 0 idx)) 174 | (throw (Exception. "Fixed point overflow"))) 175 | (let [new-data (fun data)] 176 | (if (equal data new-data) 177 | new-data 178 | (recur new-data (and idx (dec idx))))))] 179 | (step data max))) 180 | 181 | (defn- fold-into-sets 182 | [priorities] 183 | (let [max (inc (apply max 0 (vals priorities))) 184 | step (fn [acc [n dep]] 185 | (assoc acc dep (conj (acc dep) n)))] 186 | (reduce step 187 | (vec (replicate max #{})) 188 | priorities))) 189 | 190 | (defn dependency-list 191 | "Similar to a topological sort, this returns a vector of sets. The 192 | set of nodes at index 0 are independent. The set at index 1 depend 193 | on index 0; those at 2 depend on 0 and 1, and so on. Those withing 194 | a set have no mutual dependencies. Assume the input graph (which 195 | much be acyclic) has an edge a->b when a depends on b." 196 | [g] 197 | (let [step (fn [d] 198 | (let [update (fn [n] 199 | (inc (apply max -1 (map d (get-neighbors g n)))))] 200 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 201 | counts (fixed-point (zipmap (:nodes g) (repeat 0)) 202 | step 203 | (inc (count (:nodes g))) 204 | =)] 205 | (fold-into-sets counts))) 206 | 207 | (defn stratification-list 208 | "Similar to dependency-list (see doc), except two graphs are 209 | provided. The first is as dependency-list. The second (which may 210 | have cycles) provides a partial-dependency relation. If node a 211 | depends on node b (meaning an edge a->b exists) in the second 212 | graph, node a must be equal or later in the sequence." 213 | [g1 g2] 214 | (assert (= (-> g1 :nodes set) (-> g2 :nodes set))) 215 | (let [step (fn [d] 216 | (let [update (fn [n] 217 | (max (inc (apply max -1 218 | (map d (get-neighbors g1 n)))) 219 | (apply max -1 (map d (get-neighbors g2 n)))))] 220 | (into {} (map (fn [[k v]] [k (update k)]) d)))) 221 | counts (fixed-point (zipmap (:nodes g1) (repeat 0)) 222 | step 223 | (inc (count (:nodes g1))) 224 | =)] 225 | (fold-into-sets counts))) 226 | 227 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.literals 19 | (:use [datalog.util] 20 | [datalog.database]) 21 | (:use [clojure.set :only (intersection subset?)])) 22 | 23 | ;; ============================= 24 | ;; Type Definitions 25 | 26 | (defrecord AtomicLiteral 27 | [predicate ; The predicate name 28 | term-bindings ; A map of column names to bindings 29 | literal-type]) ; ::literal or ::negated 30 | 31 | (derive ::negated ::literal) 32 | 33 | (defrecord ConditionalLiteral 34 | [fun ; The fun to call 35 | symbol ; The fun symbol (for display) 36 | terms ; The formal arguments 37 | literal-type]) ; ::conditional 38 | 39 | ;; ============================= 40 | ;; Basics 41 | 42 | (defmulti literal-predicate 43 | "Return the predicate/relation this conditional operates over" 44 | :literal-type) 45 | 46 | (defmulti literal-columns 47 | "Return the column names this applies to" 48 | :literal-type) 49 | 50 | (defmulti literal-vars 51 | "Returns the logic vars used by this literal" 52 | :literal-type) 53 | 54 | (defmulti positive-vars 55 | "Returns the logic vars used in a positive position" 56 | :literal-type) 57 | 58 | (defmulti negative-vars 59 | "Returns the logic vars used in a negative position" 60 | :literal-type) 61 | 62 | (defmethod literal-predicate ::literal 63 | [l] 64 | (:predicate l)) 65 | 66 | (defmethod literal-predicate ::conditional 67 | [l] 68 | nil) 69 | 70 | (defmethod literal-columns ::literal 71 | [l] 72 | (-> l :term-bindings keys set)) 73 | 74 | (defmethod literal-columns ::conditional 75 | [l] 76 | nil) 77 | 78 | (defmethod literal-vars ::literal 79 | [l] 80 | (set (filter is-var? (-> l :term-bindings vals)))) 81 | 82 | (defmethod literal-vars ::conditional 83 | [l] 84 | (set (filter is-var? (:terms l)))) 85 | 86 | (defmethod positive-vars ::literal 87 | [l] 88 | (literal-vars l)) 89 | 90 | (defmethod positive-vars ::negated 91 | [l] 92 | nil) 93 | 94 | (defmethod positive-vars ::conditional 95 | [l] 96 | nil) 97 | 98 | (defmethod negative-vars ::literal 99 | [l] 100 | nil) 101 | 102 | (defmethod negative-vars ::negated 103 | [l] 104 | (literal-vars l)) 105 | 106 | (defmethod negative-vars ::conditional 107 | [l] 108 | (literal-vars l)) 109 | 110 | (defn negated? 111 | "Is this literal a negated literal?" 112 | [l] 113 | (= (:literal-type l) ::negated)) 114 | 115 | (defn positive? 116 | "Is this a positive literal?" 117 | [l] 118 | (= (:literal-type l) ::literal)) 119 | 120 | ;; ============================= 121 | ;; Building Literals 122 | 123 | (def negation-symbol 'not!) 124 | (def conditional-symbol 'if) 125 | 126 | (defmulti build-literal 127 | "(Returns an unevaluated expression (to be used in macros) of a 128 | literal." 129 | first) 130 | 131 | (defn build-atom 132 | "Returns an unevaluated expression (to be used in a macro) of an 133 | atom." 134 | [f type] 135 | (let [p (first f) 136 | ts (map #(if (is-var? %) `(quote ~%) %) (next f)) 137 | b (if (seq ts) (apply assoc {} ts) nil)] 138 | `(->AtomicLiteral ~p ~b ~type))) 139 | 140 | (defmethod build-literal :default 141 | [f] 142 | (build-atom f ::literal)) 143 | 144 | (defmethod build-literal negation-symbol 145 | [f] 146 | (build-atom (rest f) ::negated)) 147 | 148 | (defmethod build-literal conditional-symbol 149 | [f] 150 | (let [symbol (fnext f) 151 | terms (nnext f) 152 | fun `(fn [binds#] (apply ~symbol binds#))] 153 | `(->ConditionalLiteral 154 | ~fun 155 | '~symbol 156 | '~terms 157 | ::conditional))) 158 | 159 | ;; ============================= 160 | ;; Display 161 | 162 | (defmulti display-literal 163 | "Converts a struct representing a literal to a normal list" 164 | :literal-type) 165 | 166 | (defn- display 167 | [l] 168 | (conj (-> l :term-bindings list* flatten) (literal-predicate l))) 169 | 170 | (defmethod display-literal ::literal 171 | [l] 172 | (display l)) 173 | 174 | (defmethod display-literal ::negated 175 | [l] 176 | (conj (display l) negation-symbol)) 177 | 178 | (defmethod display-literal ::conditional 179 | [l] 180 | (list* conditional-symbol (:symbol l) (:terms l))) 181 | 182 | ;; ============================= 183 | ;; Sip computation 184 | 185 | (defmulti get-vs-from-cs 186 | "From a set of columns, return the vars" 187 | :literal-type) 188 | 189 | (defmethod get-vs-from-cs ::literal 190 | [l bound] 191 | (set (filter is-var? 192 | (vals (select-keys (:term-bindings l) 193 | bound))))) 194 | 195 | (defmethod get-vs-from-cs ::conditional 196 | [l bound] 197 | nil) 198 | 199 | (defmulti get-cs-from-vs 200 | "From a set of vars, get the columns" 201 | :literal-type) 202 | 203 | (defmethod get-cs-from-vs ::literal 204 | [l bound] 205 | (reduce conj 206 | #{} 207 | (remove nil? 208 | (map (fn [[k v]] (if (bound v) k nil)) 209 | (:term-bindings l))))) 210 | 211 | (defmethod get-cs-from-vs ::conditional 212 | [l bound] 213 | nil) 214 | 215 | (defmulti get-self-bound-cs 216 | "Get the columns that are bound withing the literal." 217 | :literal-type) 218 | 219 | (defmethod get-self-bound-cs ::literal 220 | [l] 221 | (reduce conj 222 | #{} 223 | (remove nil? 224 | (map (fn [[k v]] (if (not (is-var? v)) k nil)) 225 | (:term-bindings l))))) 226 | 227 | (defmethod get-self-bound-cs ::conditional 228 | [l] 229 | nil) 230 | 231 | (defmulti literal-appropriate? 232 | "When passed a set of bound vars, determines if this literal can be 233 | used during this point of a SIP computation." 234 | (fn [b l] (:literal-type l))) 235 | 236 | (defmethod literal-appropriate? ::literal 237 | [bound l] 238 | (not (empty? (intersection (literal-vars l) bound)))) 239 | 240 | (defmethod literal-appropriate? ::negated 241 | [bound l] 242 | (subset? (literal-vars l) bound)) 243 | 244 | (defmethod literal-appropriate? ::conditional 245 | [bound l] 246 | (subset? (literal-vars l) bound)) 247 | 248 | (defmulti adorned-literal 249 | "When passed a set of bound columns, returns the adorned literal" 250 | (fn [l b] (:literal-type l))) 251 | 252 | (defmethod adorned-literal ::literal 253 | [l bound] 254 | (let [pred (literal-predicate l) 255 | bnds (intersection (literal-columns l) bound)] 256 | (if (empty? bound) 257 | l 258 | (assoc l :predicate {:pred pred :bound bnds})))) 259 | 260 | (defmethod adorned-literal ::conditional 261 | [l bound] 262 | l) 263 | 264 | (defn get-adorned-bindings 265 | "Get the bindings from this adorned literal." 266 | [pred] 267 | (:bound pred)) 268 | 269 | (defn get-base-predicate 270 | "Get the base predicate from this predicate." 271 | [pred] 272 | (if (map? pred) 273 | (:pred pred) 274 | pred)) 275 | 276 | ;; ============================= 277 | ;; Magic Stuff 278 | 279 | (defn magic-literal 280 | "Create a magic version of this adorned predicate." 281 | [l] 282 | (assert (-> l :literal-type (isa? ::literal))) 283 | (let [pred (literal-predicate l) 284 | pred-map (if (map? pred) pred {:pred pred}) 285 | bound (get-adorned-bindings pred) 286 | ntb (select-keys (:term-bindings l) bound)] 287 | (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) 288 | 289 | (defn literal-magic? 290 | "Is this literal magic?" 291 | [lit] 292 | (let [pred (literal-predicate lit)] 293 | (when (map? pred) 294 | (:magic pred)))) 295 | 296 | (defn build-seed-bindings 297 | "Given a seed literal, already adorned and in magic form, convert 298 | its bound constants to new variables." 299 | [s] 300 | (assert (-> s :literal-type (isa? ::literal))) 301 | (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] 302 | (assoc s :term-bindings ntbs))) 303 | 304 | ;; ============================= 305 | ;; Semi-naive support 306 | 307 | (defn negated-literal 308 | "Given a literal l, return a negated version" 309 | [l] 310 | (assert (-> l :literal-type (= ::literal))) 311 | (assoc l :literal-type ::negated)) 312 | 313 | (defn delta-literal 314 | "Given a literal l, return a delta version" 315 | [l] 316 | (let [pred* (:predicate l) 317 | pred (if (map? pred*) pred* {:pred pred*})] 318 | (assoc l :predicate (assoc pred :delta true)))) 319 | 320 | ;; ============================= 321 | ;; Database operations 322 | 323 | (defn- build-partial-tuple 324 | [lit binds] 325 | (let [tbs (:term-bindings lit) 326 | each (fn [[key val :as pair]] 327 | (if (is-var? val) 328 | (if-let [n (binds val)] 329 | [key n] 330 | nil) 331 | pair))] 332 | (into {} (remove nil? (map each tbs))))) 333 | 334 | (defn- project-onto-literal 335 | "Given a literal, and a materialized tuple, return a set of variable 336 | bindings." 337 | [lit tuple] 338 | (let [step (fn [binds [key val]] 339 | (if (and (is-var? val) 340 | (contains? tuple key)) 341 | (assoc binds val (tuple key)) 342 | binds))] 343 | (reduce step {} (:term-bindings lit)))) 344 | 345 | (defn- join-literal* 346 | [db lit bs fun] 347 | (let [each (fn [binds] 348 | (let [pt (build-partial-tuple lit binds)] 349 | (fun binds pt)))] 350 | (when (contains? db (literal-predicate lit)) 351 | (apply concat (map each bs))))) 352 | 353 | (defmulti join-literal 354 | "Given a database (db), a literal (lit) and a seq of bindings (bs), 355 | return a new seq of bindings by joining this literal." 356 | (fn [db lit bs] (:literal-type lit))) 357 | 358 | (defmethod join-literal ::literal 359 | [db lit bs] 360 | (join-literal* db lit bs (fn [binds pt] 361 | (map #(merge binds %) 362 | (map (partial project-onto-literal lit) 363 | (select db (literal-predicate lit) pt)))))) 364 | 365 | (defmethod join-literal ::negated 366 | [db lit bs] 367 | (join-literal* db lit bs (fn [binds pt] 368 | (if (any-match? db (literal-predicate lit) pt) 369 | nil 370 | [binds])))) 371 | 372 | (defmethod join-literal ::conditional 373 | [db lit bs] 374 | (let [each (fn [binds] 375 | (let [resolve (fn [term] 376 | (if (is-var? term) 377 | (binds term) 378 | term)) 379 | args (map resolve (:terms lit))] 380 | (if ((:fun lit) args) 381 | binds 382 | nil)))] 383 | (remove nil? (map each bs)))) 384 | 385 | (defn project-literal 386 | "Project a stream of bindings onto a literal/relation. Returns a new 387 | db." 388 | ([db lit bs] (project-literal db lit bs is-var?)) 389 | ([db lit bs var?] 390 | (assert (= (:literal-type lit) ::literal)) 391 | (let [rel-name (literal-predicate lit) 392 | columns (-> lit :term-bindings keys) 393 | idxs (vec (get-adorned-bindings (literal-predicate lit))) 394 | db1 (ensure-relation db rel-name columns idxs) 395 | rel (get-relation db1 rel-name) 396 | step (fn [rel bindings] 397 | (let [step (fn [t [k v]] 398 | (if (var? v) 399 | (assoc t k (bindings v)) 400 | (assoc t k v))) 401 | tuple (reduce step {} (:term-bindings lit))] 402 | (add-tuple rel tuple)))] 403 | (replace-relation db rel-name (reduce step rel bs))))) 404 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.magic 19 | (:use [datalog.util] 20 | [datalog.literals] 21 | [datalog.rules]) 22 | (:use [clojure.set :only (union intersection difference)])) 23 | 24 | ;; ============================= 25 | ;; Adornment 26 | 27 | (defn adorn-query 28 | "Adorn a query" 29 | [q] 30 | (adorned-literal q (get-self-bound-cs q))) 31 | 32 | (defn adorn-rules-set 33 | "Adorns the given rules-set for the given query. (rs) is a 34 | rules-set, (q) is an adorned query." 35 | [rs q] 36 | (let [i-preds (all-predicates rs) 37 | p-map (predicate-map rs)] 38 | (loop [nrs empty-rules-set ; The rules set being built 39 | needed #{(literal-predicate q)}] 40 | (if (empty? needed) 41 | nrs 42 | (let [pred (first needed) 43 | remaining (disj needed pred) 44 | base-pred (get-base-predicate pred) 45 | bindings (get-adorned-bindings pred) 46 | new-rules (p-map base-pred) 47 | new-adorned-rules (map (partial compute-sip bindings i-preds) 48 | new-rules) 49 | new-nrs (reduce conj nrs new-adorned-rules) 50 | current-preds (all-predicates new-nrs) 51 | not-needed? (fn [pred] 52 | (or (current-preds pred) 53 | (-> pred get-base-predicate i-preds not))) 54 | add-pred (fn [np pred] 55 | (if (not-needed? pred) np (conj np pred))) 56 | add-preds (fn [np rule] 57 | (reduce add-pred np (map literal-predicate (:body rule)))) 58 | new-needed (reduce add-preds remaining new-adorned-rules)] 59 | (recur new-nrs new-needed)))))) 60 | 61 | 62 | ;; ============================= 63 | ;; Magic ! 64 | 65 | (defn seed-relation 66 | "Given a magic form of a query, give back the literal form of its seed 67 | relation" 68 | [q] 69 | (let [pred (-> q literal-predicate get-base-predicate) 70 | bnds (-> q literal-predicate get-adorned-bindings)] 71 | (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) 72 | 73 | (defn seed-rule 74 | "Given an adorned query, give back its seed rule" 75 | [q] 76 | (let [mq (build-seed-bindings (magic-literal q)) 77 | sr (seed-relation mq)] 78 | (build-rule mq [sr]))) 79 | 80 | (defn build-partial-tuple 81 | "Given a query and a set of bindings, build a partial tuple needed 82 | to extract the relation from the database." 83 | [q bindings] 84 | (into {} (remove nil? (map (fn [[k v :as pair]] 85 | (if (is-var? v) 86 | nil 87 | (if (is-query-var? v) 88 | [k (bindings v)] 89 | pair))) 90 | (:term-bindings q))))) 91 | 92 | (defn seed-predicate-for-insertion 93 | "Given a query, return the predicate to use for database insertion." 94 | [q] 95 | (let [seed (-> q seed-rule :body first) 96 | columns (-> seed :term-bindings keys) 97 | new-term-bindings (-> q :term-bindings (select-keys columns))] 98 | (assoc seed :term-bindings new-term-bindings))) 99 | 100 | (defn magic-transform 101 | "Return a magic transformation of an adorned rules-set (rs). The 102 | (i-preds) are the predicates of the intension database. These 103 | default to the predicates within the rules-set." 104 | ([rs] 105 | (magic-transform rs (all-predicates rs))) 106 | ([rs i-preds] 107 | (let [not-duplicate? (fn [l mh bd] 108 | (or (not (empty? bd)) 109 | (not (= (magic-literal l) 110 | mh)))) 111 | xr (fn [rs rule] 112 | (let [head (:head rule) 113 | body (:body rule) 114 | mh (magic-literal head) 115 | answer-rule (build-rule head 116 | (concat [mh] body)) 117 | step (fn [[rs bd] l] 118 | (if (and (i-preds (literal-predicate l)) 119 | (not-duplicate? l mh bd)) 120 | (let [nr (build-rule (magic-literal l) 121 | (concat [mh] bd))] 122 | [(conj rs nr) (conj bd l)]) 123 | [rs (conj bd l)])) 124 | [nrs _] (reduce step [rs []] body)] 125 | (conj nrs answer-rule)))] 126 | (reduce xr empty-rules-set rs)))) 127 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.rules 19 | (:use [datalog.util] 20 | [datalog.literals] 21 | [datalog.database]) 22 | (:use [clojure.set :only (union intersection difference subset?)])) 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 display-literal) 31 | (map display-literal (:body rule)))) 32 | 33 | (defn display-query 34 | "Return a query in a readable format." 35 | [query] 36 | (list* '?- (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-vars (:head rule)) 45 | bpv (apply union (map positive-vars (:body rule))) 46 | bnv (apply union (map negative-vars (:body rule))) 47 | ehv (difference hv bpv) 48 | env (difference bnv bpv)] 49 | (when-not (empty? ehv) 50 | (throw (Exception. (str "Head vars" ehv "not bound in body of rule" rule)))) 51 | (when-not (empty? env) 52 | (throw (Exception. (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 | (defmacro <- 63 | "Build a datalog rule. Like this: 64 | 65 | (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))" 66 | [hd & body] 67 | (let [head (build-atom hd :datalog.literals/literal) 68 | body (map build-literal body)] 69 | `(is-safe? (build-rule ~head [~@body])))) 70 | 71 | (defmethod print-method ::datalog-rule 72 | [rule ^java.io.Writer writer] 73 | (print-method (display-rule rule) writer)) 74 | 75 | (defn return-rule-data 76 | "Returns an untypted rule that will be fully printed" 77 | [rule] 78 | (with-meta rule {})) 79 | 80 | (defmacro ?- 81 | "Define a datalog query" 82 | [& q] 83 | (let [qq (build-atom q :datalog.literals/literal)] 84 | `(with-meta ~qq {:type ::datalog-query}))) 85 | 86 | (defmethod print-method ::datalog-query 87 | [query ^java.io.Writer writer] 88 | (print-method (display-query query) writer)) 89 | 90 | ;; ============================= 91 | ;; SIP 92 | 93 | (defn compute-sip 94 | "Given a set of bound column names, return an adorned sip for this 95 | rule. A set of intensional predicates should be provided to 96 | determine what should be adorned." 97 | [bindings i-preds rule] 98 | (let [next-lit (fn [bv body] 99 | (or (first (drop-while 100 | #(not (literal-appropriate? bv %)) 101 | body)) 102 | (first (drop-while (complement positive?) body)))) 103 | adorn (fn [lit bvs] 104 | (if (i-preds (literal-predicate lit)) 105 | (let [bnds (union (get-cs-from-vs lit bvs) 106 | (get-self-bound-cs lit))] 107 | (adorned-literal lit bnds)) 108 | lit)) 109 | new-h (adorned-literal (:head rule) bindings)] 110 | (loop [bound-vars (get-vs-from-cs (:head rule) bindings) 111 | body (:body rule) 112 | sip []] 113 | (if-let [next (next-lit bound-vars body)] 114 | (recur (union bound-vars (literal-vars next)) 115 | (remove #(= % next) body) 116 | (conj sip (adorn next bound-vars))) 117 | (build-rule new-h (concat sip body)))))) 118 | 119 | ;; ============================= 120 | ;; Rule sets 121 | 122 | (defn make-rules-set 123 | "Given an existing set of rules, make it a 'rules-set' for 124 | printing." 125 | [rs] 126 | (with-meta rs {:type ::datalog-rules-set})) 127 | 128 | (def empty-rules-set (make-rules-set #{})) 129 | 130 | (defn rules-set 131 | "Given a collection of rules return a rules set" 132 | [& rules] 133 | (reduce conj empty-rules-set rules)) 134 | 135 | (defmethod print-method ::datalog-rules-set 136 | [rules ^java.io.Writer writer] 137 | (binding [*out* writer] 138 | (do 139 | (print "(rules-set") 140 | (doseq [rule rules] 141 | (println) 142 | (print " ") 143 | (print rule)) 144 | (println ")")))) 145 | 146 | (defn predicate-map 147 | "Given a rules-set, return a map of rules keyed by their predicates. 148 | Each value will be a set of rules." 149 | [rs] 150 | (let [add-rule (fn [m r] 151 | (let [pred (-> r :head literal-predicate) 152 | os (get m pred #{})] 153 | (assoc m pred (conj os r))))] 154 | (reduce add-rule {} rs))) 155 | 156 | (defn all-predicates 157 | "Given a rules-set, return all defined predicates" 158 | [rs] 159 | (set (map literal-predicate (map :head rs)))) 160 | 161 | (defn non-base-rules 162 | "Return a collection of rules that depend, somehow, on other rules" 163 | [rs] 164 | (let [pred (all-predicates rs) 165 | non-base (fn [r] 166 | (if (some #(pred %) 167 | (map literal-predicate (:body r))) 168 | r 169 | nil))] 170 | (remove nil? (map non-base rs)))) 171 | 172 | ;; ============================= 173 | ;; Database operations 174 | 175 | (def empty-bindings [{}]) 176 | 177 | (defn apply-rule 178 | "Apply the rule against db-1, adding the results to the appropriate 179 | relation in db-2. The relation will be created if needed." 180 | ([db rule] (apply-rule db db rule)) 181 | ([db-1 db-2 rule] 182 | (trace-datalog (println) 183 | (println) 184 | (println "--------------- Begin Rule ---------------") 185 | (println rule)) 186 | (let [head (:head rule) 187 | body (:body rule) 188 | step (fn [bs lit] 189 | (trace-datalog (println bs) 190 | (println lit)) 191 | (join-literal db-1 lit bs)) 192 | bs (reduce step empty-bindings body)] 193 | (do (trace-datalog (println bs)) 194 | (project-literal db-2 head bs))))) 195 | 196 | (defn apply-rules-set 197 | [db rs] 198 | (reduce (fn [rdb rule] 199 | (apply-rule db rdb rule)) db rs)) 200 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.softstrat 19 | (:use [datalog.util] 20 | [datalog.database] 21 | [datalog.literals] 22 | [datalog.rules] 23 | [datalog.magic]) 24 | (:use [clojure.set :only (union intersection difference)]) 25 | (:require [datalog.graph :as graph])) 26 | 27 | ;; ============================= 28 | ;; Dependency graph 29 | 30 | (defn- build-rules-graph 31 | "Given a rules-set (rs), build a graph where each predicate symbol in rs, 32 | there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges 33 | from the (literal-predicate h) -> (literal-predicate b-*), one for each 34 | b-*." 35 | [rs] 36 | (let [preds (all-predicates rs) 37 | pred-map (predicate-map rs) 38 | step (fn [nbs pred] 39 | (let [rules (pred-map pred) 40 | preds (reduce (fn [pds lits] 41 | (reduce (fn [pds lit] 42 | (if-let [pred (literal-predicate lit)] 43 | (conj pds pred) 44 | pds)) 45 | pds 46 | lits)) 47 | #{} 48 | (map :body rules))] 49 | (assoc nbs pred preds))) 50 | neighbors (reduce step {} preds)] 51 | (graph/->DirectedGraph preds neighbors))) 52 | 53 | (defn- build-def 54 | "Given a rules-set, build its def function" 55 | [rs] 56 | (let [pred-map (predicate-map rs) 57 | graph (-> rs 58 | build-rules-graph 59 | graph/transitive-closure 60 | graph/add-loops)] 61 | (fn [pred] 62 | (apply union (map set (map pred-map (graph/get-neighbors graph pred))))))) 63 | 64 | ;; ============================= 65 | ;; Soft Stratificattion REQ Graph 66 | 67 | (defn- req 68 | "Returns a rules-set that is a superset of req(lit) for the lit at 69 | index lit-index" 70 | [rs soft-def rule lit-index] 71 | (let [head (:head rule) 72 | body (:body rule) 73 | lit (nth body lit-index) 74 | pre (subvec (vec body) 0 lit-index)] 75 | (conj (-> lit literal-predicate soft-def (magic-transform (all-predicates rs))) 76 | (build-rule (magic-literal lit) pre)))) 77 | 78 | (defn- rule-dep 79 | "Given a rule, return the set of rules it depends on." 80 | [rs mrs soft-def rule] 81 | (let [step (fn [nrs [idx lit]] 82 | (if (negated? lit) 83 | (union nrs (req rs soft-def rule idx)) 84 | nrs))] 85 | (intersection mrs 86 | (reduce step empty-rules-set 87 | (->> rule :body (map-indexed vector)))))) 88 | 89 | (defn- soft-strat-graph 90 | "The dependency graph for soft stratification." 91 | [rs mrs] 92 | (let [soft-def (build-def rs) 93 | step (fn [nbrs rule] 94 | (assoc nbrs rule (rule-dep rs mrs soft-def rule))) 95 | nbrs (reduce step {} mrs)] 96 | (graph/->DirectedGraph mrs nbrs))) 97 | 98 | (defn- build-soft-strat 99 | "Given a rules-set (unadorned) and an adorned query, return the soft 100 | stratified list. The rules will be magic transformed, and the 101 | magic seed will be appended." 102 | [rs q] 103 | (let [ars (adorn-rules-set rs q) 104 | mrs (conj (magic-transform ars) 105 | (seed-rule q)) 106 | gr (soft-strat-graph ars mrs)] 107 | (map make-rules-set (graph/dependency-list gr)))) 108 | 109 | ;; ============================= 110 | ;; Work plan 111 | 112 | (defrecord SoftStratWorkPlan [query stratification]) 113 | 114 | (defn build-soft-strat-work-plan 115 | "Return a work plan for the given rules-set and query" 116 | [rs q] 117 | (let [aq (adorn-query q)] 118 | (->SoftStratWorkPlan aq (build-soft-strat rs aq)))) 119 | 120 | (defn get-all-relations 121 | "Return a set of all relation names defined in this workplan" 122 | [ws] 123 | (apply union (map all-predicates (:stratification ws)))) 124 | 125 | ;; ============================= 126 | ;; Evaluate 127 | 128 | (defn- weak-consq-operator 129 | [db strat] 130 | (trace-datalog (println) 131 | (println) 132 | (println "=============== Begin iteration ===============")) 133 | (let [counts (database-counts db)] 134 | (loop [strat strat] 135 | (let [rs (first strat)] 136 | (if rs 137 | (let [new-db (apply-rules-set db rs)] 138 | (if (= counts (database-counts new-db)) 139 | (recur (next strat)) 140 | new-db)) 141 | db))))) 142 | 143 | (defn evaluate-soft-work-set 144 | ([ws db] (evaluate-soft-work-set ws db {})) 145 | ([ws db bindings] 146 | (let [query (:query ws) 147 | strat (:stratification ws) 148 | seed (seed-predicate-for-insertion query) 149 | seeded-db (project-literal db seed [bindings] is-query-var?) 150 | fun (fn [data] 151 | (weak-consq-operator data strat)) 152 | equal (fn [db1 db2] 153 | (= (database-counts db1) (database-counts db2))) 154 | new-db (graph/fixed-point seeded-db fun nil equal) 155 | pt (build-partial-tuple query bindings)] 156 | (select new-db (literal-predicate query) pt)))) 157 | -------------------------------------------------------------------------------- /src/datalog/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 | 16 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.util) 19 | 20 | ;; From clojure.contrib.seqs 21 | (defn separate 22 | "Returns a vector: 23 | [ (filter f s), (filter (complement f) s) ]" 24 | [f s] 25 | [(filter f s) (filter (complement f) s)]) 26 | 27 | ;;; Bindings and logic vars. A binding in a hash of logic vars to 28 | ;;; bound values. Logic vars are any symbol prefixed with a \?. 29 | 30 | (defn is-var? 31 | "Is this a logic variable: e.g. a symbol prefixed with a ?" 32 | [sym] 33 | (when (symbol? sym) 34 | (let [name (name sym)] 35 | (and (= \? (first name)) 36 | (not= \? (fnext name)))))) 37 | 38 | (defn is-query-var? 39 | "Is this a query variable: e.g. a symbol prefixed with ??" 40 | [sym] 41 | (when (symbol? sym) 42 | (let [name (name sym)] 43 | (and (= \? (first name)) 44 | (= \? (fnext name)))))) 45 | 46 | (defn map-values 47 | "Like map, but works over the values of a hash map" 48 | [f hash] 49 | (let [key-vals (map (fn [[key val]] [key (f val)]) hash)] 50 | (if (seq key-vals) 51 | (apply conj (empty hash) key-vals) 52 | hash))) 53 | 54 | (defn keys-to-vals 55 | "Given a map and a collection of keys, return the collection of vals" 56 | [m ks] 57 | (vals (select-keys m ks))) 58 | 59 | (defn reverse-map 60 | "Reverse the keys/values of a map" 61 | [m] 62 | (into {} (map (fn [[k v]] [v k]) m))) 63 | 64 | 65 | ;;; Preduce -- A parallel reduce over hashes 66 | 67 | (defn preduce 68 | "Similar to merge-with, but the contents of each key are merged in 69 | parallel using f. 70 | 71 | f - a function of 2 arguments. 72 | data - a collection of hashes." 73 | [f data] 74 | (let [data-1 (map (fn [h] (map-values #(list %) h)) data) 75 | merged (doall (apply merge-with concat data-1)) 76 | ; Groups w/ multiple elements are identified for parallel processing 77 | [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged) 78 | fold-group (fn [[key vals]] {key (reduce f vals)}) 79 | fix-single (fn [[key [val]]] [key val])] 80 | (apply merge (concat (pmap fold-group merged) (map fix-single simple))))) 81 | 82 | 83 | ;;; Debuging and Tracing 84 | 85 | (def ^:dynamic *trace-datalog* nil) 86 | 87 | (defmacro trace-datalog 88 | "If *test-datalog* is set to true, run the enclosed commands" 89 | [& body] 90 | `(when *trace-datalog* 91 | ~@body)) 92 | -------------------------------------------------------------------------------- /test/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-database 19 | (:use [datalog.database]) 20 | (:use [clojure.test])) 21 | 22 | (def test-db 23 | (make-database 24 | (relation :fred [:mary :sue]) 25 | (index :fred :mary) 26 | (relation :sally [:jen :becky :joan]) 27 | (index :sally :jen) 28 | (index :sally :becky))) 29 | 30 | (deftest test-make-database 31 | (is (= test-db 32 | (datalog-database 33 | {:sally (datalog-relation 34 | #{:jen :joan :becky} 35 | #{} 36 | {:becky {} 37 | :jen {}}) 38 | :fred (datalog-relation 39 | #{:sue :mary} 40 | #{} 41 | {:mary {}})})))) 42 | 43 | (deftest test-ensure-relation 44 | (is (contains? (ensure-relation test-db :bob [:sam :george] [:sam]) :bob)) 45 | (is (contains? (ensure-relation test-db :fred [:mary :sue] [:mary]) :fred)) 46 | (is (thrown? AssertionError (ensure-relation test-db :fred [:bob :joe] [])))) 47 | 48 | (deftest test-add-tuple 49 | (let [new-db (add-tuple test-db :fred {:mary 1 :sue 2})] 50 | (is (= (select new-db :fred {:mary 1}) [{:mary 1 :sue 2}]))) 51 | (is (thrown? AssertionError (add-tuple test-db :fred {:mary 1})))) 52 | 53 | (def test-db-1 54 | (add-tuples test-db 55 | [:fred :mary 1 :sue 2] 56 | [:fred :mary 2 :sue 3] 57 | [:sally :jen 1 :becky 2 :joan 0] 58 | [:sally :jen 1 :becky 4 :joan 3] 59 | [:sally :jen 1 :becky 3 :joan 0] 60 | [:sally :jen 1 :becky 2 :joan 3] 61 | [:fred :mary 1 :sue 1] 62 | [:fred :mary 3 :sue 1])) 63 | 64 | (deftest test-add-tuples 65 | (is (= test-db-1 66 | (datalog-database 67 | {:sally (datalog-relation 68 | #{:jen :joan :becky} 69 | #{{:jen 1, :joan 0, :becky 3} 70 | {:jen 1, :joan 0, :becky 2} 71 | {:jen 1, :joan 3, :becky 2} 72 | {:jen 1, :joan 3, :becky 4}} 73 | {:becky {3 74 | #{{:jen 1, :joan 0, :becky 3}} 75 | 4 76 | #{{:jen 1, :joan 3, :becky 4}} 77 | 2 78 | #{{:jen 1, :joan 0, :becky 2} 79 | {:jen 1, :joan 3, :becky 2}}} 80 | :jen {1 81 | #{{:jen 1, :joan 0, :becky 3} 82 | {:jen 1, :joan 0, :becky 2} 83 | {:jen 1, :joan 3, :becky 2} 84 | {:jen 1, :joan 3, :becky 4}}}}) 85 | :fred (datalog-relation 86 | #{:sue :mary} 87 | #{{:sue 2, :mary 1} 88 | {:sue 1, :mary 1} 89 | {:sue 3, :mary 2} 90 | {:sue 1, :mary 3}} 91 | {:mary {3 92 | #{{:sue 1, :mary 3}} 93 | 2 94 | #{{:sue 3, :mary 2}} 95 | 1 96 | #{{:sue 2, :mary 1} 97 | {:sue 1, :mary 1}}}})})))) 98 | 99 | (deftest test-remove-tuples 100 | (let [db (reduce #(apply remove-tuple %1 (first %2) (next %2)) 101 | test-db-1 102 | [[:fred {:mary 1 :sue 1}] 103 | [:fred {:mary 3 :sue 1}] 104 | [:sally {:jen 1 :becky 2 :joan 0}] 105 | [:sally {:jen 1 :becky 4 :joan 3}]])] 106 | (is (= db 107 | (datalog-database 108 | {:sally (datalog-relation 109 | #{:jen :joan :becky} 110 | #{{:jen 1, :joan 0, :becky 3} 111 | {:jen 1, :joan 3, :becky 2}} 112 | {:becky 113 | {3 114 | #{{:jen 1, :joan 0, :becky 3}} 115 | 2 116 | #{{:jen 1, :joan 3, :becky 2}}} 117 | :jen 118 | {1 119 | #{{:jen 1, :joan 0, :becky 3} 120 | {:jen 1, :joan 3, :becky 2}}}}) 121 | :fred (datalog-relation 122 | #{:sue :mary} 123 | #{{:sue 2, :mary 1} 124 | {:sue 3, :mary 2}} 125 | {:mary 126 | {2 127 | #{{:sue 3, :mary 2}} 128 | 1 129 | #{{:sue 2, :mary 1}}}})}))))) 130 | 131 | (deftest test-any-match? 132 | (is (any-match? test-db-1 :fred {:mary 3})) 133 | (is (any-match? test-db-1 :sally {:jen 1 :becky 2 :joan 3})) 134 | (is (not (any-match? test-db-1 :sally {:jen 5}))) 135 | (is (not (any-match? test-db-1 :fred {:mary 1 :sue 5})))) 136 | 137 | (deftest test-select 138 | (is (= (set (select test-db-1 :sally {:jen 1 :becky 2})) 139 | #{{:jen 1 :joan 0 :becky 2} {:jen 1 :joan 3 :becky 2}})) 140 | (is (= (set (select test-db-1 :fred {:sue 1})) 141 | #{{:mary 3 :sue 1} {:mary 1 :sue 1}})) 142 | (is (empty? (select test-db-1 :sally {:joan 5 :jen 1})))) 143 | 144 | 145 | -------------------------------------------------------------------------------- /test/datalog/test_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 | ;; test-graph 10 | ;; 11 | ;; Basic Graph Theory Algorithms Tests 12 | ;; 13 | ;; straszheimjeffrey (gmail) 14 | ;; Created 23 June 2009 15 | 16 | ;; This was clojure.contrib.graph 17 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 18 | 19 | (ns datalog.test-graph 20 | (:use [datalog.graph]) 21 | (:use [clojure.test])) 22 | 23 | (def empty-graph (->DirectedGraph #{} {})) 24 | 25 | (def test-graph-1 26 | (->DirectedGraph 27 | #{:a :b :c :d :e} 28 | {:a #{:b :c} 29 | :b #{:a :c} 30 | :c #{:d :e} 31 | :d #{:a :b} 32 | :e #{:d}})) 33 | 34 | (deftest test-reverse-graph 35 | (is (= (reverse-graph test-graph-1) 36 | (->DirectedGraph 37 | #{:a :b :c :d :e} 38 | {:c #{:b :a} 39 | :e #{:c} 40 | :d #{:c :e} 41 | :b #{:d :a} 42 | :a #{:d :b}}))) 43 | (is (= (reverse-graph (reverse-graph test-graph-1)) 44 | test-graph-1)) 45 | (is (= (reverse-graph empty-graph) empty-graph))) 46 | 47 | (deftest test-add-loops 48 | (let [tg1 (add-loops test-graph-1)] 49 | (is (every? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) 50 | (is (= (add-loops empty-graph) empty-graph))) 51 | 52 | (deftest test-remove-loops 53 | (let [tg1 (remove-loops (add-loops test-graph-1))] 54 | (is (not-any? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1)))) 55 | (is (= (remove-loops empty-graph) empty-graph))) 56 | 57 | (def test-graph-2 58 | (->DirectedGraph 59 | #{:a :b :c :d :e :f :g :h :i :j} 60 | {:a #{:b :c} 61 | :b #{:a :c} 62 | :c #{:d :e} 63 | :d #{:a :b} 64 | :e #{:d} 65 | :f #{:f} 66 | :g #{:a :f} 67 | :h #{} 68 | :i #{:j} 69 | :j #{:i}})) 70 | 71 | (deftest test-lazy-walk 72 | (is (= (lazy-walk test-graph-2 :h) [:h])) 73 | (is (= (lazy-walk test-graph-2 :j) [:j :i]))) 74 | 75 | (deftest test-transitive-closure 76 | (let [tc-1 (transitive-closure test-graph-1) 77 | tc-2 (transitive-closure test-graph-2) 78 | get (fn [n] (set (get-neighbors tc-2 n)))] 79 | (is (every? #(= #{:a :b :c :d :e} (set %)) 80 | (map (partial get-neighbors tc-1) (:nodes tc-1)))) 81 | (is (= (get :a) #{:a :b :c :d :e})) 82 | (is (= (get :h) #{})) 83 | (is (= (get :j) #{:i :j})) 84 | (is (= (get :g) #{:a :b :c :d :e :f})))) 85 | 86 | (deftest test-post-ordered-nodes 87 | (is (= (set (post-ordered-nodes test-graph-2)) 88 | #{:a :b :c :d :e :f :g :h :i :j})) 89 | (is (empty? (post-ordered-nodes empty-graph)))) 90 | 91 | (deftest test-scc 92 | (is (= (set (scc test-graph-2)) 93 | #{#{:h} #{:g} #{:i :j} #{:b :c :a :d :e} #{:f}})) 94 | (is (empty? (scc empty-graph)))) 95 | 96 | (deftest test-component-graph 97 | (let [cg (component-graph test-graph-2) 98 | ecg (component-graph empty-graph)] 99 | (is (= (:nodes cg) (set (scc test-graph-2)))) 100 | (is (= (get-neighbors cg #{:a :b :c :d :e}) 101 | #{#{:a :b :c :d :e}})) 102 | (is (= (get-neighbors cg #{:g}) 103 | #{#{:a :b :c :d :e} #{:f}})) 104 | (is (= (get-neighbors cg #{:i :j}) 105 | #{#{:i :j}})) 106 | (is (= (get-neighbors cg #{:h}) 107 | #{})) 108 | (is (= (apply max (map count (self-recursive-sets cg))) 1)) 109 | (is (= ecg empty-graph)))) 110 | 111 | (deftest test-recursive-component? 112 | (let [sccs (scc test-graph-2)] 113 | (is (= (set (filter (partial recursive-component? test-graph-2) sccs)) 114 | #{#{:i :j} #{:b :c :a :d :e} #{:f}})))) 115 | 116 | (deftest test-self-recursive-sets 117 | (is (= (set (self-recursive-sets test-graph-2)) 118 | (set (filter 119 | (partial recursive-component? test-graph-2) 120 | (scc test-graph-2))))) 121 | (is (empty? (self-recursive-sets empty-graph)))) 122 | 123 | (def test-graph-3 124 | (->DirectedGraph 125 | #{:a :b :c :d :e :f} 126 | {:a #{:b} 127 | :b #{:c} 128 | :c #{:d} 129 | :d #{:e} 130 | :e #{:f} 131 | :f #{}})) 132 | 133 | (def test-graph-4 134 | (->DirectedGraph 135 | #{:a :b :c :d :e :f :g :h} 136 | {:a #{} 137 | :b #{:a} 138 | :c #{:a} 139 | :d #{:a :b} 140 | :e #{:d :c} 141 | :f #{:e} 142 | :g #{:d} 143 | :h #{:f}})) 144 | 145 | (def test-graph-5 146 | (->DirectedGraph 147 | #{:a :b :c :d :e :f :g :h} 148 | {:a #{} 149 | :b #{} 150 | :c #{:b} 151 | :d #{} 152 | :e #{} 153 | :f #{} 154 | :g #{:f} 155 | :h #{}})) 156 | 157 | (deftest test-dependency-list 158 | (is (thrown-with-msg? Exception #".*Fixed point overflow.*" 159 | (dependency-list test-graph-2))) 160 | (is (= (dependency-list test-graph-3) 161 | [#{:f} #{:e} #{:d} #{:c} #{:b} #{:a}])) 162 | (is (= (dependency-list test-graph-4) 163 | [#{:a} #{:b :c} #{:d} #{:g :e} #{:f} #{:h}])) 164 | (is (= (dependency-list test-graph-5) 165 | [#{:f :b :a :d :h :e} #{:g :c}])) 166 | (is (= (dependency-list empty-graph) 167 | [#{}]))) 168 | 169 | (deftest test-stratification-list 170 | (is (thrown-with-msg? Exception #".*Fixed point overflow.*" 171 | (stratification-list test-graph-2 test-graph-2))) 172 | (is (= (stratification-list test-graph-4 test-graph-5) 173 | [#{:a} #{:b :c} #{:d} #{:e} #{:f :g} #{:h}])) 174 | (is (= (stratification-list empty-graph empty-graph) 175 | [#{}]))) 176 | -------------------------------------------------------------------------------- /test/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-literals 19 | (:use [datalog.literals] 20 | [datalog.database]) 21 | (:use [clojure.test])) 22 | 23 | (def pl (eval (build-literal '(:fred :x ?x :y ?y :z 3)))) 24 | (def nl (eval (build-literal '(not! :fred :x ?x :y ?y :z 3)))) 25 | (def cl (eval (build-literal '(if > ?x 3)))) 26 | 27 | (def bl (eval (build-literal '(:fred)))) 28 | 29 | (def bns {:x '?x :y '?y :z 3}) 30 | 31 | (deftest test-build-literal 32 | (is (= (:predicate pl) :fred)) 33 | (is (= (:term-bindings pl) bns)) 34 | (is (= (:predicate nl) :fred)) 35 | (is (= (:term-bindings nl) bns)) 36 | (is (= (:symbol cl) '>)) 37 | (is (= (:terms cl) '(?x 3))) 38 | (is ((:fun cl) [4 3])) 39 | (is (not ((:fun cl) [2 4]))) 40 | (is (= (:predicate bl) :fred))) 41 | 42 | (deftest test-literal-predicate 43 | (is (= (literal-predicate pl) :fred)) 44 | (is (= (literal-predicate nl) :fred)) 45 | (is (nil? (literal-predicate cl))) 46 | (is (= (literal-predicate bl) :fred))) 47 | 48 | (deftest test-literal-columns 49 | (is (= (literal-columns pl) #{:x :y :z})) 50 | (is (= (literal-columns nl) #{:x :y :z})) 51 | (is (nil? (literal-columns cl))) 52 | (is (empty? (literal-columns bl)))) 53 | 54 | (deftest test-literal-vars 55 | (is (= (literal-vars pl) #{'?x '?y})) 56 | (is (= (literal-vars nl) #{'?x '?y})) 57 | (is (= (literal-vars cl) #{'?x})) 58 | (is (empty? (literal-vars bl)))) 59 | 60 | (deftest test-positive-vars 61 | (is (= (positive-vars pl) (literal-vars pl))) 62 | (is (nil? (positive-vars nl))) 63 | (is (nil? (positive-vars cl))) 64 | (is (empty? (positive-vars bl)))) 65 | 66 | (deftest test-negative-vars 67 | (is (nil? (negative-vars pl))) 68 | (is (= (negative-vars nl) (literal-vars nl))) 69 | (is (= (negative-vars cl) (literal-vars cl))) 70 | (is (empty? (negative-vars bl)))) 71 | 72 | (deftest test-negated? 73 | (is (not (negated? pl))) 74 | (is (negated? nl)) 75 | (is (not (negated? cl)))) 76 | 77 | (deftest test-vs-from-cs 78 | (is (= (get-vs-from-cs pl #{:x}) #{'?x})) 79 | (is (empty? (get-vs-from-cs pl #{:z}))) 80 | (is (= (get-vs-from-cs pl #{:x :r}) #{'?x})) 81 | (is (empty? (get-vs-from-cs pl #{})))) 82 | 83 | (deftest test-cs-from-vs 84 | (is (= (get-cs-from-vs pl #{'?x}) #{:x})) 85 | (is (= (get-cs-from-vs pl #{'?x '?r}) #{:x})) 86 | (is (empty? (get-cs-from-vs pl #{})))) 87 | 88 | (deftest test-literal-appropriate? 89 | (is (not (literal-appropriate? #{} pl))) 90 | (is (literal-appropriate? #{'?x} pl)) 91 | (is (not (literal-appropriate? #{'?x} nl))) 92 | (is (literal-appropriate? #{'?x '?y} nl)) 93 | (is (not (literal-appropriate? #{'?z} cl))) 94 | (is (literal-appropriate? #{'?x} cl))) 95 | 96 | (deftest test-adorned-literal 97 | (is (= (literal-predicate (adorned-literal pl #{:x})) 98 | {:pred :fred :bound #{:x}})) 99 | (is (= (literal-predicate (adorned-literal nl #{:x :y :q})) 100 | {:pred :fred :bound #{:x :y}})) 101 | (is (= (:term-bindings (adorned-literal nl #{:x})) 102 | {:x '?x :y '?y :z 3})) 103 | (is (= (adorned-literal cl #{}) 104 | cl))) 105 | 106 | (deftest test-get-adorned-bindings 107 | (is (= (get-adorned-bindings (literal-predicate (adorned-literal pl #{:x}))) 108 | #{:x})) 109 | (is (= (get-adorned-bindings (literal-predicate pl)) 110 | nil))) 111 | 112 | (deftest test-get-base-predicate 113 | (is (= (get-base-predicate (literal-predicate (adorned-literal pl #{:x}))) 114 | :fred)) 115 | (is (= (get-base-predicate (literal-predicate pl)) 116 | :fred))) 117 | 118 | (deftest test-magic-literal 119 | (is (= (magic-literal pl) 120 | (->AtomicLiteral {:pred :fred :magic true} {} :datalog.literals/literal))) 121 | (is (= (magic-literal (adorned-literal pl #{:x})) 122 | (->AtomicLiteral {:pred :fred :magic true :bound #{:x}} {:x '?x} :datalog.literals/literal)))) 123 | 124 | (def db1 (make-database 125 | (relation :fred [:x :y]) 126 | (index :fred :x) 127 | (relation :sally [:x]))) 128 | 129 | (def db2 (add-tuples db1 130 | [:fred :x 1 :y :mary] 131 | [:fred :x 1 :y :becky] 132 | [:fred :x 3 :y :sally] 133 | [:fred :x 4 :y :joe] 134 | [:sally :x 1] 135 | [:sally :x 2])) 136 | 137 | (def lit1 (eval (build-literal '(:fred :x ?x :y ?y)))) 138 | (def lit2 (eval (build-literal '(not! :fred :x ?x)))) 139 | (def lit3 (eval (build-literal '(if > ?x ?y)))) 140 | (def lit4 (adorned-literal (eval (build-literal '(:joan :x ?x :y ?y))) #{:x})) 141 | 142 | (deftest test-join-literal 143 | (is (= (set (join-literal db2 lit1 [{'?x 1} {'?x 2} {'?x 3}])) 144 | #{{'?x 1, '?y :mary} {'?x 1, '?y :becky} {'?x 3, '?y :sally}})) 145 | (is (= (join-literal db2 lit2 [{'?x 1} {'?x 2} {'?x 3}]) 146 | [{'?x 2}])) 147 | (is (= (join-literal db2 lit3 [{'?x 1 '?y 2} {'?x 3 '?y 1}]) 148 | [{'?x 3 '?y 1}]))) 149 | 150 | (deftest test-project-literal 151 | (is (= ((project-literal db2 lit4 [{'?x 1 '?y 3}{'?x 4 '?y 2}]) {:pred :joan :bound #{:x}}) 152 | (datalog-relation 153 | ;; Schema 154 | #{:y :x} 155 | 156 | ;; Data 157 | #{ 158 | {:x 1, :y 3} 159 | {:x 4, :y 2} 160 | } 161 | 162 | ;; Indexes 163 | { 164 | :x 165 | { 166 | 4 167 | #{{:x 4, :y 2}} 168 | 1 169 | #{{:x 1, :y 3}} 170 | } 171 | })))) 172 | -------------------------------------------------------------------------------- /test/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-magic 19 | (:use [datalog.magic] 20 | [datalog.rules]) 21 | (:use clojure.test)) 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/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-rules 19 | (:use [datalog.rules] 20 | [datalog.literals] 21 | [datalog.database]) 22 | (:use [clojure.test])) 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 | (deftest test-rule-safety 29 | (is (thrown-with-msg? Exception #".*Head vars.*not bound.*" 30 | (<- (:fred :x ?x) (:sally :y ?y)))) 31 | (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" 32 | (<- (:fred :x ?x) (:becky :x ?x) (not! :sally :y ?y)))) 33 | (is (thrown-with-msg? Exception #".*Body vars.*not bound.*negative position.*" 34 | (<- (:fred :x ?x) (:becky :x ?x) (if > ?x ?y))))) 35 | 36 | (deftest test-sip 37 | (is (= (compute-sip #{:x} #{:mary :sally} tr-1) 38 | (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 39 | ({:pred :mary :bound #{:x}} :z ?z :x ?x) 40 | ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 41 | 42 | (is (= (compute-sip #{} #{:mary :sally} tr-1) 43 | (<- (:fred :y ?y :x ?x) (:mary :z ?z :x ?x) ({:pred :sally :bound #{:z}} :y ?y :z ?z)))) 44 | 45 | (is (= (compute-sip #{} #{:mary} tr-2) 46 | (<- (:fred) (not! {:pred :mary :bound #{:x}} :x 3)))) 47 | 48 | (is (= (compute-sip #{} #{} tr-2) 49 | tr-2)) 50 | 51 | (is (= (display-rule (compute-sip #{:x} #{:mary :sally} tr-3)) 52 | (display-rule (<- ({:pred :fred :bound #{:x}} :x ?x :y ?y) 53 | ({:pred :mary :bound #{:x}} :x ?x) 54 | (:sally :y ?y) 55 | (if > ?x ?y)))))) 56 | ; Display rule is used because = does not work on 57 | ; (if > ?x ?y) because it contains a closure 58 | 59 | (def rs 60 | (rules-set 61 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 62 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y)) 63 | (<- (:edge :a ?x :b ?y) (:route :a ?x :b ?y) (if not= ?x ?y)))) 64 | 65 | (deftest test-rules-set 66 | (is (= (count rs) 3)) 67 | (is (contains? rs (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))))) 68 | 69 | (deftest test-predicate-map 70 | (let [pm (predicate-map rs)] 71 | (is (= (pm :path) 72 | #{(<- (:path :a ?x :b ?y) (:edge :a ?x :b ?y)) 73 | (<- (:path :a ?x :b ?y) (:edge :a ?x :b ?z) (:path :a ?z :b ?y))})) 74 | (is (= (-> :edge pm count) 1)))) 75 | 76 | 77 | (def db1 (make-database 78 | (relation :fred [:x :y]) 79 | (index :fred :x) 80 | (relation :sally [:x]) 81 | (relation :ben [:y]))) 82 | 83 | (def db2 (add-tuples db1 84 | [:fred :x 1 :y :mary] 85 | [:fred :x 1 :y :becky] 86 | [:fred :x 3 :y :sally] 87 | [:fred :x 4 :y :joe] 88 | [:fred :x 4 :y :bob] 89 | [:sally :x 1] 90 | [:sally :x 2] 91 | [:sally :x 3] 92 | [:sally :x 4] 93 | [:ben :y :bob])) 94 | 95 | (deftest test-apply-rule 96 | (is (= (apply-rule db2 empty-database (<- (:becky :y ?y) (:sally :x ?x) 97 | (:fred :x ?x :y ?y) 98 | (not! :ben :y ?y) 99 | (if not= ?x 3))) 100 | (datalog-database 101 | { 102 | :becky 103 | (datalog-relation 104 | ;; Schema 105 | #{:y} 106 | ;; Data 107 | #{ 108 | {:y :joe} 109 | {:y :mary} 110 | {:y :becky} 111 | } 112 | ;; Indexes 113 | { 114 | }) 115 | })))) 116 | -------------------------------------------------------------------------------- /test/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-softstrat 19 | (:use [datalog.softstrat] 20 | [datalog.magic] 21 | [datalog.rules] 22 | [datalog.database]) 23 | (:use [clojure.test]) 24 | (:use [clojure.set :only (subset?)])) 25 | 26 | (def rs1 (rules-set 27 | (<- (:p :x ?x) (:b :x ?x :y ?y :z ?z) (not! :q :x ?x) (not! :q :x ?y) (not! :q :x ?z)) 28 | (<- (:q :x ?x) (:d :x ?x)))) 29 | 30 | (def q1 (?- :p :x 1)) 31 | 32 | (def ws (build-soft-strat-work-plan rs1 q1)) 33 | 34 | (deftest test-soft-stratification 35 | (let [soft (:stratification ws) 36 | q (:query ws)] 37 | (is (= q (?- {:pred :p :bound #{:x}} :x 1))) 38 | (is (= (count soft) 4)) 39 | (is (subset? (rules-set 40 | (<- ({:pred :q :bound #{:x}} :x ?x) ({:pred :q :magic true :bound #{:x}} :x ?x) 41 | (:d :x ?x)) 42 | 43 | (<- ({:pred :q :magic true :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 44 | (:b :z ?z :y ?y :x ?x))) 45 | (nth soft 0))) 46 | (is (= (nth soft 1) 47 | (rules-set 48 | (<- ({:pred :q :magic true :bound #{:x}} :x ?y) ({:pred :p :magic true :bound #{:x}} :x ?x) 49 | (:b :z ?z :y ?y :x ?x) 50 | (not! {:pred :q :bound #{:x}} :x ?x))))) 51 | (is (= (nth soft 2) 52 | (rules-set 53 | (<- ({:pred :q :magic true :bound #{:x}} :x ?z) ({:pred :p :magic true :bound #{:x}} :x ?x) 54 | (:b :z ?z :y ?y :x ?x) 55 | (not! {:pred :q :bound #{:x}} :x ?x) 56 | (not! {:pred :q :bound #{:x}} :x ?y))))) 57 | (is (= (nth soft 3) 58 | (rules-set 59 | (<- ({:pred :p :bound #{:x}} :x ?x) ({:pred :p :magic true :bound #{:x}} :x ?x) 60 | (:b :z ?z :y ?y :x ?x) 61 | (not! {:pred :q :bound #{:x}} :x ?x) 62 | (not! {:pred :q :bound #{:x}} :x ?y) 63 | (not! {:pred :q :bound #{:x}} :x ?z))))))) 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 | (def tdb-3 79 | (add-tuples tdb-2 80 | [:d :x 2] 81 | [:d :x 3])) 82 | 83 | (deftest test-tdb-3 84 | (is (empty? (evaluate-soft-work-set ws tdb-3 {})))) 85 | 86 | ;; ============================= 87 | 88 | (def db-base 89 | (make-database 90 | (relation :employee [:id :name :position]) 91 | (index :employee :name) 92 | 93 | (relation :boss [:employee-id :boss-id]) 94 | (index :boss :employee-id) 95 | 96 | (relation :can-do-job [:position :job]) 97 | (index :can-do-job :position) 98 | 99 | (relation :job-replacement [:job :can-be-done-by]) 100 | 101 | (relation :job-exceptions [:id :job]))) 102 | 103 | (def db 104 | (add-tuples db-base 105 | [:employee :id 1 :name "Bob" :position :boss] 106 | [:employee :id 2 :name "Mary" :position :chief-accountant] 107 | [:employee :id 3 :name "John" :position :accountant] 108 | [:employee :id 4 :name "Sameer" :position :chief-programmer] 109 | [:employee :id 5 :name "Lilian" :position :programmer] 110 | [:employee :id 6 :name "Li" :position :technician] 111 | [:employee :id 7 :name "Fred" :position :sales] 112 | [:employee :id 8 :name "Brenda" :position :sales] 113 | [:employee :id 9 :name "Miki" :position :project-management] 114 | [:employee :id 10 :name "Albert" :position :technician] 115 | 116 | [:boss :employee-id 2 :boss-id 1] 117 | [:boss :employee-id 3 :boss-id 2] 118 | [:boss :employee-id 4 :boss-id 1] 119 | [:boss :employee-id 5 :boss-id 4] 120 | [:boss :employee-id 6 :boss-id 4] 121 | [:boss :employee-id 7 :boss-id 1] 122 | [:boss :employee-id 8 :boss-id 7] 123 | [:boss :employee-id 9 :boss-id 1] 124 | [:boss :employee-id 10 :boss-id 6] 125 | 126 | [:can-do-job :position :boss :job :management] 127 | [:can-do-job :position :accountant :job :accounting] 128 | [:can-do-job :position :chief-accountant :job :accounting] 129 | [:can-do-job :position :programmer :job :programming] 130 | [:can-do-job :position :chief-programmer :job :programming] 131 | [:can-do-job :position :technician :job :server-support] 132 | [:can-do-job :position :sales :job :sales] 133 | [:can-do-job :position :project-management :job :project-management] 134 | 135 | [:job-replacement :job :pc-support :can-be-done-by :server-support] 136 | [:job-replacement :job :pc-support :can-be-done-by :programming] 137 | [:job-replacement :job :payroll :can-be-done-by :accounting] 138 | 139 | [:job-exceptions :id 4 :job :pc-support])) 140 | 141 | (def rules 142 | (rules-set 143 | (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) 144 | (:employee :id ?e-id :name ?x) 145 | (:employee :id ?b-id :name ?y)) 146 | (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) 147 | (:works-for :employee ?z :boss ?y)) 148 | (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) 149 | (:can-do-job :position ?pos :job ?y)) 150 | (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) 151 | (:employee-job* :employee ?x :job ?z)) 152 | (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) 153 | (:employee :name ?x :position ?z) 154 | (if = ?z :boss)) 155 | (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) 156 | (:employee :id ?id :name ?x) 157 | (not! :job-exceptions :id ?id :job ?y)) 158 | (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) 159 | (not! :employee-job :employee ?y :job :pc-support)))) 160 | 161 | (def ws-1 (build-soft-strat-work-plan rules (?- :works-for :employee '??name :boss ?x))) 162 | (defn evaluate-1 [name] (set (evaluate-soft-work-set ws-1 db {'??name name}))) 163 | 164 | (deftest test-ws-1 165 | (is (= (evaluate-1 "Albert") 166 | #{{:employee "Albert", :boss "Li"} 167 | {:employee "Albert", :boss "Sameer"} 168 | {:employee "Albert", :boss "Bob"}})) 169 | (is (empty? (evaluate-1 "Bob"))) 170 | (is (= (evaluate-1 "John") 171 | #{{:employee "John", :boss "Bob"} 172 | {:employee "John", :boss "Mary"}}))) 173 | 174 | (def ws-2 (build-soft-strat-work-plan rules (?- :employee-job :employee '??name :job ?x))) 175 | (defn evaluate-2 [name] (set (evaluate-soft-work-set ws-2 db {'??name name}))) 176 | 177 | (deftest test-ws-2 178 | (is (= (evaluate-2 "Albert") 179 | #{{:employee "Albert", :job :pc-support} 180 | {:employee "Albert", :job :server-support}})) 181 | (is (= (evaluate-2 "Sameer") 182 | #{{:employee "Sameer", :job :programming}})) 183 | (is (= (evaluate-2 "Bob") 184 | #{{:employee "Bob", :job :accounting} 185 | {:employee "Bob", :job :management} 186 | {:employee "Bob", :job :payroll} 187 | {:employee "Bob", :job :pc-support} 188 | {:employee "Bob", :job :project-management} 189 | {:employee "Bob", :job :programming} 190 | {:employee "Bob", :job :server-support} 191 | {:employee "Bob", :job :sales}}))) 192 | 193 | (def ws-3 (build-soft-strat-work-plan rules (?- :bj :name '??name :boss ?x))) 194 | (defn evaluate-3 [name] (set (evaluate-soft-work-set ws-3 db {'??name name}))) 195 | 196 | (deftest test-ws-3 197 | (is (= (evaluate-3 "Albert") 198 | #{{:name "Albert", :boss "Sameer"}}))) 199 | 200 | (def ws-4 (build-soft-strat-work-plan rules (?- :works-for :name ?x :boss ?x))) 201 | 202 | (deftest test-ws-4 203 | (is (= (set (evaluate-soft-work-set ws-4 db {})) 204 | #{{:employee "Miki", :boss "Bob"} 205 | {:employee "Albert", :boss "Li"} 206 | {:employee "Lilian", :boss "Sameer"} 207 | {:employee "Li", :boss "Bob"} 208 | {:employee "Lilian", :boss "Bob"} 209 | {:employee "Brenda", :boss "Fred"} 210 | {:employee "Fred", :boss "Bob"} 211 | {:employee "John", :boss "Bob"} 212 | {:employee "John", :boss "Mary"} 213 | {:employee "Albert", :boss "Sameer"} 214 | {:employee "Sameer", :boss "Bob"} 215 | {:employee "Albert", :boss "Bob"} 216 | {:employee "Brenda", :boss "Bob"} 217 | {:employee "Mary", :boss "Bob"} 218 | {:employee "Li", :boss "Sameer"}}))) 219 | 220 | -------------------------------------------------------------------------------- /test/datalog/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 | ;; Converted to Clojure1.4 by Martin Trojer 2012. 17 | 18 | (ns datalog.test-util 19 | (:use [datalog.util]) 20 | (:use [clojure.test])) 21 | 22 | (deftest test-is-var? 23 | (is (is-var? '?x)) 24 | (is (is-var? '?)) 25 | (is (not (is-var? '??x))) 26 | (is (not (is-var? '??))) 27 | (is (not (is-var? 'x))) 28 | (is (not (is-var? "fred"))) 29 | (is (not (is-var? :q)))) 30 | 31 | (deftest test-map-values 32 | (let [map {:fred 1 :sally 2}] 33 | (is (= (map-values #(* 2 %) map) {:fred 2 :sally 4})) 34 | (is (= (map-values identity {}) {})))) 35 | 36 | (deftest test-keys-to-vals 37 | (let [map {:fred 1 :sally 2 :joey 3}] 38 | (is (= (set (keys-to-vals map [:fred :sally])) #{1 2})) 39 | (is (= (set (keys-to-vals map [:fred :sally :becky])) #{1 2})) 40 | (is (empty? (keys-to-vals map []))) 41 | (is (empty? (keys-to-vals {} [:fred]))))) 42 | 43 | (deftest test-reverse-map 44 | (let [map {:fred 1 :sally 2 :joey 3} 45 | map-1 (assoc map :mary 3)] 46 | (is (= (reverse-map map) {1 :fred 2 :sally 3 :joey})) 47 | (is (or (= (reverse-map map-1) {1 :fred 2 :sally 3 :joey}) 48 | (= (reverse-map map-1) {1 :fred 2 :sally 3 :mary}))))) 49 | 50 | (def some-maps 51 | [ 52 | { :a 1 :b 2 } 53 | { :c 3 :b 3 } 54 | { :d 4 :a 1 } 55 | { :g 4 :b 4 } 56 | { :a 2 :b 1 } 57 | { :e 1 :f 1 } 58 | ]) 59 | 60 | (def reduced (preduce + some-maps)) 61 | (def merged (apply merge-with + some-maps)) 62 | 63 | (deftest test-preduce 64 | (is (= reduced merged))) 65 | --------------------------------------------------------------------------------