Still doesn't work, but it is beginning to work, and I understand what's wrong.
This commit is contained in:
parent
792ad6fbfa
commit
6287898ca5
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -48,12 +71,19 @@
|
|||
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))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(ns arboretum.dengine.node
|
||||
(: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]]
|
||||
[taoensso.telemere :refer [log!]]))
|
||||
|
||||
|
|
@ -14,10 +15,15 @@
|
|||
(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
|
||||
;; 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
|
||||
|
|
@ -26,23 +32,23 @@
|
|||
: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
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{: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)
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue