simon/dengine
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Started (but not completed) adding inference rules to the test knowledge base.

Browse source 
This commit consequently will not pass tests.
This commit is contained in:
Simon Brooke 2025-08-14 21:29:54 +01:00
parent 5c1427e8fa
commit a3a69b8439
7 changed files with 133 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/arboretum/dengine/feature.clj
View file

@ -18,7 +18,8 @@
(proposition [this] (:proposition this))) (proposition [this] (:proposition this)))
(defn make-feature (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] ([proposition default rootnode]
(make-feature proposition (string->keyword proposition) default rootnode)) (make-feature proposition (string->keyword proposition) default rootnode))
([proposition id default rootnode] ([proposition id default rootnode]

12
src/arboretum/dengine/kb.clj
View file

@ -35,12 +35,20 @@
{:feature f {:feature f
:type (type 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) (let [c (find-case-for kb case-or-id)
f (find-feature-id kb feature-or-id)] f (find-feature-id kb feature-or-id)]
(-> c :knowledge f))) (-> 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)) (-> (do-knowledge kb case-or-id feature-or-id) :value))
(defrecord KBImpl [^clojure.lang.APersistentMap cases ^clojure.lang.APersistentMap features] (defrecord KBImpl [^clojure.lang.APersistentMap cases ^clojure.lang.APersistentMap features]

9
src/arboretum/dengine/node.clj
View file

@ -4,7 +4,7 @@
[arboretum.dengine.protocols :refer [Feature Node]] [arboretum.dengine.protocols :refer [Feature Node]]
[clojure.string :as string])) [clojure.string :as string]))
(defrecord NodeImpl [children ^Boolean colour feature ^String fragment] (defrecord NodeImpl [feature ^Boolean colour ^String fragment children]
Node Node
(children [this] "The children of this node" (:children this)) (children [this] "The children of this node" (:children this))
(colour ^Boolean [this] "The colour of this node" (:colour this)) (colour ^Boolean [this] "The colour of this node" (:colour this))
@ -28,6 +28,13 @@
(first (remove nil? (map #(.evaluate % c) (first (remove nil? (map #(.evaluate % c)
(:children this))))))))) (: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, ;; 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 ;; but it's not real Interlisp code, and I remember there being at least

6
test/dengine/dengine_test.clj Normal file
View file

@ -0,0 +1,6 @@
(ns dengine.dengine-test
(:require
[arboretum.dengine.node :refer [make-node]]))

43
test/dengine/feature_test.clj
View file

@ -1,35 +1,30 @@
(ns dengine.feature-test (ns dengine.feature-test
(:require (: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.pprint :refer [pprint]]
[clojure.test :refer [deftest is testing]]) [clojure.test :refer [deftest is testing]]
(:import [dengine.test-kb :refer [testkb]]))
[arboretum.dengine.kb KBImpl]))
(def testkb (KBImpl. {:case-1 (make-case :case-1 "Mrs Nora Trellis" ;; (def testkb (KBImpl. {:case-1 (make-case :case-1 "Mrs Nora Trellis"
{:married {:value true ;; {:married {:value true
:authority :user ;; :authority :user
:reason "I have been told that married is true of Mrs Norah Trellis"} ;; :reason "I have been told that married is true of Mrs Norah Trellis"}
:divorced {:value false ;; :divorced {:value false
:authority :default ;; :authority :default
:reason "I assumed that divorced is false of Mrs Norah Trellis"} ;; :reason "I assumed that divorced is false of Mrs Norah Trellis"}
:is-entitled-to-widows-benefit {:value true ;; :is-entitled-to-widows-benefit {:value true
:authority :rule ;; :authority :rule
:reason "I infered that is-entitled-to-widows-benefit is true of Mrs Norah Trellis"}})} ;; :reason "I infered that is-entitled-to-widows-benefit is true of Mrs Norah Trellis"}})}
{:widowed (make-feature "Widowed" :widowed false nil) ;; {:widowed (make-feature "Widowed" :widowed false nil)
:married (make-feature "Married" :married false nil)})) ;; :married (make-feature "Married" :married false nil)}))
(reset! !kb testkb) ;; (reset! !kb testkb)
(pprint @!kb) ;; (pprint testkb)
(deftest feature-impl-test (deftest feature-impl-test
(testing "Testing feature implementation" (testing "Testing feature implementation"
(let [f1 (.get-feature @!kb :widowed) (let [f1 (.get-feature testkb :widowed)
c (.get-case @!kb :case-1)] c (.get-case testkb :case-1)]
(pprint {:f f1 (pprint {:f f1
:c c}) :c c})
(let [expected :widowed (let [expected :widowed
@ -42,5 +37,5 @@
actual (.decide f1 c)] actual (.decide f1 c)]
(is (= actual expected) "If we have no knowledge and no decision method, take the defualt.")) (is (= actual expected) "If we have no knowledge and no decision method, take the defualt."))
(let [expected true (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."))))) (is (= actual expected) "If we have knowledge, return it.")))))

31
test/dengine/kb_test.clj
View file

@ -1,33 +1,10 @@
(ns dengine.kb-test (ns dengine.kb-test
(:require (:require
[arboretum.dengine.case :refer [make-case]] [arboretum.dengine.core :refer [add-feature!]]
[arboretum.dengine.core :refer [add-case! add-feature!]]
[arboretum.dengine.feature :refer [make-feature]]
[arboretum.dengine.kb :refer :all] [arboretum.dengine.kb :refer :all]
[clojure.pprint :refer [pprint]] [clojure.test :refer [deftest is testing]]
[clojure.test :refer [deftest is testing]]) [dengine.test-kb :refer [testkb]]))
(: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"}
: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 (deftest access-test
(testing "Accessing knowledge in the knowledge base" (testing "Accessing knowledge in the knowledge base"
@ -42,7 +19,7 @@
(is (= actual expected)))) (is (= actual expected))))
(testing "Adding features" (testing "Adding features"
(let [expected nil (let [expected nil
actual (.get-feature @!kb :has-children)] actual (.get-feature testkb :has-children)]
(is (= actual expected) "Not present until added...")) (is (= actual expected) "Not present until added..."))
(add-feature! "Has children" :has-children false nil) (add-feature! "Has children" :has-children false nil)
(let [expected :has-children (let [expected :has-children

84
test/dengine/test_kb.clj Normal file
View file

@ -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)))))))