2-virtual-experiment-window.lisp

;;;  -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP;  Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Authors     : Frank Tamborello
;;; Copyright   : (c)2011-13 Cogscent, LLC
;;;		: All Rights Reserved
;;; Availability: public domain
;;; Address     : Cogscent, LLC
;;;             : PMB 7431
;;;		: 2711 Centerville Rd, Ste 120
;;;		: Wilmington DE 19808-1676, USA
;;;             : frank.tamborello@cogscent.com
;;; 
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public
;;; License: the GNU Lesser General Public License as published by the
;;; Free Software Foundation (either version 2.1 of the License, 
;;; or, at your option, any later version),
;;; and the Franz, Inc Lisp-specific preamble.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the Lisp Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;; and see Franz, Inc.'s preamble to the GNU Lesser General Public License,
;;; http://opensource.franz.com/preamble.html.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Filename    : virtual-experiment-window.lisp
;;; Version     : 7
;;; 
;;; Description : Forked from Mike Byrne's experiment-window4.lisp and 
;;;		: procedure-window2.lisp. This is a version intended for use 
;;;		: with ACT-R that does not actually draw windows nor other
;;;		: MCL view classes.
;;;		: Provides some base classes for running trial and event-based 
;;;             : experiments: virtual-experiment-window, for a virtual 
;;;             : experiment window, TRIAL, for keeping track of trial 
;;;             : information, TRIAL-BLOCK for keeping track of blocks, and 
;;;             : procedure-window for running procedural tasks.
;;;		
;;; Experiment-Window4.lisp and Procedure-Window2.lisp authorship:
;;; Author     : Mike Byrne
;;; Copyright   : (c)2003-7 CMU/Rice U./Mike Byrne, All Rights Reserved
;;; Availability: public domain
;;; Address     : Rice University
;;;             : Psychology Department
;;;             : Houston,TX 77251-1892
;;;             : byrne@acm.org
;;; 
;;; Bugs        : none known
;;; 
;;; Todo        :  
;;; 
;;; ----- History -----
;;; 2011.01.02 fpt r1
;;;		: Inception, taken from Mike's experiment-window4.lisp 
;;;		library.
;;; 2012.06.18 fpt r2
;;;		: Adapted all subject timer stuff since this library file is 
;;;		meant to be used with ACT-R, and thus ACT-R is the timer.
;;;		: Excised cfbundle & launch-url stuff since ACT-R will not
;;;		respond to subject questionnaires.
;;; 2012.06.26 fpt r3
;;;		: Created virtual-event-exp-window and its methods to work with
;;;		act-r.
;;; 2012.08.20 fpt r4
;;;		: Detected a bug in advance-state that would let the experiment
;;;		advance the state-num of the procedure-window greater than the
;;;		length of the state-vec. So now it checks for being at the last
;;;		step before advancing the step.
;;; 2012.08.28 fpt r5
;;;		: Revised write-events to write minute, hour, day, and month with a
;;;		place-holding 0 so that they are always two digits.
;;; 2013.08.12 fpt r6
;;;		1. Moved the widget class & some widget utilities into this file: 
;;;		widget-named, current-widget, & inside.
;;;		2. Moved widget-related slots of the procedure-window class,
;;;		widgets & mouse-pos, to the procedure-window class definition.
;;; 2013.08.26 fpt 7
;;;		1. Class actr-event-timer is now called simply actr-timer.
;;;		2. Class virtual-event-exp-window is deleted because all virtual-
;;;	experiment-windows use the same actr-timer.
;;;		3. For modeling timed-experiment-like tasks,
;;;		lots of other changes to non-event-based classes to make them
;;;		wait for the model's execution to produce a response for the 
;;;		current trial.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;; ---------------------------------------------------------------------- ;;;;
;;;; globals, macros, & setup
;;;; ---------------------------------------------------------------------- ;;;;



(defvar *tid* 0 "Holds the task ID.")
(defvar *experiment* nil "Holds the experiment window.")


