diff options
Diffstat (limited to 'src/clojure/contrib/datalog/literals.clj')
| -rw-r--r-- | src/clojure/contrib/datalog/literals.clj | 414 |
1 files changed, 0 insertions, 414 deletions
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 |