knowledge-representation.lisp

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

That's awesome