diff --git a/src/arboretum/dengine/dengine.clj b/src/arboretum/dengine/dengine.clj index f3d0f86..4ce63c5 100644 --- a/src/arboretum/dengine/dengine.clj +++ b/src/arboretum/dengine/dengine.clj @@ -6,15 +6,18 @@ (defn dengine [feat c] (let [c' (find-case-for @!kb c) f' (find-feature-for @!kb feat)] - (log! {:msg (format "Inferring value of `%s` for `%s`" - (:case-id c') (:feature-id f'))}) (when (nil? c') (throw (ex-info "Unknown or invalid case" {:case-identifier c}))) - (when (:rootnode f') - (first (remove nil? (map #(.evaluate % c) - (:children (:rootnode f')))))))) + (log! {:msg (format "Inferring value of `%s` for `%s`" + (.proposition f') (.case_name c'))}) + (when (.rootnode f') + (let [candidates (map #(.evaluate % c) + (.children (.rootnode f')))] + (log! {:msg (format "Found candidate `%s`" (remove empty? (flatten candidates)))}) + (first (remove empty? candidates)))))) -(defn decide-feat [feat c] +(defn decide-feat + [feat c] (let [c' (find-case-for @!kb c) f' (find-feature-for @!kb feat) v (.knowledge @!kb (:case-id c') (:feature-id f')) @@ -27,6 +30,13 @@ (:proposition f') (:default f') (:case-name c'))})] + (when (nil? k) + (throw (ex-info + (format "Failed to decide `%s` for `%s`" + (.proposition f') + (.case_name c')) + {:c c' + :f f'}))) (log! {:msg "decide-feat" :value k}) (remember! (:case-id c') (:feature-id f') k) (:value k))) diff --git a/src/arboretum/dengine/kb.clj b/src/arboretum/dengine/kb.clj index f99119b..9fe5c4b 100644 --- a/src/arboretum/dengine/kb.clj +++ b/src/arboretum/dengine/kb.clj @@ -2,28 +2,51 @@ (:require [arboretum.dengine.protocols :refer [Case Feature KB]] [clojure.pprint :refer [pprint]] - [taoensso.telemere :refer [log!]]) - (:import [arboretum.dengine.case CaseImpl])) + [clojure.string :refer [lower-case]] + [taoensso.telemere :refer [log!]])) -(defn find-case-for [kb c] - (cond (or (satisfies? Case c) (instance? CaseImpl c)) c - (keyword? c) (-> kb :cases c) - :else (throw (ex-info (format "Unexpected value `%s` passed for case" c) - {:case c - :type (type c)})))) +(declare !kb remember!) -(defn find-case-id [kb c] - (:case-id (find-case-for kb c))) +(defn find-case-for + "Find the case `c` in knowledge base `kb`. `c` may be passed as either id or + object and will be returned as object. If `c` is not found an exception is + thrown." + ([c] (find-case-for @!kb c)) + ([kb c] + (let [v (when (keyword? c) (-> kb :cases c))] + (cond (satisfies? Case c) c + v v + :else (throw (ex-info (format "Unexpected value `%s` passed for case" c) + {:case c + :type (type c)})))))) -(defn find-feature-for [kb f] - (cond (satisfies? Feature f) f - (and (keyword? f) (-> kb :features f)) (-> kb :features f) - :else (throw (ex-info (format "Unexpected value `%s` passed for feature" f) - {:feature f - :type (type f)})))) +(defn find-case-id + "Find the the id for case `c` in knowledge base `kb`. `c` may be passed + as either id or object and will be returned as id. If `c` is not found an + exception is thrown." + ([c] (find-case-id @!kb c)) + ([kb c] + (:case-id (find-case-for kb c)))) -(defn find-feature-id [kb f] - (:feature-id (find-feature-for kb f))) +(defn find-feature-for + "Find the feature `f` in knowledge base `kb`. `f` may be passed as either id + or object and will be returned as object. If `f` is not found an exception + is thrown." + ([f] (find-feature-for @!kb f)) + ([kb f] + (cond (satisfies? Feature f) f + (and (keyword? f) (-> kb :features f)) (-> kb :features f) + :else (throw (ex-info (format "Unexpected value `%s` passed for feature" f) + {:feature f + :type (type f)}))))) + +(defn find-feature-id + "Find the id of feature `f` in knowledge base `kb`. `f` may be passed as + either id or object and will be returned as id. If `f` is not found an + exception is thrown." + ([f] (find-feature-id @!kb f)) + ([kb f] + (:feature-id (find-feature-for kb f)))) (defn do-knowledge "The working guts of the `knowledge` method, separated out to make testing @@ -47,13 +70,20 @@ "Ask the user whether `feature-or-id` is true of the case identified by `case-or-id?` If the user doesn't know, return `nil`." (let [c (find-case-for this case-or-id) - f (find-feature-for this feature-or-id)] - (print (format "What is the value of %s for %s [true/false]: " (:proposition f) (:name c))) - (flush) - (let [in (read-line) - v (try (read-string in) - (catch Exception _))] - (when (boolean? v) v)))) + f (find-feature-for this feature-or-id)] + (print (format "What is the value of %s for %s [true/false]: " (:proposition f) (:name c))) + (flush) + (let [in (read-line) + v (try (lower-case (read-string in)) + (catch Exception _))] + (when (boolean? v) + (let [k {:value v + :authority :user + :reason (format "I have learned that %s is %s of %s" + (.proposition f) + v + (.case_name c))}] + (remember! (.case_id c) (.feature_id f) k)))))) (cases [this] (:cases this)) (explain [this case-id feature-id] (-> (do-knowledge this case-id feature-id) :reason)) diff --git a/src/arboretum/dengine/node.clj b/src/arboretum/dengine/node.clj index 486acc9..21aa36c 100644 --- a/src/arboretum/dengine/node.clj +++ b/src/arboretum/dengine/node.clj @@ -1,7 +1,8 @@ (ns arboretum.dengine.node (:require - [arboretum.dengine.kb :refer [!kb find-case-for find-feature-for]] - [arboretum.dengine.protocols :refer [Node]] + [arboretum.dengine.kb :refer [!kb find-case-for find-case-id + find-feature-for]] + [arboretum.dengine.protocols :refer [Node]] [taoensso.telemere :refer [log!]])) (defrecord NodeImpl [feature-id ^Boolean colour ^String fragment children] @@ -13,36 +14,41 @@ (:fragment this)) (evaluate [this case-id] (let [c (find-case-for @!kb case-id) - f (.get-feature @!kb (:feature-id this)) - value (:value (.knowledge @!kb c f))] - (log! {:msg (format "evaluating node %s (%s %s) for case %s" - this (:feature-id this) (:colour this) (:case-id c))}) - (when + f (.get-feature @!kb (:feature-id this)) + ;; TODO: Shouldn't ask if there is a dtree. + knowledge (or (.knowledge @!kb c f) (.ask_user @!kb c f)) + value (:value knowledge)] + (log! (format "Evaluating node `%s` with colour `%s` for feature `%s` in the case of `%s`" + this + (.colour this) + (.proposition f) + (.case-name c))) + (if value value (if (empty? (:children this)) ;; If my feature value is true, and I have no ;; children, return my colour and my fragment - {:value (:colour this) + {:value (:colour this) :authority :rule :reason (:fragment this)} ;; but if I have some children... - (first (remove nil? (map #(.evaluate % c) - (:children this))))))))) + (first (map #(.evaluate % c) + (:children this)))))))) -(defn make-node +(defn make-node "Make a node. TODO: these wrapper functions will probably disappear once I'm more comfortable with the architecture." ([feature-id ^Boolean colour ^String fragment] (make-node feature-id colour fragment nil)) - ([feature-id ^Boolean colour ^String fragment children ] - (if (and (find-feature-for @!kb feature-id) - (every? #(satisfies? Node %) children)) - (NodeImpl. feature-id colour fragment children) - (throw (ex-info "Unexpected item passed as child node" - {:feature-id feature-id - :colour colour - :fragment fragment - :children children}))))) + ([feature-id ^Boolean colour ^String fragment children] + (if (and (find-feature-for @!kb feature-id) + (every? #(satisfies? Node %) children)) + (NodeImpl. feature-id colour fragment children) + (throw (ex-info "Unexpected item passed as child node" + {:feature-id feature-id + :colour colour + :fragment fragment + :children children}))))) ;; Here's the algorithm as published in A Graphical Inference Mechanism, ;; but it's not real Interlisp code, and I remember there being at least diff --git a/test/dengine/dengine_test.clj b/test/dengine/dengine_test.clj index eb399f6..c4e0f13 100644 --- a/test/dengine/dengine_test.clj +++ b/test/dengine/dengine_test.clj @@ -3,6 +3,9 @@ [arboretum.dengine.dengine :refer [decide-feat]] [clojure.test :refer [deftest is testing]])) +;; ensure !kb is ser up the way we want it... +(load-file "test/dengine/test_kb.clj") + (deftest decide-feat-test (testing "Context of the test assertions" (let [expected true diff --git a/test/dengine/test_kb.clj b/test/dengine/test_kb.clj index 4ee74a4..f74d365 100644 --- a/test/dengine/test_kb.clj +++ b/test/dengine/test_kb.clj @@ -19,21 +19,24 @@ :divorced {:value false :authority :default :reason "I assumed that divorced is false of Mrs Norah Trellis"}})} - {:divorced (make-feature "Divorced" :divorced false nil) - :married (make-feature "Married" :married false nil) - :widowed (make-feature "Widowed" :widowed false nil) - :is-entitled-to-widows-allowance (make-feature "Is entitled to Widows' Allowance" - :is-entitled-to-widows-allowance + {:dead (make-feature "Dead" :dead false nil) + :divorced (make-feature "Divorced" :divorced false nil) + :gt-26-weeks-bereaved (make-feature "> 26 weeks bereaved" :gt-26-weeks-bereaved + false nil) + :husband-not-entitled-to-cata-rp (make-feature "Late husband was not entitled to Cat A Retirement Pension" false nil) + :husbands-contributions-qualify (make-feature "Husband's contributions qualify" :husbands-contributions-qualify true nil) + :in-prison (make-feature "In prison" :in-prison false nil) + :is-entitled-to-widows-allowance (make-feature "Is entitled to Widows' Allowance" + :is-entitled-to-widows-allowance false nil) + :killed-husband (make-feature "Killed husband" :killed-husband false nil) + :living-with-partner (make-feature "Living with partner" :living-with-partner false nil) + :married (make-feature "Married" :married false nil) :satisfies-conditions-for-widows-allowance (make-feature "Satisfies conditions for Widows' Allowance" :satisfies-conditions-for-widows-allowance false nil) - :gt-26-weeks-bereaved (make-feature "> 26 weeks bereaved" :gt-26-weeks-bereaved - false nil) - :killed-husband (make-feature "Killed husband" :killed-husband false nil) - :dead (make-feature "Dead" :dead false nil) - :in-prison (make-feature "In prison" :in-prison false nil) - :husbands-contributions-qualify (make-feature "Husband's contributions qualify" :husbands-contributions-qualify true nil)})) + :under-pension-age-when-bereaved (make-feature "Under pension age when bereaved" :living-with-partner false true) + :widowed (make-feature "Widowed" :widowed false nil)})) (reset! !kb testkb) @@ -52,8 +55,8 @@ ;; This does mean, however, that the node could be made at feature creation ;; time. -(add-dtree! :is-entitled-to-widows-allowance - (make-node :is-entitled-to-widows-allowance false +(add-dtree! :is-entitled-to-widows-allowance + (make-node :is-entitled-to-widows-allowance false "I have not been able to determine that you are entitled to Widows' Allowance." (list (make-node :satisfies-conditions-for-widows-allowance true "You satisfy all the conditions for Widows' Allowance." @@ -66,8 +69,7 @@ (make-node :in-prison false "You do not qualify for Widows' Allowance while you are in prison") (make-node :living-with-partner false - "You do not qualify for Widows' Allowance as we understand that you have a new partner.") - ))))) + "You do not qualify for Widows' Allowance as we understand that you have a new partner.")))))) (add-dtree! :satisfies-conditions-for-widows-allowance (make-node :satisfies-conditions-for-widows-allowance false @@ -75,10 +77,10 @@ (list (make-node :widowed false "Although you are a widow, your late husband's National Insurance contributions were not sufficient to qualify." (list (make-node :husbands-contributions-qualify false - "Although your late husband's contributions were sufficient, we understand you have a pension.") - (list (make-node :under-pension-age-when-bereaved true - "Because you were under pensionable age when bereaved, you are entitled to Widows' Allowance") - (make-node :husband-not-entitled-to-cata-rp true - "Because your husband was not entitled to a Category A Retirement Pension, you are entitled to Widows' Allowance"))))))) + "Although your late husband's contributions were sufficient, we understand you have a pension." + (list (make-node :under-pension-age-when-bereaved true + "Because you were under pensionable age when bereaved, you are entitled to Widows' Allowance") + (make-node :husband-not-entitled-to-cata-rp true + "Because your husband was not entitled to a Category A Retirement Pension, you are entitled to Widows' Allowance")))))))) (pp/pprint @!kb)