Skip to content

Commit

Permalink
Fix for issue #166
Browse files Browse the repository at this point in the history
  • Loading branch information
@rbrush
rbrush committed Jan 27, 2016
1 parent d51284b commit c88ca13
Show file tree
Hide file tree
Showing 4 changed files with 147 additions and 57 deletions.
12 changes: 9 additions & 3 deletions src/main/clojure/clara/macros.clj
View file
Expand Up @@ -95,7 +95,9 @@
`(eng/->ExpressionJoinNode
~id
'~condition
~(com/compile-join-filter (:join-filter-expressions beta-node) {})
~(com/compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
{})
~(gen-beta-network child-ids beta-graph all-bindings)
~join-bindings)
`(eng/->HashJoinNode
Expand All @@ -109,7 +111,9 @@
`(eng/->NegationWithJoinFilterNode
~id
'~condition
~(com/compile-join-filter (:join-filter-expressions beta-node) {})
~(com/compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
{})
~(gen-beta-network child-ids beta-graph all-bindings)
~join-bindings)
`(eng/->NegationNode
Expand All @@ -131,7 +135,9 @@
{:accumulator '~(:accumulator beta-node)
:from '~condition}
~(:accumulator beta-node)
~(com/compile-join-filter (:join-filter-expressions beta-node) {})
~(com/compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
{})
~(:result-binding beta-node)
~(gen-beta-network child-ids beta-graph all-bindings)
~join-bindings)
Expand Down
129 changes: 76 additions & 53 deletions src/main/clojure/clara/rules/compiler.clj
View file
Expand Up @@ -200,50 +200,58 @@
edata
e))))))

(defn- compile-constraints [exp-seq]
(if (empty? exp-seq)
`((deref ~'?__bindings__))
(let [ [exp & rest-exp] exp-seq
compiled-rest (compile-constraints rest-exp)
variables (into #{}
(filter (fn [item]
(and (symbol? item)
(= \? (first (name item)))))
exp))
expression-values (remove variables (rest exp))
binds-variables? (and (equality-expression? exp)
(seq variables))]
(when (and binds-variables?
(empty? expression-values))

(throw (ex-info (str "Malformed variable binding for " variables ". No associated value.")
{:variables (map keyword variables)})))

(if binds-variables?

(concat

;; Bind each variable with the first value we encounter.
;; The additional equality checks are handled below so which value
;; we bind to is not important. So an expression like (= ?x value-1 value-2) will
;; bind ?x to value-1, and then ensure value-1 and value-2 are equal below.
(for [variable variables]
`(swap! ~'?__bindings__ assoc ~(keyword variable) ~(first expression-values)))

;; If there is more than one expression value, we need to ensure they are
;; equal as well as doing the bind. This ensures that value-1 and value-2 are
;; equal.
(if (> (count expression-values) 1)


(list (list 'if (cons '= expression-values) (cons 'do compiled-rest) nil))
;; No additional values to check, so move on to the rest of
;; the expression
compiled-rest))

;; No variables to unify, so simply check the expression and
;; move on to the rest.
(list (list 'if exp (cons 'do compiled-rest) nil))))))
(defn- compile-constraints
"Compiles a sequence of constraints into a structure that can be evaluated.
Callers may also pass a collection of equality-only-variables, which instructs
this function to only do an equality check on them rather than create a unification binding."
([exp-seq]
(compile-constraints exp-seq #{}))
([exp-seq equality-only-variables]
(if (empty? exp-seq)
`((deref ~'?__bindings__))
(let [ [exp & rest-exp] exp-seq
compiled-rest (compile-constraints rest-exp equality-only-variables)
variables (into #{}
(filter (fn [item]
(and (symbol? item)
(= \? (first (name item)))
(not (equality-only-variables item))))
exp))
expression-values (remove variables (rest exp))
binds-variables? (and (equality-expression? exp)
(seq variables))]
(when (and binds-variables?
(empty? expression-values))

(throw (ex-info (str "Malformed variable binding for " variables ". No associated value.")
{:variables (map keyword variables)})))

(if binds-variables?

(concat

;; Bind each variable with the first value we encounter.
;; The additional equality checks are handled below so which value
;; we bind to is not important. So an expression like (= ?x value-1 value-2) will
;; bind ?x to value-1, and then ensure value-1 and value-2 are equal below.
(for [variable variables]
`(swap! ~'?__bindings__ assoc ~(keyword variable) ~(first expression-values)))

;; If there is more than one expression value, we need to ensure they are
;; equal as well as doing the bind. This ensures that value-1 and value-2 are
;; equal.
(if (> (count expression-values) 1)


(list (list 'if (cons '= expression-values) (cons 'do compiled-rest) nil))
;; No additional values to check, so move on to the rest of
;; the expression
compiled-rest))

;; No variables to unify, so simply check the expression and
;; move on to the rest.
(list (list 'if exp (cons 'do compiled-rest) nil)))))))

(defn flatten-expression
"Flattens expression as clojure.core/flatten does, except will flatten
Expand Down Expand Up @@ -345,7 +353,7 @@
"Compiles to a predicate function that ensures the given items can be unified. Returns a ready-to-eval
function that accepts a token, a fact, and an environment, and returns truthy if the given fact satisfies
the criteria."
[{:keys [type constraints args] :as unification-condition} env]
[{:keys [type constraints args] :as unification-condition} ancestor-bindings env]
(let [accessors (get-fields type)

binding-keys (variables-as-keywords constraints)
Expand All @@ -369,14 +377,17 @@

assignments (concat
fact-assignments
token-assignments)]
token-assignments)

equality-only-variables (into #{} (for [binding ancestor-bindings]
(symbol (name (keyword binding)))))]

