Skip to content

Commit

Permalink
Fix for issue #149
Browse files Browse the repository at this point in the history
  • Loading branch information
@rbrush
rbrush committed Jan 6, 2016
1 parent 0889766 commit 1ecf31d
Show file tree
Hide file tree
Showing 3 changed files with 227 additions and 22 deletions.
115 changes: 96 additions & 19 deletions src/main/clojure/clara/rules/compiler.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -512,7 +512,12 @@
matching-node (first (for [beta-node beta-nodes
:when (and (= condition (:condition beta-node))
(= node-type (:node-type beta-node))
(= env (:env beta-node))

;; Environment for merged nodes should be equal or empty.
(or (= env (:env beta-node))
(and (empty? env)
(empty? (:env beta-node))))

(= result-binding (:result-binding beta-node))
(= accumulator (:accumulator beta-node)))]
beta-node))
Expand Down Expand Up @@ -774,36 +779,95 @@
updated-bindings
still-unsatisfied))))))

(defn- extract-negations
"Extracts new rules to complex negations. Returns a map of :new-lhs containing
the new left-hand side of a production, and :generated-rules, containing
a sequence of rules generated to handle the complex negation."
[production]
(loop [previous-expressions []
[next-expression & remaining-expressions] (:lhs production)
generated-rules []]

(if next-expression

;; Find complex nested negations to refactor into new rules.
(if (and (= :not (first next-expression))
(vector? (second next-expression))
(#{:and :or :not} (first (second next-expression))))

;; Dealing with a compound negation, so extract it out.
(let [negation-expr (second next-expression)
gen-rule-name (str (or (:name production)
(gensym "gen-rule"))
"__"
(inc (count generated-rules)))

modified-expression `[:not {:type ~(if (compiling-cljs?)
'clara.rules.engine/NegationResult
'clara.rules.engine.NegationResult)
:constraints [(~'= ~gen-rule-name ~'gen-rule-name)]}]
generated-rule (cond-> {:name gen-rule-name
:lhs (conj previous-expressions
negation-expr)
:rhs `(clara.rules/insert! (eng/->NegationResult ~gen-rule-name))}

;; Propagate properties like salience to the generated production.
(:props production) (assoc :props (:props production))

;; Propagate the the environment (such as local bindings) if applicable.
(:env production) (assoc :env (:env production)))]

(recur (conj previous-expressions modified-expression)
remaining-expressions
(conj generated-rules generated-rule)))

;; next-expression wasn't a compound negation, so move on.
(recur (conj previous-expressions next-expression)
remaining-expressions
generated-rules))

{:new-lhs previous-expressions
:generated-rules generated-rules})))

(defn- get-conds
"Returns a sequence of [condition environment] tuples and their corresponding productions."
[production]

(let [lhs-expression (into [:and] (:lhs production)) ; Add implied and.
(let [{:keys [new-lhs generated-rules]} (extract-negations production)

;; Add implied and
lhs-expression (into [:and] new-lhs)
expression (to-dnf lhs-expression)
disjunctions (if (= :or (first expression))
(rest expression)
[expression])]

;; Now we've split the production into one ore more disjunctions that
;; can be processed independently. Commonality between disjunctions will
;; be merged when building the Rete network.
(for [disjunction disjunctions
(into

;; If any new rules were generated for complex negations,
;; process and include them in the result.
(mapcat get-conds generated-rules)

;; Now we've split the production into one ore more disjunctions that
;; can be processed independently. Commonality between disjunctions will
;; be merged when building the Rete network.
(for [disjunction disjunctions

:let [conditions (if (and (vector? disjunction)
(= :and (first disjunction)))
(rest disjunction)
[disjunction])
:let [conditions (if (and (vector? disjunction)
(= :and (first disjunction)))
(rest disjunction)
[disjunction])

;; Convert exists operators to accumulator and a test.
conditions (extract-exists conditions)
;; Convert exists operators to accumulator and a test.
conditions (extract-exists conditions)

sorted-conditions (sort-conditions conditions)
sorted-conditions (sort-conditions conditions)

;; Attach the conditions environment. TODO: narrow environment to those used?
conditions-with-env (for [condition sorted-conditions]
[condition (:env production)])]]
;; Attach the conditions environment. TODO: narrow environment to those used?
conditions-with-env (for [condition sorted-conditions]
[condition (:env production)])]]

[conditions-with-env production])))
[conditions-with-env production]))))


