diff options
Diffstat (limited to 'src/clojure/contrib/datalog')
| -rw-r--r-- | src/clojure/contrib/datalog/database.clj | 287 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/example.clj | 116 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/literals.clj | 414 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/magic.clj | 128 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/rules.clj | 207 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/softstrat.clj | 161 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test.clj | 45 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_database.clj | 153 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_literals.clj | 187 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_magic.clj | 72 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_rules.clj | 130 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_softstrat.clj | 233 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/tests/test_util.clj | 69 | ||||
| -rw-r--r-- | src/clojure/contrib/datalog/util.clj | 89 |
14 files changed, 0 insertions, 2291 deletions
diff --git a/src/clojure/contrib/datalog/database.clj b/src/clojure/contrib/datalog/database.clj deleted file mode 100644 index aba41df9..00000000 --- a/src/clojure/contrib/datalog/database.clj +++ /dev/null @@ -1,287 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and -;; distribution terms for this software are covered by the Eclipse Public -;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can -;; be found in the file epl-v10.html at the root of this distribution. By -;; using this software in any fashion, you are agreeing to be bound by the -;; terms of this license. You must not remove this notice, or any other, -;; from this software. -;; -;; database.clj -;; -;; A Clojure implementation of Datalog -- Support for in-memory database -;; -;; straszheimjeffrey (gmail) -;; Created 21 Feburary 2009 - - -(ns clojure.contrib.datalog.database - (:use clojure.contrib.datalog.util) - (:use clojure.contrib.def) - (:use [clojure.set :only (union intersection difference)]) - (:use [clojure.contrib.except :only (throwf)])) - - -(defstruct relation - :schema ; A set of key names - :data ; A set of tuples - :indexes) ; A map key names to indexes (in turn a map of value to tuples) - - -;;; DDL - -(defmethod print-method ::datalog-database - [db #^Writer writer] - (binding [*out* writer] - (do - (println "(datalog-database") - (println "{") - (doseq [key (keys db)] - (println) - (println key) - (print-method (db key) writer)) - (println "})")))) - -(defn datalog-database - [rels] - (with-meta rels {:type ::datalog-database})) - -(def empty-database (datalog-database {})) - -(defmethod print-method ::datalog-relation - [rel #^Writer writer] - (binding [*out* writer] - (do - (println "(datalog-relation") - (println " ;; Schema") - (println " " (:schema rel)) - (println) - (println " ;; Data") - (println " #{") - (doseq [tuple (:data rel)] - (println " " tuple)) - (println " }") - (println) - (println " ;; Indexes") - (println " {") - (doseq [key (-> rel :indexes keys)] - (println " " key) - (println " {") - (doseq [val (keys ((:indexes rel) key))] - (println " " val) - (println " " (get-in rel [:indexes key val]))) - (println " }")) - (println " })")))) - -(defn datalog-relation - "Creates a relation" - [schema data indexes] - (with-meta (struct relation schema data indexes) {:type ::datalog-relation})) - -(defn add-relation - "Adds a relation to the database" - [db name keys] - (assoc db name (datalog-relation (set keys) #{} {}))) - -(defn add-index - "Adds an index to an empty relation named name" - [db name key] - (assert (empty? (:data (db name)))) - (let [rel (db name) - inx (assoc (:indexes rel) key {})] - (assoc db name (datalog-relation (:schema rel) - (:data rel) - inx)))) - -(defn ensure-relation - "If the database lacks the named relation, add it" - [db name keys indexes] - (if-let [rel (db name)] - (do - (assert (= (:schema rel) (set keys))) - db) - (let [db1 (add-relation db name keys)] - (reduce (fn [db key] (add-index db name key)) - db1 - indexes)))) - - -(defmacro make-database - "Makes a database, like this - (make-database - (relation :fred [:mary :sue]) - (index :fred :mary) - (relation :sally [:jen :becky]) - (index :sally :jen) - (index :sally :becky))" - [& commands] - (let [wrapper (fn [cur new] - (let [cmd (first new) - body (next new)] - (assert (= 2 (count body))) - (cond - (= cmd 'relation) - `(add-relation ~cur ~(first body) ~(fnext body)) - (= cmd 'index) - `(add-index ~cur ~(first body) ~(fnext body)) - :otherwise (throwf "%s not recognized" new))))] - (reduce wrapper `empty-database commands))) - -(defn get-relation - "Get a relation object by name" - [db rel-name] - (db rel-name)) - -(defn replace-relation - "Add or replace a fully constructed relation object to the database." - [db rel-name rel] - (assoc db rel-name rel)) - - -;;; DML - - -(defn database-counts - "Returns a map with the count of elements in each relation." - [db] - (map-values #(-> % :data count) db)) - -(defn- modify-indexes - "Perform f on the indexed tuple-set. f should take a set and tuple, - and return the new set." - [idxs tuple f] - (into {} (for [ik (keys idxs)] - (let [im (idxs ik) - iv (tuple ik) - os (get im iv #{}) - ns (f os tuple)] - [ik (if (empty? ns) - (dissoc im iv) - (assoc im iv (f os tuple)))])))) - -(defn- add-to-indexes - "Adds the tuple to the appropriate keys in the index map" - [idxs tuple] - (modify-indexes idxs tuple conj)) - -(defn- remove-from-indexes - "Removes the tuple from the appropriate keys in the index map" - [idxs tuple] - (modify-indexes idxs tuple disj)) - -(defn add-tuple - "Two forms: - - [db relation-name tuple] adds tuple to the named relation. Returns - the new database. - - [rel tuple] adds to the relation object. Returns the new relation." - ([db rel-name tuple] - (assert (= (-> tuple keys set) (-> rel-name db :schema))) - (assoc db rel-name (add-tuple (db rel-name) tuple))) - ([rel tuple] - (let [data (:data rel) - new-data (conj data tuple)] - (if (identical? data new-data) ; optimization hack! - rel - (let [idxs (add-to-indexes (:indexes rel) tuple)] - (assoc rel :data new-data :indexes idxs)))))) - -(defn remove-tuple - "Two forms: - - [db relation-name tuple] removes the tuple from the named relation, - returns a new database. - - [rel tuple] removes the tuple from the relation. Returns the new - relation." - ([db rel-name tuple] (assoc db rel-name (remove-tuple (db rel-name) tuple))) - ([rel tuple] - (let [data (:data rel) - new-data (disj data tuple)] - (if (identical? data new-data) - rel - (let [idxs (remove-from-indexes (:indexes rel) tuple)] - (assoc rel :data new-data :indexes idxs)))))) - -(defn add-tuples - "Adds a collection of tuples to the db, as - (add-tuples db - [:rel-name :key-1 1 :key-2 2] - [:rel-name :key-1 2 :key-2 3])" - [db & tupls] - (reduce #(add-tuple %1 (first %2) (apply hash-map (next %2))) db tupls)) - -(defn- find-indexes - "Given a map of indexes and a partial tuple, return the sets of full tuples" - [idxs pt] - (if (empty? idxs) - nil - (filter identity (for [key (keys pt)] - (if-let [idx-map (idxs key)] - (get idx-map (pt key) #{}) - nil))))) - -(defn- match? - "Is m2 contained in m1?" - [m1 m2] - (let [compare (fn [key] - (and (contains? m1 key) - (= (m1 key) (m2 key))))] - (every? compare (keys m2)))) - -(defn- scan-space - "Computes a stream of tuples from relation rn matching partial tuple (pt) - and applies fun to each" - [fun db rn pt] - (let [rel (db rn) - idxs (find-indexes (:indexes rel) pt) - space (if (empty? idxs) - (:data rel) ; table scan :( - (reduce intersection idxs))] - (trace-datalog (when (empty? idxs) - (println (format "Table scan of %s: %s rows!!!!!" - rn - (count space))))) - (fun #(match? % pt) space))) - -(defn select - "finds all matching tuples to the partial tuple (pt) in the relation named (rn)" - [db rn pt] - (scan-space filter db rn pt)) - -(defn any-match? - "Finds if there are any matching records for the partial tuple" - [db rn pt] - (if (= (-> pt keys set) (:schema (db rn))) - (contains? (:data (db rn)) pt) - (scan-space some db rn pt))) - - -;;; Merge - -(defn merge-indexes - [idx1 idx2] - (merge-with (fn [h1 h2] (merge-with union h1 h2)) idx1 idx2)) - -(defn merge-relations - "Merges two relations" - [r1 r2] - (assert (= (:schema r1) (:schema r2))) - (let [merged-indexes (merge-indexes (:indexes r1) - (:indexes r2)) - merged-data (union (:data r1) - (:data r2))] - (assoc r1 :data merged-data :indexes merged-indexes))) - -(defn database-merge - "Merges databases together" - [dbs] - (apply merge-with merge-relations dbs)) - -(defn database-merge-parallel - "Merges databases together in parallel" - [dbs] - (preduce merge-relations dbs)) - - -;; End of file diff --git a/src/clojure/contrib/datalog/example.clj b/src/clojure/contrib/datalog/example.clj deleted file mode 100644 index 88fcf961..00000000 --- a/src/clojure/contrib/datalog/example.clj +++ /dev/null @@ -1,116 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and -;; distribution terms for this software are covered by the Eclipse Public -;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can -;; be found in the file epl-v10.html at the root of this distribution. By -;; using this software in any fashion, you are agreeing to be bound by the -;; terms of this license. You must not remove this notice, or any other, -;; from this software. -;; -;; example.clj -;; -;; A Clojure implementation of Datalog - Example -;; -;; straszheimjeffrey (gmail) -;; Created 2 March 2009 - - -(ns clojure.contrib.datalog.example - (:use [clojure.contrib.datalog :only (build-work-plan run-work-plan)] - [clojure.contrib.datalog.rules :only (<- ?- rules-set)] - [clojure.contrib.datalog.database :only (make-database add-tuples)] - [clojure.contrib.datalog.util :only (*trace-datalog*)])) - - - - -(def db-base - (make-database - (relation :employee [:id :name :position]) - (index :employee :name) - - (relation :boss [:employee-id :boss-id]) - (index :boss :employee-id) - - (relation :can-do-job [:position :job]) - (index :can-do-job :position) - - (relation :job-replacement [:job :can-be-done-by]) - ;(index :job-replacement :can-be-done-by) - - (relation :job-exceptions [:id :job]))) - -(def db - (add-tuples db-base - [:employee :id 1 :name "Bob" :position :boss] - [:employee :id 2 :name "Mary" :position :chief-accountant] - [:employee :id 3 :name "John" :position :accountant] - [:employee :id 4 :name "Sameer" :position :chief-programmer] - [:employee :id 5 :name "Lilian" :position :programmer] - [:employee :id 6 :name "Li" :position :technician] - [:employee :id 7 :name "Fred" :position :sales] - [:employee :id 8 :name "Brenda" :position :sales] - [:employee :id 9 :name "Miki" :position :project-management] - [:employee :id 10 :name "Albert" :position :technician] - - [:boss :employee-id 2 :boss-id 1] - [:boss :employee-id 3 :boss-id 2] - [:boss :employee-id 4 :boss-id 1] - [:boss :employee-id 5 :boss-id 4] - [:boss :employee-id 6 :boss-id 4] - [:boss :employee-id 7 :boss-id 1] - [:boss :employee-id 8 :boss-id 7] - [:boss :employee-id 9 :boss-id 1] - [:boss :employee-id 10 :boss-id 6] - - [:can-do-job :position :boss :job :management] - [:can-do-job :position :accountant :job :accounting] - [:can-do-job :position :chief-accountant :job :accounting] - [:can-do-job :position :programmer :job :programming] - [:can-do-job :position :chief-programmer :job :programming] - [:can-do-job :position :technician :job :server-support] - [:can-do-job :position :sales :job :sales] - [:can-do-job :position :project-management :job :project-management] - - [:job-replacement :job :pc-support :can-be-done-by :server-support] - [:job-replacement :job :pc-support :can-be-done-by :programming] - [:job-replacement :job :payroll :can-be-done-by :accounting] - - [:job-exceptions :id 4 :job :pc-support])) - -(def rules - (rules-set - (<- (:works-for :employee ?x :boss ?y) (:boss :employee-id ?e-id :boss-id ?b-id) - (:employee :id ?e-id :name ?x) - (:employee :id ?b-id :name ?y)) - (<- (:works-for :employee ?x :boss ?y) (:works-for :employee ?x :boss ?z) - (:works-for :employee ?z :boss ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:employee :name ?x :position ?pos) - (:can-do-job :position ?pos :job ?y)) - (<- (:employee-job* :employee ?x :job ?y) (:job-replacement :job ?y :can-be-done-by ?z) - (:employee-job* :employee ?x :job ?z)) - (<- (:employee-job* :employee ?x :job ?y) (:can-do-job :job ?y) - (:employee :name ?x :position ?z) - (if = ?z :boss)) - (<- (:employee-job :employee ?x :job ?y) (:employee-job* :employee ?x :job ?y) - (:employee :id ?id :name ?x) - (not! :job-exceptions :id ?id :job ?y)) - (<- (:bj :name ?x :boss ?y) (:works-for :employee ?x :boss ?y) - (not! :employee-job :employee ?y :job :pc-support)))) - - - -(def wp-1 (build-work-plan rules (?- :works-for :employee '??name :boss ?x))) -(run-work-plan wp-1 db {'??name "Albert"}) - -(def wp-2 (build-work-plan rules (?- :employee-job :employee '??name :job ?x))) -(binding [*trace-datalog* true] - (run-work-plan wp-2 db {'??name "Li"})) - -(def wp-3 (build-work-plan rules (?- :bj :name '??name :boss ?x))) -(run-work-plan wp-3 db {'??name "Albert"}) - -(def wp-4 (build-work-plan rules (?- :works-for :employee ?x :boss ?y))) -(run-work-plan wp-4 db {}) - - -;; End of file diff --git a/src/clojure/contrib/datalog/literals.clj b/src/clojure/contrib/datalog/literals.clj deleted file mode 100644 index 12605160..00000000 --- a/src/clojure/contrib/datalog/literals.clj +++ /dev/null @@ -1,414 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and -;; distribution terms for this software are covered by the Eclipse Public -;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can -;; be found in the file epl-v10.html at the root of this distribution. By -;; using this software in any fashion, you are agreeing to be bound by the -;; terms of this license. You must not remove this notice, or any other, -;; from this software. -;; -;; literals.clj -;; -;; A Clojure implementation of Datalog -- Literals -;; -;; straszheimjeffrey (gmail) -;; Created 25 Feburary 2009 - - -(ns clojure.contrib.datalog.literals - (:use clojure.contrib.datalog.util) - (:use clojure.contrib.datalog.database) - (:use [clojure.set :only (intersection)]) - (:use [clojure.contrib.set :only (subset?)]) - (:use [clojure.contrib.seq-utils :only (flatten)])) - - -;;; Type Definitions - -(defstruct atomic-literal - :predicate ; The predicate name - :term-bindings ; A map of column names to bindings - :literal-type) ; ::literal or ::negated - -(derive ::negated ::literal) - -(defstruct conditional-literal - :fun ; The fun to call - :symbol ; The fun symbol (for display) - :terms ; The formal arguments - :literal-type) ; ::conditional - - -;;; Basics - - -(defmulti literal-predicate - "Return the predicate/relation this conditional operates over" - :literal-type) - -(defmulti literal-columns - "Return the column names this applies to" - :literal-type) - -(defmulti literal-vars - "Returns the logic vars used by this literal" - :literal-type) - -(defmulti positive-vars - "Returns the logic vars used in a positive position" - :literal-type) - -(defmulti negative-vars - "Returns the logic vars used in a negative position" - :literal-type) - -(defmethod literal-predicate ::literal - [l] - (:predicate l)) - -(defmethod literal-predicate ::conditional - [l] - nil) - -(defmethod literal-columns ::literal - [l] - (-> l :term-bindings keys set)) - -(defmethod literal-columns ::conditional - [l] - nil) - -(defmethod literal-vars ::literal - [l] - (set (filter is-var? (-> l :term-bindings vals)))) - -(defmethod literal-vars ::conditional - [l] - (set (filter is-var? (:terms l)))) - -(defmethod positive-vars ::literal - [l] - (literal-vars l)) - -(defmethod positive-vars ::negated - [l] - nil) - -(defmethod positive-vars ::conditional - [l] - nil) - -(defmethod negative-vars ::literal - [l] - nil) - -(defmethod negative-vars ::negated - [l] - (literal-vars l)) - -(defmethod negative-vars ::conditional - [l] - (literal-vars l)) - -(defn negated? - "Is this literal a negated literal?" - [l] - (= (:literal-type l) ::negated)) - -(defn positive? - "Is this a positive literal?" - [l] - (= (:literal-type l) ::literal)) - - -;;; Building Literals - -(def negation-symbol 'not!) -(def conditional-symbol 'if) - -(defmulti build-literal - "(Returns an unevaluated expression (to be used in macros) of a - literal." - first) - -(defn build-atom - "Returns an unevaluated expression (to be used in a macro) of an - atom." - [f type] - (let [p (first f) - ts (map #(if (is-var? %) `(quote ~%) %) (next f)) - b (if (seq ts) (apply assoc {} ts) nil)] - `(struct atomic-literal ~p ~b ~type))) - -(defmethod build-literal :default - [f] - (build-atom f ::literal)) - -(defmethod build-literal negation-symbol - [f] - (build-atom (rest f) ::negated)) - -(defmethod build-literal conditional-symbol - [f] - (let [symbol (fnext f) - terms (nnext f) - fun `(fn [binds#] (apply ~symbol binds#))] - `(struct conditional-literal - ~fun - '~symbol - '~terms - ::conditional))) - - -;;; Display - -(defmulti display-literal - "Converts a struct representing a literal to a normal list" - :literal-type) - -(defn- display - [l] - (conj (-> l :term-bindings list* flatten) (literal-predicate l))) - -(defmethod display-literal ::literal - [l] - (display l)) - -(defmethod display-literal ::negated - [l] - (conj (display l) negation-symbol)) - -(defmethod display-literal ::conditional - [l] - (list* conditional-symbol (:symbol l) (:terms l))) - - -;;; Sip computation - -(defmulti get-vs-from-cs - "From a set of columns, return the vars" - :literal-type) - -(defmethod get-vs-from-cs ::literal - [l bound] - (set (filter is-var? - (vals (select-keys (:term-bindings l) - bound))))) - -(defmethod get-vs-from-cs ::conditional - [l bound] - nil) - - -(defmulti get-cs-from-vs - "From a set of vars, get the columns" - :literal-type) - -(defmethod get-cs-from-vs ::literal - [l bound] - (reduce conj - #{} - (remove nil? - (map (fn [[k v]] (if (bound v) k nil)) - (:term-bindings l))))) - -(defmethod get-cs-from-vs ::conditional - [l bound] - nil) - - -(defmulti get-self-bound-cs - "Get the columns that are bound withing the literal." - :literal-type) - -(defmethod get-self-bound-cs ::literal - [l] - (reduce conj - #{} - (remove nil? - (map (fn [[k v]] (if (not (is-var? v)) k nil)) - (:term-bindings l))))) - -(defmethod get-self-bound-cs ::conditional - [l] - nil) - - -(defmulti literal-appropriate? - "When passed a set of bound vars, determines if this literal can be - used during this point of a SIP computation." - (fn [b l] (:literal-type l))) - -(defmethod literal-appropriate? ::literal - [bound l] - (not (empty? (intersection (literal-vars l) bound)))) - -(defmethod literal-appropriate? ::negated - [bound l] - (subset? (literal-vars l) bound)) - -(defmethod literal-appropriate? ::conditional - [bound l] - (subset? (literal-vars l) bound)) - - -(defmulti adorned-literal - "When passed a set of bound columns, returns the adorned literal" - (fn [l b] (:literal-type l))) - -(defmethod adorned-literal ::literal - [l bound] - (let [pred (literal-predicate l) - bnds (intersection (literal-columns l) bound)] - (if (empty? bound) - l - (assoc l :predicate {:pred pred :bound bnds})))) - -(defmethod adorned-literal ::conditional - [l bound] - l) - - -(defn get-adorned-bindings - "Get the bindings from this adorned literal." - [pred] - (:bound pred)) - -(defn get-base-predicate - "Get the base predicate from this predicate." - [pred] - (if (map? pred) - (:pred pred) - pred)) - - -;;; Magic Stuff - -(defn magic-literal - "Create a magic version of this adorned predicate." - [l] - (assert (-> l :literal-type (isa? ::literal))) - (let [pred (literal-predicate l) - pred-map (if (map? pred) pred {:pred pred}) - bound (get-adorned-bindings pred) - ntb (select-keys (:term-bindings l) bound)] - (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal))) - -(defn literal-magic? - "Is this literal magic?" - [lit] - (let [pred (literal-predicate lit)] - (when (map? pred) - (:magic pred)))) - -(defn build-seed-bindings - "Given a seed literal, already adorned and in magic form, convert - its bound constants to new variables." - [s] - (assert (-> s :literal-type (isa? ::literal))) - (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))] - (assoc s :term-bindings ntbs))) - - -;;; Semi-naive support - -(defn negated-literal - "Given a literal l, return a negated version" - [l] - (assert (-> l :literal-type (= ::literal))) - (assoc l :literal-type ::negated)) - -(defn delta-literal - "Given a literal l, return a delta version" - [l] - (let [pred* (:predicate l) - pred (if (map? pred*) pred* {:pred pred*})] - (assoc l :predicate (assoc pred :delta true)))) - - -;;; Database operations - -(defn- build-partial-tuple - [lit binds] - (let [tbs (:term-bindings lit) - each (fn [[key val :as pair]] - (if (is-var? val) - (if-let [n (binds val)] - [key n] - nil) - pair))] - (into {} (remove nil? (map each tbs))))) - -(defn- project-onto-literal - "Given a literal, and a materialized tuple, return a set of variable - bindings." - [lit tuple] - (let [step (fn [binds [key val]] - (if (and (is-var? val) - (contains? tuple key)) - (assoc binds val (tuple key)) - binds))] - (reduce step {} (:term-bindings lit)))) - - -(defn- join-literal* - [db lit bs fun] - (let [each (fn [binds] - (let [pt (build-partial-tuple lit binds)] - (fun binds pt)))] - (when (contains? db (literal-predicate lit)) - (apply concat (map each bs))))) - -(defmulti join-literal - "Given a database (db), a literal (lit) and a seq of bindings (bs), - return a new seq of bindings by joining this literal." - (fn [db lit bs] (:literal-type lit))) - -(defmethod join-literal ::literal - [db lit bs] - (join-literal* db lit bs (fn [binds pt] - (map #(merge binds %) - (map (partial project-onto-literal lit) - (select db (literal-predicate lit) pt)))))) - -(defmethod join-literal ::negated - [db lit bs] - (join-literal* db lit bs (fn [binds pt] - (if (any-match? db (literal-predicate lit) pt) - nil - [binds])))) - -(defmethod join-literal ::conditional - [db lit bs] - (let [each (fn [binds] - (let [resolve (fn [term] - (if (is-var? term) - (binds term) - term)) - args (map resolve (:terms lit))] - (if ((:fun lit) args) - binds - nil)))] - (remove nil? (map each bs)))) - -(defn project-literal - "Project a stream of bindings onto a literal/relation. Returns a new - db." - ([db lit bs] (project-literal db lit bs is-var?)) - ([db lit bs var?] - (assert (= (:literal-type lit) ::literal)) - (let [rel-name (literal-predicate lit) - columns (-> lit :term-bindings keys) - idxs (vec (get-adorned-bindings (literal-predicate lit))) - db1 (ensure-relation db rel-name columns idxs) - rel (get-relation db1 rel-name) - step (fn [rel bindings] - (let [step (fn [t [k v]] - (if (var? v) - (assoc t k (bindings v)) - (assoc t k v))) - tuple (reduce step {} (:term-bindings lit))] - (add-tuple rel tuple)))] - (replace-relation db rel-name (reduce step rel bs))))) - - -;; End of file diff --git a/src/clojure/contrib/datalog/magic.clj b/src/clojure/contrib/datalog/magic.clj deleted file mode 100644 index ff6891a4..00000000 --- a/src/clojure/contrib/datalog/magic.clj +++ /dev/null @@ -1,128 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and -;; distribution terms for this software are covered by the Eclipse Public -;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can -;; be found in the file epl-v10.html at the root of this distribution. By -;; using this software in any fashion, you are agreeing to be bound by the -;; terms of this license. You must not remove this notice, or any other, -;; from this software. -;; -;; magic.clj -;; -;; A Clojure implementation of Datalog -- Magic Sets -;; -;; straszheimjeffrey (gmail) -;; Created 18 Feburary 2009 - - -(ns clojure.contrib.datalog.magic - (:use clojure.contrib.datalog.util - clojure.contrib.datalog.literals - clojure.contrib.datalog.rules) - (:use [clojure.set :only (union intersection difference)])) - - -;;; Adornment - -(defn adorn-query - "Adorn a query" - [q] - (adorned-literal q (get-self-bound-cs q))) - -(defn adorn-rules-set - "Adorns the given rules-set for the given query. (rs) is a - rules-set, (q) is an adorned query." - [rs q] - (let [i-preds (all-predicates rs) - p-map (predicate-map rs)] - (loop [nrs empty-rules-set ; The rules set being built - needed #{(literal-predicate q)}] - (if (empty? needed) - nrs - (let [pred (first needed) - remaining (disj needed pred) - base-pred (get-base-predicate pred) - bindings (get-adorned-bindings pred) - new-rules (p-map base-pred) - new-adorned-rules (map (partial compute-sip bindings i-preds) - new-rules) - new-nrs (reduce conj nrs new-adorned-rules) - current-preds (all-predicates new-nrs) - not-needed? (fn [pred] - (or (current-preds pred) - (-> pred get-base-predicate i-preds not))) - add-pred (fn [np pred] - (if (not-needed? pred) np (conj np pred))) - add-preds (fn [np rule] - (reduce add-pred np (map literal-predicate (:body rule)))) - new-needed (reduce add-preds remaining new-adorned-rules)] - (recur new-nrs new-needed)))))) - - -;;; Magic ! - -(defn seed-relation - "Given a magic form of a query, give back the literal form of its seed - relation" - [q] - (let [pred (-> q literal-predicate get-base-predicate) - bnds (-> q literal-predicate get-adorned-bindings)] - (with-meta (assoc q :predicate [pred :magic-seed bnds]) {}))) - -(defn seed-rule - "Given an adorned query, give back its seed rule" - [q] - (let [mq (build-seed-bindings (magic-literal q)) - sr (seed-relation mq)] - (build-rule mq [sr]))) - -(defn build-partial-tuple - "Given a query and a set of bindings, build a partial tuple needed - to extract the relation from the database." - [q bindings] - (into {} (remove nil? (map (fn [[k v :as pair]] - (if (is-var? v) - nil - (if (is-query-var? v) - [k (bindings v)] - pair))) - (:term-bindings q))))) - -(defn seed-predicate-for-insertion - "Given a query, return the predicate to use for database insertion." - [q] - (let [seed (-> q seed-rule :body first) - columns (-> seed :term-bindings keys) - new-term-bindings (-> q :term-bindings (select-keys columns))] - (assoc seed :term-bindings new-term-bindings))) - -(defn magic-transform - "Return a magic transformation of an adorned rules-set (rs). The - (i-preds) are the predicates of the intension database. These - default to the predicates within the rules-set." - ([rs] - (magic-transform rs (all-predicates rs))) - ([rs i-preds] - (let [not-duplicate? (fn [l mh bd] - (or (not (empty? bd)) - (not (= (magic-literal l) - mh)))) - xr (fn [rs rule] - (let [head (:head rule) - body (:body rule) - mh (magic-literal head) - answer-rule (build-rule head - (concat [mh] body)) - step (fn [[rs bd] l] - (if (and (i-preds (literal-predicate l)) - (not-duplicate? l mh bd)) - (let [nr (build-rule (magic-literal l) - (concat [mh] bd))] - [(conj rs nr) (conj bd l)]) - [rs (conj bd l)])) - [nrs _] (reduce step [rs []] body)] - (conj nrs answer-rule)))] - (reduce xr empty-rules-set rs)))) - - - -;; End of file diff --git a/src/clojure/contrib/datalog/rules.clj b/src/clojure/contrib/datalog/rules.clj deleted file mode 100644 index bcfe5c4c..00000000 --- a/src/clojure/contrib/datalog/rules.clj +++ /dev/null @@ -1,207 +0,0 @@ -;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and -;; distribution terms for this software are covered by the Eclipse Public -;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can -;; be found in the file epl-v10.html at the root of this distribution. By -;; using this software in any fashion, you are agreeing to be bound by the -;; terms of this license. You must not remove this notice, or any other, -;; from this software. -;; -;; rules.cl |