examples/published-results/ecvp-2023-posner/posner-tests.lisp

;; This file was created by Laura

;; It will run a series of tests for the operators involved in the Posner experiment.
;; THIS IS SPECIFICALLY FOR ARJONA

;; code checking 
(defun check (query error-message)
  (if query
      (format t ".")
      (format t "~&Error: ~a~&" error-message)))

;; need to load the relevant information in order to run the checks
;; will just run the Chao experiment file for this - this includes all run-gp run-experiment and loads interpret file

(require :asdf)
(require :gems)
(setf *default-pathname-defaults*
      #P"/Users/bartletl/Documents/portacle/projects/gems-1.2-alpha-3/posner/")
      ;;#P"/home/laurab/common-lisp/gems-1.2-alpha-3/posner/")

(load "posner-initialise.lisp")
(load "posner-ARJONA.lisp")

;; TESTING JUST THE DECAY TOGGLE STUFF
#|
(setf decay-toggle 1) ;; just on for these tests
(setf *decay-threshold* 0.6) ;; just try different values

(defparameter stored-state (make-random-state t))
(setf *random-state* (make-random-state stored-state)) ;; to load previous

(defun test-decay ()
  (setf *decay-threshold* 0.6) ;; just try different values
  (let* ((md (make-model :current test-input-1 :salient test-input-2)))
    (interpret '(prog3 (put-stm) (attend) (put-stm)) md)
    (check (equal 2 (input-name (second (model-stm md)))) "test-input-1 is in stm2")
    (check (equal 3 (input-name (first (model-stm md)))) "test-input-2 is in stm1")
    (setf (model-clock md) 1500)
    (interpret '(rehearsal-1) md)
    (setf (model-clock md) 2000)
    (interpret '(retrieve-1) md)
    ;;(print md)
    (check (equal nil (input-name (second (model-stm md)))) "test-input-1 has decayed")
    (check (equal 3 (input-name (first (model-stm md)))) "test-input-2 is still good")
    (setf *decay-threshold* 0.0)
    (let* ((md (make-model :current test-input-1 :salient test-input-2)))
      (interpret '(prog3 (put-stm) (attend) (put-stm)) md)
      (check (equal 2 (input-name (second (model-stm md)))) "test-input-1 is in stm2")
      (check (equal 3 (input-name (first (model-stm md)))) "test-input-2 is in stm1")
      (setf (model-clock md) 1500)
      (interpret '(rehearsal-1) md)
      (setf (model-clock md) 2000)
      (interpret '(retrieve-1) md)
      ;;(print md)
      (check (equal 2 (input-name (second (model-stm md)))) "test-input-1 has NOT decayed")
      (check (equal 3 (input-name (first (model-stm md)))) "test-input-2 is still good")
      (interpret '(prog2 (wait-1500) (retrieve-1)) md)
      (check (equal 2 (input-name (second (model-stm md)))) "test-input-1 has NOT decayed - again")
      (check (equal 3 (input-name (first (model-stm md)))) "test-input-2 is still good - again")
      )))
|#

(setf decay-toggle 0) ;; just off for tests for now

(defun test-nil-op ()
  (let ((md (make-model :current test-input-1)))
    (check (equal :centre (input-location (model-current md))) "initial current value")
    (interpret '(nil) md)
    (check (equal nil (input-location (model-current md))) "nil current location")
    (check (equal nil (input-type (model-current md))) "nil current type")))
;; WORKS: Aj

(defun test-if-resp ()
  (let ((md (make-model :salient test-input-2 :current test-input-1 :clock (first *response-window*))))
    (interpret '(if (current-target-p) (respond-left) (respond-right)) md)
    (check (equal (model-response md) :right)  "input-1 is cue, so false")
    (interpret '(if (current-cue-p) (respond-left) (respond-right)) md)
    (check (equal (model-response md) :left)  "input-1 is cue, so true")

    (interpret '(attend) md)
    (interpret '(if (current-cue-p) (respond-left) (respond-right)) md)
    (check (equal (model-response md) :right)  "input-2 is target, so false")
    (interpret '(if (current-target-p) (respond-left) (respond-right)) md)
    (check (equal (model-response md) :left)  "input-2 is target, so true")))
;; WORKS: Aj

(defun test-prog ()
  (let ((md (make-model)))
    (check (equal 0 (model-clock md)) "initial clock 0")   
    (interpret '(prog2 (wait-100) (wait-100)) md)
    (check (equal 200 (model-clock md)) "updated clock 2x100")
    (interpret '(prog3 (wait-100) (wait-100) (wait-100)) md)
    (check (equal 500 (model-clock md)) "updated clock 3x100")
    (interpret '(prog4 (wait-100) (wait-100) (wait-100) (wait-100)) md)
    (check (equal 900 (model-clock md)) "updated clock 4x100")))
;; WORKS: Aj

(defun test-put-stm ()
  (let ((md (make-model :current test-input-1 :salient test-input-2)))
    (check (equal nil (input-location (first (model-stm md)))) "initial empty stm1")
    (check (equal nil (input-location (second (model-stm md)))) "initial empty stm2")
    (check (equal nil (input-location (third (model-stm md)))) "initial empty stm3")

    (interpret '(put-stm) md)
    (check (equal :centre (input-location (first (model-stm md)))) "fill stm1")
    (check (equal nil (input-location (second (model-stm md)))) "second empty stm2")
    (check (equal nil (input-location (third (model-stm md)))) "second empty stm3")

    (interpret '(prog2 (attend) (put-stm)) md)
    (check (equal :left (input-location (first (model-stm md)))) "update stm1")
    (check (equal :centre (input-location (second (model-stm md)))) "move 1 to stm2")
    (check (equal nil (input-location (third (model-stm md)))) "third empty stm3")
    ;;(print md)

    (interpret '(put-stm) md)
    (check (equal :left (input-location (first (model-stm md)))) "update stm1 again")
    (check (equal :left (input-location (second (model-stm md)))) "move 1 to stm2 again")
    (check (equal :centre (input-location (third (model-stm md)))) "move 2 to stm3")

    (interpret '(put-stm) md)
    (check (equal :left (input-location (first (model-stm md)))) "update stm1 again again")
    (check (equal :left (input-location (second (model-stm md)))) "move 1 to stm2 again again")
    (check (equal :left (input-location (third (model-stm md)))) "remove the previous stm3")
    ))
;; WORKS: Aj

(defun test-attend ()
  (let ((md (make-model :salient test-input-1)))
    (check (equal nil (input-location (model-current md))) "check current is empty")
    (interpret '(attend) md)
    (check (equal :centre (input-location (model-current md))) "current updated with salient")
    ))
;; WORKS: Aj

(defun test-move-att ()
  (let ((md (make-model :attfocus :left :current test-input-1)))
    (check (equal :left (model-attfocus md)) "model start left")
    (interpret '(move-att-left) md)
    (check (equal 0 (model-clock md)) "nothing changed so no change to clock")
    (interpret '(move-att-centre) md)
    (check (equal :centre (model-attfocus md)) "model moved to centre")
    (interpret '(move-att-centre) md)
    (check (equal 70 (model-clock md)) "nothing changed so no change to clock")
    (interpret '(move-att-left) md)
    (check (equal :left (model-attfocus md)) "model moved to left")
    (interpret '(move-att-right) md)
    (check (equal :right (model-attfocus md)) "model moved to right")
    (interpret '(move-att-right) md)
    (check (equal 210 (model-clock md)) "nothing changed so no change to clock")
    (interpret '(move-att-cue) md)
    (check (equal :left (model-attfocus md)) "model moved to left, because cue direction")
    (check (equal 350 (model-clock md)) "clock increased because operations")
    (interpret '(move-att-cue) md)
    (check (equal 420 (model-clock md)) "clock increased but only but cog for cue")
    (let ((md (make-model :attfocus :right)))
      (interpret '(move-att-cue) md)
      (check (equal :right (model-attfocus md)) "no cue saved so no effect (except time)")
      (check (equal 70 (model-clock md)) "time change")
    )))
;; WORKS: Aj

(defun test-attn-capture-loc ()
  (let ((md (make-model :attfocus :left :inputs (list test-input-1 test-input-2) :clock 310)))
    (check (equal :left (model-attfocus md)) "model start left")
    (interpret '(attn-capture-location) md)
    ;;(print md)
    (check (equal :centre (model-attfocus md)) "attn captured to centre")
    (let ((md (make-model :clock (first *response-window*) :inputs (list test-input-1 test-input-2))))
      (check (equal :centre (model-attfocus md)) "attnfocus is at default centre position")
      ;;(setf test-mod md)
      (interpret '(attn-capture-location) md)
      (check (equal :left (model-attfocus md)) "attnfocus is left, in line with test-input-2")
      (let ((md (make-model :inputs (list test-input-1 test-input-2) :attfocus :right))) ;; default clock, so no stim
	(check (equal :right (model-attfocus md)) "attn right at start")
	(check (equal 0 (model-clock md)) "clock default 0")
	(interpret '(attn-capture-location) md)
	(check (equal :right (model-attfocus md)) "attn still to right - no stim")))))
;; WORKS: Arjona


(defun test-detect ()
  (let ((md (make-model :inputs (list test-input-1) :clock 300)))
    (check (equal input-nil (model-salient md)) "salient is nil")
    (interpret '(detect) md)
    (check (equal test-input-1 (model-salient md)) "salient is now test-input 1"))
  (let ((md (make-model :inputs (list test-input-1) :attfocus :left :clock 300)))
    (check (equal input-nil (model-salient md)) "salient is nil")
    (interpret '(detect) md)
    (check (equal input-nil (model-salient md)) "salient is still nil because stim in centre")))
;; WORKS: Aj

(defun test-respond ()
  (let ((md (make-model :current test-input-1)))
    (check (equal nil (model-response md)) "response is nil")
    (interpret '(respond-current) md)
    (check (equal :centre (model-response md)) "responding with what is in current")
    (interpret '(respond-left) md)
    (check (equal :left (model-response md)) "responding left")
    (interpret '(respond-right) md)
    (check (equal :right (model-response md)) "responding right")
    (interpret '(respond-cue) md)
    (check (equal :left (model-response md)) "respond left, direction of cue")
    (interpret '(respond-cue-opp) md)
    (check (equal :right (model-response md)) "respond right, opposite direction of cue")
    (interpret '(prog2 (nil) (respond-current)) md)
    (check (equal :right (model-response md)) "still left because nothing in current")
    ))
;; WORKS: Aj

(defun test-prev-cue ()
  (let ((md (make-model :current test-input-1 :prev-trial "V")))
    (interpret '(prev-val) md)
    (check (equalp (model-response md) :left) "response in line with previous trial validity")
    (let ((md (make-model :current test-input-1 :prev-trial "I")))
      (interpret '(prev-val) md)
      (check (equalp (model-response md) nil) "no change in response because no benefit from valid")
      )))



(defun test-rehearsal ()
  (let ((md (make-model :current test-input-1 :salient test-input-2)))
    (interpret '(prog2 (dotimes-2 (put-stm)) (prog2 (attend) (put-stm))) md)
    (check (equal (input-location test-input-1) (input-location (second (model-stm md)))) "put item1 in stm2")
    (check (equal (input-location test-input-1) (input-location (third (model-stm md)))) "put item1 in stm3")

    (check (equal (input-location test-input-2) (input-location (first (model-stm md)))) "put item2 in stm1")

    (check (not (equal (input-store-time (third (model-stm md))) (model-clock md))) "stm3 not same as clock")
    (check (not (equal (input-store-time (second (model-stm md))) (model-clock md))) "stm2 not same as clock")
    
    (interpret '(rehearsal-2) md)
    (check (equal (input-store-time (second (model-stm md))) (model-clock md)) "updated store time stm2")
    
    (interpret '(rehearsal-3) md)
    (check (equal (input-store-time (third (model-stm md))) (model-clock md)) "updated store time stm3")

    (check (not (equal (input-store-time (first (model-stm md))) (model-clock md))) "stm1 not same as clock")
    (interpret '(rehearsal-1) md)
    (check (equal (input-store-time (first (model-stm md))) (model-clock md)) "updated store time stm1")
))
;; WORKS: Aj

(defun test-while ()
  (let ((md (make-model :current test-input-1 :salient test-input-2)))
    (interpret '(while-200 (put-stm)) md)
    (check (equal (input-location input-1) (input-location (third (model-stm md)))) "repeated enough that input1 is in stm3")
    (interpret '(prog2 (attend) (while-100 (put-stm))) md)
    (check (equal (input-location test-input-1) (input-location (third (model-stm md)))) "input1 is still in stm3")
    (check (equal (input-location test-input-2) (input-location (second (model-stm md)))) "input2 is in stm2")
    (check (equal (input-location test-input-2) (input-location (first (model-stm md)))) "input2 is in stm1")
    ))
;; WORKS: Aj

(defun test-wait ()
  (let ((md (make-model)))
    (check (equal 0 (model-clock md)) "model-clock at 0")
    (interpret '(wait-25) md)
    (check (equal 25 (model-clock md)) "model-clock at 25")
    (interpret '(wait-50) md)
    (check (equal 75 (model-clock md)) "model-clock at 75")
    (interpret '(wait-100) md)
    (check (equal 175 (model-clock md)) "model-clock at 175")
    (interpret '(wait-200) md)
    (check (equal 375 (model-clock md)) "model-clock at 375")
    (interpret '(wait-1000) md)
    (check (equal 1375 (model-clock md)) "model-clock at 1375")
    (interpret '(wait-1500) md)
    (check (equal 2875 (model-clock md)) "model-clock at 2875")
    (interpret '(wait-.5trial) md)
    (check (equal (+ 2875 (/ (second *response-window*) 2)) (model-clock md)) "model-clock added .5 of trial")
    (setf (model-clock md) 0)
    (interpret '(wait-.25trial) md)
    (check (equal (/ (second *response-window*) 4) (model-clock md)) "model-clock added .25 of trial")
    (setf (model-clock md) 0)
    (interpret '(wait-.1trial) md)
    (check (equal (/ (second *response-window*) 10) (model-clock md)) "model-clock added .25 of trial")
    ;;(print md)
    ))
;; WORKS: Aj

(defun test-dotimes ()
  (let ((md (make-model)))
    (check (equal 0 (model-clock md)) "model-clock at 0")
    (interpret '(dotimes-2 (wait-100)) md)
    (check (equal 200 (model-clock md)) "model-clock at 200")
    (interpret '(dotimes-3 (wait-100)) md)
    (check (equal 500 (model-clock md)) "model-clock at 500")
    (interpret '(dotimes-4 (wait-100)) md)
    (check (equal 900 (model-clock md)) "model-clock at 900")
    ))
;; WORKS: Aj

(defun avg (faff) (/ (apply '+ faff) (length faff)))

(defun test-match-prob ()
  (setf tally-86 nil)
  (setf tally-50 nil)
  (setf tally-68 nil)
  (dotimes (more 50)
    (setf current-prob 0.86)
    (setf tally 0)
    (let* ((md (make-model :current test-input-1)))
      (check (equal :left (input-direction (model-current md))) "check input direction is left")
      (dotimes (rep 100)
	(interpret '(match-probability) md)
	(when (equalp :left (model-response md)) (setf tally (1+ tally))))   
      ;;(check (< 66 tally) "is it in line with response?")
      (push tally tally-86) 
    
    (let* ((md (make-model :current test-input-1)))
      (setf current-prob 0.5)
      (setf tally 0)
      (dotimes (rep 100)
	(interpret '(match-probability) md)
	(when (equalp :left (model-response md)) (setf tally (1+ tally))))
      ;;(check (AND (< 30 tally) (> 70 tally)) "is it in line with response?")
      (push tally tally-50) 

      (let* ((md (make-model :current test-input-1)))
	(setf current-prob 0.68)
	(setf tally 0)
	(dotimes (rep 100)
	  (interpret '(match-probability) md)
	  (when (equalp :left (model-response md)) (setf tally (1+ tally))))
	;;(check (AND (< tally 88) (> tally 48)) "is it in line with response?")
	(push tally tally-68)
	))))
  (print tally-86)
  (print (avg tally-86))
  (check (< 66 (avg tally-86)) "tally-86 avg")
  (print tally-50)
  (print (avg tally-50))
  (check (AND (< 30 (avg tally-50)) (> 70 (avg tally-50))) "tally-50 avg")
  (print tally-68)
  (print (avg tally-68))
  (check (AND (< (avg tally-68) 88) (> (avg tally-68) 48)) "tally-68 avg")
  )
;; WORKS: Aj      

(defun test-RW-cue-strength () ;; so it takes the *strength-assoc* and works out how likely the cue is. In run-experiment, the *strength-assoc* is updated based on the validity of the trial. so can just run with a variety of strength-assoc's and see whether it outputs in line with that.

  (setf tally-50 nil)
  (setf tally-75 nil)
  (setf tally-25 nil)

  (dotimes (more 10)

    (setf tally 0)
    (dotimes (we 100)
      (let ((md (make-model :strength-assoc 0.5 :current test-input-1)))
        (interpret '(RW-cue-strength) md)
        (when (equalp :left (model-response md)) (setf tally (1+ tally)))))
    (push tally tally-50)

    (setf tally 0)
    (dotimes (we 100)
      (let ((md (make-model :strength-assoc 0.75 :current test-input-1)))
        (interpret '(RW-cue-strength) md)
        (when (equalp :left (model-response md)) (setf tally (1+ tally)))))
    (push tally tally-75)

    (setf tally 0)
    (dotimes (we 100)
      (let ((md (make-model :strength-assoc 0.25 :current test-input-1)))
        (interpret '(RW-cue-strength) md)
        (when (equalp :left (model-response md)) (setf tally (1+ tally)))))
    (push tally tally-25))

  (print tally-75)
  (print (avg tally-75))
  (check (AND (< 55 (avg tally-75)) (> 95 (avg tally-75))) "tally-75 avg")
  (print tally-50)
  (print (avg tally-50))
  (check (AND (< 30 (avg tally-50)) (> 70 (avg tally-50))) "tally-50 avg")
  (print tally-25)
  (print (avg tally-25))
  (check (AND (< (avg tally-25) 45) (> (avg tally-25) 5)) "tally-25 avg")
  )
;; WORKS: Aj (still need to test the updating of the strength-assoc)

(defun test-RW-cue-percept ()
  ;; uses the cue and perception of stimulus (not strength of learning?)
  ;; still uses the strength-assoc, but it only slighty affects things.
  ;; RW-predict-stim (strength-assoc, cue-direction)

  (setf tally-50-match nil)
  (setf tally-90-match nil)
  (setf tally-10-match nil)
  (setf tally-50-no nil)
  (setf tally-90-no nil)
  (setf tally-10-no nil)

  (let* ((md (make-model :strength-assoc 0.5 :current test-input-1)))
    (interpret '(RW-cue-percept) md)
    (check (equal nil (model-response md)) "don't have the target so shouldnt do anything")


      (dotimes (faff 100)

        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.5 :current test-input-2 :stm (list test-input-1 input-nil input-nil))))

          (interpret '(rw-cue-percept) md)
          (when (equalp :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-50-match)

        ;;(setf (model-strength-assoc md) 0.90)
        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.9 :current test-input-2 :stm (list test-input-1 input-nil input-nil))))

          (interpret '(rw-cue-percept) md)
          (when (equal :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-90-match)
        
        ;;(setf (model-strength-assoc md) 0.10)
        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.1 :current test-input-2 :stm (list test-input-1 input-nil input-nil))))
          (interpret '(rw-cue-percept) md)
          (when (equal :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-10-match)
        )
    

      ;;(interpret '(attend) md)
      ;;(print md)
      ;;(check (equal (input-location test-input-3) (model-response md)) "current is now not matched with cue")

      (dotimes (faff 100)
        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.5 :current test-input-3 :stm (list test-input-1 input-nil input-nil))))

          (interpret '(rw-cue-percept) md)
          (when (equal :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-50-no)

        ;;(setf (model-strength-assoc md) 0.90)
        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.9 :current test-input-3 :stm (list test-input-1 input-nil input-nil))))

          (interpret '(rw-cue-percept) md)
          (when (equal :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-90-no)
        
        (setf (model-strength-assoc md) 0.10)
        (setf tally 0)
        (dotimes (we 100)
          (let* ((md (make-model :strength-assoc 0.1 :current test-input-3 :stm (list test-input-1 input-nil input-nil))))

          (interpret '(rw-cue-percept) md)
          (when (equal :left (model-response md)) (setf tally (1+ tally)))))
        (push tally tally-10-no)
        )

      (print tally-50-match)
      (print (list (avg tally-50-match) 0.975))
      ;;(check (AND (< 55 (avg tally-50-match)) (> 95 (avg tally-50-match))) "tally-50-match avg") ;;0.975

      (print tally-50-no)
      (print (list (avg tally-50-no) 0.925))
      ;;(check (AND (< 55 (avg tally-50-no)) (> 95 (avg tally-50-no))) "tally-50-no avg")

      (print tally-90-match)
      (print (list (avg tally-90-match) 0.995))
      ;;(check (AND (< 55 (avg tally-90-match)) (> 95 (avg tally-90-match))) "tally-90-match avg") ;;0.995

      (print tally-90-no)
      (print (list (avg tally-90-no) 0.905))
      ;;(check (AND (< 55 (avg tally-90-no)) (> 95 (avg tally-90-no))) "tally-90-no avg") ;; 0.905

      (print tally-10-match)
      (print (list (avg tally-10-match) 0.955))
      ;;(check (AND (< 55 (avg tally-10-match)) (> 95 (avg tally-10-match))) "tally-10-match avg") ;;0.955

      (print tally-90-no)
      (print (list (avg tally-10-no) 0.945))
      ;;(check (AND (< 55 (avg tally-10-no)) (> 95 (avg tally-10-no))) "tally-10-no avg") ;; 0.945

      )
  )
;; WORKS: Aj (requires manual checking of output because i'm lazy)
  
          
(defun test-if-sa ()
  (let* ((md (make-model :current test-input-1 :strength-assoc 0.5)))
    (interpret '(if-strength-assoc) md)
    (check (equal nil (model-response md)) "no change because not at threshold")
    (let* ((md (make-model :current test-input-1 :strength-assoc 0.71)))
      (interpret '(if-strength-assoc) md)
      (check (equal :left (model-response md)) "changed in line with cue"))))
;; WORKS: Aj
      

    


(defun test-current-type ()
  (let ((md (make-model :salient test-input-2 :current test-input-1)))
    (interpret '(if (current-target-p) (respond-left) (respond-right)) md)
    (check (equal :right (model-response md)) "check right response as not target")
    (interpret '(if (current-cue-p) (respond-left) (respond-right)) md)
    (check (equal :left (model-response md)) "check left response as is cue")
    (interpret '(prog2 (attend) (if (current-target-p) (respond-left) (respond-right))) md)
    (check (equal :left (model-response md)) "check left response as is target")
    (interpret '(if (current-cue-p) (respond-left) (respond-right)) md)
    (check (equal :right (model-response md)) "check right response as not cue")
    ))
;; works: Aj

(defun test-retrieve ()
  (let ((md (make-model :salient test-input-2 :current test-input-1)))
    (interpret '(prog3 (put-stm) (prog2 (attend) (put-stm)) (put-stm)) md)

    (check (equal (input-location test-input-1) (input-location (third (model-stm md)))) "stm3 is item1")
    (check (equal (input-location test-input-2) (input-location (second (model-stm md)))) "stm2 is item2")
    (check (equal (input-location test-input-2) (input-location (first (model-stm md)))) "stm1 is item2")
    (check (equal (input-location test-input-2) (input-location (model-current md))) "model current is item2")
    
    (interpret '(retrieve-3) md)
    (check (equal (input-location test-input-1) (input-location (model-current md))) "model current is now item1, which was in stm3")
    (interpret '(retrieve-2) md)
    (check (equal (input-location test-input-2) (input-location (model-current md))) "model current is now item2, which was in stm2")
    (interpret '(retrieve-3) md)
    (check (equal (input-location test-input-1) (input-location (model-current md))) "model current is now item1, which was in stm3")
    (interpret '(retrieve-1) md)
    (check (equal (input-location test-input-2) (input-location (model-current md))) "model current is now item2, which was in stm1")

    (interpret '(retrieve-target-stm) md)
    (check (equal (input-type test-input-2) (input-type (model-current md))) "model current is now the target item")
    (interpret '(retrieve-cue-stm) md)
    (check (equal (input-type test-input-1) (input-type (model-current md))) "model current is now the most recent stimulus item")
    ))
;; WORKS: Aj

(defun test-shift-attn ()
  (let ((md (make-model :attfocus :centre)))
    (check (equal (model-attfocus md) :centre)  "attention focus is centre")
    (interpret '(shift-attn-cw) md)
    (check (equal (model-attfocus md) :right)  "attention focus is right")
    (interpret '(shift-attn-cw) md)
    (check (equal (model-attfocus md) :left)  "attention focus is left (all the way round)")
    (interpret '(shift-attn-cw) md)
    (check (equal (model-attfocus md) :centre)  "attention focus is centre (from left)")
    (interpret '(shift-attn-ccw) md)
    (check (equal (model-attfocus md) :left)  "attention focus is left")
    (interpret '(shift-attn-ccw) md)
    (check (equal (model-attfocus md) :right)  "attention focus is right (from all the way round)")
    (interpret '(shift-attn-ccw) md)
    (check (equal (model-attfocus md) :centre)  "attention focus is centre (from right)")
    ))
;; WORKS: Aj
  



;; timings have changed, so that ps have to give a response within time to save the results, rather than in the operator code... maybe change this though?
(defun test-dmts-ops ()
  (let ((md (make-model :inputs (list input-1 input-2 input-3))))
    (check (equal input-nil (model-current md)) "current starts with input-nil")
    (interpret '(detect-attend) md)
    (check (equal input-1 (model-current md)) "current changes to input1")
    (interpret '(prog2 (move-att-left) (detect-attend)) md)
    (check (equal input-nil (model-current md)) "current changes to nil, due to clock")
    (setf (model-clock md) 1600)
    (interpret '(detect-attend) md)
    (check (equal input-2 (model-current md)) "current changes to input2")
    (interpret '(prog2 (move-att-right) (detect-attend)) md)
    (check (equal input-3 (model-current md)) "current changes to 3")
    (check (equal nil (model-response md)) "default response is nil")
    (setf (model-clock md) (- (first *response-window*) 200))
    (interpret '(respond-left) md)
    (check (equal nil (model-response md)) "no response, due to clock (too early)")
    (setf (model-clock md) (first *response-window*))
    (interpret '(respond-right) md)
    (check (equal :right (model-response md)) "responds right")
    (interpret '(respond-left) md)
    (check (equal :left (model-response md)) "responds left")
    (interpret '(respond-current) md)
    (check (equal :right (model-response md)) "responds current - input3 (right)")
    ))

(defun test-program-depth ()
  (check (= 0 (program-depth '())) "empty tree")
  (check (= 1 (program-depth '(x))) "single entry")
  (check (= 2 (program-depth '(x (a) (b)))) "three items, two levels")
  (check (= 1 (program-depth '(x a b))) "three items, one level, terminals")
  (check (= 3 (program-depth '(x (a) (b (c))))) "four items, three levels")
  )

(defun test-program-size ()
  (check (= 0 (program-size '())) "empty tree")
  (check (= 1 (program-size '(x))) "single entry")
  (check (= 3 (program-size '(x (a) (b)))) "three items, one level")
  (check (= 3 (program-size '(x a b))) "three items, one level, terminals")
  (check (= 4 (program-size '(x (a) (b (c))))) "four items, two levels")
  )

(defun run-tests ()
  (format t "~&Testing: ")
  (test-nil-op)
  (test-if)
  (test-prog)
  (test-put-stm)
  (test-attend)
  (test-move-att)
  (test-attn-capture)
  (test-detect)
  (test-respond)
  (test-rehearsal)
  (test-while)
  (test-wait)
  (test-dotimes)
  (test-compare-current1-Rc)
  (test-compare-current1-r1)
  (test-compare-1-2-p)
  (test-compare-current1-p)
  (test-magic-operator)
  (test-retrieve)
  (test-dmts-ops)
  ;;(test-program-depth)
  ;;(test-program-size)
  (format t "~%-------- Done~&"))