Created
October 23, 2014 09:46
-
-
Save matthew-ball/e15d05e8464e9b4b2fb9 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; IMPORTANT: knowledge representation system (krs) | |
(defstruct (knowledge-base (:conc-name kb-)) | |
(facts nil) | |
(beliefs nil)) | |
(defun new-knowledge-base () | |
(let ((base (make-knowledge-base :facts (make-hash-table) :beliefs (make-hash-table)))) | |
base)) | |
(defvar *knowledge-base* (new-knowledge-base)) | |
(defun add-fact (fact &optional (kb (kb-facts *knowledge-base*))) | |
(let ((predicate (first fact)) | |
(instance (second fac))) | |
(setf (gethash predicate kb) (push instance (gethash predicate kb))))) | |
(defun retrieve-fact (fact &optional (kb (kb-facts *knowledge-base*))) | |
(gethash fact kb)) | |
;; TODO: add first-order logic as known facts | |
(defun add-belief (belief &optional (kb (kb-beliefs *knowledge-base*))) | |
;; NOTE: can *only* accept belief as a pair - (predicate . instance) | |
(let ((predicate (first belief)) | |
(instance (second belief))) | |
(setf (gethash predicate kb) (push instance (gethash predicate kb))))) | |
(defun delete-belief (belief &optional (kb (kb-beliefs *knowledge-base*))) | |
(remhash belief kb)) | |
(defun retrieve-belief (belief &optional (kb (kb-beliefs *knowledge-base*))) | |
(gethash belief kb)) | |
(defun clear-beliefs (&optional (kb (kb-beliefs *knowledge-base*))) | |
(clrhash kb)) | |
;; IMPORTANT: belief revision | |
(defun update-beliefs (&optional (kb (kb-beliefs *knowledge-base*))) | |
(list kb)) | |
(defun revise-beliefs (&optional (kb (kb-beliefs *knowledge-base*))) | |
(list kb)) | |
(defun belief-contraction (belief &optional (kb (kb-beliefs *knowledge-base*))) | |
(list belief kb)) | |
(defun belief-expand (belief &optional (kb (kb-beliefs *knowledge-base*))) | |
(list belief kb)) | |
;; IMPORTANT: auxiliary functions for system | |
(defun belief-values (belief) | |
(mapcar | |
#'(lambda (value) | |
(if (listp value) | |
(cons (cadr value) 'f) | |
(cons value t))) | |
(retrieve-belief belief))) | |
(defun not-belief? (belief) | |
(and (listp belief) (eq (first belief) 'NOT))) | |
(defun belief->fact (belief justification) | |
;; change from belief to fact (i.e. by use of the justification) | |
(list belief justification)) | |
(defun belief->contradiction (belief justification) | |
;; change from belief to contradiction (i.e. by use of the justification) | |
;; a contradiction is just a negative fact | |
;; so apply/remove all NOT statements from an expression | |
;; this may require some serious transformation | |
(list belief justification)) | |
(defun consistent-belief? (key value &optional (kb (kb-beliefs *knowledge-base*))) | |
(list key value kb)) | |
(defun consistent-beliefs? (&optional (kb (kb-beliefs *knowledge-base*))) | |
(maphash #'consistent-belief? kb)) | |
;; IMPORTANT: knowledge representation language (krl) | |
;; TODO: ... | |
;; IMPORTANT: knowledge "concepts" | |
(defstruct concept | |
(name nil) | |
(parent nil) | |
(attributes nil)) | |
(defun print-concept (concept stream ignore) | |
(declare (ignore ignore)) | |
(format t "#<CONCEPT: ~A>" concept)) | |
(defvar *thing-concept* (make-concept :name 'THING :parent nil :attributes '(value))) | |
(defvar *concept-list* nil "List of concepts.") | |
(defmacro defconcept (name &optional (parent (quote (concept-name *thing-concept*))) &body body) | |
`(let ((concept (make-concept :name ,name :parent ,parent ,@body))) | |
(setf *concept-list* (push concept *concept-list*)))) | |
(defmacro definstance (name &body body) | |
`(list ,name ,@body)) | |
;; IMPORTANT: auxiliary functions for language | |
(defvar *no-bindings* '((t . t)) "The default environment.") | |
(defun atom? (var) (and (symbolp var) (equal (char (symbol-name var) 0) #\?))) | |
(defun get-binding (var bindings) (assoc var bindings)) | |
(defun make-binding (var value) (cons var value)) | |
(defun binding-variable (binding) (car binding)) | |
(defun binding-value (binding) (cdr binding)) | |
(defun lookup-value (var bindings) | |
(binding-value (get-binding var bindings))) | |
(defun extend-bindings (variable value bindings) | |
(cons (make-binding variable value) | |
(if (eq bindings *no-bindings*) | |
nil | |
bindings))) | |
(defun substitute-bindings (bindings temp) | |
(cond | |
((eq bindings nil) nil) | |
((eq bindings *no-bindings*) temp) | |
((and (atom? temp) (get-binding temp bindings)) | |
(substitute-bindings bindings (lookup-value temp bindings))) | |
((atom temp) temp) | |
(t (cons (substitute-bindings bindings (car temp)) | |
(substitute-bindings bindings (cdr temp)))))) | |
;; IMPORTANT: top level functions | |
(defmacro defquery (query) | |
;; `retrieve-belief' | |
`(list ,query)) | |
(defmacro defbelief (name) | |
;; `add-belief' | |
`(list ,name ,@body)) | |
;; IMPORTANT: scratch | |
(defstruct belief | |
(predicate nil) | |
(subject nil)) | |
(defstruct (fact (:include belief)) | |
(justification nil)) | |
;; test | |
;; > (clear-beliefs) | |
;; > (defconcept 'human) | |
;; > (defbelief '(human Socrates)) | |
;; > (defbelief '(if (human ?x) (mortal ?x))) | |
;; > (defconcept 'adult 'human) | |
;; > (defconcept 'child 'human) | |
;; > (defbelief '(adult Socrates)) | |
;; > (defbelief '(and (human Alex) (child Alex)) | |
;; > (defquery '(mortal Socrates)) | |
;; > (defquery '(child Alex)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
That's awesome