;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Author      : Mike Byrne
;;; Copyright   : (c)1997-2000 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston, TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; 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.
;;; 00.03.07 mdb
;;;             : Fixed minor bug in START-BTN.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(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
    :window-title "RPM Test Suite"
    :view-size #@(300 300)
    :view-position #@(900 165)))               ;     30 40


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


(defmethod make-start ((wind test-window))
  "Make the 'start' button at a random location."
  (let ((x (+ 50 (random 200)))
        (y (+ 50 (random 200))))
    (add-subviews wind
      (make-dialog-item 'button-dialog-item
                        (make-point x y)
                        #@(60 20)
                        "Start"
                        #'(lambda (self)
                            (start-btn (view-window self)))
                        :default-button nil))))


(defmethod clear-window ((wind test-window))
  "Remove all subviews and have RPM process the screen."
  (apply #'remove-subviews wind (subviews wind))
  (pm-proc-display))


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


;;; 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.  Fixed duration of 500 ms.

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


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


(defmethod show-text ((wind 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)))))
    (add-subviews wind
      (make-dialog-item 'static-text-dialog-item
                        (make-point x y)
                        #@(80 20)
                        str))
    (view-draw-contents wind)
    (event-dispatch)
    (setf (start-time wind) (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 ((wind test-window))
  "Set up tracking:  Install the views, set update information."
  ;; install the windo views
  (cond ((flip) 
         (setf (move1 wind) (make-instance 'circle-view))
         (setf (move2 wind) (make-instance 'star-view)))
        (t
         (setf (move2 wind) (make-instance 'circle-view))
         (setf (move1 wind) (make-instance 'star-view))))
  (set-view-position (move1 wind)
                     (random 120) (+ 150 (random 120)))
  (set-view-position (move2 wind)
                     (+ 150 (random 120)) (+ 150 (random 120)))
  (add-subviews wind (move1 wind) (move2 wind))
  (setf (current-state wind) :TRACKING)
  (pm-proc-display)
  ;; (pm-set-params :device-updater-fct #'update-move)
  (setf (last-update wind) (mp-time *mp*)))


(defmethod move-views ((wind test-window))
  "Change the location of the moving views, update the screen, and process the screen."
  (let ((x1 (point-h (view-position (move1 wind))))
        (y1 (point-v (view-position (move1 wind))))
        (x2 (point-h (view-position (move2 wind))))
        (y2 (point-v (view-position (move2 wind)))))
    (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))
    (set-view-position (move1 wind) x1 y1)
    (set-view-position (move2 wind) 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 view-key-event-handler ((wind test-window) key)
  "Handle keystrokes."
  (print-rt wind)
  (format t "~&[-=- DEVICE -=-] Got key: ~A" key)
  (ecase (current-state wind)
    (:key2 (show-text wind (random-item '("up" "down"))))
    (:key3 (show-text wind 
                      (random-item '("key left" "key right"))
                      (first (first-loc wind)) (second (first-loc wind))))
    (:click (setup-tracking wind))))


;;; 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 ((wind test-window) where)
  "Handle a click on the view."
  (declare (ignore where))
  (when (eq (current-state wind) :start) 
    (call-next-method)
    (return-from view-click-event-handler nil))
  (if (eq (current-state wind) :sound)
    (got-sound wind "click")
    (print-rt wind)))
    ;; (pm-set-params :device-updater-fct #'null))))

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


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



#|
The old style way of doing things was installing hook functions.  Too messy
for me, I like methods better.  Here's what these old functions looked like:

(defun soundhandler (time text)
  "Function called by RPM when a something is spoken by the Speech Module"
  (got-sound *experiment* time text))


;;; UPDATE-MOVE      [Function]
;;; Description : This will be called at the end of every production cycle
;;;             : to make sure the moving views are moved appropriately.

(defun update-move (time)
  "Determines whether the views need updating.  If so, do an update."
  (when (<= 0.050 (- time (last-update *experiment*)))
    (setf (last-update *experiment*) time)
    (move-views *experiment*)))
|#






  


;;;; ---------------------------------------------------------------------- ;;;;
;;;; 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 (simple-view)
  ()
  (:default-initargs
    :view-size #@(30 30)))


;;; 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))))


;;; 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
    :obj-freq 0.2
    :x (px (view-loc self))
    :y (py (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
    :kind '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 (simple-view)
  ()
  (:default-initargs
    :view-size #@(30 30)))


;;; 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)))


;;; 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
    :obj-freq 0.2
    :x (px (view-loc self))
    :y (py (view-loc self))
    :screen-obj self))