Some progress. but tests don't run.
This commit is contained in:
parent
a3a69b8439
commit
1ac950b53a
|
|
@ -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)})))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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`"))
|
||||
and possibly `:authority`."))
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue