Mercurial > lasercutter

annotate src/clojure/contrib/datalog/literals.clj @ 10:ef7dbbd6452c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added clojure source goodness
author Robert McIntyre <rlm@mit.edu>
date Sat, 21 Aug 2010 06:25:44 -0400
parents
children
rev   line source
rlm@10 1 ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and
rlm@10 2 ;; distribution terms for this software are covered by the Eclipse Public
rlm@10 3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
rlm@10 4 ;; be found in the file epl-v10.html at the root of this distribution. By
rlm@10 5 ;; using this software in any fashion, you are agreeing to be bound by the
rlm@10 6 ;; terms of this license. You must not remove this notice, or any other,
rlm@10 7 ;; from this software.
rlm@10 8 ;;
rlm@10 9 ;; literals.clj
rlm@10 10 ;;
rlm@10 11 ;; A Clojure implementation of Datalog -- Literals
rlm@10 12 ;;
rlm@10 13 ;; straszheimjeffrey (gmail)
rlm@10 14 ;; Created 25 Feburary 2009
rlm@10 15
rlm@10 16
rlm@10 17 (ns clojure.contrib.datalog.literals
rlm@10 18 (:use clojure.contrib.datalog.util)
rlm@10 19 (:use clojure.contrib.datalog.database)
rlm@10 20 (:use [clojure.set :only (intersection)])
rlm@10 21 (:use [clojure.contrib.set :only (subset?)]))
rlm@10 22
rlm@10 23
rlm@10 24 ;;; Type Definitions
rlm@10 25
rlm@10 26 (defstruct atomic-literal
rlm@10 27 :predicate ; The predicate name
rlm@10 28 :term-bindings ; A map of column names to bindings
rlm@10 29 :literal-type) ; ::literal or ::negated
rlm@10 30
rlm@10 31 (derive ::negated ::literal)
rlm@10 32
rlm@10 33 (defstruct conditional-literal
rlm@10 34 :fun ; The fun to call
rlm@10 35 :symbol ; The fun symbol (for display)
rlm@10 36 :terms ; The formal arguments
rlm@10 37 :literal-type) ; ::conditional
rlm@10 38
rlm@10 39
rlm@10 40 ;;; Basics
rlm@10 41
rlm@10 42
rlm@10 43 (defmulti literal-predicate
rlm@10 44 "Return the predicate/relation this conditional operates over"
rlm@10 45 :literal-type)
rlm@10 46
rlm@10 47 (defmulti literal-columns
rlm@10 48 "Return the column names this applies to"
rlm@10 49 :literal-type)
rlm@10 50
rlm@10 51 (defmulti literal-vars
rlm@10 52 "Returns the logic vars used by this literal"
rlm@10 53 :literal-type)
rlm@10 54
rlm@10 55 (defmulti positive-vars
rlm@10 56 "Returns the logic vars used in a positive position"
rlm@10 57 :literal-type)
rlm@10 58
rlm@10 59 (defmulti negative-vars
rlm@10 60 "Returns the logic vars used in a negative position"
rlm@10 61 :literal-type)
rlm@10 62
rlm@10 63 (defmethod literal-predicate ::literal
rlm@10 64 [l]
rlm@10 65 (:predicate l))
rlm@10 66
rlm@10 67 (defmethod literal-predicate ::conditional
rlm@10 68 [l]
rlm@10 69 nil)
rlm@10 70
rlm@10 71 (defmethod literal-columns ::literal
rlm@10 72 [l]
rlm@10 73 (-> l :term-bindings keys set))
rlm@10 74
rlm@10 75 (defmethod literal-columns ::conditional
rlm@10 76 [l]
rlm@10 77 nil)
rlm@10 78
rlm@10 79 (defmethod literal-vars ::literal
rlm@10 80 [l]
rlm@10 81 (set (filter is-var? (-> l :term-bindings vals))))
rlm@10 82
rlm@10 83 (defmethod literal-vars ::conditional
rlm@10 84 [l]
rlm@10 85 (set (filter is-var? (:terms l))))
rlm@10 86
rlm@10 87 (defmethod positive-vars ::literal
rlm@10 88 [l]
rlm@10 89 (literal-vars l))
rlm@10 90
rlm@10 91 (defmethod positive-vars ::negated
rlm@10 92 [l]
rlm@10 93 nil)
rlm@10 94
rlm@10 95 (defmethod positive-vars ::conditional
rlm@10 96 [l]
rlm@10 97 nil)
rlm@10 98
rlm@10 99 (defmethod negative-vars ::literal
rlm@10 100 [l]
rlm@10 101 nil)
rlm@10 102
rlm@10 103 (defmethod negative-vars ::negated
rlm@10 104 [l]
rlm@10 105 (literal-vars l))
rlm@10 106
rlm@10 107 (defmethod negative-vars ::conditional
rlm@10 108 [l]
rlm@10 109 (literal-vars l))
rlm@10 110
rlm@10 111 (defn negated?
rlm@10 112 "Is this literal a negated literal?"
rlm@10 113 [l]
rlm@10 114 (= (:literal-type l) ::negated))
rlm@10 115
rlm@10 116 (defn positive?
rlm@10 117 "Is this a positive literal?"
rlm@10 118 [l]
rlm@10 119 (= (:literal-type l) ::literal))
rlm@10 120
rlm@10 121
rlm@10 122 ;;; Building Literals
rlm@10 123
rlm@10 124 (def negation-symbol 'not!)
rlm@10 125 (def conditional-symbol 'if)
rlm@10 126
rlm@10 127 (defmulti build-literal
rlm@10 128 "(Returns an unevaluated expression (to be used in macros) of a
rlm@10 129 literal."
rlm@10 130 first)
rlm@10 131
rlm@10 132 (defn build-atom
rlm@10 133 "Returns an unevaluated expression (to be used in a macro) of an
rlm@10 134 atom."
rlm@10 135 [f type]
rlm@10 136 (let [p (first f)
rlm@10 137 ts (map #(if (is-var? %) `(quote ~%) %) (next f))
rlm@10 138 b (if (seq ts) (apply assoc {} ts) nil)]
rlm@10 139 `(struct atomic-literal ~p ~b ~type)))
rlm@10 140
rlm@10 141 (defmethod build-literal :default
rlm@10 142 [f]
rlm@10 143 (build-atom f ::literal))
rlm@10 144
rlm@10 145 (defmethod build-literal negation-symbol
rlm@10 146 [f]
rlm@10 147 (build-atom (rest f) ::negated))
rlm@10 148
rlm@10 149 (defmethod build-literal conditional-symbol
rlm@10 150 [f]
rlm@10 151 (let [symbol (fnext f)
rlm@10 152 terms (nnext f)
rlm@10 153 fun `(fn [binds#] (apply ~symbol binds#))]
rlm@10 154 `(struct conditional-literal
rlm@10 155 ~fun
rlm@10 156 '~symbol
rlm@10 157 '~terms
rlm@10 158 ::conditional)))
rlm@10 159
rlm@10 160
rlm@10 161 ;;; Display
rlm@10 162
rlm@10 163 (defmulti display-literal
rlm@10 164 "Converts a struct representing a literal to a normal list"
rlm@10 165 :literal-type)
rlm@10 166
rlm@10 167 (defn- display
rlm@10 168 [l]
rlm@10 169 (conj (-> l :term-bindings list* flatten) (literal-predicate l)))
rlm@10 170
rlm@10 171 (defmethod display-literal ::literal
rlm@10 172 [l]
rlm@10 173 (display l))
rlm@10 174
rlm@10 175 (defmethod display-literal ::negated
rlm@10 176 [l]
rlm@10 177 (conj (display l) negation-symbol))
rlm@10 178
rlm@10 179 (defmethod display-literal ::conditional
rlm@10 180 [l]
rlm@10 181 (list* conditional-symbol (:symbol l) (:terms l)))
rlm@10 182
rlm@10 183
rlm@10 184 ;;; Sip computation
rlm@10 185
rlm@10 186 (defmulti get-vs-from-cs
rlm@10 187 "From a set of columns, return the vars"
rlm@10 188 :literal-type)
rlm@10 189
rlm@10 190 (defmethod get-vs-from-cs ::literal
rlm@10 191 [l bound]
rlm@10 192 (set (filter is-var?
rlm@10 193 (vals (select-keys (:term-bindings l)
rlm@10 194 bound)))))
rlm@10 195
rlm@10 196 (defmethod get-vs-from-cs ::conditional
rlm@10 197 [l bound]
rlm@10 198 nil)
rlm@10 199
rlm@10 200
rlm@10 201 (defmulti get-cs-from-vs
rlm@10 202 "From a set of vars, get the columns"
rlm@10 203 :literal-type)
rlm@10 204
rlm@10 205 (defmethod get-cs-from-vs ::literal
rlm@10 206 [l bound]
rlm@10 207 (reduce conj
rlm@10 208 #{}
rlm@10 209 (remove nil?
rlm@10 210 (map (fn [[k v]] (if (bound v) k nil))
rlm@10 211 (:term-bindings l)))))
rlm@10 212
rlm@10 213 (defmethod get-cs-from-vs ::conditional
rlm@10 214 [l bound]
rlm@10 215 nil)
rlm@10 216
rlm@10 217
rlm@10 218 (defmulti get-self-bound-cs
rlm@10 219 "Get the columns that are bound withing the literal."
rlm@10 220 :literal-type)
rlm@10 221
rlm@10 222 (defmethod get-self-bound-cs ::literal
rlm@10 223 [l]
rlm@10 224 (reduce conj
rlm@10 225 #{}
rlm@10 226 (remove nil?
rlm@10 227 (map (fn [[k v]] (if (not (is-var? v)) k nil))
rlm@10 228 (:term-bindings l)))))
rlm@10 229
rlm@10 230 (defmethod get-self-bound-cs ::conditional
rlm@10 231 [l]
rlm@10 232 nil)
rlm@10 233
rlm@10 234
rlm@10 235 (defmulti literal-appropriate?
rlm@10 236 "When passed a set of bound vars, determines if this literal can be
rlm@10 237 used during this point of a SIP computation."
rlm@10 238 (fn [b l] (:literal-type l)))
rlm@10 239
rlm@10 240 (defmethod literal-appropriate? ::literal
rlm@10 241 [bound l]
rlm@10 242 (not (empty? (intersection (literal-vars l) bound))))
rlm@10 243
rlm@10 244 (defmethod literal-appropriate? ::negated
rlm@10 245 [bound l]
rlm@10 246 (subset? (literal-vars l) bound))
rlm@10 247
rlm@10 248 (defmethod literal-appropriate? ::conditional
rlm@10 249 [bound l]
rlm@10 250 (subset? (literal-vars l) bound))
rlm@10 251
rlm@10 252
rlm@10 253 (defmulti adorned-literal
rlm@10 254 "When passed a set of bound columns, returns the adorned literal"
rlm@10 255 (fn [l b] (:literal-type l)))
rlm@10 256
rlm@10 257 (defmethod adorned-literal ::literal
rlm@10 258 [l bound]
rlm@10 259 (let [pred (literal-predicate l)
rlm@10 260 bnds (intersection (literal-columns l) bound)]
rlm@10 261 (if (empty? bound)
rlm@10 262 l
rlm@10 263 (assoc l :predicate {:pred pred :bound bnds}))))
rlm@10 264
rlm@10 265 (defmethod adorned-literal ::conditional
rlm@10 266 [l bound]
rlm@10 267 l)
rlm@10 268
rlm@10 269
rlm@10 270 (defn get-adorned-bindings
rlm@10 271 "Get the bindings from this adorned literal."
rlm@10 272 [pred]
rlm@10 273 (:bound pred))
rlm@10 274
rlm@10 275 (defn get-base-predicate
rlm@10 276 "Get the base predicate from this predicate."
rlm@10 277 [pred]
rlm@10 278 (if (map? pred)
rlm@10 279 (:pred pred)
rlm@10 280 pred))
rlm@10 281
rlm@10 282
rlm@10 283 ;;; Magic Stuff
rlm@10 284
rlm@10 285 (defn magic-literal
rlm@10 286 "Create a magic version of this adorned predicate."
rlm@10 287 [l]
rlm@10 288 (assert (-> l :literal-type (isa? ::literal)))
rlm@10 289 (let [pred (literal-predicate l)
rlm@10 290 pred-map (if (map? pred) pred {:pred pred})
rlm@10 291 bound (get-adorned-bindings pred)
rlm@10 292 ntb (select-keys (:term-bindings l) bound)]
rlm@10 293 (assoc l :predicate (assoc pred-map :magic true) :term-bindings ntb :literal-type ::literal)))
rlm@10 294
rlm@10 295 (defn literal-magic?
rlm@10 296 "Is this literal magic?"
rlm@10 297 [lit]
rlm@10 298 (let [pred (literal-predicate lit)]
rlm@10 299 (when (map? pred)
rlm@10 300 (:magic pred))))
rlm@10 301
rlm@10 302 (defn build-seed-bindings
rlm@10 303 "Given a seed literal, already adorned and in magic form, convert
rlm@10 304 its bound constants to new variables."
rlm@10 305 [s]
rlm@10 306 (assert (-> s :literal-type (isa? ::literal)))
rlm@10 307 (let [ntbs (map-values (fn [_] (gensym '?_gen_)) (:term-bindings s))]
rlm@10 308 (assoc s :term-bindings ntbs)))
rlm@10 309
rlm@10 310
rlm@10 311 ;;; Semi-naive support
rlm@10 312
rlm@10 313 (defn negated-literal
rlm@10 314 "Given a literal l, return a negated version"
rlm@10 315 [l]
rlm@10 316 (assert (-> l :literal-type (= ::literal)))
rlm@10 317 (assoc l :literal-type ::negated))
rlm@10 318
rlm@10 319 (defn delta-literal
rlm@10 320 "Given a literal l, return a delta version"
rlm@10 321 [l]
rlm@10 322 (let [pred* (:predicate l)
rlm@10 323 pred (if (map? pred*) pred* {:pred pred*})]
rlm@10 324 (assoc l :predicate (assoc pred :delta true))))
rlm@10 325
rlm@10 326
rlm@10 327 ;;; Database operations
rlm@10 328
rlm@10 329 (defn- build-partial-tuple
rlm@10 330 [lit binds]
rlm@10 331 (let [tbs (:term-bindings lit)
rlm@10 332 each (fn [[key val :as pair]]
rlm@10 333 (if (is-var? val)
rlm@10 334 (if-let [n (binds val)]
rlm@10 335 [key n]
rlm@10 336 nil)
rlm@10 337 pair))]
rlm@10 338 (into {} (remove nil? (map each tbs)))))
rlm@10 339
rlm@10 340 (defn- project-onto-literal
rlm@10 341 "Given a literal, and a materialized tuple, return a set of variable
rlm@10 342 bindings."
rlm@10 343 [lit tuple]
rlm@10 344 (let [step (fn [binds [key val]]
rlm@10 345 (if (and (is-var? val)
rlm@10 346 (contains? tuple key))
rlm@10 347 (assoc binds val (tuple key))
rlm@10 348 binds))]
rlm@10 349 (reduce step {} (:term-bindings lit))))
rlm@10 350
rlm@10 351
rlm@10 352 (defn- join-literal*
rlm@10 353 [db lit bs fun]
rlm@10 354 (let [each (fn [binds]
rlm@10 355 (let [pt (build-partial-tuple lit binds)]
rlm@10 356 (fun binds pt)))]
rlm@10 357 (when (contains? db (literal-predicate lit))
rlm@10 358 (apply concat (map each bs)))))
rlm@10 359
rlm@10 360 (defmulti join-literal
rlm@10 361 "Given a database (db), a literal (lit) and a seq of bindings (bs),
rlm@10 362 return a new seq of bindings by joining this literal."
rlm@10 363 (fn [db lit bs] (:literal-type lit)))
rlm@10 364
rlm@10 365 (defmethod join-literal ::literal
rlm@10 366 [db lit bs]
rlm@10 367 (join-literal* db lit bs (fn [binds pt]
rlm@10 368 (map #(merge binds %)
rlm@10 369 (map (partial project-onto-literal lit)
rlm@10 370 (select db (literal-predicate lit) pt))))))
rlm@10 371
rlm@10 372 (defmethod join-literal ::negated
rlm@10 373 [db lit bs]
rlm@10 374 (join-literal* db lit bs (fn [binds pt]
rlm@10 375 (if (any-match? db (literal-predicate lit) pt)
rlm@10 376 nil
rlm@10 377 [binds]))))
rlm@10 378
rlm@10 379 (defmethod join-literal ::conditional
rlm@10 380 [db lit bs]
rlm@10 381 (let [each (fn [binds]
rlm@10 382 (let [resolve (fn [term]
rlm@10 383 (if (is-var? term)
rlm@10 384 (binds term)
rlm@10 385 term))
rlm@10 386 args (map resolve (:terms lit))]
rlm@10 387 (if ((:fun lit) args)
rlm@10 388 binds
rlm@10 389 nil)))]
rlm@10 390 (remove nil? (map each bs))))
rlm@10 391
rlm@10 392 (defn project-literal
rlm@10 393 "Project a stream of bindings onto a literal/relation. Returns a new
rlm@10 394 db."
rlm@10 395 ([db lit bs] (project-literal db lit bs is-var?))
rlm@10 396 ([db lit bs var?]
rlm@10 397 (assert (= (:literal-type lit) ::literal))
rlm@10 398 (let [rel-name (literal-predicate lit)
rlm@10 399 columns (-> lit :term-bindings keys)
rlm@10 400 idxs (vec (get-adorned-bindings (literal-predicate lit)))
rlm@10 401 db1 (ensure-relation db rel-name columns idxs)
rlm@10 402 rel (get-relation db1 rel-name)
rlm@10 403 step (fn [rel bindings]
rlm@10 404 (let [step (fn [t [k v]]
rlm@10 405 (if (var? v)
rlm@10 406 (assoc t k (bindings v))
rlm@10 407 (assoc t k v)))
rlm@10 408 tuple (reduce step {} (:term-bindings lit))]
rlm@10 409 (add-tuple rel tuple)))]
rlm@10 410 (replace-relation db rel-name (reduce step rel bs)))))
rlm@10 411
rlm@10 412
rlm@10 413 ;; End of file