(sc/defn to-beta-tree :- [schema/BetaNode]
Expand Down Expand Up @@ -1089,9 +1153,22 @@

;; We preserve a map of fact types to alpha nodes for efficiency,
;; effectively memoizing this operation.
(let [alpha-map (atom {})]
(let [alpha-map (atom {})

;; If a customized fact-type-fn is provided,
;; we must use a specialized grouping function
;; that handles internal control types that may not
;; follow the provided type function.
fact-grouping-fn (if (= fact-type-fn type)
type
(fn [fact]
(if (isa? (type fact) :clara.rules.engine/system-type)
;; Internal system types always use Clojure's type mechanism.
(type fact)
;; All other types defer to the provided function.
(fact-type-fn fact))))]
(fn [facts]
(for [[fact-type facts] (platform/tuned-group-by fact-type-fn facts)]
(for [[fact-type facts] (platform/tuned-group-by fact-grouping-fn facts)]

(if-let [alpha-nodes (get @alpha-map fact-type)]

Expand Down
7 changes: 7 additions & 0 deletions src/main/clojure/clara/rules/engine.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,13 @@
;; Token with no bindings, used as the root of beta nodes.
(def empty-token (->Token [] {}))

;; Record indicating the negation existing in the working memory.
(defrecord NegationResult [gen-rule-name])

;; Make the negation result a "system type", so its type is not overridden
;; with a customized fact type function.
(derive NegationResult :clara.rules.engine/system-type)

;; Schema for the structure returned by the components
;; function on the session protocol.
;; This is simply a comment rather than first-class schema
Expand Down
127 changes: 124 additions & 3 deletions src/test/clojure/clara/test_rules.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -956,7 +956,8 @@

session-with-data (-> session
(insert (->WindSpeed 40 "MCI"))
(insert (->Temperature 10 "MCI")))]
(insert (->Temperature 10 "MCI"))
(fire-rules))]

;; It is not cold and windy, so we should have a match.
(is (= #{{}}
Expand All @@ -971,8 +972,8 @@

session (mk-session [not-cold-or-windy])

session-with-temp (insert session (->WindSpeed 40 "MCI"))
session-retracted (retract session-with-temp (->WindSpeed 40 "MCI"))]
session-with-temp (fire-rules (insert session (->WindSpeed 40 "MCI")))
session-retracted (fire-rules (retract session-with-temp (->WindSpeed 40 "MCI")))]

;; It is not cold and windy, so we should have a match.
(is (= #{{}}
Expand All @@ -985,6 +986,126 @@
(is (= #{{}}
(set (query session-retracted not-cold-or-windy))))))


(deftest test-complex-negation
(let [cold-not-match-temp
(dsl/parse-query []
[[:not [:and
[?t <- Temperature]
[Cold (= temperature (:temperature ?t))]]]])

negation-with-prior-bindings
(dsl/parse-query []
[[WindSpeed (= ?l location)]
[:not [:and
[?t <- Temperature (= ?l location)]
[Cold (= temperature (:temperature ?t))]]]])

nested-negation-with-prior-bindings
(dsl/parse-query []
[[WindSpeed (= ?l location)]
[:not [:and
[?t <- Temperature (= ?l location)]
[:not [Cold (= temperature (:temperature ?t))]]]]])

s (mk-session [cold-not-match-temp] :cache false)
s-with-prior (mk-session [negation-with-prior-bindings] :cache false)
s-with-nested (mk-session [nested-negation-with-prior-bindings] :cache false)]

(is (= [{}]
(-> s
(fire-rules)
(query cold-not-match-temp))))

;; Should not match when negation is met.
(is (empty? (-> s
(insert (->Temperature 10 "MCI")
(->Cold 10))
(fire-rules)
(query cold-not-match-temp))))

;; Should have result if only a single item matched.
(is (= [{}]
(-> s
(insert (->Temperature 10 "MCI"))
(fire-rules)
(query cold-not-match-temp))))

;; Test previous binding is visible.
(is (empty? (-> s-with-prior
(fire-rules)
(query negation-with-prior-bindings))))

;; Should have result since negation does not match.
(is (= [{:?l "MCI"}]
(-> s-with-prior
(insert (->WindSpeed 10 "MCI")
(->Temperature 10 "ORD")
(->Cold 10))
(fire-rules)
(query negation-with-prior-bindings))))

;; No result because negation matches.
(is (empty? (-> s-with-prior
(insert (->WindSpeed 10 "MCI")
(->Temperature 10 "MCI")
(->Cold 10))
(fire-rules)
(query negation-with-prior-bindings))))

;; There should be only one root to the beta tree because the top condition is reused.
(is (= 1 (count (com/to-beta-tree [negation-with-prior-bindings]))))
(is (= 1 (count (com/to-beta-tree [nested-negation-with-prior-bindings]))))

;; Has nothing because the cold does not match the nested negation,
;; so the :and is true and is negated at the top level.
(is (empty?
(-> s-with-nested
(insert (->WindSpeed 10 "MCI")
(->Temperature 10 "MCI")
(->Cold 20))
(fire-rules)
(query nested-negation-with-prior-bindings))))

;; Match the nested negation, which is then negated again at the higher level,
;; so this rule matches.
(is (= [{:?l "MCI"}]
(-> s-with-nested
(insert (->WindSpeed 10 "MCI")
(->Temperature 10 "MCI")
(->Cold 10))
(fire-rules)
(query nested-negation-with-prior-bindings))))))


(deftest test-complex-negation-custom-type
(let [cold-not-match-temp
(dsl/parse-query []
[[:not [:and
[?t <- :temperature]
[:cold [{temperature :temperature}] (= temperature (:temperature ?t))]]]])

s (mk-session [cold-not-match-temp] :cache false :fact-type-fn :type)]

(is (= [{}]
(-> s
(fire-rules)
(query cold-not-match-temp))))

;; Should not match when negation is met.
(is (empty? (-> s
(insert {:type :temperature :temperature 10}
{:type :cold :temperature 10})
(fire-rules)
(query cold-not-match-temp))))

;; Should have result if only a single item matched.
(is (= [{}]
(-> s
(insert {:type :temperature :temperature 10})
(fire-rules)
(query cold-not-match-temp))))))

(deftest test-negation-with-complex-retractions
(let [;; Non-blocked rule, where "blocked" means there is a
;; negated condition "guard".
Expand Down

0 comments on commit 1ecf31d

Please sign in to comment.