Mercurial > lasercutter

annotate src/clojure/contrib/datalog/rules.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 ;; rules.clj
rlm@10 10 ;;
rlm@10 11 ;; A Clojure implementation of Datalog -- Rules Engine
rlm@10 12 ;;
rlm@10 13 ;; straszheimjeffrey (gmail)
rlm@10 14 ;; Created 2 Feburary 2009
rlm@10 15
rlm@10 16
rlm@10 17 (ns clojure.contrib.datalog.rules
rlm@10 18 (:use clojure.contrib.datalog.util)
rlm@10 19 (:use clojure.contrib.datalog.literals
rlm@10 20 clojure.contrib.datalog.database)
rlm@10 21 (:use [clojure.set :only (union intersection difference)])
rlm@10 22 (:use [clojure.contrib.set :only (subset?)])
rlm@10 23 (:use [clojure.contrib.except :only (throwf)])
rlm@10 24 (:import java.io.Writer))
rlm@10 25
rlm@10 26
rlm@10 27 (defstruct datalog-rule
rlm@10 28 :head
rlm@10 29 :body)
rlm@10 30
rlm@10 31 (defn display-rule
rlm@10 32 "Return the rule in a readable format."
rlm@10 33 [rule]
rlm@10 34 (list* '<-
rlm@10 35 (-> rule :head display-literal)
rlm@10 36 (map display-literal (:body rule))))
rlm@10 37
rlm@10 38 (defn display-query
rlm@10 39 "Return a query in a readable format."
rlm@10 40 [query]
rlm@10 41 (list* '?- (display-literal query)))
rlm@10 42
rlm@10 43
rlm@10 44 ;;; Check rule safety
rlm@10 45
rlm@10 46 (defn is-safe?
rlm@10 47 "Is the rule safe according to the datalog protocol?"
rlm@10 48 [rule]
rlm@10 49 (let [hv (literal-vars (:head rule))
rlm@10 50 bpv (apply union (map positive-vars (:body rule)))
rlm@10 51 bnv (apply union (map negative-vars (:body rule)))
rlm@10 52 ehv (difference hv bpv)
rlm@10 53 env (difference bnv bpv)]
rlm@10 54 (when-not (empty? ehv)
rlm@10 55 (throwf "Head vars %s not bound in body in rule %s" ehv rule))
rlm@10 56 (when-not (empty? env)
rlm@10 57 (throwf "Body vars %s not bound in negative positions in rule %s" env rule))
rlm@10 58 rule))
rlm@10 59
rlm@10 60
rlm@10 61 ;;; Rule creation and printing
rlm@10 62
rlm@10 63 (defn build-rule
rlm@10 64 [hd bd]
rlm@10 65 (with-meta (struct datalog-rule hd bd) {:type ::datalog-rule}))
rlm@10 66
rlm@10 67 (defmacro <-
rlm@10 68 "Build a datalog rule. Like this:
rlm@10 69
rlm@10 70 (<- (:head :x ?x :y ?y) (:body-1 :x ?x :y ?y) (:body-2 :z ?z) (not! :body-3 :x ?x) (if > ?y ?z))"
rlm@10 71 [hd & body]
rlm@10 72 (let [head (build-atom hd :clojure.contrib.datalog.literals/literal)
rlm@10 73 body (map build-literal body)]
rlm@10 74 `(is-safe? (build-rule ~head [~@body]))))
rlm@10 75
rlm@10 76 (defmethod print-method ::datalog-rule
rlm@10 77 [rule ^Writer writer]
rlm@10 78 (print-method (display-rule rule) writer))
rlm@10 79
rlm@10 80 (defn return-rule-data
rlm@10 81 "Returns an untypted rule that will be fully printed"
rlm@10 82 [rule]
rlm@10 83 (with-meta rule {}))
rlm@10 84
rlm@10 85 (defmacro ?-
rlm@10 86 "Define a datalog query"
rlm@10 87 [& q]
rlm@10 88 (let [qq (build-atom q :clojure.contrib.datalog.literals/literal)]
rlm@10 89 `(with-meta ~qq {:type ::datalog-query})))
rlm@10 90
rlm@10 91 (defmethod print-method ::datalog-query
rlm@10 92 [query ^Writer writer]
rlm@10 93 (print-method (display-query query) writer))
rlm@10 94
rlm@10 95
rlm@10 96
rlm@10 97 ;;; SIP
rlm@10 98
rlm@10 99 (defn compute-sip
rlm@10 100 "Given a set of bound column names, return an adorned sip for this
rlm@10 101 rule. A set of intensional predicates should be provided to
rlm@10 102 determine what should be adorned."
rlm@10 103 [bindings i-preds rule]
rlm@10 104 (let [next-lit (fn [bv body]
rlm@10 105 (or (first (drop-while
rlm@10 106 #(not (literal-appropriate? bv %))
rlm@10 107 body))
rlm@10 108 (first (drop-while (complement positive?) body))))
rlm@10 109 adorn (fn [lit bvs]
rlm@10 110 (if (i-preds (literal-predicate lit))
rlm@10 111 (let [bnds (union (get-cs-from-vs lit bvs)
rlm@10 112 (get-self-bound-cs lit))]
rlm@10 113 (adorned-literal lit bnds))
rlm@10 114 lit))
rlm@10 115 new-h (adorned-literal (:head rule) bindings)]
rlm@10 116 (loop [bound-vars (get-vs-from-cs (:head rule) bindings)
rlm@10 117 body (:body rule)
rlm@10 118 sip []]
rlm@10 119 (if-let [next (next-lit bound-vars body)]
rlm@10 120 (recur (union bound-vars (literal-vars next))
rlm@10 121 (remove #(= % next) body)
rlm@10 122 (conj sip (adorn next bound-vars)))
rlm@10 123 (build-rule new-h (concat sip body))))))
rlm@10 124
rlm@10 125
rlm@10 126 ;;; Rule sets
rlm@10 127
rlm@10 128 (defn make-rules-set
rlm@10 129 "Given an existing set of rules, make it a 'rules-set' for
rlm@10 130 printing."
rlm@10 131 [rs]
rlm@10 132 (with-meta rs {:type ::datalog-rules-set}))
rlm@10 133
rlm@10 134 (def empty-rules-set (make-rules-set #{}))
rlm@10 135
rlm@10 136 (defn rules-set
rlm@10 137 "Given a collection of rules return a rules set"
rlm@10 138 [& rules]
rlm@10 139 (reduce conj empty-rules-set rules))
rlm@10 140
rlm@10 141 (defmethod print-method ::datalog-rules-set
rlm@10 142 [rules ^Writer writer]
rlm@10 143 (binding [*out* writer]
rlm@10 144 (do
rlm@10 145 (print "(rules-set")
rlm@10 146 (doseq [rule rules]
rlm@10 147 (println)
rlm@10 148 (print " ")
rlm@10 149 (print rule))
rlm@10 150 (println ")"))))
rlm@10 151
rlm@10 152 (defn predicate-map
rlm@10 153 "Given a rules-set, return a map of rules keyed by their predicates.
rlm@10 154 Each value will be a set of rules."
rlm@10 155 [rs]
rlm@10 156 (let [add-rule (fn [m r]
rlm@10 157 (let [pred (-> r :head literal-predicate)
rlm@10 158 os (get m pred #{})]
rlm@10 159 (assoc m pred (conj os r))))]
rlm@10 160 (reduce add-rule {} rs)))
rlm@10 161
rlm@10 162 (defn all-predicates
rlm@10 163 "Given a rules-set, return all defined predicates"
rlm@10 164 [rs]
rlm@10 165 (set (map literal-predicate (map :head rs))))
rlm@10 166
rlm@10 167 (defn non-base-rules
rlm@10 168 "Return a collection of rules that depend, somehow, on other rules"
rlm@10 169 [rs]
rlm@10 170 (let [pred (all-predicates rs)
rlm@10 171 non-base (fn [r]
rlm@10 172 (if (some #(pred %)
rlm@10 173 (map literal-predicate (:body r)))
rlm@10 174 r
rlm@10 175 nil))]
rlm@10 176 (remove nil? (map non-base rs))))
rlm@10 177
rlm@10 178
rlm@10 179 ;;; Database operations
rlm@10 180
rlm@10 181 (def empty-bindings [{}])
rlm@10 182
rlm@10 183 (defn apply-rule
rlm@10 184 "Apply the rule against db-1, adding the results to the appropriate
rlm@10 185 relation in db-2. The relation will be created if needed."
rlm@10 186 ([db rule] (apply-rule db db rule))
rlm@10 187 ([db-1 db-2 rule]
rlm@10 188 (trace-datalog (println)
rlm@10 189 (println)
rlm@10 190 (println "--------------- Begin Rule ---------------")
rlm@10 191 (println rule))
rlm@10 192 (let [head (:head rule)
rlm@10 193 body (:body rule)
rlm@10 194 step (fn [bs lit]
rlm@10 195 (trace-datalog (println bs)
rlm@10 196 (println lit))
rlm@10 197 (join-literal db-1 lit bs))
rlm@10 198 bs (reduce step empty-bindings body)]
rlm@10 199 (do (trace-datalog (println bs))
rlm@10 200 (project-literal db-2 head bs)))))
rlm@10 201
rlm@10 202 (defn apply-rules-set
rlm@10 203 [db rs]
rlm@10 204 (reduce (fn [rdb rule]
rlm@10 205 (apply-rule db rdb rule)) db rs))
rlm@10 206
rlm@10 207
rlm@10 208 ;; End of file