minichrest/MiniChrest/Version-2/chrest-2.lisp

;;; mini-Chrest architecture version 2
;;; written by Peter Lane, February 2008

;;; Patterns
(defclass pattern () ())
(defclass visual-pattern (pattern) ())
(defclass verbal-pattern (pattern) ())

(defmethod visual-pattern-p ((pattern visual-pattern)) t)
(defmethod visual-pattern-p ((pattern t)) ())

(defgeneric make-pattern-for (pattern))
(defgeneric empty-pattern-p (pattern))
(defgeneric equal-patterns-p (pattern-1 pattern-2))
(defgeneric matching-patterns-p (pattern-1 pattern-2))
(defgeneric get-next-item (source-pattern target-pattern))
(defgeneric combine-patterns (source-pattern target-pattern))

;; - some implementations of fall back calls, 
;;   required when pattern types do not match
(defmethod equal-patterns-p ((pattern-1 pattern) (pattern-2 pattern))
  ())
(defmethod matching-patterns-p ((pattern-1 pattern) (pattern-2 pattern))
  ())

;; - root pattern 
;;   (empty pattern type, used only for root node)
(defclass root-pattern (visual-pattern) ())

(defmethod make-pattern-for ((pattern root-pattern))
  pattern)

(defmethod equal-patterns-p ((pattern-1 root-pattern) (pattern-2 root-pattern))
  t)

(defmethod matching-patterns-p ((pattern-1 root-pattern) (pattern-2 pattern))
  "Root pattern matches any other kind of pattern"
  t)

(defmethod get-next-item ((source-pattern pattern) (target-pattern root-pattern))
  "Use empty pattern of source-pattern type as target-pattern"
  (get-next-item source-pattern (make-pattern-for source-pattern)))

(defmethod combine-patterns ((source-pattern root-pattern) (target-pattern pattern))
  target-pattern)

;; - verbal-learning pattern
(defclass vl-pattern (visual-pattern)
  ((data :accessor get-data :initarg :data :initform ())))

