From 1ecf31d2a41f5c83cdaada5fc0798a9b39eeef53 Mon Sep 17 00:00:00 2001 From: Ryan Brush Date: Tue, 5 Jan 2016 20:34:02 -0600 Subject: [PATCH] Fix for issue #149 --- src/main/clojure/clara/rules/compiler.clj | 115 ++++++++++++++++---- src/main/clojure/clara/rules/engine.cljc | 7 ++ src/test/clojure/clara/test_rules.clj | 127 +++++++++++++++++++++- 3 files changed, 227 insertions(+), 22 deletions(-) diff --git a/src/main/clojure/clara/rules/compiler.clj b/src/main/clojure/clara/rules/compiler.clj index b0d1e3be..384fa572 100644 --- a/src/main/clojure/clara/rules/compiler.clj +++ b/src/main/clojure/clara/rules/compiler.clj @@ -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)) @@ -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] @@ -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)] diff --git a/src/main/clojure/clara/rules/engine.cljc b/src/main/clojure/clara/rules/engine.cljc index ae21c3ef..7da7af91 100644 --- a/src/main/clojure/clara/rules/engine.cljc +++ b/src/main/clojure/clara/rules/engine.cljc @@ -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 diff --git a/src/test/clojure/clara/test_rules.clj b/src/test/clojure/clara/test_rules.clj index b9e27dfd..6f59b6fd 100644 --- a/src/test/clojure/clara/test_rules.clj +++ b/src/test/clojure/clara/test_rules.clj @@ -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 (= #{{}} @@ -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 (= #{{}} @@ -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".