diff --git a/src/arboretum/dengine/feature.clj b/src/arboretum/dengine/feature.clj index 45a2762..9e76de0 100644 --- a/src/arboretum/dengine/feature.clj +++ b/src/arboretum/dengine/feature.clj @@ -18,7 +18,8 @@ (proposition [this] (:proposition this))) (defn make-feature - "A convenience function to make features." + "A convenience function to make features. TODO: these wrapper functions will + probably disappear once I'm more comfortable with the architecture." ([proposition default rootnode] (make-feature proposition (string->keyword proposition) default rootnode)) ([proposition id default rootnode] diff --git a/src/arboretum/dengine/kb.clj b/src/arboretum/dengine/kb.clj index 408cab1..63a467f 100644 --- a/src/arboretum/dengine/kb.clj +++ b/src/arboretum/dengine/kb.clj @@ -35,12 +35,20 @@ {:feature f :type (type f)})))) -(defn do-knowledge [kb case-or-id feature-or-id] +(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." + [kb case-or-id feature-or-id] (let [c (find-case-for kb case-or-id) f (find-feature-id kb feature-or-id)] (-> c :knowledge f))) -(defn do-is? [kb case-or-id feature-or-id] +(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." + [kb case-or-id feature-or-id] (-> (do-knowledge kb case-or-id feature-or-id) :value)) (defrecord KBImpl [^clojure.lang.APersistentMap cases ^clojure.lang.APersistentMap features] diff --git a/src/arboretum/dengine/node.clj b/src/arboretum/dengine/node.clj index a80c7b4..3f0b5e0 100644 --- a/src/arboretum/dengine/node.clj +++ b/src/arboretum/dengine/node.clj @@ -4,7 +4,7 @@ [arboretum.dengine.protocols :refer [Feature Node]] [clojure.string :as string])) -(defrecord NodeImpl [children ^Boolean colour feature ^String fragment] +(defrecord NodeImpl [feature ^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)) @@ -28,6 +28,13 @@ (first (remove nil? (map #(.evaluate % c) (:children this))))))))) +(defn make-node + "Make a node. TODO: these wrapper functions will probably disappear once + I'm more comfortable with the architecture." + ([feature ^Boolean colour ^String fragment] + (make-node feature colour fragment nil)) + ([feature ^Boolean colour ^String fragment children ] + (NodeImpl. feature colour fragment 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 new file mode 100644 index 0000000..96e888b --- /dev/null +++ b/test/dengine/dengine_test.clj @@ -0,0 +1,6 @@ +(ns dengine.dengine-test + (:require + [arboretum.dengine.node :refer [make-node]])) + + + diff --git a/test/dengine/feature_test.clj b/test/dengine/feature_test.clj index 79b79bc..6c3ef19 100644 --- a/test/dengine/feature_test.clj +++ b/test/dengine/feature_test.clj @@ -1,35 +1,30 @@ (ns dengine.feature-test (:require - [arboretum.dengine.case :refer [make-case]] - [arboretum.dengine.core :refer [add-case! add-feature!]] - [arboretum.dengine.feature :refer [make-feature]] - [arboretum.dengine.kb :refer [!kb]] [clojure.pprint :refer [pprint]] - [clojure.test :refer [deftest is testing]]) - (:import - [arboretum.dengine.kb KBImpl])) + [clojure.test :refer [deftest is testing]] + [dengine.test-kb :refer [testkb]])) -(def testkb (KBImpl. {:case-1 (make-case :case-1 "Mrs Nora Trellis" - {:married {:value true - :authority :user - :reason "I have been told that married is true of Mrs Norah Trellis"} - :divorced {:value false - :authority :default - :reason "I assumed that divorced is false of Mrs Norah Trellis"} - :is-entitled-to-widows-benefit {:value true - :authority :rule - :reason "I infered that is-entitled-to-widows-benefit is true of Mrs Norah Trellis"}})} - {:widowed (make-feature "Widowed" :widowed false nil) - :married (make-feature "Married" :married false nil)})) +;; (def testkb (KBImpl. {:case-1 (make-case :case-1 "Mrs Nora Trellis" +;; {:married {:value true +;; :authority :user +;; :reason "I have been told that married is true of Mrs Norah Trellis"} +;; :divorced {:value false +;; :authority :default +;; :reason "I assumed that divorced is false of Mrs Norah Trellis"} +;; :is-entitled-to-widows-benefit {:value true +;; :authority :rule +;; :reason "I infered that is-entitled-to-widows-benefit is true of Mrs Norah Trellis"}})} +;; {:widowed (make-feature "Widowed" :widowed false nil) +;; :married (make-feature "Married" :married false nil)})) -(reset! !kb testkb) +;; (reset! !kb testkb) -(pprint @!kb) +;; (pprint testkb) (deftest feature-impl-test (testing "Testing feature implementation" - (let [f1 (.get-feature @!kb :widowed) - c (.get-case @!kb :case-1)] + (let [f1 (.get-feature testkb :widowed) + c (.get-case testkb :case-1)] (pprint {:f f1 :c c}) (let [expected :widowed @@ -42,5 +37,5 @@ actual (.decide f1 c)] (is (= actual expected) "If we have no knowledge and no decision method, take the defualt.")) (let [expected true - actual (.decide (.get-feature @!kb :married) :case-1)] + actual (.decide (.get-feature testkb :married) :case-1)] (is (= actual expected) "If we have knowledge, return it."))))) \ No newline at end of file diff --git a/test/dengine/kb_test.clj b/test/dengine/kb_test.clj index 9aa8893..f3e5d5e 100644 --- a/test/dengine/kb_test.clj +++ b/test/dengine/kb_test.clj @@ -1,33 +1,10 @@ (ns dengine.kb-test (:require - [arboretum.dengine.case :refer [make-case]] - [arboretum.dengine.core :refer [add-case! add-feature!]] - [arboretum.dengine.feature :refer [make-feature]] + [arboretum.dengine.core :refer [add-feature!]] [arboretum.dengine.kb :refer :all] - [clojure.pprint :refer [pprint]] - [clojure.test :refer [deftest is testing]]) - (:import - [arboretum.dengine.kb KBImpl])) + [clojure.test :refer [deftest is testing]] + [dengine.test-kb :refer [testkb]])) -(def testkb (KBImpl. {:case-1 (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"} - :divorced {:value false - :authority :default - :reason "I assumed that divorced is false of Mrs Norah Trellis"} - :is-entitled-to-widows-benefit {:value true - :authority :rule - :reason "I infered that is-entitled-to-widows-benefit is true of Mrs Norah Trellis"}})} - {:divorced (make-feature "Divorced" :divorced false nil) - :married (make-feature "Married" :married false nil) - :widowed (add-feature! "Widowed" :widowed false nil) - :is-entitled-to-widows-benefit - (add-feature! "Is entitled to widows' benefit" - :is-entitled-to-widows-benefit false nil)})) - -(pprint testkb) - -(reset! !kb testkb) (deftest access-test (testing "Accessing knowledge in the knowledge base" @@ -42,7 +19,7 @@ (is (= actual expected)))) (testing "Adding features" (let [expected nil - actual (.get-feature @!kb :has-children)] + actual (.get-feature testkb :has-children)] (is (= actual expected) "Not present until added...")) (add-feature! "Has children" :has-children false nil) (let [expected :has-children diff --git a/test/dengine/test_kb.clj b/test/dengine/test_kb.clj new file mode 100644 index 0000000..1dfcc0e --- /dev/null +++ b/test/dengine/test_kb.clj @@ -0,0 +1,84 @@ +(ns dengine.test-kb + "Knowledge base to use in testing." + (:require + [arboretum.dengine.case :refer [make-case]] + [arboretum.dengine.core :refer [add-feature!]] + [arboretum.dengine.feature :refer [make-feature]] + [arboretum.dengine.kb :refer [!kb]] + [arboretum.dengine.node :refer [make-node]] + [clojure.pprint :as pp]) + (:import + [arboretum.dengine.kb KBImpl])) + +(def testkb + (KBImpl. {:case-1 + (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"} + :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 + 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)})) + +(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." + (list (make-node :satisfies-conditions-for-widows-allowance true + "You satisfy all the conditions for Widows' Allowance." + (list (make-node :gt-26-weeks-bereaved false + "You no longer qualify for Widows' Allowance as it is more than 26 weeks since you were bereaved") + (make-node :killed-husband false + "You do not qualify for Widows' Allowance as we understand that you killed your husband.") + (make-node :dead false + "The subject of this application does not qualify for Widows' Allowance as we understand that she is dead") + (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.") + ))))) + +(add-dtree! :satisfies-conditions-for-widows-allowance + (make-node :satisfies-conditions-for-widows-allowance false + "I have not been able to determine that you satisfy the conditions for Widows' Allowance." + (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))))))) +