Still doesn't work, but it is beginning to work, and I understand what's wrong.

This commit is contained in:
Simon Brooke 2025-08-22 21:56:23 +01:00
parent 792ad6fbfa
commit 6287898ca5
5 changed files with 122 additions and 71 deletions

View file

@ -6,15 +6,18 @@
(defn dengine [feat c] (defn dengine [feat c]
(let [c' (find-case-for @!kb c) (let [c' (find-case-for @!kb c)
f' (find-feature-for @!kb feat)] 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" (when (nil? c') (throw (ex-info "Unknown or invalid case"
{:case-identifier c}))) {:case-identifier c})))
(when (:rootnode f') (log! {:msg (format "Inferring value of `%s` for `%s`"
(first (remove nil? (map #(.evaluate % c) (.proposition f') (.case_name c'))})
(:children (:rootnode f')))))))) (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) (let [c' (find-case-for @!kb c)
f' (find-feature-for @!kb feat) f' (find-feature-for @!kb feat)
v (.knowledge @!kb (:case-id c') (:feature-id f')) v (.knowledge @!kb (:case-id c') (:feature-id f'))
@ -27,6 +30,13 @@
(:proposition f') (:proposition f')
(:default f') (:default f')
(:case-name c'))})] (: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}) (log! {:msg "decide-feat" :value k})
(remember! (:case-id c') (:feature-id f') k) (remember! (:case-id c') (:feature-id f') k)
(:value k))) (:value k)))

View file

@ -2,28 +2,51 @@
(:require (:require
[arboretum.dengine.protocols :refer [Case Feature KB]] [arboretum.dengine.protocols :refer [Case Feature KB]]
[clojure.pprint :refer [pprint]] [clojure.pprint :refer [pprint]]
[taoensso.telemere :refer [log!]]) [clojure.string :refer [lower-case]]
(:import [arboretum.dengine.case CaseImpl])) [taoensso.telemere :refer [log!]]))
(defn find-case-for [kb c] (declare !kb remember!)
(cond (or (satisfies? Case c) (instance? CaseImpl c)) c
(keyword? c) (-> kb :cases 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) :else (throw (ex-info (format "Unexpected value `%s` passed for case" c)
{:case c {:case c
:type (type c)})))) :type (type c)}))))))
(defn find-case-id [kb c] (defn find-case-id
(:case-id (find-case-for kb c))) "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-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 (cond (satisfies? Feature f) f
(and (keyword? f) (-> kb :features 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) :else (throw (ex-info (format "Unexpected value `%s` passed for feature" f)
{:feature f {:feature f
:type (type f)})))) :type (type f)})))))
(defn find-feature-id [kb f] (defn find-feature-id
(:feature-id (find-feature-for kb f))) "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 (defn do-knowledge
"The working guts of the `knowledge` method, separated out to make testing "The working guts of the `knowledge` method, separated out to make testing
@ -51,9 +74,16 @@
(print (format "What is the value of %s for %s [true/false]: " (:proposition f) (:name c))) (print (format "What is the value of %s for %s [true/false]: " (:proposition f) (:name c)))
(flush) (flush)
(let [in (read-line) (let [in (read-line)
v (try (read-string in) v (try (lower-case (read-string in))
(catch Exception _))] (catch Exception _))]
(when (boolean? v) v)))) (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)) (cases [this] (:cases this))
(explain [this case-id feature-id] (explain [this case-id feature-id]
(-> (do-knowledge this case-id feature-id) :reason)) (-> (do-knowledge this case-id feature-id) :reason))

View file

