Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

208 lines (170 sloc) 6.254 kB
;; 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.
;;
;; rules.clj
;;
;; A Clojure implementation of Datalog -- Rules Engine
;;
;; straszheimjeffrey (gmail)
;; Created 2 Feburary 2009
(ns clojure.contrib.datalog.rules
(:use clojure.contrib.datalog.util)
(:use clojure.contrib.datalog.literals
clojure.contrib.datalog.database)
(:use [clojure.set :only (union intersection difference)])
(:use [clojure.contrib.set :only (subset?)])
(:use [clojure.contrib.except :only (throwf)])
(:import java.io.Writer))
(defstruct datalog-rule
:head
:body)
(defn display-rule
"Return the rule in a readable format."
[rule]
(list* '<-
(-> rule :head display-literal)
(map display-literal (:body rule))))
(defn display-query
"Return a query in a readable format."
[query]
(list* '?- (display-literal query)))
;;; Check rule safety
(defn is-safe?
"Is the rule safe according to the datalog protocol?"
[rule]
(let [hv (literal-vars (:head rule))
bpv (apply union (map positive-vars (:body rule)))
bnv (apply union (map negative-vars (:body rule)))
ehv (difference hv bpv)
env (difference bnv bpv)]
(when-not (empty? ehv)
(throwf "Head vars %s not bound in body in rule %s" ehv rule))
(when-not (empty? env)
(throwf "Body vars %s not bound in negative positions in rule %s" env rule))
rule))
;;; Rule creation and printing
(defn build-rule
[hd bd]
(with-meta (struct datalog-rule hd bd) {:type ::datalog-rule}))
(defmacro <-
"Build a datalog rule. Like this:
(<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))"
[hd & body]
(let [head (build-atom hd :clojure.contrib.datalog.literals/literal)
body (map build-literal body)]
`(is-safe? (build-rule ~head [~@body]))))
(defmethod print-method ::datalog-rule
[rule ^Writer writer]
(print-method (display-rule rule) writer))
(defn return-rule-data
"Returns an untypted rule that will be fully printed"
[rule]
(with-meta rule {}))
(defmacro ?-
"Define a datalog query"
[& q]
(let [qq (build-atom q :clojure.contrib.datalog.literals/literal)]
`(with-meta ~qq {:type ::datalog-query})))
(defmethod print-method ::datalog-query
[query ^Writer writer]
(print-method (display-query query) writer))
;;; SIP
(defn compute-sip
"Given a set of bound column names, return an adorned sip for this
rule. A set of intensional predicates should be provided to
determine what should be adorned."
[bindings i-preds rule]
(let [next-lit (fn [bv body]
(or (first (drop-while
#(not (literal-appropriate? bv %))
body))
(first (drop-while (complement positive?) body))))
adorn (fn [lit bvs]
(if (i-preds (literal-predicate lit))
(let [bnds (union (get-cs-from-vs lit bvs)
(get-self-bound-cs lit))]
(adorned-literal lit bnds))
lit))
new-h (adorned-literal (:head rule) bindings)]
(loop [bound-vars (get-vs-from-cs (:head rule) bindings)
body (:body rule)
sip []]
(if-let [next (next-lit bound-vars body)]
(recur (union bound-vars (literal-vars next))
(remove #(= % next) body)
(conj sip (adorn next bound-vars)))
(build-rule new-h (concat sip body))))))
;;; Rule sets
(defn make-rules-set
"Given an existing set of rules, make it a 'rules-set' for
printing."
[rs]
(with-meta rs {:type ::datalog-rules-set}))
(def empty-rules-set (make-rules-set #{}))
(defn rules-set
"Given a collection of rules return a rules set"
[& rules]
(reduce conj empty-rules-set rules))
(defmethod print-method ::datalog-rules-set
[rules ^Writer writer]
(binding [*out* writer]
(do
(print "(rules-set")
(doseq [rule rules]
(println)
(print " ")
(print rule))
(println ")"))))
(defn predicate-map
"Given a rules-set, return a map of rules keyed by their predicates.
Each value will be a set of rules."
[rs]
(let [add-rule (fn [m r]
(let [pred (-> r :head literal-predicate)
os (get m pred #{})]
(assoc m pred (conj os r))))]
(reduce add-rule {} rs)))
(defn all-predicates
"Given a rules-set, return all defined predicates"
[rs]
(set (map literal-predicate (map :head rs))))
(defn non-base-rules
"Return a collection of rules that depend, somehow, on other rules"
[rs]
(let [pred (all-predicates rs)
non-base (fn [r]
(if (some #(pred %)
(map literal-predicate (:body r)))
r
nil))]
(remove nil? (map non-base rs))))
;;; Database operations
(def empty-bindings [{}])
(defn apply-rule
"Apply the rule against db-1, adding the results to the appropriate
relation in db-2. The relation will be created if needed."
([db rule] (apply-rule db db rule))
([db-1 db-2 rule]
(trace-datalog (println)
(println)
(println "--------------- Begin Rule ---------------")
(println rule))
(let [head (:head rule)
body (:body rule)
step (fn [bs lit]
(trace-datalog (println bs)
(println lit))
(join-literal db-1 lit bs))
bs (reduce step empty-bindings body)]
(do (trace-datalog (println bs))
(project-literal db-2 head bs)))))
(defn apply-rules-set
[db rs]
(reduce (fn [rdb rule]
(apply-rule db rdb rule)) db rs))
;; End of file
Jump to Line
Something went wrong with that request. Please try again.