diff --git a/src/arboretum/dengine/core.clj b/src/arboretum/dengine/core.clj index a4a96a7..a740969 100644 --- a/src/arboretum/dengine/core.clj +++ b/src/arboretum/dengine/core.clj @@ -5,10 +5,9 @@ (:require [arboretum.dengine.case :refer [make-case]] [arboretum.dengine.feature :refer [make-feature]] - [arboretum.dengine.kb :refer [!kb]] - [arboretum.dengine.utils :refer [string->keyword]]) - - (:import [arboretum.dengine.case CaseImpl])) + [arboretum.dengine.kb :refer [!kb find-feature-for]] + [arboretum.dengine.protocols :refer [Node]] + [arboretum.dengine.utils :refer [string->keyword]])) ;; (defn is? ;; [feature case kb] @@ -36,3 +35,12 @@ (let [f (make-feature proposition id default rootnode)] (swap! !kb assoc-in [:features id] f) f))) + +(defn add-dtree! [feature-or-id root-node] + (let [f (find-feature-for @!kb feature-or-id) + id (:feature-id f)] + (if (satisfies? Node root-node)(swap! !kb assoc-in [:features id :rootnode] root-node) + (throw (ex-info (format "Unexpected value `%s` passed for feature" id) + {:feature f + :root-node root-node + :type (type root-node)}))))) diff --git a/src/arboretum/dengine/kb.clj b/src/arboretum/dengine/kb.clj index 63a467f..f99119b 100644 --- a/src/arboretum/dengine/kb.clj +++ b/src/arboretum/dengine/kb.clj @@ -2,40 +2,30 @@ (:require [arboretum.dengine.protocols :refer [Case Feature KB]] [clojure.pprint :refer [pprint]] - [taoensso.telemere :refer [log!]])) + [taoensso.telemere :refer [log!]]) + (:import [arboretum.dengine.case CaseImpl])) (defn find-case-for [kb c] - (cond (satisfies? Case c) 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)})))) (defn find-case-id [kb c] - (cond - (and (keyword? c) (-> kb :cases c)) c - (satisfies? Case c) (:case-id c) - :else (throw (ex-info (format "Unexpected value `%s` passed for case" c) - {:case c - :type (type c)})))) + (:case-id (find-case-for kb c))) (defn find-feature-for [kb f] (cond (satisfies? Feature f) f - (keyword? f) (-> kb :features 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 [kb f] - (cond - (and (keyword? f) (-> kb :features f)) f - (satisfies? Feature f) (:feature-id f) - :else (throw - (ex-info (format "Unexpected value `%s` passed for feature" f) - {:feature f - :type (type f)})))) + (:feature-id (find-feature-for kb f))) -(defn do-knowledge +(defn do-knowledge "The working guts of the `knowledge` method, separated out to make testing easier. TODO: these wrapper functions will probably disappear once I'm more comfortable with the architecture." @@ -44,7 +34,7 @@ f (find-feature-id kb feature-or-id)] (-> c :knowledge f))) -(defn do-is? +(defn do-is? "The working guts of the `is?` method, separated out to make testing easier. TODO: these wrapper functions will probably disappear once I'm more comfortable with the architecture." @@ -53,7 +43,20 @@ (defrecord KBImpl [^clojure.lang.APersistentMap cases ^clojure.lang.APersistentMap features] KB + (ask-user ^Boolean [this case-or-id feature-or-id] + "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)))) (cases [this] (:cases this)) + (explain [this case-id feature-id] + (-> (do-knowledge this case-id feature-id) :reason)) (features [this] (:features this)) (get-case [this case-id] (-> this :cases case-id)) (get-feature [this feature-id] (-> this :features feature-id)) @@ -69,9 +72,9 @@ (defn remember! "Remember this `value` for the feature with this `feature-id` of the case with this `case-id`. Return the `value`." - ([case-id feature-id value] + ([case-id feature-id value] (let [v (cond (boolean? value) {:value value} - (and (map? value) (boolean? (:value value))) value) + (and (map? value) (boolean? (:value value))) value) c (find-case-id @!kb case-id) f (find-feature-id @!kb feature-id)] (when-not (and v c f) diff --git a/src/arboretum/dengine/node.clj b/src/arboretum/dengine/node.clj index 3f0b5e0..2891041 100644 --- a/src/arboretum/dengine/node.clj +++ b/src/arboretum/dengine/node.clj @@ -1,21 +1,22 @@ (ns arboretum.dengine.node (:require - [arboretum.dengine.kb :refer [!kb]] - [arboretum.dengine.protocols :refer [Feature Node]] - [clojure.string :as string])) + [arboretum.dengine.kb :refer [!kb find-case-for find-feature-for]] + [arboretum.dengine.protocols :refer [Node]] + [taoensso.telemere :refer [log!]])) -(defrecord NodeImpl [feature ^Boolean colour ^String fragment children] +(defrecord NodeImpl [feature-id ^Boolean colour ^String fragment children] Node (children [this] "The children of this node" (:children this)) (colour ^Boolean [this] "The colour of this node" (:colour this)) - (feature [this] "The feature at this node" (:feature this)) + (feature [this] "The id of the feature at this node" (.get-feature @!kb (:feature-id this))) (fragment ^String [this] "The explanation fragment at this node" (:fragment this)) (evaluate [this case-id] - (let [c (-> !kb .cases case-id) - f (if (satisfies? Feature (:feature this)) (:feature this) - (-> !kb .features (:feature this))) - value (:value (.knowledge !kb c f))] + (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 value (if (empty? (:children this)) diff --git a/src/arboretum/dengine/protocols.clj b/src/arboretum/dengine/protocols.clj index 201904e..a3d66fa 100644 --- a/src/arboretum/dengine/protocols.clj +++ b/src/arboretum/dengine/protocols.clj @@ -56,19 +56,22 @@ (defprotocol KB "A knowledge base, comprising features and means to infer their value in a given case, and cases which have features with values." - (ask-user ^Boolean [this case-or-id] + (ask-user ^Boolean [this case-or-id feature-or-id] "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`.") - (get-case ^APersistentMap [this ^Keyword case_id] - "Return the case with this `id` from among my cases, - if present, else `nil`") (cases ^APersistentMap [this] "All cases known in this knowledge base, keyed by `:case-id`") - (get-feature ^APersistentMap [this id-or-prop] - "Return the feature with this `id` from among my features, - if present, else `nil`") + (explain ^String [this case-id feature-id] + "Return the reason for believing the value that is believed of the feature + identified by `feature-id` in the case identified by `case-id`.") (features ^APersistentMap [this] "All features known in this knowledge base, keyed by `:proposition`") + (get-case ^APersistentMap [this ^Keyword case_id] + "Return the case with this `id` from among my cases, + if present, else `nil`") + (get-feature ^APersistentMap [this id-or-prop] + "Return the feature with this `id` from among my features, + if present, else `nil`") (is? ^Boolean [this case-or-id feature-or-id] "Is the feature identified by `feature-or-id` true of the case identified by `case-or-id`? If feature is undecided for this case, return `nil`.") @@ -89,6 +92,4 @@ (evaluate [this case-id] "evaluate this node in the context of the case identified by `case-id`. Returns a map with keys `:value`, `:explanation` - and possibly `:authority`.") - (explain [this case-id] "return an explanation from this node or its children - for the case identified by `case-id`")) \ No newline at end of file + and possibly `:authority`.")) \ No newline at end of file diff --git a/test/dengine/dengine_test.clj b/test/dengine/dengine_test.clj index 96e888b..aa2a83c 100644 --- a/test/dengine/dengine_test.clj +++ b/test/dengine/dengine_test.clj @@ -1,6 +1,12 @@ (ns dengine.dengine-test (:require - [arboretum.dengine.node :refer [make-node]])) - + [arboretum.dengine.dengine :refer [decide-feat]] + [clojure.test :refer [deftest is testing]])) + +(deftest decide-feat-test + (testing "Context of the test assertions" + (let [expected true + actual (:value + (decide-feat :is-entitled-to-widows-allowance :case-1))](is (= actual expected))))) diff --git a/test/dengine/test_kb.clj b/test/dengine/test_kb.clj index 1dfcc0e..d341ba5 100644 --- a/test/dengine/test_kb.clj +++ b/test/dengine/test_kb.clj @@ -2,7 +2,7 @@ "Knowledge base to use in testing." (:require [arboretum.dengine.case :refer [make-case]] - [arboretum.dengine.core :refer [add-feature!]] + [arboretum.dengine.core :refer [add-dtree! add-feature!]] [arboretum.dengine.feature :refer [make-feature]] [arboretum.dengine.kb :refer [!kb]] [arboretum.dengine.node :refer [make-node]] @@ -12,7 +12,7 @@ (def testkb (KBImpl. {:case-1 - (make-case :case-1 "Mrs Norah Trellis" + (make-case :case-1 "Mrs Norah Trellis" {:married {:value true :authority :user :reason "I have been told that married is true of Mrs Norah Trellis"} @@ -35,27 +35,10 @@ :in-prison (make-feature "In prison" :in-prison false nil) :husbands-contributions-qualify (make-feature "Husband's contributions qualify" :husbands-contributions-qualify true nil)})) -(pp/pprint testkb) - (reset! !kb testkb) (add-feature! "Is entitled to Widows' Allowance" :is-entitled-to-widows-allowance false nil) -;; TODO: -;; we can't add a node in `add-feature!` since creating the root node requires -;; that the feature already exists. So the 'rootnode' argument to `add-feature` -;; and make-feature is not useful and should be deleted. We also need to test -;; when adding a dtree to an existing feature that the rootnode references that -;; feature. - -;; OK, it's worse than that. We can't persist and restore a knowledge base in -;; which features are directly linked from DTree nodes, since then we would -;; (probably) create multiple copies of the feature when reloading. So probably -;; the node should only hold the id of the feature, not a direct link. - -;; 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 "I have not been able to determine that you are entitled to Widows' Allowance." @@ -80,5 +63,9 @@ "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))))))) + (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)