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

;;; Tests for mini Chrest architecture version 2
;;; written by Peter Lane, November 2007 - February 2008

(load "chrest-2")
(load "../Utilities/test-framework")

;; tests to check internal functions in the code
(def-unit-tests presequence-tests ()
  (assert-true (presequence-p () ()))
  (assert-true (presequence-p () '(1 2 3)))
  (assert-false (presequence-p '(1 2 3) ()))
  (assert-true (presequence-p '(1) '(1)))
  (assert-true (presequence-p '(1 2) '(1 2)))
  (assert-true (presequence-p '(1) '(1 2 3)))
  (assert-true (presequence-p '(1 2) '(1 2 3)))
  (assert-false (presequence-p '(1 2 3) '(1 2))))

(def-unit-tests remove-presequence-tests ()
  (assert-equalp () (remove-matching-presequence () '(1 2 3)))
  (assert-equalp '(1 2 3) (remove-matching-presequence '(1 2 3) ()))
  (assert-equalp '(2 3) (remove-matching-presequence '(1 2 3) '(1)))
  (assert-equalp '(2 3) (remove-matching-presequence '(1 2 3) '(1 3))))

;; tests to check verbal-learning pattern
(def-unit-tests verbal-equal-pattern-tests ()
  (let ((a (make-instance 'vl-pattern :data ()))
	(b (make-instance 'vl-pattern :data '(1)))
	(c (make-instance 'vl-pattern :data '(1 2)))
	(d (make-instance 'vl-pattern :data '(1 2 3))))
       (assert-true (equal-patterns-p a a))
       (assert-false (equal-patterns-p a d))
       (assert-false (equal-patterns-p d a))
       (assert-true (equal-patterns-p b b))
       (assert-true (equal-patterns-p c c))
       (assert-false (equal-patterns-p b d))
       (assert-false (equal-patterns-p c d))
       (assert-false (equal-patterns-p d c))))

(def-unit-tests verbal-matching-pattern-tests ()
  (let ((a (make-instance 'vl-pattern :data ()))
	(b (make-instance 'vl-pattern :data '(a)))
	(c (make-instance 'vl-pattern :data '(a b)))
	(d (make-instance 'vl-pattern :data '(a b c))))
       (assert-true (matching-patterns-p a a))
       (assert-true (matching-patterns-p a d))
       (assert-false (matching-patterns-p d a))
       (assert-true (matching-patterns-p b b))
       (assert-true (matching-patterns-p c c))
       (assert-true (matching-patterns-p b d))
       (assert-true (matching-patterns-p c d))
       (assert-false (matching-patterns-p d c))))

(def-unit-tests verbal-get-next-item-tests ()
  (let ((a (make-instance 'vl-pattern :data ()))
	(b (make-instance 'vl-pattern :data '(a)))
	(c (make-instance 'vl-pattern :data '(b)))
	(d (make-instance 'vl-pattern :data '(a b)))
	(e (make-instance 'vl-pattern :data '(a c))))
       (assert-true (equal-patterns-p a (get-next-item a a)))
       (assert-true (equal-patterns-p a (get-next-item a b)))
       (assert-true (equal-patterns-p c (get-next-item d b)))
       (assert-true (equal-patterns-p c (get-next-item d e)))))

(def-unit-tests verbal-combine-pattern-tests ()
  (assert-true (equal-patterns-p (make-instance 'vl-pattern :data '(1 2 3))
				 (combine-patterns (make-instance 'vl-pattern :data '(1))
						   (make-instance 'vl-pattern :data '(2 3))))))


;; tests confirming the core processes within the architecture
(def-process-tests recognise-tests ()
  (let ((bif (make-instance 'vl-pattern :data '(B I F)))
	(bef (make-instance 'vl-pattern :data '(B E F)))
	(vif (make-instance 'vl-pattern :data '(I F)))
	(bi (make-instance 'vl-pattern :data '(B I)))
	(b (make-instance 'vl-pattern :data '(B)))
	(i (make-instance 'vl-pattern :data '(I)))
	(g (make-instance 'vl-pattern :data '(G))))
       (let ((empty-model (create-chrest)))
	    (assert-eq (chrest-ltm empty-model)
		       (recognise-pattern empty-model bif)))
       (let* ((node-1 (make-node :contents bi :image bi :children nil))
	      (link-1 (make-link :test i :child node-1))
	      (node-2 (make-node :contents b :image bif :children (list link-1)))
	      (link-2 (make-link :test b :child node-2))
	      (node-3 (make-node :contents i :image vif :children nil))
	      (link-3 (make-link :test i :child node-3))
	      (root-node (make-node :contents nil :image nil :children (list link-2 link-3)))
	      (model (create-chrest)))
	     (setf (chrest-ltm model) root-node) ; point at test root-node
	     (assert-eq node-1 (recognise-pattern model bif))
	     (assert-eq node-2 (recognise-pattern model b))
	     (assert-eq node-2 (recognise-pattern model bef))
	     (assert-eq node-3 (recognise-pattern model i))
	     (assert-eq root-node (recognise-pattern model g)))))

(def-process-tests familiarise-tests ()
  "Use verbal patterns to test familiarisation"
  (let ((model (create-chrest))
	(node (make-node :contents (make-instance 'vl-pattern)
			 :image (make-instance 'vl-pattern)
			 :children nil))
	(pattern (make-instance 'vl-pattern :data '(B I F))))
       (assert-true (empty-pattern-p (node-image node)))
       (familiarise model node pattern)
       (assert-true (equal-patterns-p (make-instance 'vl-pattern :data '(B))
				      (node-image node)))
       (familiarise model node pattern)
       (assert-true (equal-patterns-p (make-instance 'vl-pattern :data '(B I))
				      (node-image node)))
       (familiarise model node pattern)
       (assert-true (equal-patterns-p pattern (node-image node)))
       (familiarise model node pattern)
       (assert-true (equal-patterns-p pattern (node-image node)))))

(def-process-tests discriminate-tests ()
  (let ((node (make-node :contents (make-instance 'vl-pattern :data '(B I))
			 :image (make-instance 'vl-pattern :data '(B I F))
			 :children nil))
	(pattern (make-instance 'vl-pattern :data '(B I G))))
       (discriminate (create-chrest) node pattern)
       (assert-false (null (node-children node)))
       (assert-false (eq node (recognise-pattern (create-chrest) pattern node)))
       (assert-true (equal-patterns-p (make-instance 'vl-pattern :data '(G))
				      (link-test (car (node-children node)))))
       (assert-true (equal-patterns-p pattern (node-contents (recognise-pattern (create-chrest) pattern node))))))

(def-process-tests recognise-and-learn-tests ()
  (let ((model (create-chrest))
	(pattern-a (make-instance 'vl-pattern :data '(B I F)))
	(pattern-b (make-instance 'vl-pattern :data '(X A Q))))
       (dotimes (n 4) 
		(recognise-and-learn-pattern model pattern-a)
		(recognise-and-learn-pattern model pattern-b))
       (assert-true (equal-patterns-p pattern-a (recall-pattern model pattern-a)))
       (assert-true (equal-patterns-p pattern-b (recall-pattern model pattern-b)))))

(def-process-tests timing-test ()
  (let ((model (create-chrest))
	(pattern-a (make-instance 'vl-pattern :data '(B I F)))
	(pattern-b (make-instance 'vl-pattern :data '(X A Q))))
       (setf (chrest-familiarisation-time model) 2000)
       (setf (chrest-discrimination-time model) 10000)
       (assert= 0 (chrest-clock model))
       ;; check changed on one learning operation
       (recognise-and-learn-pattern model pattern-a)
       (assert= 10000 (chrest-clock model))
       ;; check changed on other learning operation
       (recognise-and-learn-pattern model pattern-a)
       (assert= 12000 (chrest-clock model))
       ;; check a busy model is not changed
       (recognise-and-learn-pattern model pattern-b 10000)
       (assert= 12000 (chrest-clock model))
       (assert-eq (chrest-ltm model) (recognise-pattern model pattern-b))
       ;; check model updates to time of current input pattern
       (recognise-and-learn-pattern model pattern-a 20000)
       (assert= 22000 (chrest-clock model))))

;; -- for short-term memory
(def-unit-tests take-tests ()
  (assert-null (take 0 '(1 2 3)))
  (assert-null (take 10 ()))
  (assert-equalp '(1 2 3) (take 3 '(1 2 3 4)))
  (assert-equalp '(1 2 3) (take 3 '(1 2 3)))
  (assert-equalp '(1 2) (take 3 '(1 2))))

(def-process-tests stm-tests ()
  (let ((model (create-chrest))
	(pattern-a (make-instance 'vl-pattern :data '(B I F))))
       (assert-true (visual-pattern-p pattern-a))
       (recognise-pattern model pattern-a)
       (assert-eq (chrest-ltm model) (car (fixed-queue-items (stm-visual (chrest-stm model)))))
       (recognise-and-learn-pattern model pattern-a)
       (assert-true (and (= 2 (length (fixed-queue-items (stm-visual (chrest-stm model)))))
			 (eq (chrest-ltm model) (cadr (fixed-queue-items (stm-visual (chrest-stm model)))))))
       (recognise-and-learn-pattern model (make-instance 'vl-pattern :data '(C I F)))
       (assert-true (= 3 (length (fixed-queue-items (stm-visual (chrest-stm model))))))
       (recognise-and-learn-pattern model (make-instance 'vl-pattern :data '(D I F)))
       (assert-true (= 4 (length (fixed-queue-items (stm-visual (chrest-stm model))))))
       (recognise-and-learn-pattern model (make-instance 'vl-pattern :data '(E I F)))
       (assert-true (= 4 (length (fixed-queue-items (stm-visual (chrest-stm model))))))
       (recognise-and-learn-pattern model pattern-a)
       (assert-true (and (= 4 (length (fixed-queue-items (stm-visual (chrest-stm model)))))
			 (equal-patterns-p (make-instance 'vl-pattern :data '(B))
					   (node-contents (car (fixed-queue-items (stm-visual (chrest-stm model))))))))))

;; tests providing empirical support for the theory

;; -- experiments can be asssessed based on correlation coefficients
(defun compute-pearson-correlation-coefficient (paired-list)
  "Given a list of pairs of numbers, return the Pearson correlation coefficient"
  (labels ((expected-value (lst)
			   (if (null lst)
			       0.0
			       (/ (apply #'+ lst)
				  (length lst))))
	   (sigma-lst (lst) (sqrt (- (expected-value (mapcar #'(lambda (n) (* n n)) lst))
				     (* (expected-value lst)
					(expected-value lst))))))
	  (let ((sigma-x (sigma-lst (mapcar #'first paired-list)))
		(sigma-y (sigma-lst (mapcar #'second paired-list))))
	       (if (or (zerop sigma-x)
		       (zerop sigma-y))
		   0.0
		   (/ (- (expected-value (mapcar #'(lambda (pair) (* (first pair) (second pair)))
						 paired-list))
			 (* (expected-value (mapcar #'first paired-list))
			    (expected-value (mapcar #'second paired-list))))
		      (* sigma-x sigma-y))))))

(def-unit-tests pearson-coefficient-tests ()
  (assert= 1.0 (compute-pearson-correlation-coefficient '((1 1) (2 2))))
  (assert= -1.0 (compute-pearson-correlation-coefficient '((1 0) (0 1))))
  (assert= 0.0 (compute-pearson-correlation-coefficient '((0 1) (0 0) (1 0) (1 1))))
  )

;; -- Verbal learning experiment
;; -- aim is to replicate Bugelski's 1962 result that number of cycles through a 
;;    list until it is completely learnt is inversely proportional to the 
;;    presentation time

(defstruct experiment 
  items              ; the list of items to present to the model
  current            ; the current indexed item
  cycles             ; the number of times the list has been presented
  clock              ; the current experiment time, measured in milliseconds
  presentation-time  ; the time to allow each item to be presented, in milliseconds
  )

(defun create-experiment (items presentation-time)
  "Define an experiment by providing the initial list of items and the item-presentation time"
  (make-experiment :items items
		   :current 0
		   :cycles 0
		   :clock 0
		   :presentation-time presentation-time))

(defun get-current-item (experiment)
  "Return the current item in the experiment"
  (assert (< (experiment-current experiment) (length (experiment-items experiment))))
  (nth (experiment-current experiment) (experiment-items experiment)))

(defun starting-new-cycle-p (experiment)
  "Experiment is beginning a new cycle if the current item is the first one"
  (= 0 (experiment-current experiment)))

(defun next-item (experiment)
  "Advance experiment to next item, incrementing clock"
  (incf (experiment-current experiment))
  (incf (experiment-clock experiment) (experiment-presentation-time experiment))
  ;; check for wrapping around end of list
  (when (>= (experiment-current experiment) (length (experiment-items experiment)))
	(setf (experiment-current experiment) 0)
	(incf (experiment-cycles experiment))))

(def-unit-tests experiment-tests ()
  "Some tests of the experiment setup and format"
  (let ((expt-1 (create-experiment '((A B C) (D E F) (G H I)) 200)))
       (assert-true (starting-new-cycle-p expt-1))
       (assert-equalp '(A B C) (get-current-item expt-1))
       (next-item expt-1)
       (assert-false (starting-new-cycle-p expt-1))
       (assert-equalp '(D E F) (get-current-item expt-1))
       (assert= 200 (experiment-clock expt-1))
       (next-item expt-1)
       (assert-false (starting-new-cycle-p expt-1))
       (assert-equalp '(G H I) (get-current-item expt-1))
       (assert= 400 (experiment-clock expt-1))
       (assert= 0 (experiment-cycles expt-1))
       (next-item expt-1)
       (assert-true (starting-new-cycle-p expt-1))
       (assert-equalp '(A B C) (get-current-item expt-1))
       (assert= 600 (experiment-clock expt-1))
       (assert= 1 (experiment-cycles expt-1))))

(defun presentation-cycle (model experiment)
  "Present each stimulus to the model for learning in turn, until starting a new cycle"
  (recognise-and-learn-pattern model 
			       (get-current-item experiment) 
			       (experiment-clock experiment))
  (next-item experiment)
  (unless (starting-new-cycle-p experiment)
	  (presentation-cycle model experiment)))

(defun reached-success-p (model experiment)
  "Model has succeeded when it recalls the stimulus exactly for all items in list"
  (every #'(lambda (pattern) (equal-patterns-p pattern (recall-pattern model pattern)))
	 (experiment-items experiment)))

(defun train-to-success (model experiment &optional (safety-net 100))
  "Repeat the presentation of a cycle repeatedly, until the successfully learnt.
  A safety-net is provided to stop recursion after a number of cycles, if failed to learn."
  (unless (or (zerop safety-net)
	      (reached-success-p model experiment))
	  (presentation-cycle model experiment)
	  (train-to-success model experiment (1- safety-net))))

(defun do-bugelski (initial-time time-step num-runs items)
  "Perform the experiment, repeated for gradually increasing presentation times.
   Return a list of pairs, time vs num-cycles."
  (let ((results ()))
       (do ((current-time initial-time (+ current-time time-step))
	    (cycle 0 (1+ cycle)))
	   ((= cycle num-runs) (reverse results))
	   (let ((ex (create-experiment items current-time))
		 (m (create-chrest)))
		(train-to-success m ex)
		(push (list current-time (experiment-cycles ex))
		      results)))))

(defun list-to-visual-pattern (lst) (make-instance 'vl-pattern :data lst))

(def-canonical-result-tests constant-learning-rate ()
  "This result performs the experiment, and checks there is at least a -0.9 correlation
   between the presentation time and the number of training cycles."
  (assert-true (< (compute-pearson-correlation-coefficient
		   (do-bugelski 500 100 20 
				(mapcar #'list-to-visual-pattern
					'((D A G) (B I F) (G I H) (J A L) (M I Q) (P E L) (S U J)))))
		  -0.9)))