rlm@10: ;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
rlm@10: ;;  distribution terms for this software are covered by the Eclipse Public
rlm@10: ;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
rlm@10: ;;  be found in the file epl-v10.html at the root of this distribution.  By
rlm@10: ;;  using this software in any fashion, you are agreeing to be bound by the
rlm@10: ;;  terms of this license.  You must not remove this notice, or any other,
rlm@10: ;;  from this software.
rlm@10: ;;
rlm@10: ;;  literals.clj
rlm@10: ;;
rlm@10: ;;  A Clojure implementation of Datalog -- Literals
rlm@10: ;;
rlm@10: ;;  straszheimjeffrey (gmail)
rlm@10: ;;  Created 25 Feburary 2009
rlm@10: 
rlm@10: 
rlm@10: (ns clojure.contrib.datalog.literals
rlm@10:   (:use clojure.contrib.datalog.util)
rlm@10:   (:use clojure.contrib.datalog.database)
rlm@10:   (:use [clojure.set :only (intersection)])
rlm@10:   (:use [clojure.contrib.set :only (subset?)]))
rlm@10: 
rlm@10: 
rlm@10: ;;; Type Definitions
rlm@10: 
rlm@10: (defstruct atomic-literal
rlm@10:   :predicate              ; The predicate name
rlm@10:   :term-bindings          ; A map of column names to bindings
rlm@10:   :literal-type)          ; ::literal or ::negated
rlm@10: 
rlm@10: (derive ::negated ::literal)
rlm@10: 
rlm@10: (defstruct conditional-literal
rlm@10:   :fun                    ; The fun to call
rlm@10:   :symbol                 ; The fun symbol (for display)
rlm@10:   :terms                  ; The formal arguments
rlm@10:   :literal-type)          ; ::conditional
rlm@10: 
rlm@10: 
rlm@10: ;;; Basics
rlm@10: 
rlm@10: 
rlm@10: (defmulti literal-predicate
rlm@10:   "Return the predicate/relation this conditional operates over"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmulti literal-columns
rlm@10:   "Return the column names this applies to"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmulti literal-vars
rlm@10:   "Returns the logic vars used by this literal"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmulti positive-vars
rlm@10:   "Returns the logic vars used in a positive position"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmulti negative-vars
rlm@10:   "Returns the logic vars used in a negative position"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmethod literal-predicate ::literal
rlm@10:   [l]
rlm@10:   (:predicate l))
rlm@10: 
rlm@10: (defmethod literal-predicate ::conditional
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: (defmethod literal-columns ::literal
rlm@10:   [l]
rlm@10:   (-> l :term-bindings keys set))
rlm@10: 
rlm@10: (defmethod literal-columns ::conditional
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: (defmethod literal-vars ::literal
rlm@10:   [l]
rlm@10:   (set (filter is-var? (-> l :term-bindings vals))))
rlm@10: 
rlm@10: (defmethod literal-vars ::conditional
rlm@10:   [l]
rlm@10:   (set (filter is-var? (:terms l))))
rlm@10: 
rlm@10: (defmethod positive-vars ::literal
rlm@10:   [l]
rlm@10:   (literal-vars l))
rlm@10: 
rlm@10: (defmethod positive-vars ::negated
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: (defmethod positive-vars ::conditional
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: (defmethod negative-vars ::literal
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: (defmethod negative-vars ::negated
rlm@10:   [l]
rlm@10:   (literal-vars l))
rlm@10: 
rlm@10: (defmethod negative-vars ::conditional
rlm@10:   [l]
rlm@10:   (literal-vars l))
rlm@10: 
rlm@10: (defn negated?
rlm@10:   "Is this literal a negated literal?"
rlm@10:   [l]
rlm@10:   (= (:literal-type l) ::negated))
rlm@10: 
rlm@10: (defn positive?
rlm@10:   "Is this a positive literal?"
rlm@10:   [l]
rlm@10:   (= (:literal-type l) ::literal))
rlm@10: 
rlm@10: 
rlm@10: ;;; Building Literals
rlm@10: 
rlm@10: (def negation-symbol 'not!)
rlm@10: (def conditional-symbol 'if)
rlm@10: 
rlm@10: (defmulti build-literal
rlm@10:   "(Returns an unevaluated expression (to be used in macros) of a
rlm@10:    literal."
rlm@10:   first)
rlm@10: 
rlm@10: (defn build-atom
rlm@10:   "Returns an unevaluated expression (to be used in a macro) of an
rlm@10:    atom."
rlm@10:   [f type]
rlm@10:   (let [p (first f)
rlm@10:         ts (map #(if (is-var? %) `(quote ~%) %) (next f))
rlm@10:         b (if (seq ts) (apply assoc {} ts) nil)]
rlm@10:     `(struct atomic-literal ~p ~b ~type)))
rlm@10: 
rlm@10: (defmethod build-literal :default
rlm@10:   [f]
rlm@10:   (build-atom f ::literal))
rlm@10: 
rlm@10: (defmethod build-literal negation-symbol
rlm@10:   [f]
rlm@10:   (build-atom (rest f) ::negated))
rlm@10: 
rlm@10: (defmethod build-literal conditional-symbol
rlm@10:   [f]
rlm@10:   (let [symbol (fnext f)
rlm@10:         terms (nnext f)
rlm@10:         fun `(fn [binds#] (apply ~symbol binds#))]
rlm@10:     `(struct conditional-literal
rlm@10:              ~fun
rlm@10:              '~symbol
rlm@10:              '~terms
rlm@10:              ::conditional)))
rlm@10: 
rlm@10: 
rlm@10: ;;; Display
rlm@10: 
rlm@10: (defmulti display-literal
rlm@10:   "Converts a struct representing a literal to a normal list"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defn- display
rlm@10:   [l]
rlm@10:   (conj (-> l :term-bindings list* flatten) (literal-predicate l)))
rlm@10: 
rlm@10: (defmethod display-literal ::literal
rlm@10:   [l]
rlm@10:   (display l))
rlm@10: 
rlm@10: (defmethod display-literal ::negated
rlm@10:   [l]
rlm@10:   (conj (display l) negation-symbol))
rlm@10: 
rlm@10: (defmethod display-literal ::conditional
rlm@10:   [l]
rlm@10:   (list* conditional-symbol (:symbol l) (:terms l)))
rlm@10: 
rlm@10: 
rlm@10: ;;; Sip computation
rlm@10: 
rlm@10: (defmulti get-vs-from-cs
rlm@10:   "From a set of columns, return the vars"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmethod get-vs-from-cs ::literal
rlm@10:   [l bound]
rlm@10:   (set (filter is-var?
rlm@10:                (vals (select-keys (:term-bindings l)
rlm@10:                                   bound)))))
rlm@10: 
rlm@10: (defmethod get-vs-from-cs ::conditional
rlm@10:   [l bound]
rlm@10:   nil)
rlm@10: 
rlm@10: 
rlm@10: (defmulti get-cs-from-vs
rlm@10:   "From a set of vars, get the columns"
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmethod get-cs-from-vs ::literal
rlm@10:   [l bound]
rlm@10:   (reduce conj
rlm@10:           #{}
rlm@10:           (remove nil? 
rlm@10:                   (map (fn [[k v]] (if (bound v) k nil))
rlm@10:                        (:term-bindings l)))))
rlm@10: 
rlm@10: (defmethod get-cs-from-vs ::conditional
rlm@10:   [l bound]
rlm@10:   nil)
rlm@10: 
rlm@10: 
rlm@10: (defmulti get-self-bound-cs
rlm@10:   "Get the columns that are bound withing the literal."
rlm@10:   :literal-type)
rlm@10: 
rlm@10: (defmethod get-self-bound-cs ::literal
rlm@10:   [l]
rlm@10:   (reduce conj
rlm@10:           #{}
rlm@10:           (remove nil?
rlm@10:                   (map (fn [[k v]] (if (not (is-var? v)) k nil))
rlm@10:                        (:term-bindings l)))))
rlm@10: 
rlm@10: (defmethod get-self-bound-cs ::conditional
rlm@10:   [l]
rlm@10:   nil)
rlm@10: 
rlm@10: 
rlm@10: (defmulti literal-appropriate?
rlm@10:   "When passed a set of bound vars, determines if this literal can be
rlm@10:    used during this point of a SIP computation."
rlm@10:   (fn [b l] (:literal-type l)))
rlm@10: 
rlm@10: (defmethod literal-appropriate? ::literal
rlm@10:   [bound l]
rlm@10:   (not (empty? (intersection (literal-vars l) bound))))
rlm@10: 
rlm@10: (defmethod literal-appropriate? ::negated
rlm@10:   [bound l]
rlm@10:   (subset? (literal-vars l) bound))
rlm@10: 
rlm@10: (defmethod literal-appropriate? ::conditional
rlm@10:   [bound l]
rlm@10:   (subset? (literal-vars l) bound))
rlm@10: 
rlm@10: 
rlm@10: (defmulti adorned-literal
rlm@10:   "When passed a set of bound columns, returns the adorned literal"
rlm@10:   (fn [l b] (:literal-type l)))
rlm@10: 
rlm@10: (defmethod adorned-literal ::literal
rlm@10:   [l bound]
rlm@10:   (let [pred (literal-predicate l)
rlm@10:         bnds (intersection (literal-columns l) bound)]
rlm@10:     (if (empty? bound)
rlm@10:       l
rlm@10:       (assoc l :predicate {:pred pred :bound bnds}))))
rlm@10: 
rlm@10: (defmethod adorned-literal ::conditional
rlm@10:   [l bound]
rlm@10:   l)
rlm@10: 
rlm@10: 
rlm@10: (defn get-adorned-bindings
rlm@10:   "Get the bindings from this adorned literal."
rlm@10:   [pred]
rlm@10:   (:bound pred))
rlm@10: 
rlm@10: (defn get-base-predicate
rlm@10:   "Get the base predicate from this predicate."
rlm@10:   [pred]
rlm@10:   (if (map? pred)
rlm@10:     (:pred pred)
rlm@10:     pred))
rlm@10: 
rlm@10: 
rlm@10: ;;; Magic Stuff
rlm@10: 
rlm@10: (defn magic-literal
rlm@10:   "Create a magic version of this adorned predicate."
rlm@10:   [l]
rlm@10:   (assert (-> l :literal-type (isa? ::literal)))
rlm@10:   (let [pred (literal-predicate l)
rlm@10:         pred-map (if (map? pred) pred {:pred pred})
rlm@10:         bound (get-adorned-bindings pred)
rlm@10:         ntb (select-keys (:term-bindings l) bound)]
rlm@10:     (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal)))
rlm@10: 
rlm@10: (defn literal-magic?
rlm@10:   "Is this literal magic?"
rlm@10:   [lit]
rlm@10:   (let [pred (literal-predicate lit)]
rlm@10:     (when (map? pred)
rlm@10:       (:magic pred))))
rlm@10:       
rlm@10: (defn build-seed-bindings
rlm@10:   "Given a seed literal, already adorned and in magic form, convert
rlm@10:    its bound constants to new variables."
rlm@10:   [s]
rlm@10:   (assert (-> s :literal-type (isa? ::literal)))
rlm@10:   (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))]
rlm@10:     (assoc s :term-bindings ntbs)))
rlm@10: 
rlm@10: 
rlm@10: ;;; Semi-naive support
rlm@10: 
rlm@10: (defn negated-literal
rlm@10:   "Given a literal l, return a negated version"
rlm@10:   [l]
rlm@10:   (assert (-> l :literal-type (= ::literal)))
rlm@10:   (assoc l :literal-type ::negated))
rlm@10: 
rlm@10: (defn delta-literal
rlm@10:   "Given a literal l, return a delta version"
rlm@10:   [l]
rlm@10:   (let [pred* (:predicate l)
rlm@10:         pred (if (map? pred*) pred* {:pred pred*})]
rlm@10:     (assoc l :predicate (assoc pred :delta true))))
rlm@10: 
rlm@10:         
rlm@10: ;;; Database operations
rlm@10: 
rlm@10: (defn- build-partial-tuple
rlm@10:   [lit binds]
rlm@10:   (let [tbs (:term-bindings lit)
rlm@10:         each (fn [[key val :as pair]]
rlm@10:                (if (is-var? val)
rlm@10:                  (if-let [n (binds val)]
rlm@10:                    [key n]
rlm@10:                    nil)
rlm@10:                  pair))]
rlm@10:     (into {} (remove nil? (map each tbs)))))
rlm@10: 
rlm@10: (defn- project-onto-literal
rlm@10:   "Given a literal, and a materialized tuple, return a set of variable
rlm@10:    bindings."
rlm@10:   [lit tuple]
rlm@10:   (let [step (fn [binds [key val]]
rlm@10:                (if (and (is-var? val)
rlm@10:                         (contains? tuple key))
rlm@10:                  (assoc binds val (tuple key))
rlm@10:                  binds))]
rlm@10:     (reduce step {} (:term-bindings lit))))
rlm@10:   
rlm@10: 
rlm@10: (defn- join-literal*
rlm@10:   [db lit bs fun]
rlm@10:   (let [each (fn [binds]
rlm@10:                (let [pt (build-partial-tuple lit binds)]
rlm@10:                  (fun binds pt)))]
rlm@10:     (when (contains? db (literal-predicate lit))
rlm@10:       (apply concat (map each bs)))))
rlm@10: 
rlm@10: (defmulti join-literal
rlm@10:   "Given a database (db), a literal (lit) and a seq of bindings (bs),
rlm@10:    return a new seq of bindings by joining this literal."
rlm@10:   (fn [db lit bs] (:literal-type lit)))
rlm@10: 
rlm@10: (defmethod join-literal ::literal
rlm@10:   [db lit bs]
rlm@10:   (join-literal* db lit bs (fn [binds pt]
rlm@10:                              (map #(merge binds %)
rlm@10:                                   (map (partial project-onto-literal lit)
rlm@10:                                        (select db (literal-predicate lit) pt))))))
rlm@10: 
rlm@10: (defmethod join-literal ::negated
rlm@10:   [db lit bs]
rlm@10:   (join-literal* db lit bs (fn [binds pt]
rlm@10:                              (if (any-match? db (literal-predicate lit) pt)
rlm@10:                                nil
rlm@10:                                [binds]))))
rlm@10: 
rlm@10: (defmethod join-literal ::conditional
rlm@10:   [db lit bs]
rlm@10:   (let [each (fn [binds]
rlm@10:                (let [resolve (fn [term]
rlm@10:                                (if (is-var? term)
rlm@10:                                  (binds term)
rlm@10:                                  term))
rlm@10:                      args (map resolve (:terms lit))]
rlm@10:                  (if ((:fun lit) args)
rlm@10:                    binds
rlm@10:                    nil)))]
rlm@10:     (remove nil? (map each bs))))
rlm@10:                  
rlm@10: (defn project-literal
rlm@10:   "Project a stream of bindings onto a literal/relation. Returns a new
rlm@10:    db."
rlm@10:   ([db lit bs] (project-literal db lit bs is-var?))
rlm@10:   ([db lit bs var?]
rlm@10:      (assert (= (:literal-type lit) ::literal))
rlm@10:      (let [rel-name (literal-predicate lit)
rlm@10:            columns (-> lit :term-bindings keys)
rlm@10:            idxs (vec (get-adorned-bindings (literal-predicate lit)))
rlm@10:            db1 (ensure-relation db rel-name columns idxs)
rlm@10:            rel (get-relation db1 rel-name)
rlm@10:            step (fn [rel bindings]
rlm@10:                   (let [step (fn [t [k v]]
rlm@10:                                (if (var? v)
rlm@10:                                  (assoc t k (bindings v))
rlm@10:                                  (assoc t k v)))
rlm@10:                         tuple (reduce step {} (:term-bindings lit))]
rlm@10:                     (add-tuple rel tuple)))]
rlm@10:        (replace-relation db rel-name (reduce step rel bs)))))
rlm@10: 
rlm@10: 
rlm@10: ;; End of file