1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/datalog/rules.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,208 @@
     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 +;;  rules.clj
    1.13 +;;
    1.14 +;;  A Clojure implementation of Datalog -- Rules Engine
    1.15 +;;
    1.16 +;;  straszheimjeffrey (gmail)
    1.17 +;;  Created 2 Feburary 2009
    1.18 +
    1.19 +
    1.20 +(ns clojure.contrib.datalog.rules
    1.21 +  (:use clojure.contrib.datalog.util)
    1.22 +  (:use clojure.contrib.datalog.literals
    1.23 +       clojure.contrib.datalog.database)
    1.24 +  (:use [clojure.set :only (union intersection difference)])
    1.25 +  (:use [clojure.contrib.set :only (subset?)])
    1.26 +  (:use [clojure.contrib.except :only (throwf)])
    1.27 +  (:import java.io.Writer))
    1.28 +
    1.29 +
    1.30 +(defstruct datalog-rule
    1.31 +  :head
    1.32 +  :body)
    1.33 +
    1.34 +(defn display-rule
    1.35 +  "Return the rule in a readable format."
    1.36 +  [rule]
    1.37 +  (list* '<-
    1.38 +         (-> rule :head display-literal)
    1.39 +         (map display-literal (:body rule))))
    1.40 +
    1.41 +(defn display-query
    1.42 +  "Return a query in a readable format."
    1.43 +  [query]
    1.44 +  (list* '?- (display-literal query)))
    1.45 +
    1.46 +
    1.47 +;;; Check rule safety
    1.48 +
    1.49 +(defn is-safe?
    1.50 +  "Is the rule safe according to the datalog protocol?"
    1.51 +  [rule]
    1.52 +  (let [hv (literal-vars (:head rule))
    1.53 +        bpv (apply union (map positive-vars (:body rule)))
    1.54 +        bnv (apply union (map negative-vars (:body rule)))
    1.55 +        ehv (difference hv bpv)
    1.56 +        env (difference bnv bpv)]
    1.57 +    (when-not (empty? ehv)
    1.58 +      (throwf "Head vars %s not bound in body in rule %s" ehv rule))
    1.59 +    (when-not (empty? env)
    1.60 +      (throwf "Body vars %s not bound in negative positions in rule %s" env rule))
    1.61 +    rule))
    1.62 +
    1.63 +
    1.64 +;;; Rule creation and printing
    1.65 +
    1.66 +(defn build-rule
    1.67 +  [hd bd]
    1.68 +  (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule}))
    1.69 +
    1.70 +(defmacro <-
    1.71 +  "Build a datalog rule.  Like this:
    1.72 +
    1.73 +   (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))"
    1.74 +  [hd & body]
    1.75 +  (let [head (build-atom hd :clojure.contrib.datalog.literals/literal)
    1.76 +        body (map build-literal body)]
    1.77 +    `(is-safe? (build-rule ~head [~@body]))))
    1.78 +
    1.79 +(defmethod print-method ::datalog-rule
    1.80 +  [rule ^Writer writer]
    1.81 +  (print-method (display-rule rule) writer))
    1.82 +
    1.83 +(defn return-rule-data
    1.84 +  "Returns an untypted rule that will be fully printed"
    1.85 +  [rule]
    1.86 +  (with-meta rule {}))
    1.87 +
    1.88 +(defmacro ?-
    1.89 +  "Define a datalog query"
    1.90 +  [& q]
    1.91 +  (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)]
    1.92 +  `(with-meta ~qq {:type ::datalog-query})))
    1.93 +
    1.94 +(defmethod print-method ::datalog-query
    1.95 +  [query ^Writer writer]
    1.96 +  (print-method (display-query query) writer))
    1.97 +
    1.98 +
    1.99 +
   1.100 +;;; SIP
   1.101 +
   1.102 +(defn compute-sip
   1.103 +  "Given a set of bound column names, return an adorned sip for this
   1.104 +   rule.  A set of intensional predicates should be provided to
   1.105 +   determine what should be adorned."
   1.106 +  [bindings i-preds rule]
   1.107 +  (let [next-lit (fn [bv body]
   1.108 +                   (or (first (drop-while
   1.109 +                               #(not (literal-appropriate? bv %))
   1.110 +                               body))
   1.111 +                       (first (drop-while (complement positive?) body))))
   1.112 +        adorn (fn [lit bvs]
   1.113 +                (if (i-preds (literal-predicate lit))
   1.114 +                  (let [bnds (union (get-cs-from-vs lit bvs)
   1.115 +                                    (get-self-bound-cs lit))]
   1.116 +                    (adorned-literal lit bnds))
   1.117 +                  lit))
   1.118 +        new-h (adorned-literal (:head rule) bindings)]
   1.119 +    (loop [bound-vars (get-vs-from-cs (:head rule) bindings)
   1.120 +           body (:body rule)
   1.121 +           sip []]
   1.122 +      (if-let [next (next-lit bound-vars body)]
   1.123 +        (recur (union bound-vars (literal-vars next))
   1.124 +               (remove #(= % next) body)
   1.125 +               (conj sip (adorn next bound-vars)))
   1.126 +        (build-rule new-h (concat sip body))))))
   1.127 +
   1.128 +
   1.129 +;;; Rule sets
   1.130 +
   1.131 +(defn make-rules-set
   1.132 +  "Given an existing set of rules, make it a 'rules-set' for
   1.133 +   printing."
   1.134 +  [rs]
   1.135 +  (with-meta rs {:type ::datalog-rules-set}))
   1.136 +    
   1.137 +(def empty-rules-set (make-rules-set #{}))
   1.138 +
   1.139 +(defn rules-set
   1.140 +  "Given a collection of rules return a rules set"
   1.141 +  [& rules]
   1.142 +  (reduce conj empty-rules-set rules))
   1.143 +  
   1.144 +(defmethod print-method ::datalog-rules-set
   1.145 +  [rules ^Writer writer]
   1.146 +  (binding [*out* writer]
   1.147 +    (do
   1.148 +      (print "(rules-set")
   1.149 +      (doseq [rule rules]
   1.150 +        (println)
   1.151 +        (print "   ")
   1.152 +        (print rule))
   1.153 +      (println ")"))))
   1.154 +
   1.155 +(defn predicate-map
   1.156 +  "Given a rules-set, return a map of rules keyed by their predicates.
   1.157 +   Each value will be a set of rules."
   1.158 +  [rs]
   1.159 +  (let [add-rule (fn [m r]
   1.160 +                   (let [pred (-> r :head literal-predicate)
   1.161 +                         os (get m pred #{})]
   1.162 +                     (assoc m pred (conj os r))))]
   1.163 +    (reduce add-rule {} rs)))
   1.164 +
   1.165 +(defn all-predicates
   1.166 +  "Given a rules-set, return all defined predicates"
   1.167 +  [rs]
   1.168 +  (set (map literal-predicate (map :head rs))))
   1.169 +
   1.170 +(defn non-base-rules
   1.171 +  "Return a collection of rules that depend, somehow, on other rules"
   1.172 +  [rs]
   1.173 +  (let [pred (all-predicates rs)
   1.174 +        non-base (fn [r]
   1.175 +                   (if (some #(pred %)
   1.176 +                             (map literal-predicate (:body r)))
   1.177 +                     r
   1.178 +                     nil))]
   1.179 +    (remove nil? (map non-base rs))))
   1.180 +
   1.181 +
   1.182 +;;; Database operations
   1.183 +
   1.184 +(def empty-bindings [{}])
   1.185 +
   1.186 +(defn apply-rule
   1.187 +  "Apply the rule against db-1, adding the results to the appropriate
   1.188 +   relation in db-2.  The relation will be created if needed."
   1.189 +  ([db rule] (apply-rule db db rule))
   1.190 +  ([db-1 db-2 rule]
   1.191 +     (trace-datalog (println)
   1.192 +                    (println)
   1.193 +                    (println "--------------- Begin Rule ---------------")
   1.194 +                    (println rule))
   1.195 +     (let [head (:head rule)
   1.196 +           body (:body rule)
   1.197 +           step (fn [bs lit]
   1.198 +                  (trace-datalog (println bs)
   1.199 +                                 (println lit))
   1.200 +                  (join-literal db-1 lit bs))
   1.201 +           bs (reduce step empty-bindings body)]
   1.202 +       (do (trace-datalog (println bs))
   1.203 +           (project-literal db-2 head bs)))))
   1.204 +
   1.205 +(defn apply-rules-set
   1.206 +  [db rs]
   1.207 +  (reduce (fn [rdb rule]
   1.208 +            (apply-rule db rdb rule)) db rs))
   1.209 +
   1.210 +
   1.211 +;; End of file
   1.212 \ No newline at end of file