1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/datalog/softstrat.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,161 @@
     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 +;;  softstrat.clj
    1.13 +;;
    1.14 +;;  A Clojure implementation of Datalog -- Soft Stratification
    1.15 +;;
    1.16 +;;  straszheimjeffrey (gmail)
    1.17 +;;  Created 28 Feburary 2009
    1.18 +
    1.19 +
    1.20 +(ns clojure.contrib.datalog.softstrat
    1.21 +  (:use clojure.contrib.datalog.util
    1.22 +        clojure.contrib.datalog.database
    1.23 +        clojure.contrib.datalog.literals
    1.24 +        clojure.contrib.datalog.rules
    1.25 +        clojure.contrib.datalog.magic)
    1.26 +  (:use [clojure.set :only (union intersection difference)])
    1.27 +  (:use [clojure.contrib.seq :only (indexed)])
    1.28 +  (:require [clojure.contrib.graph :as graph]))
    1.29 +
    1.30 +
    1.31 +;;; Dependency graph
    1.32 +
    1.33 +(defn- build-rules-graph
    1.34 +  "Given a rules-set (rs), build a graph where each predicate symbol in rs,
    1.35 +   there is a node n, and for each rule (<- h b-1 b-2 ...), there are edges
    1.36 +   from the (literal-predicate h) -> (literal-predicate b-*), one for each
    1.37 +   b-*."
    1.38 +  [rs]
    1.39 +  (let [preds (all-predicates rs)
    1.40 +        pred-map (predicate-map rs)
    1.41 +        step (fn [nbs pred]
    1.42 +               (let [rules (pred-map pred)
    1.43 +                     preds (reduce (fn [pds lits]
    1.44 +                                     (reduce (fn [pds lit]
    1.45 +                                               (if-let [pred (literal-predicate lit)]
    1.46 +                                                 (conj pds pred)
    1.47 +                                                 pds))
    1.48 +                                             pds
    1.49 +                                             lits))
    1.50 +                                   #{}
    1.51 +                                   (map :body rules))]
    1.52 +                 (assoc nbs pred preds)))
    1.53 +        neighbors (reduce step {} preds)]
    1.54 +    (struct graph/directed-graph preds neighbors)))
    1.55 +
    1.56 +(defn- build-def
    1.57 +  "Given a rules-set, build its def function"
    1.58 +  [rs]
    1.59 +  (let [pred-map (predicate-map rs)
    1.60 +        graph (-> rs
    1.61 +                  build-rules-graph
    1.62 +                  graph/transitive-closure
    1.63 +                  graph/add-loops)]
    1.64 +    (fn [pred]
    1.65 +      (apply union (map set (map pred-map (graph/get-neighbors graph pred)))))))
    1.66 +
    1.67 +
    1.68 +;;; Soft Stratificattion REQ Graph                 
    1.69 +
    1.70 +(defn- req
    1.71 +  "Returns a rules-set that is a superset of req(lit) for the lit at
    1.72 +  index lit-index"
    1.73 +  [rs soft-def rule lit-index]
    1.74 +  (let [head (:head rule)
    1.75 +        body (:body rule)
    1.76 +        lit (nth body lit-index)
    1.77 +        pre (subvec (vec body) 0 lit-index)]
    1.78 +    (conj (-> lit literal-predicate soft-def (magic-transform (all-predicates rs)))
    1.79 +          (build-rule (magic-literal lit) pre))))
    1.80 +
    1.81 +(defn- rule-dep
    1.82 +  "Given a rule, return the set of rules it depends on."
    1.83 +  [rs mrs soft-def rule]
    1.84 +  (let [step (fn [nrs [idx lit]]
    1.85 +               (if (negated? lit)
    1.86 +                 (union nrs (req rs soft-def rule idx))
    1.87 +                 nrs))]
    1.88 +    (intersection mrs
    1.89 +                  (reduce step empty-rules-set (-> rule :body indexed)))))
    1.90 +
    1.91 +(defn- soft-strat-graph
    1.92 +  "The dependency graph for soft stratification."
    1.93 +  [rs mrs]
    1.94 +  (let [soft-def (build-def rs)
    1.95 +        step (fn [nbrs rule]
    1.96 +               (assoc nbrs rule (rule-dep rs mrs soft-def rule)))
    1.97 +        nbrs (reduce step {} mrs)]
    1.98 +    (struct graph/directed-graph mrs nbrs)))
    1.99 +
   1.100 +(defn- build-soft-strat
   1.101 +  "Given a rules-set (unadorned) and an adorned query, return the soft
   1.102 +   stratified list.  The rules will be magic transformed, and the
   1.103 +   magic seed will be appended."
   1.104 +  [rs q]
   1.105 +  (let [ars (adorn-rules-set rs q)
   1.106 +        mrs (conj (magic-transform ars)
   1.107 +                  (seed-rule q))
   1.108 +        gr (soft-strat-graph ars mrs)]
   1.109 +    (map make-rules-set (graph/dependency-list gr))))
   1.110 +        
   1.111 +
   1.112 +;;; Work plan
   1.113 +
   1.114 +(defstruct soft-strat-work-plan
   1.115 +  :query
   1.116 +  :stratification)
   1.117 +
   1.118 +(defn build-soft-strat-work-plan
   1.119 +  "Return a work plan for the given rules-set and query"
   1.120 +  [rs q]
   1.121 +  (let [aq (adorn-query q)]
   1.122 +    (struct soft-strat-work-plan aq (build-soft-strat rs aq))))
   1.123 +
   1.124 +(defn get-all-relations
   1.125 +  "Return a set of all relation names defined in this workplan"
   1.126 +  [ws]
   1.127 +  (apply union (map all-predicates (:stratification ws))))
   1.128 +
   1.129 +
   1.130 +;;; Evaluate
   1.131 +
   1.132 +(defn- weak-consq-operator
   1.133 +  [db strat]
   1.134 +  (trace-datalog (println)
   1.135 +                 (println)
   1.136 +                 (println "=============== Begin iteration ==============="))
   1.137 +  (let [counts (database-counts db)]
   1.138 +    (loop [strat strat]
   1.139 +      (let [rs (first strat)]
   1.140 +        (if rs
   1.141 +          (let [new-db (apply-rules-set db rs)]
   1.142 +            (if (= counts (database-counts new-db))
   1.143 +              (recur (next strat))
   1.144 +              new-db))
   1.145 +          db)))))
   1.146 +
   1.147 +(defn evaluate-soft-work-set
   1.148 +  ([ws db] (evaluate-soft-work-set ws db {}))
   1.149 +  ([ws db bindings]
   1.150 +     (let [query (:query ws)
   1.151 +           strat (:stratification ws)
   1.152 +           seed (seed-predicate-for-insertion query)
   1.153 +           seeded-db (project-literal db seed [bindings] is-query-var?)
   1.154 +           fun (fn [data]
   1.155 +                 (weak-consq-operator data strat))
   1.156 +           equal (fn [db1 db2]
   1.157 +                   (= (database-counts db1) (database-counts db2)))
   1.158 +           new-db (graph/fixed-point seeded-db fun nil equal)
   1.159 +           pt (build-partial-tuple query bindings)]
   1.160 +       (select new-db (literal-predicate query) pt))))
   1.161 +
   1.162 +
   1.163 +
   1.164 +;; End of file