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

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

;; tests to check internal functions in the code
(def-unit-tests matching-pattern-tests ()
  (assert-true (matching-pattern-p () ()))
  (assert-true (matching-pattern-p () '(a b c)))
  (assert-false (matching-pattern-p '(a b c) ()))
  (assert-true (matching-pattern-p '(a) '(a)))
  (assert-true (matching-pattern-p '(a b) '(a b)))
  (assert-true (matching-pattern-p '(a) '(a b c)))
  (assert-true (matching-pattern-p '(a b) '(a b c)))
  (assert-false (matching-pattern-p '(a b c) '(a b))))

;; tests confirming the core processes within the architecture
(def-process-tests recognise-tests ()
  (let ((empty-model (create-chrest)))
       (assert-eq (chrest-ltm empty-model)
		  (recognise-pattern empty-model '(B I F))))
  (let* ((node-1 (make-node :contents '(B I) :image '(B I) :children nil))
	 (link-1 (make-link :test '(I) :child node-1))
	 (node-2 (make-node :contents '(B) :image '(B I F) :children (list link-1)))
	 (link-2 (make-link :test '(B) :child node-2))
	 (node-3 (make-node :contents '(I) :image '(I F) :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 (make-chrest :ltm root-node)))
	(assert-eq node-1 (recognise-pattern model '(B I F)))
	(assert-eq node-2 (recognise-pattern model '(B)))
	(assert-eq node-2 (recognise-pattern model '(B E F)))
	(assert-eq node-3 (recognise-pattern model '(I)))
	(assert-eq root-node (recognise-pattern model '(G)))))

(def-process-tests familiarise-tests ()
  (let ((node (make-node :contents nil :image nil :children nil))
	(model (create-chrest)))
       (assert-null (node-image node))
       (familiarise model node '(B I F))
       (assert-equalp '(B) (node-image node))
       (familiarise model node '(B I F))
       (assert-equalp '(B I) (node-image node))
       (familiarise model node '(B I F))
       (assert-equalp '(B I F) (node-image node))
       (familiarise model node '(B I F))
       (assert-equalp '(B I F) (node-image node))))

(def-process-tests discriminate-tests ()
  (let ((node (make-node :contents '(B I) :image '(B I F) :children nil)))
       (discriminate (create-chrest) node '(B I G))
       (assert-false (null (node-children node)))
       (assert-false (eq node (recognise-pattern nil '(B I G) node)))
       (assert-equalp '(B I G) (node-contents (recognise-pattern nil '(B I G) node)))))

(def-process-tests recognise-and-learn-tests ()
  (let ((model (create-chrest))
	(pattern-a '(B I F))
	(pattern-b '(X A Q)))
       (dotimes (n 4) 
		(recognise-and-learn-pattern model pattern-a)
		(recognise-and-learn-pattern model pattern-b))
       (assert-equalp pattern-a (recall-pattern model pattern-a))
       (assert-equalp pattern-b (recall-pattern model pattern-b))))

(def-process-tests timing-test ()
  (let ((model (create-chrest))
	(pattern-a '(B I F))
	(pattern-b '(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))))

;; 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) (equalp 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 ((expt-setup (create-experiment items current-time))
		 (model (create-chrest)))
		(train-to-success model expt-setup)
		(push (list current-time (experiment-cycles expt-setup))
		      results)))))

(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 
				'((D A G) (B I F) (G I H) (J A L) (M I Q) (P E L) (S U J))))
		  -0.9)))

