Mercurial > lasercutter

     1 ;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and

     2 ;;  distribution terms for this software are covered by the Eclipse Public

     3 ;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can

     4 ;;  be found in the file epl-v10.html at the root of this distribution.  By

     5 ;;  using this software in any fashion, you are agreeing to be bound by the

     6 ;;  terms of this license.  You must not remove this notice, or any other,

     7 ;;  from this software.

     8 ;;

     9 ;;  magic.clj

    10 ;;

    11 ;;  A Clojure implementation of Datalog -- Magic Sets

    12 ;;

    13 ;;  straszheimjeffrey (gmail)

    14 ;;  Created 18 Feburary 2009

    15 

    16 

    17 (ns clojure.contrib.datalog.magic

    18   (:use clojure.contrib.datalog.util

    19         clojure.contrib.datalog.literals

    20         clojure.contrib.datalog.rules)

    21   (:use [clojure.set :only (union intersection difference)]))

    22 

    23 

    24 ;;; Adornment

    25 

    26 (defn adorn-query

    27   "Adorn a query"

    28   [q]

    29   (adorned-literal q (get-self-bound-cs q)))

    30 

    31 (defn adorn-rules-set

    32   "Adorns the given rules-set for the given query.  (rs) is a

    33    rules-set, (q) is an adorned query."

    34   [rs q]

    35   (let [i-preds (all-predicates rs)

    36         p-map (predicate-map rs)]

    37     (loop [nrs empty-rules-set ; The rules set being built

    38            needed #{(literal-predicate q)}]

    39       (if (empty? needed)

    40           nrs

    41           (let [pred (first needed)

    42                 remaining (disj needed pred)

    43                 base-pred (get-base-predicate pred)

    44                 bindings (get-adorned-bindings pred)

    45                 new-rules (p-map base-pred)

    46                 new-adorned-rules (map (partial compute-sip bindings i-preds)

    47                                        new-rules)

    48                 new-nrs (reduce conj nrs new-adorned-rules)

    49                 current-preds (all-predicates new-nrs)

    50                 not-needed? (fn [pred]

    51                               (or (current-preds pred)

    52                                   (-> pred get-base-predicate i-preds not)))

    53                 add-pred (fn [np pred]

    54                            (if (not-needed? pred) np (conj np pred)))

    55                 add-preds (fn [np rule]

    56                             (reduce add-pred np (map literal-predicate (:body rule))))

    57                 new-needed (reduce add-preds remaining new-adorned-rules)]

    58             (recur new-nrs new-needed))))))

    59 

    60 

    61 ;;; Magic !

    62 

    63 (defn seed-relation

    64   "Given a magic form of a query, give back the literal form of its seed

    65    relation"

    66   [q]

    67   (let [pred (-> q literal-predicate get-base-predicate)

    68         bnds (-> q literal-predicate get-adorned-bindings)]

    69     (with-meta (assoc q :predicate [pred :magic-seed bnds]) {})))

    70 

    71 (defn seed-rule

    72   "Given an adorned query, give back its seed rule"

    73   [q]

    74   (let [mq (build-seed-bindings (magic-literal q))

    75         sr (seed-relation mq)]

    76     (build-rule mq [sr])))

    77 

    78 (defn build-partial-tuple

    79   "Given a query and a set of bindings, build a partial tuple needed

    80    to extract the relation from the database."

    81   [q bindings]

    82   (into {} (remove nil? (map (fn [[k v :as pair]]

    83                                (if (is-var? v)

    84                                  nil

    85                                  (if (is-query-var? v)

    86                                    [k (bindings v)]

    87                                    pair)))

    88                              (:term-bindings q)))))

    89 

    90 (defn seed-predicate-for-insertion

    91   "Given a query, return the predicate to use for database insertion."

    92   [q]

    93   (let [seed (-> q seed-rule :body first)

    94         columns (-> seed :term-bindings keys)

    95         new-term-bindings (-> q :term-bindings (select-keys columns))]

    96     (assoc seed :term-bindings new-term-bindings)))

    97     

    98 (defn magic-transform

    99   "Return a magic transformation of an adorned rules-set (rs).  The

   100    (i-preds) are the predicates of the intension database.  These

   101    default to the predicates within the rules-set."

   102   ([rs]

   103      (magic-transform rs (all-predicates rs)))

   104   ([rs i-preds]

   105      (let [not-duplicate? (fn [l mh bd]

   106                             (or (not (empty? bd))

   107                                 (not (= (magic-literal l)

   108                                         mh))))

   109            xr (fn [rs rule]

   110                 (let [head (:head rule)

   111                       body (:body rule)

   112                       mh (magic-literal head)

   113                       answer-rule (build-rule head

   114                                               (concat [mh] body))

   115                       step (fn [[rs bd] l]

   116                              (if (and (i-preds (literal-predicate l))

   117                                       (not-duplicate? l mh bd))

   118                                (let [nr (build-rule (magic-literal l)

   119                                                     (concat [mh] bd))]

   120                                  [(conj rs nr) (conj bd l)])

   121                                [rs (conj bd l)]))

   122                       [nrs _] (reduce step [rs []] body)]

   123                   (conj nrs answer-rule)))]

   124      (reduce xr empty-rules-set rs))))

   125              

   126          

   127 

   128 ;; End of file
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children