;;  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?)]))

 

 

 ;;; 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