@ -1,6 +1,7 @@
(ns arboretum.dengine.node (ns arboretum.dengine.node
(:require (:require
[arboretum.dengine.kb :refer [!kb find-case-for find-feature-for]] [arboretum.dengine.kb :refer [!kb find-case-for find-case-id
find-feature-for]]
[arboretum.dengine.protocols :refer [Node]] [arboretum.dengine.protocols :refer [Node]]
[taoensso.telemere :refer [log!]])) [taoensso.telemere :refer [log!]]))
@ -14,10 +15,15 @@
(evaluate [this case-id] (evaluate [this case-id]
(let [c (find-case-for @!kb case-id) (let [c (find-case-for @!kb case-id)
f (.get-feature @!kb (:feature-id this)) f (.get-feature @!kb (:feature-id this))
value (:value (.knowledge @!kb c f))] ;; TODO: Shouldn't ask if there is a dtree.
(log! {:msg (format "evaluating node %s (%s %s) for case %s" knowledge (or (.knowledge @!kb c f) (.ask_user @!kb c f))
this (:feature-id this) (:colour this) (:case-id c))}) value (:value knowledge)]
(when (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 value (if
(empty? (:children this)) (empty? (:children this))
;; If my feature value is true, and I have no ;; If my feature value is true, and I have no
@ -26,8 +32,8 @@
:authority :rule :authority :rule
:reason (:fragment this)} :reason (:fragment this)}
;; but if I have some children... ;; but if I have some children...
(first (remove nil? (map #(.evaluate % c) (first (map #(.evaluate % c)
(:children this))))))))) (:children this))))))))
(defn make-node (defn make-node
"Make a node. TODO: these wrapper functions will probably disappear once "Make a node. TODO: these wrapper functions will probably disappear once

View file

@ -3,6 +3,9 @@
[arboretum.dengine.dengine :refer [decide-feat]] [arboretum.dengine.dengine :refer [decide-feat]]
[clojure.test :refer [deftest is testing]])) [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 (deftest decide-feat-test
(testing "Context of the test assertions" (testing "Context of the test assertions"
(let [expected true (let [expected true

View file

@ -19,21 +19,24 @@
: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"}})}
{:divorced (make-feature "Divorced" :divorced false nil) {:dead (make-feature "Dead" :dead false nil)
:married (make-feature "Married" :married false nil) :divorced (make-feature "Divorced" :divorced false nil)
:widowed (make-feature "Widowed" :widowed 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 (make-feature "Is entitled to Widows' Allowance"
:is-entitled-to-widows-allowance :is-entitled-to-widows-allowance
false nil) 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 (make-feature "Satisfies conditions for Widows' Allowance"
:satisfies-conditions-for-widows-allowance :satisfies-conditions-for-widows-allowance
false nil) false nil)
:gt-26-weeks-bereaved (make-feature "> 26 weeks bereaved" :gt-26-weeks-bereaved :under-pension-age-when-bereaved (make-feature "Under pension age when bereaved" :living-with-partner false true)
false nil) :widowed (make-feature "Widowed" :widowed 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)}))
(reset! !kb testkb) (reset! !kb testkb)
@ -66,8 +69,7 @@
(make-node :in-prison false (make-node :in-prison false
"You do not qualify for Widows' Allowance while you are in prison") "You do not qualify for Widows' Allowance while you are in prison")
(make-node :living-with-partner false (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 (add-dtree! :satisfies-conditions-for-widows-allowance
(make-node :satisfies-conditions-for-widows-allowance false (make-node :satisfies-conditions-for-widows-allowance false
@ -75,10 +77,10 @@
(list (make-node :widowed false (list (make-node :widowed false
"Although you are a widow, your late husband's National Insurance contributions were not sufficient to qualify." "Although you are a widow, your late husband's National Insurance contributions were not sufficient to qualify."
(list (make-node :husbands-contributions-qualify false (list (make-node :husbands-contributions-qualify false
"Although your late husband's contributions were sufficient, we understand you have a pension.") "Although your late husband's contributions were sufficient, we understand you have a pension."
(list (make-node :under-pension-age-when-bereaved true (list (make-node :under-pension-age-when-bereaved true
"Because you were under pensionable age when bereaved, you are entitled to Widows' Allowance") "Because you were under pensionable age when bereaved, you are entitled to Widows' Allowance")
(make-node :husband-not-entitled-to-cata-rp true (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"))))))) "Because your husband was not entitled to a Category A Retirement Pension, you are entitled to Widows' Allowance"))))))))
(pp/pprint @!kb) (pp/pprint @!kb)