`(fn [~'?__token__
~(add-meta '?__fact__ type)
~destructured-env]
(let [~@assignments
~'?__bindings__ (atom {})]
(do ~@(compile-constraints constraints))))))
(do ~@(compile-constraints constraints equality-only-variables))))))

(defn- expr-type [expression]
(if (map? expression)
Expand Down Expand Up @@ -774,12 +785,16 @@
condition)

;; Variables used in the condition.
cond-bindings (variables-as-keywords (:constraints condition))]
cond-bindings (variables-as-keywords (:constraints condition))

join-filter-bindings (if join-filter-expressions
(variables-as-keywords join-filter-expressions)
nil)]

(cond->
{:node-type node-type
:condition condition
:used-bindings cond-bindings}
:used-bindings (s/union cond-bindings join-filter-bindings)}

(seq env) (assoc :env env)

Expand All @@ -790,7 +805,9 @@

result-binding (assoc :result-binding result-binding)

join-filter-expressions (assoc :join-filter-expressions join-filter-expressions))))
join-filter-expressions (assoc :join-filter-expressions join-filter-expressions)

join-filter-bindings (assoc :join-filter-join-bindings (s/intersection join-filter-bindings parent-bindings)))))

(sc/defn ^:private add-node :- schema/BetaGraph
"Adds a node to the beta graph."
Expand Down Expand Up @@ -1094,7 +1111,9 @@
:env (:env beta-node)
:msg "compiling expression join node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node) (:env beta-node))))
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
children
join-bindings)
(eng/->HashJoinNode
Expand All @@ -1117,7 +1136,9 @@
:env (:env beta-node)
:msg "compiling negation with join filter node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node) (:env beta-node))))
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
children
join-bindings)

Expand Down Expand Up @@ -1171,7 +1192,9 @@
:env (:env beta-node)
:msg "compiling accumulate with join filter node"}]
(compile-expr id
(compile-join-filter (:join-filter-expressions beta-node) (:env beta-node))))
(compile-join-filter (:join-filter-expressions beta-node)
(:join-filter-join-bindings beta-node)
(:env beta-node))))
(:result-binding beta-node)
children
join-bindings)
Expand Down
6 changes: 5 additions & 1 deletion src/main/clojure/clara/rules/schema.clj
View file
Expand Up @@ -95,12 +95,16 @@
;; Variables used to join to other expressions in the network.
(s/optional-key :join-bindings) #{s/Keyword}

;; All bindings used by this condition.
;; Variable bindings used by expressions in this node.
:used-bindings #{s/Keyword}

;; An expression used to filter joined data.
(s/optional-key :join-filter-expressions) LeafCondition

;; Bindings used to perform non-hash joins in the join filter expression.
;; this is a subset of :used-bindings.
(s/optional-key :join-filter-join-bindings) #{s/Keyword}

;; The expression to create the accumulator.
(s/optional-key :accumulator) s/Any

Expand Down
57 changes: 57 additions & 0 deletions src/test/clojure/clara/test_rules.clj
View file
Expand Up @@ -3247,3 +3247,60 @@
first)]
(is (= {:?t temp}
res))))

(deftest test-non-binding-equality
(let [temps-with-addition (dsl/parse-query [] [[Temperature (= ?t1 temperature)
(= "MCI" location )]
[Temperature (= ?t2 temperature)
(= ?foo (+ 20 ?t1))
(= "SFO" location)]
[Temperature (= ?t3 temperature)
(= ?foo (+ 10 ?t2))
(= "ORD" location)]])

temps-with-negation (dsl/parse-query [] [[Temperature (= ?t1 temperature)
(= "MCI" location )]
[Temperature (= ?t2 temperature)
(= ?foo (+ 20 ?t1))
(= "SFO" location)]
[:not [Temperature (= ?t3 temperature)
(= ?foo (+ 10 ?t2))
(= "ORD" location)]]])



session (-> (mk-session [temps-with-addition temps-with-negation] :cache false)
(fire-rules))]

;; Test a match.
(is (= [{:?t3 30, :?t2 20, :?t1 10, :?foo 30}]
(-> session
(insert (->Temperature 10 "MCI")
(->Temperature 20 "SFO")
(->Temperature 30 "ORD"))
(fire-rules)
(query temps-with-addition))))

;; Test if not all conditions are satisfied.
(is (empty? (-> session
(insert (->Temperature 10 "MCI")
(->Temperature 21 "SFO")
(->Temperature 30 "ORD"))
(fire-rules)
(query temps-with-addition))))

;; Test if there is a negated element.
(is (empty? (-> session
(insert (->Temperature 10 "MCI")
(->Temperature 20 "SFO")
(->Temperature 30 "ORD"))
(fire-rules)
(query temps-with-negation))))

;; Test there is a match when the negated element does not exist.
(is (= [{:?t2 20, :?t1 10, :?foo 30}]
(-> session
(insert (->Temperature 10 "MCI")
(->Temperature 20 "SFO"))
(fire-rules)
(query temps-with-negation))))))

0 comments on commit c88ca13

Please sign in to comment.