;;; mini-Chrest architecture version 1
;;; written by Peter Lane, November 2007

;;; Data is held in form of 3-item lists
;;; e.g. (D A G)  (B I F)

(defun matching-pattern-p (pattern-1 pattern-2)
  "Pattern-1 matches pattern-2 if it is a presequence: check this by recursion"
  (cond ((null pattern-1) 
	 t)
	((null pattern-2) 
	 nil)
	((equalp (car pattern-1) (car pattern-2))
	 (matching-pattern-p (cdr pattern-1) (cdr pattern-2)))
	(t
	 nil)))

;;; 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-pattern-p (node-image node) pattern))
  (when (> (length pattern) (length (node-image node))) ; only familiarise if something new to add
        (incf (chrest-clock model) (chrest-familiarisation-time model))
	(setf (node-image node)
	      (append (node-image node)
		      (list (nth (length (node-image node)) pattern))))))

(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 nil pattern node) node))
  (assert (> (length pattern) (length (node-contents node))))
  (incf (chrest-clock model) (chrest-discrimination-time model))
  (let ((new-item (nth (length (node-contents node)) pattern)))
       (push (make-link :test new-item
			:child (make-node :contents (append (node-contents node)
							    (list new-item))
					  :image nil
					  :children nil))
	     (node-children node))))

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

(defun create-chrest ()
  (make-chrest :clock 0
	       :familiarisation-time 2000
	       :discrimination-time 10000
	       :ltm (make-node :contents nil :image nil :children nil)))

;;; 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) 
	 current-node)
	((matching-pattern-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-pattern-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)))