(unless (fboundp 'menubar-hide)
  (defun menubar-hide () nil))

(unless (fboundp 'menubar-show)
  (defun menubar-show () nil))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; The READABLE-WRITER class
;;;;
;;;             : A base class for objects that can write reable 
;;;             : represenations of themselves.
;;;
;;;; ---------------------------------------------------------------------- ;;;;


(defclass readable-writer ()
  ((slot-lst :accessor slot-lst :initarg :slot-lst :initform nil)
   ))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; 
;;;;  Timing
;;;;
;;;; ---------------------------------------------------------------------- ;;;;


(defclass timer () ())

(defclass actr-timer (timer) 
  ((start-time :accessor start-time :initarg :start-time :initform 0)))

(defgeneric spin-for (tmr ms-delay)
  (:documentation "Spins for ms-delay milliseconds."))

#| Deprecated. Can schedule an event with ACT-R's meta process instead.
(defmethod spin-for ((tmr timer) ms-delay)
  (without-interrupts
     (let ((start (mp-time-ms)))
       (while (> ms-delay (- (mp-time-ms) start))))))
|#

(defgeneric start-timing (tmr)
  (:documentation "Starts an event timer at the current event."))

(defmethod start-timing ((tmr actr-timer))
  (setf (start-time tmr) (current-time tmr)))

(defgeneric current-time (tmr)
  (:documentation "Returns the current time in milliseconds."))

(defmethod current-time ((tmr actr-timer))
  (mp-time-ms))

(defgeneric stop-timing (tmr)
  (:documentation "Stops an event timer at the current event and returns the time in ms."))

(defmethod stop-timing ((tmr actr-timer))
  (- (current-time tmr) (start-time tmr)))


(defmethod start-stop-timer ((tmr actr-timer))
  (let ((lat (stop-timing tmr)))
    (start-timing tmr)
    lat))





;;;; ---------------------------------------------------------------------- ;;;;
;;;;
;;;; The TRIAL class
;;;;
;;;;             : A class for storing information about trials, like condition
;;;;             : stimuli, and the like.  Used by the EXPEIRMENT-WINDOW class.
;;;;             : A WRITE-TRIAL method is expected for printing the trial
;;;;             : information to the data file.
;;;;
;;;; ---------------------------------------------------------------------- ;;;;


;;; TRIAL      [Class]
;;; Description :  A class for storing information about a particular trial.

(defclass trial ()
  ((trial-kind :accessor trial-kind :initarg :trial-kind :initform nil)
   (trial-block :accessor trial-block :initarg :trial-block :initform nil)
   (start-time :accessor start-time :initarg :start-time :initform nil)))


;;; WRITE-TRIAL      [Generic Function]
;;; Description : Writes a text representation (for the data file) of the trial
;;;             : to the given stream

(defgeneric write-trial (trial strm)
  (:documentation "Writes a text representation (for the data file) of the trial 
  to the given stream."))


;;;; ---------------------------------------------------------------------- ;;;;
;;;;             
;;;; The virtual-experiment-window class
;;;;
;;;             : A class for the actual experiment window and trial management.
;;;             : This class assumes that the experiment happens in blocks.
;;;             : If not, well, build only one block of trials.
;;;             : Any derived subclass will probably want to supply certain
;;;             : methods:
;;;             : 
;;;             : INITIALIZE-INSTANCE, to set up the experiment:  set the 
;;;             : data file path and number of blocks in the experiment,
;;;             : write a first line to the data file, that kind of thing.
;;;             : 
;;;             : A BUILD-TRIAL-lst method, for building lists of trial
;;;             : objects.
;;;             : 
;;;             : A :before or :after method for SETUP-TRIAL.
;;;             : 
;;;             : A DO-TRIAL method.
;;;             : 
;;;             : A FINISH-TRIAL method, to do cleanup for each trial.
;;;
;;;; ---------------------------------------------------------------------- ;;;;

;;; virtual-experiment-window      [Class]
;;; Description : Base class for the experiment window, including slots for
;;;             : trial management and the data file.

(defclass virtual-experiment-window ()
  ((block-lst :accessor block-lst :initform nil :initarg :block-lst)
   (current-trial :accessor current-trial :initform nil)
   (nblocks :accessor nblocks :initarg :nblocks :initform nil)
   (cblock :accessor cblock :initarg :cblock :initform 0)
   (base-path :accessor base-path :initarg :base-path
              :initform nil)
   (completed-trials :accessor completed-trials :initarg :completed-trials 
                     :initform 0)
   (timer :accessor timer :initarg :timer 
          :initform (make-instance 'actr-timer))
   (instructions :accessor instructions :initarg :instructions
                 :initform nil)
   (snum :accessor snum :initarg :snum :initform nil)
   (write-type :accessor write-type :initarg :write-type :initform :BOTH)
   (iti :accessor iti :initarg :iti :initform 500)
   (xcond :accessor xcond :initarg :xcond :initform 0)
   (xnum :accessor xnum :initarg :xnum :initform nil)
   (mouse-pos :accessor mouse-pos :initarg :mouse-pos :initform #(0 0))))



(defclass virtual-event-exp-window (virtual-experiment-window)
  ())



;;;; ---------------------------------------------------------------------- ;;;;
;;;;
;;;; The TRIAL-BLOCK class.
;;;;
;;;             : Used to store and manage lists of trials.
;;;
;;;; ---------------------------------------------------------------------- ;;;;


;;; TRIAL-BLOCK      [Class]
;;; Date        : 97.10.09
;;; Description : A class for storing information about blocks.

(defclass trial-block ()
  ((kind :accessor kind :initform nil :initarg :kind)
   (trial-lst :accessor trial-lst :initform nil :initarg :trial-lst)
   (size :accessor size :initform 0 :initarg :size)
   (current-idx :accessor current-idx :initarg :current-idx :initform 0)
   ))






;;;; ---------------------------------------------------------------------- ;;;;
;;;; end of class definitions



;;;; ---------------------------------------------------------------------- ;;;;
;;;; 
;;;;  Methods for the virtual-experiment-window class and its children
;;;;
;;;; ---------------------------------------------------------------------- ;;;;

(defgeneric setup-experiment (wind)
  (:documentation "Method for any initialization code not in the INITIALIZE-INSTANCE method."))

(defmethod setup-experiment ((wind virtual-experiment-window))
  nil)

(defgeneric run-experiment (wind)
  (:documentation "Run the experiment.  Works different for different subclasses."))


;;; RUN-EXPERIMENT      [Method]
;;; Description : Running the experiment, which is three phases:  Set up
;;;             : whatever needs to be set up, then iterating through all
;;;             : the blocks, then a finish method.

(defmethod run-experiment ((wind virtual-experiment-window))
  (when (member (write-type wind) '(:LISP :BOTH))
    (with-open-file (strm (make-data-path wind "lisp") :direction :output 
                          :if-exists :append :if-does-not-exist :create)
      (format strm "(list ")))
  (setup-experiment wind)
  (dolist (block (block-lst wind))
    (run-block wind block))
  (finish-experiment wind))


;;; RUN-EXPERIMENT      [Method]
;;; Date        : 00.06.06
;;; Description : Much simpler for event-driven--just run the first block.
(defmethod run-experiment ((wind virtual-event-exp-window))
  (setup-experiment wind)
  (run-block wind (first (block-lst wind))))


(defgeneric finish-experiment (wind)
  (:documentation "Clean-up the data file at the end of the experiment. Might want an :AFTER method here."))

#| (defmethod finish-experiment ((wind virtual-experiment-window))
  (when (and (base-path wind) (member (write-type wind) '(:SS :BOTH))))
  (when (member (write-type wind) '(:LISP :BOTH))
    (with-open-file (strm (make-data-path wind "lisp") :direction :output 
                          :if-exists :append :if-does-not-exist :create)
      (format strm ")")))) |#


(defmethod make-data-path ((wind virtual-experiment-window) type)
  (when (base-path wind)
    (make-pathname :directory (base-path wind)
                   :name
                   (format nil "subj~3,'0D" (snum wind))
                   :type type)))


(defmethod data-file ((wind virtual-experiment-window))
  (make-data-path wind "txt"))



;;;; ---------------------------------------------------------------------- ;;;;
;;;; Trial management

;;; SETUP-TRIAL      [Method]
;;; Description : Pop trial-lst into the current trial slot.  Probably
;;;             : requires an :AFTER method from the subclass.

(defgeneric setup-trial (wind trl)
  (:documentation "Pops the window's trial-lst into the <current-trial> slot.  Probably will 
require an :AFTER method from the subclass."))

(defmethod setup-trial ((wind virtual-experiment-window) (trl trial))
    (setf (trial-block trl) (cblock wind)
          (start-time trl) (mp-time-ms)))


(defgeneric do-trial (wind trl)
  (:documentation "Method to handle the main part of the trial, after set-up."))


(defgeneric finish-trial (wind)
  (:documentation "Method for trial clean-up. *Must* be called explicitly in EVENT-EXP-WINDOWs."))


;;; FINISH-TRIAL      [Method]
;;; Date        : 00.02.16
;;; Description : At the end of a trial, check to see if we're at the end of
;;;             : a block.  If so, finish the block.  If not, update the
;;;             : trial index in the block, wait for a bit, and start the next
;;;             : trial.
;;;             : Note that this method does not take a trial argument so that
;;;             : it can be called more easily from code in, say, a button. 
(defmethod finish-trial ((wind virtual-event-exp-window))
  (let ((curr-block (nth (cblock wind) (block-lst wind))))
    (incf (current-idx curr-block))
    (if (= (size curr-block) (current-idx curr-block))
      (finish-block wind curr-block)
      (progn
        (setf (current-trial wind)
              (nth (current-idx curr-block) (trial-lst curr-block)))
;;        (spin-for (timer wind) (iti wind))
        (setup-trial wind (current-trial wind))))))




;;;; ---------------------------------------------------------------------- ;;;;
;;;;
;;;; The TRIAL-BLOCK class.
;;;;
;;;             : Used to store and manage lists of trials.
;;;
;;;; ---------------------------------------------------------------------- ;;;;


;;; TRIAL-BLOCK      [Class]
;;; Date        : 97.10.09
;;; Description : A class for storing information about blocks.

(defclass trial-block ()
  ((kind :accessor kind :initform nil :initarg :kind)
   (trial-lst :accessor trial-lst :initform nil :initarg :trial-lst)
   (size :accessor size :initform 0 :initarg :size)
   (current-idx :accessor current-idx :initarg :current-idx :initform 0)
   ))




;;;; ---------------------------------------------------------------------- ;;;;
;;;; block management


(defgeneric setup-block (wind blk)
  (:documentation "Sets up a block.  Default does nothing."))

(defmethod setup-block ((wind virtual-experiment-window) (blk trial-block))
  nil)


(defgeneric run-block (wind blk)
  (:documentation "Runs a block of trials. Different subclasses do this differently."))  

;;; RUN-BLOCK      [Method]
;;; Description : Run a block when not event-driven.  To run a block, do the 
;;;             : setup, then iterate through the trials, then finish off the 
;;;             : block.

(defmethod run-block ((wind virtual-experiment-window) (blk trial-block))
  (setup-block wind blk)
  (let ((trl (nth (current-idx blk) (trial-lst blk))))
    (setf (current-trial wind) trl)
    (setup-trial wind trl)))



;;; RUN-BLOCK      [Method]
;;; Description : Run a block when event-driven.  All that's done here is
;;;             : starting off the block.

(defmethod run-block ((wind virtual-event-exp-window) (blk trial-block))
  (setup-block wind blk)
  (setf (current-trial wind) (first (trial-lst blk)))
  (setup-trial wind (current-trial wind)))


(defgeneric finish-block (wind blk)
  (:documentation "Called upon finishing a block of trials.  Write the data, 
put up a status update. Subclasses do more.  Might add a :BEFORE method to 
compute accuracy."))

(defmethod finish-block ((wind virtual-experiment-window) (blk trial-block))
;;  (write-block wind blk)
  (gc)
  (incf (cblock wind))
  (if (eql (nblocks wind)
           (cblock wind))
    (finish-experiment wind)
    (run-block wind (nth (cblock wind) (block-lst wind)))))


;;; FINISH-BLOCK      [Method]
;;; Description : When it's event-driven, have to check for the end of the
;;;             : experiment and start the next block manually.

(defmethod finish-block :after ((wind virtual-event-exp-window) (blk trial-block))
  (if (= (nblocks wind) (cblock wind))
    (finish-experiment wind)
    (run-block wind (nth (cblock wind) (block-lst wind)))))


(defgeneric write-block (wind blk)
  (:documentation "Writes a block of trial data to the file specified in <wind>, if there is one.  If not, print to T."))

(defmethod write-block ((wind virtual-experiment-window) (blk trial-block))
  (if (null (base-path wind))
    ;; if not writing to a file, write SS data to terminal
    (dolist (the-trial (trial-lst blk))
      (write-trial the-trial t))
    ;; otherwise, need to know what type to write
    (progn
      (when (member (write-type wind) '(:SS :BOTH))
        (with-open-file (strm (make-data-path wind "txt") :direction :output 
                              :if-exists :append :if-does-not-exist :create)
          (dolist (the-trial (trial-lst blk))
            (write-trial the-trial strm)))))))


;;;; ---------------------------------------------------------------------- ;;;;
;;;;  Misc utility stuff
;;;; ---------------------------------------------------------------------- ;;;;



(defun stim-sequence-ok (lst)
  (< (maxrun lst #'trial-kind) 4))

(defun maxrun (lst &optional key)
  (apply #'max 
         (mapcar #'first 
                 (remove-if #'atom
                            (compress 
                             (if key
                               (mapcar key lst)
                               lst))))))

(defun compress (x)
  (if (consp x) 
    (compr (car x) 1 (cdr x))
    x))

(defun compr (elt n lst)
  (if (null lst)
    (list (n-elts elt n))
    (let ((next (car lst)))
      (if (eql next elt)
        (compr elt (+ n 1) (cdr lst))
        (cons (n-elts elt n)
              (compr next 1 (cdr lst)))))))

(defun n-elts (elt n)
  (if (> n 1)
    (list n elt)
    elt))







;;;; ---------------------------------------------------------------------- ;;;;
;;;;
;;;; The Procedure Window
;;;;
;;;             : For procedural, rather than trial-based, tasks.
;;;
;;;; ---------------------------------------------------------------------- ;;;;




;;;; ---------------------------------------------------------------------- ;;;;
;;;; an action record
;;;; from MDB's procedure-window2

(defclass proc-action ()
  ((latency :accessor latency :initarg :latency :initform nil)
   (expected :accessor expected :initarg :expected :initform nil)
   (got :accessor got :initarg :got :initform nil)
   (step-num :accessor step-num :initarg :step-num :initform nil)
   (info :accessor info :initarg :info :initform nil)
   (info2 :accessor info2 :initarg :info2 :initform nil)
   ))


(defmethod is-error ((p-act proc-action))
;;  (terpri)
;;  (format t "expected: ~A	got: ~A~%" (expected p-act) (got p-act))
  (neq (expected p-act) (got p-act))
  )


(defmethod write-pa ((p-act proc-action) &optional (strm t))
  (let ((out-lst 
         (list 
          (step-num p-act)
          (if (is-error p-act) 0 1)
          (latency p-act) 
          (expected p-act)
          (got p-act))))
    (terpri strm)
    (when (info p-act) (setf out-lst (append out-lst (list (info p-act)))))
    (when (info2 p-act) (setf out-lst (append out-lst (list (info2 p-act)))))
    (tab-output out-lst strm)))


;;;; ---------------------------------------------------------------------- ;;;;
;;;; the procedure window itself
;;;; from MDB's procedure-window2

(defclass procedure-window ()    
  ((state-vec :accessor state-vec :initarg :state-vec :initform nil)
   (state-num :accessor state-num :initarg :state-num :initform 0)
   (training-p :accessor training-p :initarg :training-p :initform nil)
   (action-log :accessor action-log :initarg :action-log :initform nil)
   (timer :accessor timer :initarg :timer 
          :initform (make-instance 'actr-timer))
   (out-path :accessor out-path :initarg :out-path :initform nil)
   (start-time :accessor start-time :initarg :start-time 
               :initform (get-internal-real-time))
   (num-errors :accessor num-errors :initarg :num-errors :initform 0)
   (advance-p :accessor advance-p :initarg :advance-p :initform t)
   (snd-player :accessor snd-player :initarg :snd-player :initform nil)
   (task-id :accessor task-id :initarg :task-id :initform 0)
   
   (gui-vec :accessor gui-vec :initarg :gui-vec :initform nil)
   (check-gui-p :accessor check-gui-p :initarg :check-gui-p :initform t)
   (widgets :accessor widgets :initarg :widgets :initform nil)
   (mouse-pos :accessor mouse-pos :initarg :mouse-pos :initform #(0 0))))

(defmethod curr-state ((wind procedure-window))
  (svref (state-vec wind) (state-num wind)))


(defmethod write-log ((wind procedure-window))
  (when (eq t (out-path wind))
    (write-events wind t)
    (return-from write-log nil))
  (with-open-file (strm (out-path wind) :direction :output :if-exists :append
                        :if-does-not-exist :create)
    (write-events wind strm)))


(defmethod write-events ((wind procedure-window) &optional (strm t))
  (setf *tid* (task-id wind))
  (multiple-value-bind (sec min hour date mnth yr)
                       (decode-universal-time (get-universal-time))
    (declare (ignore sec))
    (format strm "~%---------- Task ID: ~3,,,'0@S  trial ending ~2,,,'0@S:~2,,,'0@S on ~2,,,'0@S/~2,,,'0@S/~S ----------"
            (task-id wind) hour min mnth date yr)
    (dolist (p-act (reverse (action-log wind)))
      (write-pa p-act strm))))



(defmethod state-check ((wind procedure-window) state-name 
                          &optional info)
  (let ((p-act (make-instance 'proc-action
                  :latency (round (start-stop-timer (timer wind)))
                  :expected (curr-state wind)
                  :got state-name
                  :step-num (state-num wind)
                  :info info)))
    (push p-act (action-log wind))
    (if (not (is-error p-act))
      (advance-state wind)
      (proc-error wind))))


(defgeneric check-state-update (procedure-window state)
  (:documentation "Takes a procedure-window and a state, performs some 
    action according to the state."))

(defmethod advance-state ((wind procedure-window))
  (unless
      (eq (state-num wind) (1- (length (state-vec wind))))
    (setf (advance-p wind) t))
  (gui-check wind)                      ; r2 new
  (check-state-update wind (curr-state wind))
  (when (advance-p wind)
    (incf (state-num wind))))



;;; The Widget class & its methods

;; widgets of the task window
(defclass widget ()
  ((nick-name :accessor nick-name :initarg :nick-name :initform nil)
   (vwindow :accessor vwindow :initarg :vwindow :initform nil)
   (vis-loc :accessor vis-loc :initarg :vis-loc :initform nil)
   (vis-obj :accessor vis-obj :initarg :vis-obj :initform nil)))




;; methods for working with widgets
(defgeneric widget-named (procedure-window name)
  (:documentation "Widget-named returns the first widget of virtual-experiment-window whose name is name."))

(defmethod widget-named ((pw procedure-window) name)
  (labels
      ((wn-helper (lst name)
         (if (null lst) nil
           (let* ((wgt (car lst))
                  (wnn (nick-name wgt)))
             (if
                 (eq name wnn) wgt
               (wn-helper (cdr lst) name))))))
    (wn-helper (widgets pw) name)))

;; methods for detecting where the model clicked

(defgeneric current-widget (device loc)
  (:documentation "Given a device and a location, return a widget containing 
  the location else nil if no widget contains that location."))

(defun inside (loc vl)
  "Takes a display coordinate as a vector and a visual-location chunk name, 
  returns t if the display coordinate is inside the area of the named 
  visual-location chunk."
  (let* ((x1 (chunk-slot-value-fct vl 'screen-x))
         (x2 (+ x1 (chunk-slot-value-fct vl 'width)))
         (y1 (chunk-slot-value-fct vl 'screen-y))
         (y2 (+ y1 (chunk-slot-value-fct vl 'height))))
    (and (>= (svref loc 0) x1)
         (<= (svref loc 0) x2)
         (>= (svref loc 1) y1)
         (<= (svref loc 1) y2))))

(defmethod current-widget ((device procedure-window) (loc vector))
  (labels
      ((current-widget-helper (widgets loc)
         (cond
          ((null widgets) nil)
          ((inside loc (vis-loc (car widgets))) (car widgets))
          (t (current-widget-helper (cdr widgets) loc)))))
  (current-widget-helper (widgets device) loc)))


(defmethod gui-check ((wind procedure-window))
  (when (and (check-gui-p wind) (gui-vec wind))
    (awhen (aref (gui-vec wind) (state-num wind))
      (funcall (symbol-function (first it)) (widget-named (rest it) wind)))))




(defmethod proc-error ((wind procedure-window))
;;  (format t "error, step: ~A task: ~A~%" (curr-state (task-wind *experiment*)) (task-wind *experiment*))
  (incf (num-errors wind)))











;;;; ---------------------------------------------------------------------- ;;;;
;;;; bookkeeping

(provide :virtual-experiment-window)