1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/datalog/literals.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,413 @@
     1.4 +;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
     1.5 +;;  distribution terms for this software are covered by the Eclipse Public
     1.6 +;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
     1.7 +;;  be found in the file epl-v10.html at the root of this distribution.  By
     1.8 +;;  using this software in any fashion, you are agreeing to be bound by the
     1.9 +;;  terms of this license.  You must not remove this notice, or any other,
    1.10 +;;  from this software.
    1.11 +;;
    1.12 +;;  literals.clj
    1.13 +;;
    1.14 +;;  A Clojure implementation of Datalog -- Literals
    1.15 +;;
    1.16 +;;  straszheimjeffrey (gmail)
    1.17 +;;  Created 25 Feburary 2009
    1.18 +
    1.19 +
    1.20 +(ns clojure.contrib.datalog.literals
    1.21 +  (:use clojure.contrib.datalog.util)
    1.22 +  (:use clojure.contrib.datalog.database)
    1.23 +  (:use [clojure.set :only (intersection)])
    1.24 +  (:use [clojure.contrib.set :only (subset?)]))
    1.25 +
    1.26 +
    1.27 +;;; Type Definitions
    1.28 +
    1.29 +(defstruct atomic-literal
    1.30 +  :predicate              ; The predicate name
    1.31 +  :term-bindings          ; A map of column names to bindings
    1.32 +  :literal-type)          ; ::literal or ::negated
    1.33 +
    1.34 +(derive ::negated ::literal)
    1.35 +
    1.36 +(defstruct conditional-literal
    1.37 +  :fun                    ; The fun to call
    1.38 +  :symbol                 ; The fun symbol (for display)
    1.39 +  :terms                  ; The formal arguments
    1.40 +  :literal-type)          ; ::conditional
    1.41 +
    1.42 +
    1.43 +;;; Basics
    1.44 +
    1.45 +
    1.46 +(defmulti literal-predicate
    1.47 +  "Return the predicate/relation this conditional operates over"
    1.48 +  :literal-type)
    1.49 +
    1.50 +(defmulti literal-columns
    1.51 +  "Return the column names this applies to"
    1.52 +  :literal-type)
    1.53 +
    1.54 +(defmulti literal-vars
    1.55 +  "Returns the logic vars used by this literal"
    1.56 +  :literal-type)
    1.57 +
    1.58 +(defmulti positive-vars
    1.59 +  "Returns the logic vars used in a positive position"
    1.60 +  :literal-type)
    1.61 +
    1.62 +(defmulti negative-vars
    1.63 +  "Returns the logic vars used in a negative position"
    1.64 +  :literal-type)
    1.65 +
    1.66 +(defmethod literal-predicate ::literal
    1.67 +  [l]
    1.68 +  (:predicate l))
    1.69 +
    1.70 +(defmethod literal-predicate ::conditional
    1.71 +  [l]
    1.72 +  nil)
    1.73 +
    1.74 +(defmethod literal-columns ::literal
    1.75 +  [l]
    1.76 +  (-> l :term-bindings keys set))
    1.77 +
    1.78 +(defmethod literal-columns ::conditional
    1.79 +  [l]
    1.80 +  nil)
    1.81 +
    1.82 +(defmethod literal-vars ::literal
    1.83 +  [l]
    1.84 +  (set (filter is-var? (-> l :term-bindings vals))))
    1.85 +
    1.86 +(defmethod literal-vars ::conditional
    1.87 +  [l]
    1.88 +  (set (filter is-var? (:terms l))))
    1.89 +
    1.90 +(defmethod positive-vars ::literal
    1.91 +  [l]
    1.92 +  (literal-vars l))
    1.93 +
    1.94 +(defmethod positive-vars ::negated
    1.95 +  [l]
    1.96 +  nil)
    1.97 +
    1.98 +(defmethod positive-vars ::conditional
    1.99 +  [l]
   1.100 +  nil)
   1.101 +
   1.102 +(defmethod negative-vars ::literal
   1.103 +  [l]
   1.104 +  nil)
   1.105 +
   1.106 +(defmethod negative-vars ::negated
   1.107 +  [l]
   1.108 +  (literal-vars l))
   1.109 +
   1.110 +(defmethod negative-vars ::conditional
   1.111 +  [l]
   1.112 +  (literal-vars l))
   1.113 +
   1.114 +(defn negated?
   1.115 +  "Is this literal a negated literal?"
   1.116 +  [l]
   1.117 +  (= (:literal-type l) ::negated))
   1.118 +
   1.119 +(defn positive?
   1.120 +  "Is this a positive literal?"
   1.121 +  [l]
   1.122 +  (= (:literal-type l) ::literal))
   1.123 +
   1.124 +
   1.125 +;;; Building Literals
   1.126 +
   1.127 +(def negation-symbol 'not!)
   1.128 +(def conditional-symbol 'if)
   1.129 +
   1.130 +(defmulti build-literal
   1.131 +  "(Returns an unevaluated expression (to be used in macros) of a
   1.132 +   literal."
   1.133 +  first)
   1.134 +
   1.135 +(defn build-atom
   1.136 +  "Returns an unevaluated expression (to be used in a macro) of an
   1.137 +   atom."
   1.138 +  [f type]
   1.139 +  (let [p (first f)
   1.140 +        ts (map #(if (is-var? %) `(quote ~%) %) (next f))
   1.141 +        b (if (seq ts) (apply assoc {} ts) nil)]
   1.142 +    `(struct atomic-literal ~p ~b ~type)))
   1.143 +
   1.144 +(defmethod build-literal :default
   1.145 +  [f]
   1.146 +  (build-atom f ::literal))
   1.147 +
   1.148 +(defmethod build-literal negation-symbol
   1.149 +  [f]
   1.150 +  (build-atom (rest f) ::negated))
   1.151 +
   1.152 +(defmethod build-literal conditional-symbol
   1.153 +  [f]
   1.154 +  (let [symbol (fnext f)
   1.155 +        terms (nnext f)
   1.156 +        fun `(fn [binds#] (apply ~symbol binds#))]
   1.157 +    `(struct conditional-literal
   1.158 +             ~fun
   1.159 +             '~symbol
   1.160 +             '~terms
   1.161 +             ::conditional)))
   1.162 +
   1.163 +
   1.164 +;;; Display
   1.165 +
   1.166 +(defmulti display-literal
   1.167 +  "Converts a struct representing a literal to a normal list"
   1.168 +  :literal-type)
   1.169 +
   1.170 +(defn- display
   1.171 +  [l]
   1.172 +  (conj (-> l :term-bindings list* flatten) (literal-predicate l)))
   1.173 +
   1.174 +(defmethod display-literal ::literal
   1.175 +  [l]
   1.176 +  (display l))
   1.177 +
   1.178 +(defmethod display-literal ::negated
   1.179 +  [l]
   1.180 +  (conj (display l) negation-symbol))
   1.181 +
   1.182 +(defmethod display-literal ::conditional
   1.183 +  [l]
   1.184 +  (list* conditional-symbol (:symbol l) (:terms l)))
   1.185 +
   1.186 +
   1.187 +;;; Sip computation
   1.188 +
   1.189 +(defmulti get-vs-from-cs
   1.190 +  "From a set of columns, return the vars"
   1.191 +  :literal-type)
   1.192 +
   1.193 +(defmethod get-vs-from-cs ::literal
   1.194 +  [l bound]
   1.195 +  (set (filter is-var?
   1.196 +               (vals (select-keys (:term-bindings l)
   1.197 +                                  bound)))))
   1.198 +
   1.199 +(defmethod get-vs-from-cs ::conditional
   1.200 +  [l bound]
   1.201 +  nil)
   1.202 +
   1.203 +
   1.204 +(defmulti get-cs-from-vs
   1.205 +  "From a set of vars, get the columns"
   1.206 +  :literal-type)
   1.207 +
   1.208 +(defmethod get-cs-from-vs ::literal
   1.209 +  [l bound]
   1.210 +  (reduce conj
   1.211 +          #{}
   1.212 +          (remove nil? 
   1.213 +                  (map (fn [[k v]] (if (bound v) k nil))
   1.214 +                       (:term-bindings l)))))
   1.215 +
   1.216 +(defmethod get-cs-from-vs ::conditional
   1.217 +  [l bound]
   1.218 +  nil)
   1.219 +
   1.220 +
   1.221 +(defmulti get-self-bound-cs
   1.222 +  "Get the columns that are bound withing the literal."
   1.223 +  :literal-type)
   1.224 +
   1.225 +(defmethod get-self-bound-cs ::literal
   1.226 +  [l]
   1.227 +  (reduce conj
   1.228 +          #{}
   1.229 +          (remove nil?
   1.230 +                  (map (fn [[k v]] (if (not (is-var? v)) k nil))
   1.231 +                       (:term-bindings l)))))
   1.232 +
   1.233 +(defmethod get-self-bound-cs ::conditional
   1.234 +  [l]
   1.235 +  nil)
   1.236 +
   1.237 +
   1.238 +(defmulti literal-appropriate?
   1.239 +  "When passed a set of bound vars, determines if this literal can be
   1.240 +   used during this point of a SIP computation."
   1.241 +  (fn [b l] (:literal-type l)))
   1.242 +
   1.243 +(defmethod literal-appropriate? ::literal
   1.244 +  [bound l]
   1.245 +  (not (empty? (intersection (literal-vars l) bound))))
   1.246 +
   1.247 +(defmethod literal-appropriate? ::negated
   1.248 +  [bound l]
   1.249 +  (subset? (literal-vars l) bound))
   1.250 +
   1.251 +(defmethod literal-appropriate? ::conditional
   1.252 +  [bound l]
   1.253 +  (subset? (literal-vars l) bound))
   1.254 +
   1.255 +
   1.256 +(defmulti adorned-literal
   1.257 +  "When passed a set of bound columns, returns the adorned literal"
   1.258 +  (fn [l b] (:literal-type l)))
   1.259 +
   1.260 +(defmethod adorned-literal ::literal
   1.261 +  [l bound]
   1.262 +  (let [pred (literal-predicate l)
   1.263 +        bnds (intersection (literal-columns l) bound)]
   1.264 +    (if (empty? bound)
   1.265 +      l
   1.266 +      (assoc l :predicate {:pred pred :bound bnds}))))
   1.267 +
   1.268 +(defmethod adorned-literal ::conditional
   1.269 +  [l bound]
   1.270 +  l)
   1.271 +
   1.272 +
   1.273 +(defn get-adorned-bindings
   1.274 +  "Get the bindings from this adorned literal."
   1.275 +  [pred]
   1.276 +  (:bound pred))
   1.277 +
   1.278 +(defn get-base-predicate
   1.279 +  "Get the base predicate from this predicate."
   1.280 +  [pred]
   1.281 +  (if (map? pred)
   1.282 +    (:pred pred)
   1.283 +    pred))
   1.284 +
   1.285 +
   1.286 +;;; Magic Stuff
   1.287 +
   1.288 +(defn magic-literal
   1.289 +  "Create a magic version of this adorned predicate."
   1.290 +  [l]
   1.291 +  (assert (-> l :literal-type (isa? ::literal)))
   1.292 +  (let [pred (literal-predicate l)
   1.293 +        pred-map (if (map? pred) pred {:pred pred})
   1.294 +        bound (get-adorned-bindings pred)
   1.295 +        ntb (select-keys (:term-bindings l) bound)]
   1.296 +    (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal)))
   1.297 +
   1.298 +(defn literal-magic?
   1.299 +  "Is this literal magic?"
   1.300 +  [lit]
   1.301 +  (let [pred (literal-predicate lit)]
   1.302 +    (when (map? pred)
   1.303 +      (:magic pred))))
   1.304 +      
   1.305 +(defn build-seed-bindings
   1.306 +  "Given a seed literal, already adorned and in magic form, convert
   1.307 +   its bound constants to new variables."
   1.308 +  [s]
   1.309 +  (assert (-> s :literal-type (isa? ::literal)))
   1.310 +  (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))]
   1.311 +    (assoc s :term-bindings ntbs)))
   1.312 +
   1.313 +
   1.314 +;;; Semi-naive support
   1.315 +
   1.316 +(defn negated-literal
   1.317 +  "Given a literal l, return a negated version"
   1.318 +  [l]
   1.319 +  (assert (-> l :literal-type (= ::literal)))
   1.320 +  (assoc l :literal-type ::negated))
   1.321 +
   1.322 +(defn delta-literal
   1.323 +  "Given a literal l, return a delta version"
   1.324 +  [l]
   1.325 +  (let [pred* (:predicate l)
   1.326 +        pred (if (map? pred*) pred* {:pred pred*})]
   1.327 +    (assoc l :predicate (assoc pred :delta true))))
   1.328 +
   1.329 +        
   1.330 +;;; Database operations
   1.331 +
   1.332 +(defn- build-partial-tuple
   1.333 +  [lit binds]
   1.334 +  (let [tbs (:term-bindings lit)
   1.335 +        each (fn [[key val :as pair]]
   1.336 +               (if (is-var? val)
   1.337 +                 (if-let [n (binds val)]
   1.338 +                   [key n]
   1.339 +                   nil)
   1.340 +                 pair))]
   1.341 +    (into {} (remove nil? (map each tbs)))))
   1.342 +
   1.343 +(defn- project-onto-literal
   1.344 +  "Given a literal, and a materialized tuple, return a set of variable
   1.345 +   bindings."
   1.346 +  [lit tuple]
   1.347 +  (let [step (fn [binds [key val]]
   1.348 +               (if (and (is-var? val)
   1.349 +                        (contains? tuple key))
   1.350 +                 (assoc binds val (tuple key))
   1.351 +                 binds))]
   1.352 +    (reduce step {} (:term-bindings lit))))
   1.353 +  
   1.354 +
   1.355 +(defn- join-literal*
   1.356 +  [db lit bs fun]
   1.357 +  (let [each (fn [binds]
   1.358 +               (let [pt (build-partial-tuple lit binds)]
   1.359 +                 (fun binds pt)))]
   1.360 +    (when (contains? db (literal-predicate lit))
   1.361 +      (apply concat (map each bs)))))
   1.362 +
   1.363 +(defmulti join-literal
   1.364 +  "Given a database (db), a literal (lit) and a seq of bindings (bs),
   1.365 +   return a new seq of bindings by joining this literal."
   1.366 +  (fn [db lit bs] (:literal-type lit)))
   1.367 +
   1.368 +(defmethod join-literal ::literal
   1.369 +  [db lit bs]
   1.370 +  (join-literal* db lit bs (fn [binds pt]
   1.371 +                             (map #(merge binds %)
   1.372 +                                  (map (partial project-onto-literal lit)
   1.373 +                                       (select db (literal-predicate lit) pt))))))
   1.374 +
   1.375 +(defmethod join-literal ::negated
   1.376 +  [db lit bs]
   1.377 +  (join-literal* db lit bs (fn [binds pt]
   1.378 +                             (if (any-match? db (literal-predicate lit) pt)
   1.379 +                               nil
   1.380 +                               [binds]))))
   1.381 +
   1.382 +(defmethod join-literal ::conditional
   1.383 +  [db lit bs]
   1.384 +  (let [each (fn [binds]
   1.385 +               (let [resolve (fn [term]
   1.386 +                               (if (is-var? term)
   1.387 +                                 (binds term)
   1.388 +                                 term))
   1.389 +                     args (map resolve (:terms lit))]
   1.390 +                 (if ((:fun lit) args)
   1.391 +                   binds
   1.392 +                   nil)))]
   1.393 +    (remove nil? (map each bs))))
   1.394 +                 
   1.395 +(defn project-literal
   1.396 +  "Project a stream of bindings onto a literal/relation. Returns a new
   1.397 +   db."
   1.398 +  ([db lit bs] (project-literal db lit bs is-var?))
   1.399 +  ([db lit bs var?]
   1.400 +     (assert (= (:literal-type lit) ::literal))
   1.401 +     (let [rel-name (literal-predicate lit)
   1.402 +           columns (-> lit :term-bindings keys)
   1.403 +           idxs (vec (get-adorned-bindings (literal-predicate lit)))
   1.404 +           db1 (ensure-relation db rel-name columns idxs)
   1.405 +           rel (get-relation db1 rel-name)
   1.406 +           step (fn [rel bindings]
   1.407 +                  (let [step (fn [t [k v]]
   1.408 +                               (if (var? v)
   1.409 +                                 (assoc t k (bindings v))
   1.410 +                                 (assoc t k v)))
   1.411 +                        tuple (reduce step {} (:term-bindings lit))]
   1.412 +                    (add-tuple rel tuple)))]
   1.413 +       (replace-relation db rel-name (reduce step rel bs)))))
   1.414 +
   1.415 +
   1.416 +;; End of file