(defmethod make-pattern-for ((pattern vl-pattern))
  "Create a new empty pattern of same type as given"
  (make-instance 'vl-pattern))

(defmethod empty-pattern-p ((pattern vl-pattern))
  (null (get-data pattern)))

(defmethod equal-patterns-p ((pattern-1 vl-pattern) (pattern-2 vl-pattern))
  (and (= (length (get-data pattern-1)) (length (get-data pattern-2)))
       (matching-patterns-p pattern-1 pattern-2)))

(defmethod matching-patterns-p ((pattern-1 vl-pattern) (pattern-2 vl-pattern))
  "Pattern 1 matches pattern 2 if its data is a presequence"
  (presequence-p (get-data pattern-1) (get-data pattern-2)))

(defmethod get-next-item ((source-pattern vl-pattern) (target-pattern vl-pattern))
  "Return a new pattern with an item from source which is not present in target"
  (let ((new-items (remove-matching-presequence (get-data source-pattern)
						(get-data target-pattern))))
       (make-instance 'vl-pattern 
		      :data (if (null new-items)
				()
				(list (first new-items))))))

(defmethod combine-patterns ((source-pattern vl-pattern) (target-pattern vl-pattern))
  "Combining two patterns means concatenating their component lists"
  (make-instance 'vl-pattern
		 :data (append (get-data source-pattern)
			       (get-data target-pattern))))

;; -- utility functions
(defun presequence-p (list-1 list-2)
  (cond ((null list-1) 
	 t)
	((null list-2) 
	 nil)
	((equalp (car list-1) (car list-2))
	 (presequence-p (cdr list-1) (cdr list-2)))
	(t
	 nil)))

(defun remove-matching-presequence (list-1 list-2)
  "Return the part of list-1 after removing the elements which match the start of list-2"
  (cond ((null list-1)
	 ())
	((null list-2)
	 list-1)
	((equalp (car list-1) (car list-2))
	 (remove-matching-presequence (cdr list-1) (cdr list-2)))
	(t
	 list-1)))

;;; Memory is a discrimination network,
;;; chunks are held in nodes, interconnected with test links
(defstruct node contents image children)
(defstruct link test child)

(defun familiarise (model node pattern)
  "Extend image of node with a new item from pattern"
  (assert (matching-patterns-p (node-image node) pattern))
  (unless (equal-patterns-p pattern (node-image node)) ; don't familiarise if everything known
        (incf (chrest-clock model) (chrest-familiarisation-time model))
	(setf (node-image node) (combine-patterns (node-image node) 
						  (get-next-item pattern (node-image node))))))

(defun discriminate (model node pattern)
  "Add a new child to node, with a new item from pattern, taken from node contents"
  (assert (eq (recognise-pattern (create-chrest) pattern node) node))
  (assert (and (matching-patterns-p (node-contents node) pattern)
	       (not (equal-patterns-p (node-contents node) pattern))))
  (incf (chrest-clock model) (chrest-discrimination-time model))
  (let* ((new-item (get-next-item pattern (node-contents node)))
	 (new-node (make-node :contents (combine-patterns (node-contents node)
							  new-item)	
			      :image (make-pattern-for (node-image node))
			      :children nil)))
	(add-to-stm new-node (chrest-stm model)) ; add new node to STM
	(push (make-link :test new-item
			 :child new-node)
	      (node-children node))))

;;; short-term memory
(defstruct stm visual verbal)

(defun add-to-stm (node stm)
  (if (visual-pattern-p (node-image node))
      (add-item node (stm-visual stm))
      (add-item node (stm-verbal stm))))

;; - utility structure, fixed length queue
(defstruct fixed-queue size (items ()))

(defun add-item (item queue)
  (setf (fixed-queue-items queue)
	(take (fixed-queue-size queue)
	      (cons item (remove item (fixed-queue-items queue))))))

(defun take (n lst &optional (taken ()))
  "Return a list of first n items in lst"
  (cond ((zerop n) (reverse taken))
	((null lst) (reverse taken))
	(t (take (1- n) (cdr lst) (cons (car lst) taken)))))

;;; Model holds a pointer to discrimination network
(defstruct chrest clock discrimination-time familiarisation-time ltm stm)

(defun create-chrest ()
  (make-chrest :clock 0
	       :familiarisation-time 2000
	       :discrimination-time 10000
	       :ltm (make-node :contents (make-instance 'root-pattern) 
			       :image (make-instance 'root-pattern) 
			       :children nil)
	       :stm (make-stm :visual (make-fixed-queue :size 4)
			      :verbal (make-fixed-queue :size 2))))

;;; Key processes for model
(defun recognise-pattern (model 
                          pattern 
                          &optional (current-node (chrest-ltm model))
			            (remaining-children (node-children current-node)))
  "Sort given pattern through LTM, returning the deepest node found"
  (cond ((null remaining-children)
	 (add-to-stm current-node (chrest-stm model)) ; add retrieved node to STM before returning it
	 current-node)
	((matching-patterns-p (node-contents (link-child (car remaining-children))) pattern)
	 (recognise-pattern model pattern (link-child (car remaining-children))))
	(t
	 (recognise-pattern model pattern current-node (cdr remaining-children)))))

(defun recognise-and-learn-pattern (model pattern &optional (input-time (chrest-clock model)))
  "Train the node found after recognition: time assumed to be model time"
  (let ((found-node (recognise-pattern model pattern)))
       (unless (> (chrest-clock model) input-time)
	       (setf (chrest-clock model) input-time) ; bring clock upto input time
	       (if (or (eq found-node (chrest-ltm model))
		       (not (matching-patterns-p (node-image found-node) pattern)))
		   (discriminate model found-node pattern)
		   (familiarise model found-node pattern)))))

(defun recall-pattern (model pattern)
  "Finds the remembered part of the given pattern"
  (node-image (recognise-pattern model pattern)))