;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)1998 CMU/Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Carnegie Mellon University
;;;             : Psychology Department
;;;             : Pittsburgh,PA 15213-3890
;;;             : byrne+@andrew.cmu.edu
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : test-suite.lisp
;;; Version     : 1.0b5
;;; 
;;; Description : Lisp source for the "test suite" example with ACT-R/PM. 
;;;             : 
;;;             : Most of this is pretty straightforward but it does give
;;;             : examples of how to use some of the ACT-R/PM stuff like sound
;;;             : events (both generating and responding to), the device
;;;             : methods, tracking, and the MCL view-based interface with the
;;;             : Vision Module.
;;;
;;; To Do       : Use DEVICE-* methods.
;;; 
;;; ----- History -----
;;; 98.06.05 Mike Byrne
;;;             : Documentation genesis.
;;; 98.08.25 mdb
;;;             : Added AFTER method for OUTPUT-CURSOR-MOVE.
;;; 99.04.08 mdb
;;;             : Updated for beta 6 of RPM.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defvar *experiment* nil "The window")
(defparameter *letters '("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m"))

(defun flip ()
  (= 0 (random 2)))

;;; TEST-WINDOW      [Class]
;;; Description : Base class for the window that RPM will interact with.

(defclass test-window (dialog)
  ((base-states :accessor base-states
                :initform '(:start :sound :key1 :key2 :key3 :click))
   (states :accessor states)
   (current-state :accessor current-state)
   (start-time :accessor start-time :initform 0)
   (first-loc :accessor first-loc :initform nil)
   (move1 :accessor move1 :initform nil)
   (move2 :accessor move2 :initform nil)
   (last-update :accessor last-update :initform 0)
   )
  (:default-initargs
    :title "RPM Test Suite"
    :width 300
    :height 300
    :left 30
    :right 40
    
    ))


(defmethod initialize-instance :after ((tw test-window) &key)
  (setf (states tw) (copy-list (base-states tw)))
  (setf (current-state tw) (pop (states tw)))
  (make-start tw)
  (setf (start-time tw) 0.0))


(defmethod make-start ((tw test-window))
  "Make the 'start' button at a random location."
  (let ((x (+ 50 (random 200)))
        (y (+ 50 (random 200))))
    (push (make-instance 'button
            :left x
            :width 60
            :height 20
            :on-click 'start-btn
            :title "Start"
            :top y)
          (dialog-items tw))))
    


;;; START-BTN      [Method]
;;; Description : When the "Start" button is pressed, there are a few
;;;             : things to do.  Print the RT (which also does some 
;;;             : other bookkeeping), then picks a random onset for
;;;             : the audio stimulus, and randomly picks which frequency
;;;             : to use.

(defun start-btn (tw b)
  "Response when the 'start' button is pressed."
  (print-rt tw)
  (let ((onset (float (/ (+ 150 (random 300)) 1000)))
        (freq (if (flip) 800 2000)))
    (new-tone-sound freq onset)
    (pm-delayed-event onset #'beep)
    (setf (start-time tw) (+ (pm-get-time) (* 1000 onset)))))


(defmethod clear-window ((tw test-window))
  "Remove all subviews and have RPM process the screen."
  (setf (dialog-items tw) nil)
  (pm-proc-display :clear t))



(defmethod print-rt ((tw test-window))
  "Prints the RT, pops the state, and clears the window."
  (format t "~&[-=- DEVICE -=-] RT was: ~S" (- (pm-get-time) (start-time tw)))
  (setf (current-state tw) (pop (states tw)))
  (clear-window tw))



(defmethod got-sound ((tw test-window) text)
  "Handle the sound.  Print the RT and what was said, and show the letter."
  (print-rt tw)
  (format t "~&[-=- DEVICE -=-] Word was: ~S" text)
  (setf (first-loc tw) (show-text tw (random-item *letters))))


(defmethod show-text ((tw test-window) (str string) &optional x y)
  "Show text at some random location, draw it, reset the clock, and process the screen."
  (let ((x (if x x (+ 50 (random 200))))
        (y (if y y (+ 50 (random 200)))))
    (push
      (make-instance 'static-text
        :left x
        :width 80
        :height 20
        :value str
        :top y)
     (dialog-items tw))
    ;(view-draw-contents tw)
    ;(event-dispatch)
    (setf (start-time tw) (pm-get-time))
    (pm-proc-display)
    (list x y)))


;;; DO-TRACKING      [Method]
;;; Description : When we start the tracking business, we need to first 
;;;             : set up the star and oval views--randomly decide which
;;;             : is the left view and which is the right.  Then set the
;;;             : locations randomly.  Add them and process the screen.
;;;             : Finally, set the updater function and the start time.

(defmethod setup-tracking ((tw test-window))
  "Set up tracking:  Install the views, set update information."
  ;; install the two views
  (cond ((flip) 
         (setf (move1 tw) (make-instance 'circle-view))
         (setf (move2 tw) (make-instance 'star-view)))
        (t
         (setf (move2 tw) (make-instance 'circle-view))
         (setf (move1 tw) (make-instance 'star-view))))
  (setf (left (move1 tw)) (random 120))
  (setf (top (move1 tw)) (+ 150 (random 120)))
  
  (setf (left (move2 tw)) (+ 150 (random 120)))
  (setf (top (move2 tw)) (+ 150 (random 120)))

  #|
   (set-view-position (move1 tw)
                     (random 120) (+ 150 (random 120)))
   (set-view-position (move2 tw)
                     (+ 150 (random 120)) (+ 150 (random 120)))
   |#

  (push (move1 tw) (dialog-items tw))
  (push (move2 tw) (dialog-items tw))
  
  ;;(add-subviews tw (move1 tw) (move2 tw))
  
  (setf (current-state tw) :TRACKING)
  (pm-proc-display)
  ;; (pm-set-params :device-updater-fct #'update-move)
  (setf (last-update tw) (mp-time *mp*)))



(defmethod move-views ((tw test-window))
  "Change the location of the moving views, update the screen, and process the screen."
  (let ((x1 (left (move1 tw)))
        (y1 (top (move1 tw)))
        (x2 (left (move2 tw)))
        (y2 (top (move2 tw))))
    (incf x1 (random 10))
    (decf y1 (random 10))
    (decf x2 (random 10))
    (decf y2 (random 10))
    (when (< 270 x1) (setf x1 270))
    (when (> 0 y1) (setf y1 0))
    (when (> 0 x2) (setf x2 0))
    (when (> 0 y2) (setf y2 0))
    
    (setf (left (move1 tw)) x1)
    (setf (top (move1 tw)) y1)
    
    (setf (left (move2 tw)) x2)
    (setf (top (move2 tw)) y2)

    ;(set-view-position (move1 tw) x1 y1)
    ;(set-view-position (move2 tw) x2 y2)
    ;(event-dispatch)
    (pm-proc-display)))

;;;; ---------------------------------------------------------------------- ;;;;
;;;; Being an RPM device.
;;;; ---------------------------------------------------------------------- ;;;;

;;; VIEW-KEY-EVENT-HANDLER      [Method]
;;; Description : What is done when a key is pressed depends on the state 
;;;             : we're currently in.  Either show the appropriate text
;;;             : or start the tracking business.

(defmethod rpm-window-key-event-handler ((tw test-window) key)
  "Handle keystrokes."
  (print-rt tw)
  (format t "~&[-=- DEVICE -=-] Got key: ~A" key)
  (FORMAT T "current-state is ~S~%" (current-state tw))
  (ecase (current-state tw)
    (:key2 (show-text tw (random-item '("up" "down"))))
    (:key3 (show-text tw 
                      (random-item '("key left" "key right"))
                      (first (first-loc tw)) (second (first-loc tw))))
    (:click (setup-tracking tw))))


;;; VIEW-CLICK-EVENT-HANDLER      [Method]
;;; Description : When the view is clicked, what to do depends on the 
;;;             : state.  If we're waiting for the "Start" button to be pressed, 
;;;             : we have to pass the event so the button will get it.
;;;             : A mouse click can also be used in place of the sound in cases
;;;             : where the sound won't be listened for.
;;;             : Finally, the real click we're handling here is the one
;;;             : that ends tracking.

(defmethod view-click-event-handler ((tw test-window) where)
  "Handle a click on the view."
  (declare (ignore where))
  (when (eq (current-state tw) :start) 
    ;(call-next-method)
    (return-from view-click-event-handler nil))
  (if (eq (current-state tw) :sound)
    (got-sound tw (pm-get-time) "click")
    (print-rt tw)))
    ;; (pm-set-params :device-updater-fct #'null))))


(defmethod device-update ((tw test-window) time)
  (when (eq (current-state tw) :TRACKING)
    (when (<= 0.050 (- time (last-update tw)))
      (setf (last-update tw) time)
      (move-views tw))))  

(defmethod device-speak-string :after ((tw test-window) string)
  (got-sound tw string))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; The moving subviews
;;;; ---------------------------------------------------------------------- ;;;;

;;; CIRCLE-VIEW      [Class]
;;; Description : A class for the moving circle on the screen--nothing special
;;;             : is needed in the class itself.

(defclass circle-view (drawable)
  ()
  (:default-initargs
      :background-color light-gray
    :title nil
    :border nil
      :height 30
    :width 30
    :on-redisplay 'redraw-circle
    )
  )




#|
;;; VIEW-DRAW-CONTENTS      [Method]
;;; Description : Drawing the view on the screen is just a FILL-OVAL on
;;;             : the view.

(defmethod view-draw-contents ((self circle-view))
  (fill-oval self *black-pattern* 0 0 (point-h (view-size self)) 
             (point-v (view-size self))))
|#

(defun redraw-circle (circle stream)
  ;(setf (color stream) black)
  (fill-circle stream (make-position (round (height circle) 2) (round (width circle) 2))
               (round (height circle) 2))
  t)


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : How to turn the view into a feature for the icon.  
;;;             : OVAL-FEATURE works as the class because that's a feature
;;;             : that's already defined in RPM.

(defmethod build-features-for ((self circle-view) (vis-mgr vision-module))
  (make-instance 'oval-feature
    :x (left self) ;(first (view-loc self))
    :y (top self) ;(second (view-loc self))
    :screen-obj self))



;;; STAR-FEATURE      [Class]
;;; Description : The ICON-FEATURE class for the star.  If we had any other
;;;             : information that had to be in the feature, we would also
;;;             : need a FEAT-TO-DMO method to translate the feature to 
;;;             : a declarative memory representation.  Not necessary since
;;;             : the default is to build a chunk with the type and value
;;;             : specified.  (Do need a "STAR" chunk-type, though.)

(defclass star-feature (icon-feature)
  ()
  (:default-initargs
    :isa 'STAR
    :value 'STAR
    :dmo-id (gentemp "STAR")))

;;; STAR-VIEW      [Class]
;;; Description : A class for the star-view itself.  No slots, there's no
;;;             : special information to be stored here.

(defclass star-view (drawable)
  ()
  (:default-initargs
      :background-color light-gray
    :border nil
      :height 30
    :width 30
    :on-redisplay 'redraw-star
    ))


#|
;;; VIEW-DRAW-CONTENTS      [Method]
;;; Description : The drawing method for the star view.  Draw the four lines,
;;;             : two corner-to-corner and two midpoint-to-midpoint.

(defmethod view-draw-contents ((self star-view))
  (let ((xmax (point-h (view-size self)))
        (ymax (point-v (view-size self))))
    (move-to self 0 0)
    (line-to self xmax ymax)
    (move-to self xmax 0)
    (line-to self 0 ymax)
    (move-to self 0 (/ ymax 2))
    (line-to self xmax (/ ymax 2))
    (move-to self (/ xmax 2) 0)
    (line-to self (/ xmax 2) ymax)))
|#

(defun redraw-star (star stream)
  (let ((xmax (width stream))
        (ymax (height stream)))
    
    (move-to stream (make-position 0 0))
    (draw-to stream (make-position xmax ymax))
    (move-to stream (make-position xmax 0))
    (draw-to stream (make-position 0 ymax))
    (move-to stream (make-position 0 (round ymax 2)))
    (draw-to stream (make-position xmax (round ymax 2)))
    (move-to stream (make-position (round xmax 2) 0))
    (draw-to stream (make-position (round xmax 2) ymax)))
  t)
    


;;; BUILD-FEATURES-FOR      [Method]
;;; Description : Creates an icon feature for the star view, which is
;;;             : one instance of the star-feature.

(defmethod build-features-for ((self star-view) (vis-mgr vision-module))
  (make-instance 'star-feature
    :x (left self) ;(first (view-loc self))
    :y (right self) ;(second (view-loc self))
    :screen-obj self))