;;; mini-Chrest architecture version 3
;;; written by Peter Lane, February-March 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)

;; - list pattern
(defclass list-pattern (visual-pattern)
  ((data :accessor get-data :initarg :data :initform ())))

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

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

(defmethod equal-patterns-p ((pattern-1 list-pattern) (pattern-2 list-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 list-pattern) (pattern-2 list-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 list-pattern) (target-pattern list-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 'list-pattern 
		      :data (if (null new-items)
				()
				(list (first new-items))))))

(defmethod combine-patterns ((source-pattern list-pattern) (target-pattern list-pattern))
  "Combining two patterns means concatenating their component lists"
  (make-instance 'list-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)))

;; - name pattern
(defclass name-pattern (verbal-pattern)
  ((name :accessor get-name :initarg :name :initform "")))

(defmethod make-pattern-for ((pattern name-pattern))
  (make-instance 'name-pattern :name ""))

(defmethod empty-pattern-p ((pattern name-pattern))
  (string= "" (get-name pattern)))

(defmethod equal-patterns-p ((pattern-1 name-pattern) (pattern-2 name-pattern))
  (string= (get-name pattern-1) (get-name pattern-2)))

(defmethod matching-patterns-p ((pattern-1 name-pattern) (pattern-2 name-pattern))
  (or (empty-pattern-p pattern-1)
      (equal-patterns-p pattern-1 pattern-2)))

(defmethod get-next-item ((source-pattern name-pattern) (target-pattern name-pattern))
  "You cannot extract a feature from a string, so next item is just the source pattern"
  source-pattern)

(defmethod combine-patterns ((source-pattern name-pattern) (target-pattern name-pattern))
  "Can only combine with given pattern if this one is empty"
  (if (empty-pattern-p source-pattern)
      target-pattern
      source-pattern))


;;; Memory is a discrimination network,
;;; chunks are held in nodes, interconnected with test links
;;; -- cross-modal-link is a pointer to another node in network
;;;    of opposite modality.  Only one such link allowed per node.
(defstruct node contents image children cross-modal-link)
(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))
        (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))))

(defun learn-stm-links (model)
  "Create a cross-modal link between the top node of visual STM and the 
  top node of verbal STM"
  (let ((visual-stm (stm-visual (chrest-stm model)))
	(verbal-stm (stm-verbal (chrest-stm model))))
       (unless (or (empty-queue-p visual-stm)
		   (empty-queue-p verbal-stm))
	       (incf (chrest-clock model) (chrest-add-link-time model))
	       ; set cross-modal link of top visual node to point to top verbal node
	       (setf (node-cross-modal-link (peek-queue visual-stm))
		     (peek-queue verbal-stm))
	       ; set cross-modal link of top verbal node to point to top visual node
	       (setf (node-cross-modal-link (peek-queue verbal-stm))
		     (peek-queue visual-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)))))

(defun empty-queue-p (queue)
  (null (fixed-queue-items queue)))

(defun peek-queue (queue)
  "Return first item of queue, without changing queue"
  (assert (not (null (fixed-queue-items queue))))
  (car (fixed-queue-items queue)))

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

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

;;; 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 (or (> (chrest-clock model) input-time)  ; unless busy
		   (> (random 1.0) (chrest-rho model))) ; or randomly ignore stimulus
	       (setf (chrest-clock model) input-time) ; bring clock up to 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)))

(defun learn-and-link-two-patterns (model pattern-1 pattern-2 &optional (input-time (chrest-clock model)))
  "Given two patterns, do a cycle of learning on them both, then try to form a link."
  (recognise-and-learn-pattern model pattern-1 input-time)
  (recognise-and-learn-pattern model pattern-2 input-time)
  (learn-stm-links model))

(defun name-pattern (model pattern)
  "Given a pattern, sort it, and then return the image of any cross-modal link."
  (let ((found-node (recognise-pattern model pattern)))
       (if (null (node-cross-modal-link found-node))
	   'no-name-found
	   (node-image (node-cross-modal-link found-node)))))

